From: qrczak <unknown>
Date: Thu, 11 Jan 2001 07:04:17 +0000 (+0000)
Subject: [project @ 2001-01-11 07:04:16 by qrczak]
X-Git-Tag: Approximately_9120_patches~2949
X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=11980a5d6609e95f22b74b48f37b1dfa323bd9a5;p=ghc-hetmet.git

[project @ 2001-01-11 07:04:16 by qrczak]
Change the representation of IOException: add optional filename.
---

diff --git a/ghc/lib/std/CPUTime.lhs b/ghc/lib/std/CPUTime.lhs
index acf514e..a695214 100644
--- a/ghc/lib/std/CPUTime.lhs
+++ b/ghc/lib/std/CPUTime.lhs
@@ -1,5 +1,5 @@
 % -----------------------------------------------------------------------------
-% $Id: CPUTime.lhs,v 1.25 2000/09/14 13:46:42 simonpj Exp $
+% $Id: CPUTime.lhs,v 1.26 2001/01/11 07:04:16 qrczak Exp $
 %
 % (c) The University of Glasgow, 1995-2000
 %
@@ -55,7 +55,8 @@ getCPUTime = do
      else
 	ioException (IOError Nothing UnsupportedOperation 
 			 "getCPUTime"
-		         "can't get CPU time")
+		         "can't get CPU time"
+			 Nothing)
 
 cpuTimePrecision :: Integer
 cpuTimePrecision = round ((1000000000000::Integer) % 
diff --git a/ghc/lib/std/Directory.lhs b/ghc/lib/std/Directory.lhs
index 009833d..9ade44d 100644
--- a/ghc/lib/std/Directory.lhs
+++ b/ghc/lib/std/Directory.lhs
@@ -1,5 +1,5 @@
 % -----------------------------------------------------------------------------
-% $Id: Directory.lhs,v 1.20 2000/08/24 10:27:01 simonmar Exp $
+% $Id: Directory.lhs,v 1.21 2001/01/11 07:04:16 qrczak Exp $
 %
 % (c) The University of Glasgow, 1994-2000
 %
@@ -482,7 +482,8 @@ setPermissions name (Permissions r w e s) = do
     rc <- primChmod (primPackString name) mode
     if rc == 0
 	then return ()
-	else ioException (IOError Nothing SystemError "setPermissions" "insufficient permissions")
+	else ioException (IOError Nothing SystemError
+	    "setPermissions" "insufficient permissions" (Just name))
 \end{code}
 
 (Sigh)..copied from Posix.Files to avoid dep. on posix library
@@ -500,7 +501,8 @@ getFileStatus name = do
 #else
 	then stToIO (unsafeFreezeByteArray bytes)
 #endif
-     	else ioException (IOError Nothing SystemError "getFileStatus" "")
+     	else ioException (IOError Nothing SystemError
+	    "getFileStatus" "" (Just name))
 
 #ifndef __HUGS__
 modificationTime :: FileStatus -> IO ClockTime
diff --git a/ghc/lib/std/PrelHandle.lhs b/ghc/lib/std/PrelHandle.lhs
index 6d3e4c7..aea1192 100644
--- a/ghc/lib/std/PrelHandle.lhs
+++ b/ghc/lib/std/PrelHandle.lhs
@@ -1,5 +1,5 @@
 % ------------------------------------------------------------------------------
-% $Id: PrelHandle.lhs,v 1.64 2001/01/10 16:28:15 qrczak Exp $
+% $Id: PrelHandle.lhs,v 1.65 2001/01/11 07:04:16 qrczak Exp $
 %
 % (c) The AQUA Project, Glasgow University, 1994-2000
 %
@@ -64,7 +64,8 @@ mkBuffer__ fo sz_in_bytes = do
     _ -> do
      chunk <- malloc sz_in_bytes
      if chunk == nullAddr
-      then ioException (IOError Nothing ResourceExhausted "mkBuffer__" "not enough virtual memory")
+      then ioException (IOError Nothing ResourceExhausted
+	  "mkBuffer__" "not enough virtual memory" Nothing)
       else return chunk
  setBuf fo chunk sz_in_bytes
 \end{code}
@@ -520,8 +521,9 @@ hSetBuffering handle mode =
 		         (IOError (Just handle)
 				  InvalidArgument
 			          "hSetBuffering"
-				  ("illegal buffer size " ++ showsPrec 9 n []))  
+				  ("illegal buffer size " ++ showsPrec 9 n [])
 					-- 9 => should be parens'ified.
+				  Nothing)
       _ ->
           withHandle__ handle $ \ handle_ -> do
           case haType__ handle_ of
@@ -937,21 +939,18 @@ ioeGetFileName        :: IOError -> Maybe FilePath
 ioeGetErrorString     :: IOError -> String
 ioeGetHandle          :: IOError -> Maybe Handle
 
-ioeGetHandle (IOException (IOError h _ _ _))   = h
+ioeGetHandle (IOException (IOError h _ _ _ _)) = h
 ioeGetHandle (UserError _) = Nothing
 ioeGetHandle _ = error "IO.ioeGetHandle: not an IO error"
 
-ioeGetErrorString (IOException (IOError _ iot _ str)) =
+ioeGetErrorString (IOException (IOError _ iot _ str _)) =
   case iot of
     EOF -> "end of file"
     _   -> str
 ioeGetErrorString (UserError str) = str
 ioeGetErrorString _ = error "IO.ioeGetErrorString: not an IO error"
 
-ioeGetFileName (IOException (IOError _ _  _ str)) = 
-  case break (== ':') str of
-    (_, [])      -> Nothing
-    (_, _:' ':fs)-> Just fs
+ioeGetFileName (IOException (IOError _ _ _ _ fn)) = fn
 ioeGetFileName (UserError _) = Nothing
 ioeGetFileName _ = error "IO.ioeGetFileName: not an IO error"
 \end{code}
@@ -1023,8 +1022,8 @@ wantReadableHandle fun handle act =
       _ 		   -> act handle_
   where
    not_readable_error = 
-	   IOError (Just handle) IllegalOperation fun	
-		   ("handle is not open for reading")
+	IOError (Just handle) IllegalOperation fun	
+		"handle is not open for reading" Nothing
 
 wantWriteableHandle :: String -> Handle -> (Handle__ -> IO a) -> IO a
 wantWriteableHandle fun handle act = 
@@ -1040,12 +1039,12 @@ checkWriteableHandle fun handle handle_ act
   = case haType__ handle_ of 
       ClosedHandle 	   -> ioe_closedHandle fun handle
       SemiClosedHandle 	   -> ioe_closedHandle fun handle
-      ReadHandle 	   -> ioError not_writeable_error
+      ReadHandle 	   -> ioException not_writeable_error
       _ 		   -> act
   where
    not_writeable_error = 
-	   IOException (IOError (Just handle) IllegalOperation fun
-		   			("handle is not open for writing"))
+	IOError (Just handle) IllegalOperation fun
+		"handle is not open for writing" Nothing
 
 wantRWHandle :: String -> Handle -> (Handle__ -> IO a) -> IO a
 wantRWHandle fun handle act = 
@@ -1069,8 +1068,8 @@ access to a closed file.
 
 \begin{code}
 ioe_closedHandle :: String -> Handle -> IO a
-ioe_closedHandle fun h = ioError (IOException (IOError (Just h) IllegalOperation fun 
-					"handle is closed"))
+ioe_closedHandle fun h = ioException (IOError (Just h) IllegalOperation fun
+			     "handle is closed" Nothing)
 \end{code}
 
 Internal helper functions for Concurrent Haskell implementation
diff --git a/ghc/lib/std/PrelIO.lhs b/ghc/lib/std/PrelIO.lhs
index 70f52c8..b78c697 100644
--- a/ghc/lib/std/PrelIO.lhs
+++ b/ghc/lib/std/PrelIO.lhs
@@ -1,5 +1,5 @@
 % ------------------------------------------------------------------------------
-% $Id: PrelIO.lhs,v 1.16 2000/11/07 10:42:56 simonmar Exp $
+% $Id: PrelIO.lhs,v 1.17 2001/01/11 07:04:16 qrczak Exp $
 %
 % (c) The University of Glasgow, 1992-2000
 %
@@ -252,8 +252,8 @@ hGetContents handle =
     	    return (handle_', str)
   where
    not_readable_error = 
-	   IOError (Just handle) IllegalOperation "hGetContents"
-		   ("handle is not open for reading")
+	IOError (Just handle) IllegalOperation "hGetContents"
+		"handle is not open for reading" Nothing
 \end{code}
 
 Note that someone may close the semi-closed handle (or change its buffering), 
diff --git a/ghc/lib/std/PrelIOBase.lhs b/ghc/lib/std/PrelIOBase.lhs
index 00653b2..1efaee6 100644
--- a/ghc/lib/std/PrelIOBase.lhs
+++ b/ghc/lib/std/PrelIOBase.lhs
@@ -1,5 +1,5 @@
 % ------------------------------------------------------------------------------
-% $Id: PrelIOBase.lhs,v 1.30 2001/01/10 16:28:15 qrczak Exp $
+% $Id: PrelIOBase.lhs,v 1.31 2001/01/11 07:04:16 qrczak Exp $
 % 
 % (c) The University of Glasgow, 1994-2000
 %
@@ -362,7 +362,8 @@ malloc :: Int -> IO Addr
 malloc sz = do
   a <- _malloc sz
   if (a == nullAddr)
-	then ioException (IOError Nothing ResourceExhausted "malloc" "")
+	then ioException (IOError Nothing ResourceExhausted
+	    "malloc" "out of memory" Nothing)
 	else return a
 
 foreign import "malloc" unsafe _malloc :: Int -> IO Addr
@@ -496,15 +497,16 @@ type IOError = Exception
 
 data IOException
  = IOError
-     (Maybe Handle)  -- the handle used by the action flagging the
-		     -- the error.
-     IOErrorType     -- what it was.
-     String	     -- location
-     String          -- error type specific information.
+     (Maybe Handle)   -- the handle used by the action flagging the
+		      --   the error.
+     IOErrorType      -- what it was.
+     String	      -- location.
+     String           -- error type specific information.
+     (Maybe FilePath) -- filename the error is related to.
 
 instance Eq IOException where
-  (IOError h1 e1 loc1 str1) == (IOError h2 e2 loc2 str2) = 
-    e1==e2 && str1==str2 && h1==h2 && loc1 == loc2
+  (IOError h1 e1 loc1 str1 fn1) == (IOError h2 e2 loc2 str2 fn2) = 
+    e1==e2 && str1==str2 && h1==h2 && loc1==loc2 && fn1==fn2
 
 data IOErrorType
   = AlreadyExists        | HardwareFault
@@ -559,36 +561,36 @@ Predicates on IOError; little effort made on these so far...
 \begin{code}
 
 isAlreadyExistsError :: IOError -> Bool
-isAlreadyExistsError (IOException (IOError _ AlreadyExists _ _)) = True
-isAlreadyExistsError _		                   		 = False
+isAlreadyExistsError (IOException (IOError _ AlreadyExists _ _ _)) = True
+isAlreadyExistsError _                                             = False
 
 isAlreadyInUseError :: IOError -> Bool
-isAlreadyInUseError (IOException (IOError _ ResourceBusy _ _)) = True
-isAlreadyInUseError _		                 	       = False
+isAlreadyInUseError (IOException (IOError _ ResourceBusy _ _ _)) = True
+isAlreadyInUseError _                                            = False
 
 isFullError :: IOError -> Bool
-isFullError (IOException (IOError _ ResourceExhausted _ _)) = True
-isFullError _			             		    = False
+isFullError (IOException (IOError _ ResourceExhausted _ _ _)) = True
+isFullError _                                                 = False
 
 isEOFError :: IOError -> Bool
-isEOFError (IOException (IOError _ EOF _ _)) = True
-isEOFError _                   		     = False
+isEOFError (IOException (IOError _ EOF _ _ _)) = True
+isEOFError _                                   = False
 
 isIllegalOperation :: IOError -> Bool
-isIllegalOperation (IOException (IOError _ IllegalOperation _ _)) = True
-isIllegalOperation _			            		  = False
+isIllegalOperation (IOException (IOError _ IllegalOperation _ _ _)) = True
+isIllegalOperation _                                                = False
 
 isPermissionError :: IOError -> Bool
-isPermissionError (IOException (IOError _ PermissionDenied _ _)) = True
-isPermissionError _			          		 = False
+isPermissionError (IOException (IOError _ PermissionDenied _ _ _)) = True
+isPermissionError _                                                = False
 
 isDoesNotExistError :: IOError -> Bool
-isDoesNotExistError (IOException (IOError _ NoSuchThing _ _)) = True
-isDoesNotExistError _                           	      = False
+isDoesNotExistError (IOException (IOError _ NoSuchThing _ _ _)) = True
+isDoesNotExistError _                                           = False
 
 isUserError :: IOError -> Bool
 isUserError (UserError _) = True
-isUserError _		  = False
+isUserError _             = False
 \end{code}
 
 Showing @IOError@s
@@ -598,24 +600,26 @@ Showing @IOError@s
 -- For now we give a fairly uninformative error message which just happens to
 -- be like the ones that Hugs used to give.
 instance Show IOException where
-    showsPrec p (IOError hdl iot loc s) = showString s . showChar '\n'
+    showsPrec p (IOError _ _ _ s _) = showString s . showChar '\n'
 #else
 instance Show IOException where
-    showsPrec p (IOError hdl iot loc s) =
+    showsPrec p (IOError hdl iot loc s fn) =
       showsPrec p iot .
-      showChar '\n' .
       (case loc of
          "" -> id
-	 _  -> showString "Action: " . showString loc . showChar '\n') .
+	 _  -> showString "\nAction: " . showString loc) .
       showHdl .
       (case s of
 	 "" -> id
-	 _  -> showString "Reason: " . showString s)
+	 _  -> showString "\nReason: " . showString s) .
+      (case fn of
+	 Nothing -> id
+	 Just name -> showString "\nFile: " . showString name)
      where
       showHdl = 
        case hdl of
         Nothing -> id
-	Just h  -> showString "Handle: " . showsPrec p h
+	Just h  -> showString "\nHandle: " . showsPrec p h
 
 #endif
 \end{code}
@@ -634,8 +638,8 @@ constructErrorAndFail call_site
     ioError (IOException io_error)
 
 constructErrorAndFailWithInfo :: String -> String -> IO a
-constructErrorAndFailWithInfo call_site reason
-  = constructErrorMsg call_site (Just reason) >>= \ io_error ->
+constructErrorAndFailWithInfo call_site fn
+  = constructErrorMsg call_site (Just fn) >>= \ io_error ->
     ioError (IOException io_error)
 
 \end{code}
@@ -658,7 +662,7 @@ constructError	      :: String -> IO IOException
 constructError call_site = constructErrorMsg call_site Nothing
 
 constructErrorMsg	      :: String -> Maybe String -> IO IOException
-constructErrorMsg call_site reason =
+constructErrorMsg call_site fn =
  getErrType__            >>= \ errtype ->
  getErrStr__             >>= \ str ->
  let
@@ -688,10 +692,7 @@ constructErrorMsg call_site reason =
    unpackCString str ++
    (case iot of
      OtherError -> "(error code: " ++ show errtype ++ ")"
-     _ -> "") ++
-   (case reason of
-      Nothing -> ""
-      Just m  -> ": "++m)
+     _ -> "")
  in
- return (IOError Nothing iot call_site msg)
+ return (IOError Nothing iot call_site msg fn)
 \end{code}
diff --git a/ghc/lib/std/System.lhs b/ghc/lib/std/System.lhs
index c96e2b9..0cfec05 100644
--- a/ghc/lib/std/System.lhs
+++ b/ghc/lib/std/System.lhs
@@ -1,5 +1,5 @@
 % -----------------------------------------------------------------------------
-% $Id: System.lhs,v 1.26 2000/07/07 11:03:58 simonmar Exp $
+% $Id: System.lhs,v 1.27 2001/01/11 07:04:16 qrczak Exp $
 %
 % (c) The University of Glasgow, 1994-2000
 %
@@ -94,7 +94,7 @@ getEnv name = do
     if litstring /= nullAddr
 	then primUnpackCString litstring
         else ioException (IOError Nothing NoSuchThing "getEnv"
-			    ("environment variable: " ++ name))
+			  "no environment variable" (Just name))
 
 foreign import ccall "libHS_cbits.so" "getenv" unsafe primGetEnv :: PrimByteArray -> IO Addr
 \end{code}
@@ -114,7 +114,7 @@ The implementation does not support system calls.
 
 \begin{code}
 system        		:: String -> IO ExitCode
-system "" = ioException (IOError Nothing InvalidArgument "system" "null command")
+system "" = ioException (IOError Nothing InvalidArgument "system" "null command" Nothing)
 system cmd = do
     status <- primSystem (primPackString cmd)
     case status of
@@ -132,13 +132,13 @@ Before it terminates, any open or semi-closed handles are first closed.
 exitWith   		:: ExitCode -> IO a
 exitWith ExitSuccess = do
     primExit 0
-    ioException (IOError Nothing OtherError "exitWith" "exit should not return")
+    ioException (IOError Nothing OtherError "exitWith" "exit should not return" Nothing)
 
 exitWith (ExitFailure n) 
-  | n == 0 = ioException (IOError Nothing InvalidArgument "exitWith" "ExitFailure 0")
+  | n == 0 = ioException (IOError Nothing InvalidArgument "exitWith" "ExitFailure 0" Nothing)
   | otherwise = do
     primExit n
-    ioException (IOError Nothing OtherError "exitWith" "exit should not return")
+    ioException (IOError Nothing OtherError "exitWith" "exit should not return" Nothing)
 
 -- NOTE: shutdownHaskellAndExit must be called "safe", because it *can*
 -- re-enter Haskell land through finalizers.