[project @ 1998-05-05 10:31:14 by sof]

constructErrorAndFailWithInfo: new function for including files/paths that caused IO op to fail

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}
 
 

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

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}

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}