diff --git a/ghc/lib/std/Directory.lhs b/ghc/lib/std/Directory.lhs
index edd0e7ba3ab5a0833b2f1595d5e8e4fdeef264a3..e3bb80cda0e683fffb8aa42eb04e9abf3a6287ef 100644
--- a/ghc/lib/std/Directory.lhs
+++ b/ghc/lib/std/Directory.lhs
@@ -133,7 +133,7 @@ The path refers to an existing non-directory object.
createDirectory path = do
rc <- _ccall_ createDirectory path
if rc == 0 then return () else
- constructErrorAndFail "createDirectory"
+ constructErrorAndFailWithInfo "createDirectory" path
\end{code}
@removeDirectory dir@ removes an existing directory {\em dir}. The
@@ -176,7 +176,7 @@ removeDirectory path = do
if rc == 0 then
return ()
else
- constructErrorAndFail "removeDirectory"
+ constructErrorAndFailWithInfo "removeDirectory" path
\end{code}
@removeFile file@ removes the directory entry for an existing file
@@ -213,7 +213,7 @@ removeFile path = do
if rc == 0 then
return ()
else
- constructErrorAndFail "removeFile"
+ constructErrorAndFailWithInfo "removeFile" path
\end{code}
@renameDirectory old@ {\em new} changes the name of an existing
@@ -260,7 +260,7 @@ renameDirectory opath npath = do
if rc == 0 then
return ()
else
- constructErrorAndFail "renameDirectory"
+ constructErrorAndFailWithInfo "renameDirectory" opath
\end{code}
@renameFile old@ {\em new} changes the name of an existing file system
@@ -305,7 +305,7 @@ renameFile opath npath = do
if rc == 0 then
return ()
else
- constructErrorAndFail "renameFile"
+ constructErrorAndFailWithInfo "renameFile" opath
\end{code}
@getDirectoryContents dir@ returns a list of {\em all} entries
@@ -338,7 +338,7 @@ The path refers to an existing non-directory object.
getDirectoryContents path = do
dir <- _ccall_ openDir__ path
if dir == ``NULL''
- then constructErrorAndFail "getDirectoryContents"
+ then constructErrorAndFailWithInfo "getDirectoryContents" path
else loop dir
where
loop :: Addr -> IO [String]
@@ -346,6 +346,8 @@ getDirectoryContents path = do
dirent_ptr <- _ccall_ readDir__ dir
if (dirent_ptr::Addr) == ``NULL''
then do
+ -- readDir__ implicitly performs closedir() when the
+ -- end is reached.
return []
else do
str <- _casm_ `` %r=(char*)((struct dirent*)%0)->d_name; '' dirent_ptr
@@ -423,7 +425,7 @@ setCurrentDirectory path = do
rc <- _ccall_ setCurrentDirectory path
if rc == 0
then return ()
- else constructErrorAndFail "setCurrentDirectory"
+ else constructErrorAndFailWithInfo "setCurrentDirectory" path
\end{code}
diff --git a/ghc/lib/std/PrelHandle.lhs b/ghc/lib/std/PrelHandle.lhs
index bf3416dd8606ffbdd839a39bf31823b61e58be9a..c80b941f4607c39bb721c102bc22c8c6552da65a 100644
--- a/ghc/lib/std/PrelHandle.lhs
+++ b/ghc/lib/std/PrelHandle.lhs
@@ -206,15 +206,7 @@ openFileEx f m = do
newHandle (htype ptr Nothing False)
#endif
else do
- ioError@(IOError hn iot msg) <- constructError "openFile"
- let
- improved_error -- a HACK, I guess
- = case iot of
- AlreadyExists -> IOError hn AlreadyExists (msg ++ ": " ++ f)
- NoSuchThing -> IOError hn NoSuchThing (msg ++ ": " ++ f)
- PermissionDenied -> IOError hn PermissionDenied (msg ++ ": " ++ f)
- _ -> ioError
- fail improved_error
+ constructErrorAndFailWithInfo "openFile" f
where
imo = case m of
BinaryMode imo -> imo
diff --git a/ghc/lib/std/PrelIOBase.lhs b/ghc/lib/std/PrelIOBase.lhs
index bcf6d7dec9e2659c8ea3891e0754541fe5c346e4..f8c8cf81817516f1e820f0c52f944adebcc34722 100644
--- a/ghc/lib/std/PrelIOBase.lhs
+++ b/ghc/lib/std/PrelIOBase.lhs
@@ -20,7 +20,7 @@ import PrelMaybe
import PrelAddr
import PrelPack ( unpackCString )
import PrelBase
-import PrelArr ( ByteArray(..), MutableVar(..) )
+import PrelArr ( ByteArray(..), MutableVar )
import PrelGHC
\end{code}
@@ -216,17 +216,17 @@ the exact strings to be used for particular errors. For errors not
explicitly mentioned in the standard, any descriptive string may be
used.
-\begin{change}
-SOF & 4/96 & added argument to indicate function that flagged error
-\end{change}
-% Hmm..does these envs work?!...SOF
-
\begin{code}
constructErrorAndFail :: String -> IO a
constructErrorAndFail call_site
= constructError call_site >>= \ io_error ->
fail io_error
+constructErrorAndFailWithInfo :: String -> String -> IO a
+constructErrorAndFailWithInfo call_site reason
+ = constructErrorMsg call_site (Just reason) >>= \ io_error ->
+ fail io_error
+
\end{code}
This doesn't seem to be documented/spelled out anywhere,
@@ -243,7 +243,10 @@ information.
\begin{code}
constructError :: String -> IO IOError
-constructError call_site =
+constructError call_site = constructErrorMsg call_site Nothing
+
+constructErrorMsg :: String -> Maybe String -> IO IOError
+constructErrorMsg call_site reason =
_casm_ ``%r = ghc_errtype;'' >>= \ (I# errtype#) ->
_casm_ ``%r = ghc_errstr;'' >>= \ str ->
let
@@ -271,9 +274,12 @@ constructError call_site =
msg =
call_site ++ ':' : ' ' : unpackCString str ++
- case iot of
+ (case iot of
OtherError -> "(error code: " ++ show (I# errtype#) ++ ")"
- _ -> ""
+ _ -> "") ++
+ (case reason of
+ Nothing -> ""
+ Just m -> ' ':m)
in
return (IOError Nothing iot msg)
\end{code}
diff --git a/ghc/lib/std/System.lhs b/ghc/lib/std/System.lhs
index ad0b66c6cfd81f34edbefa4adee9e409189d7a57..096a860d6ba6c5c72a96187ffbdf0b5359aff2ae 100644
--- a/ghc/lib/std/System.lhs
+++ b/ghc/lib/std/System.lhs
@@ -12,7 +12,7 @@ module System (
import Prelude
import PrelAddr
-import PrelIOBase ( IOError(..), IOErrorType(..), constructErrorAndFail )
+import PrelIOBase ( IOError(..), IOErrorType(..), constructErrorAndFailWithInfo )
import PrelArr ( indexAddrOffAddr )
import PrelPack ( unpackCString )
@@ -103,7 +103,7 @@ system cmd = do
status <- _ccall_ systemCmd cmd
case status of
0 -> return ExitSuccess
- -1 -> constructErrorAndFail "system"
+ -1 -> constructErrorAndFailWithInfo "system" cmd
n -> return (ExitFailure n)
\end{code}