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

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

diff --git a/ghc/lib/std/Directory.lhs b/ghc/lib/std/Directory.lhs
index edd0e7b..e3bb80c 100644 (file)
--- 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 bf3416d..c80b941 100644 (file)
--- 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 bcf6d7d..f8c8cf8 100644 (file)
--- 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 ad0b66c..096a860 100644 (file)
--- 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}