From: Ian Lynagh Date: Sun, 4 Jan 2009 17:30:18 +0000 (+0000) Subject: Add errno to the IOError type X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=dfa89e180abad4d06a4b444e0a97aa2e05fa43cc;hp=328a2c4f748e81a1e613e2de48ebe86cfff60c67;p=ghc-base.git Add errno to the IOError type --- diff --git a/Foreign/C/Error.hs b/Foreign/C/Error.hs index 950a7a4..7c48180 100644 --- a/Foreign/C/Error.hs +++ b/Foreign/C/Error.hs @@ -498,8 +498,9 @@ errnoToIOError :: String -- ^ the location where the error occurred errnoToIOError loc errno maybeHdl maybeName = unsafePerformIO $ do str <- strerror errno >>= peekCString #if __GLASGOW_HASKELL__ - return (IOError maybeHdl errType loc str maybeName) + return (IOError maybeHdl errType loc str (Just errno') maybeName) where + Errno errno' = errno errType | errno == eOK = OtherError | errno == e2BIG = ResourceExhausted diff --git a/Foreign/Marshal/Alloc.hs b/Foreign/Marshal/Alloc.hs index 9fd576d..282791a 100644 --- a/Foreign/Marshal/Alloc.hs +++ b/Foreign/Marshal/Alloc.hs @@ -178,7 +178,10 @@ failWhenNULL :: String -> IO (Ptr a) -> IO (Ptr a) failWhenNULL name f = do addr <- f if addr == nullPtr -#if __GLASGOW_HASKELL__ || __HUGS__ +#if __GLASGOW_HASKELL__ + then ioError (IOError Nothing ResourceExhausted name + "out of memory" Nothing Nothing) +#elif __HUGS__ then ioError (IOError Nothing ResourceExhausted name "out of memory" Nothing) #else diff --git a/GHC/Handle.hs b/GHC/Handle.hs index 97b7f88..6255a79 100644 --- a/GHC/Handle.hs +++ b/GHC/Handle.hs @@ -187,8 +187,8 @@ withHandle__' fun h m act = return () augmentIOError :: IOException -> String -> Handle -> IOException -augmentIOError (IOError _ iot _ str fp) fun h - = IOError (Just h) iot fun str filepath +augmentIOError ioe@IOError{ ioe_filename = fp } fun h + = ioe { ioe_handle = Just h, ioe_location = fun, ioe_filename = filepath } where filepath | Just _ <- fp = fp | otherwise = case h of @@ -267,7 +267,7 @@ checkReadableHandle act handle_ = wantSeekableHandle :: String -> Handle -> (Handle__ -> IO a) -> IO a wantSeekableHandle fun h@(DuplexHandle _ _ _) _act = ioException (IOError (Just h) IllegalOperation fun - "handle is not seekable" Nothing) + "handle is not seekable" Nothing Nothing) wantSeekableHandle fun h@(FileHandle _ m) act = withHandle_' fun h m (checkSeekableHandle act) @@ -289,32 +289,32 @@ ioe_closedHandle, ioe_EOF, ioe_closedHandle = ioException (IOError Nothing IllegalOperation "" - "handle is closed" Nothing) + "handle is closed" Nothing Nothing) ioe_EOF = ioException - (IOError Nothing EOF "" "" Nothing) + (IOError Nothing EOF "" "" Nothing Nothing) ioe_notReadable = ioException (IOError Nothing IllegalOperation "" - "handle is not open for reading" Nothing) + "handle is not open for reading" Nothing Nothing) ioe_notWritable = ioException (IOError Nothing IllegalOperation "" - "handle is not open for writing" Nothing) + "handle is not open for writing" Nothing Nothing) ioe_notSeekable = ioException (IOError Nothing IllegalOperation "" - "handle is not seekable" Nothing) + "handle is not seekable" Nothing Nothing) ioe_notSeekable_notBin = ioException (IOError Nothing IllegalOperation "" "seek operations on text-mode handles are not allowed on this platform" - Nothing) + Nothing Nothing) ioe_finalizedHandle :: FilePath -> Handle__ ioe_finalizedHandle fp = throw (IOError Nothing IllegalOperation "" - "handle is finalized" (Just fp)) + "handle is finalized" Nothing (Just fp)) ioe_bufsiz :: Int -> IO a ioe_bufsiz n = ioException (IOError Nothing InvalidArgument "hSetBuffering" - ("illegal buffer size " ++ showsPrec 9 n []) Nothing) + ("illegal buffer size " ++ showsPrec 9 n []) Nothing Nothing) -- 9 => should be parens'ified. -- ----------------------------------------------------------------------------- @@ -843,8 +843,8 @@ stderr = unsafePerformIO $ do -- Opening and Closing Files addFilePathToIOError :: String -> FilePath -> IOException -> IOException -addFilePathToIOError fun fp (IOError h iot _ str _) - = IOError h iot fun str (Just fp) +addFilePathToIOError fun fp ioe + = ioe{ ioe_location = fun, ioe_filename = Just fp } -- | Computation 'openFile' @file mode@ allocates and returns a new, open -- handle to manage the file @file@. It manages input if @mode@ @@ -994,7 +994,7 @@ fdToHandle_stat fd mb_stat is_socket filepath mode binary = do case fd_type of Directory -> ioException (IOError Nothing InappropriateType "openFile" - "is a directory" Nothing) + "is a directory" Nothing Nothing) -- regular files need to be locked RegularFile -> do @@ -1005,7 +1005,7 @@ fdToHandle_stat fd mb_stat is_socket filepath mode binary = do r <- lockFile fd dev ino (fromBool write) when (r == -1) $ ioException (IOError Nothing ResourceBusy "openFile" - "file is locked" Nothing) + "file is locked" Nothing Nothing) #endif mkFileHandle fd is_socket filepath ha_type binary @@ -1232,7 +1232,7 @@ hFileSize handle = if r /= -1 then return r else ioException (IOError Nothing InappropriateType "hFileSize" - "not a regular file" Nothing) + "not a regular file" Nothing Nothing) -- | 'hSetFileSize' @hdl@ @size@ truncates the physical file with handle @hdl@ to @size@ bytes. @@ -1746,7 +1746,7 @@ hDuplicateTo h1@(DuplexHandle _ r1 w1) h2@(DuplexHandle _ r2 w2) = do withHandle' "hDuplicateTo" h1 r1 (dupHandleTo (Just w1) r2_) hDuplicateTo h1 _ = ioException (IOError (Just h1) IllegalOperation "hDuplicateTo" - "handles are incompatible" Nothing) + "handles are incompatible" Nothing Nothing) -- --------------------------------------------------------------------------- -- showing Handles. diff --git a/GHC/IO.hs b/GHC/IO.hs index e73b592..a17714f 100644 --- a/GHC/IO.hs +++ b/GHC/IO.hs @@ -341,7 +341,7 @@ lazyRead handle = SemiClosedHandle -> lazyRead' handle handle_ _ -> ioException (IOError (Just handle) IllegalOperation "lazyRead" - "illegal handle type" Nothing) + "illegal handle type" Nothing Nothing) lazyRead' :: Handle -> Handle__ -> IO (Handle__, [Char]) lazyRead' h handle_ = do @@ -971,4 +971,4 @@ illegalBufferSize handle fn sz = ioException (IOError (Just handle) InvalidArgument fn ("illegal buffer size " ++ showsPrec 9 sz []) - Nothing) + Nothing Nothing) diff --git a/GHC/IOBase.lhs b/GHC/IOBase.lhs index c15d6c7..48a0950 100644 --- a/GHC/IOBase.lhs +++ b/GHC/IOBase.lhs @@ -787,6 +787,7 @@ data IOException ioe_type :: IOErrorType, -- what it was. ioe_location :: String, -- location. ioe_description :: String, -- error type specific information. + ioe_errno :: Maybe CInt, -- errno leading to this error, if any. ioe_filename :: Maybe FilePath -- filename the error is related to. } deriving Typeable @@ -794,8 +795,8 @@ data IOException instance Exception IOException instance Eq IOException where - (IOError h1 e1 loc1 str1 fn1) == (IOError h2 e2 loc2 str2 fn2) = - e1==e2 && str1==str2 && h1==h2 && loc1==loc2 && fn1==fn2 + (IOError h1 e1 loc1 str1 en1 fn1) == (IOError h2 e2 loc2 str2 en2 fn2) = + e1==e2 && str1==str2 && h1==h2 && loc1==loc2 && en1==en2 && fn1==fn2 -- | An abstract type that contains a value for each variant of 'IOError'. data IOErrorType @@ -857,13 +858,13 @@ instance Show IOErrorType where -- > fail s = ioError (userError s) -- userError :: String -> IOError -userError str = IOError Nothing UserError "" str Nothing +userError str = IOError Nothing UserError "" str Nothing Nothing -- --------------------------------------------------------------------------- -- Showing IOErrors instance Show IOException where - showsPrec p (IOError hdl iot loc s fn) = + showsPrec p (IOError hdl iot loc s _ fn) = (case fn of Nothing -> case hdl of Nothing -> id diff --git a/System/Environment.hs b/System/Environment.hs index 4b32987..c734158 100644 --- a/System/Environment.hs +++ b/System/Environment.hs @@ -123,7 +123,7 @@ getEnv name = if litstring /= nullPtr then peekCString litstring else ioException (IOError Nothing NoSuchThing "getEnv" - "no environment variable" (Just name)) + "no environment variable" Nothing (Just name)) foreign import ccall unsafe "getenv" c_getenv :: CString -> IO (Ptr CChar) diff --git a/System/Exit.hs b/System/Exit.hs index e211ca5..f4fbac5 100644 --- a/System/Exit.hs +++ b/System/Exit.hs @@ -64,7 +64,7 @@ exitWith ExitSuccess = throwIO ExitSuccess exitWith code@(ExitFailure n) | n /= 0 = throwIO code #ifdef __GLASGOW_HASKELL__ - | otherwise = ioError (IOError Nothing InvalidArgument "exitWith" "ExitFailure 0" Nothing) + | otherwise = ioError (IOError Nothing InvalidArgument "exitWith" "ExitFailure 0" Nothing Nothing) #endif #endif /* ! __NHC__ */ diff --git a/System/IO/Error.hs b/System/IO/Error.hs index 0313d7b..fcbffad 100644 --- a/System/IO/Error.hs +++ b/System/IO/Error.hs @@ -155,6 +155,9 @@ mkIOError t location maybe_hdl maybe_filename = IOError{ ioe_type = t, ioe_location = location, ioe_description = "", +#if defined(__GLASGOW_HASKELL__) + ioe_errno = Nothing, +#endif ioe_handle = maybe_hdl, ioe_filename = maybe_filename } @@ -370,8 +373,9 @@ annotateIOError :: IOError -> Maybe Handle -> Maybe FilePath -> IOError -annotateIOError (IOError ohdl errTy _ str opath) loc hdl path = - IOError (hdl `mplus` ohdl) errTy loc str (path `mplus` opath) +annotateIOError ioe loc hdl path = + ioe{ ioe_handle = hdl `mplus` ioe_handle ioe, + ioe_location = loc, ioe_filename = path `mplus` ioe_filename ioe } where Nothing `mplus` ys = ys xs `mplus` _ = xs diff --git a/System/Posix/Internals.hs b/System/Posix/Internals.hs index 1a9f845..ebd9ec9 100644 --- a/System/Posix/Internals.hs +++ b/System/Posix/Internals.hs @@ -129,7 +129,11 @@ statGetType p_stat = do ioe_unknownfiletype :: IOException ioe_unknownfiletype = IOError Nothing UnsupportedOperation "fdType" - "unknown file type" Nothing + "unknown file type" +#if __GLASGOW_HASKELL__ + Nothing +#endif + Nothing #if __GLASGOW_HASKELL__ && (defined(mingw32_HOST_OS) || defined(__MINGW32__)) closeFd :: Bool -> CInt -> IO CInt