X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Flib%2Fstd%2FIO.lhs;h=d078d7babf003fbbc0a347adb26f40610c3a9e04;hb=ea138284b7343bb1810cfbd0284a608dc57f7d46;hp=4ce03d6fa4dc91889bc9dcf97a4d5fd37fa133dd;hpb=bb864806cef069b0bba9fbaa92b4135f99041dcd;p=ghc-hetmet.git diff --git a/ghc/lib/std/IO.lhs b/ghc/lib/std/IO.lhs index 4ce03d6..d078d7b 100644 --- a/ghc/lib/std/IO.lhs +++ b/ghc/lib/std/IO.lhs @@ -1,6 +1,9 @@ +% ----------------------------------------------------------------------------- +% $Id: IO.lhs,v 1.44 2001/06/09 07:06:05 qrczak Exp $ % -% (c) The AQUA Project, Glasgow University, 1994-1998 +% (c) The University of Glasgow, 1994-2000 % + \section[IO]{Module @IO@} Implementation of the standard Haskell IO interface, see @@ -16,7 +19,7 @@ module IO ( BufferMode(NoBuffering,LineBuffering,BlockBuffering), SeekMode(AbsoluteSeek,RelativeSeek,SeekFromEnd), - stdin, stdout, stderr, -- :: Handle + stdin, stdout, stderr, -- :: Handle openFile, -- :: FilePath -> IOMode -> IO Handle hClose, -- :: Handle -> IO () @@ -28,7 +31,7 @@ module IO ( hGetBuffering, -- :: Handle -> IO BufferMode hFlush, -- :: Handle -> IO () hGetPosn, -- :: Handle -> IO HandlePosn - hSetPosn, -- :: Handle -> HandlePosn -> IO () + hSetPosn, -- :: HandlePosn -> IO () hSeek, -- :: Handle -> SeekMode -> Integer -> IO () hWaitForInput, -- :: Handle -> Int -> IO Bool hReady, -- :: Handle -> IO Bool @@ -83,422 +86,9 @@ module IO ( ) where -#ifndef __HUGS__ import PrelIOBase -- Together these four Prelude modules define +import PrelRead import PrelHandle -- all the stuff exported by IO for the GHC version import PrelIO import PrelException - - --- The entire rest of this module is just Hugs - -#else /* ifndef __HUGS__ */ - -import Ix(Ix) -import PrelPrim ( IORef - , unsafePerformIO - , prelCleanupAfterRunAction - , copy_String_to_cstring - , primIntToChar - , primWriteCharOffAddr - , nullAddr - , newIORef - , writeIORef - , readIORef - , nh_close - , nh_errno - , nh_stdin - , nh_stdout - , nh_stderr - , nh_flush - , nh_open - , nh_free - , nh_read - , nh_write - , nh_filesize - , nh_iseof - ) -\end{code} - - -%********************************************************* -%* * -\subsection{The HUGS version of IO -%* * -%********************************************************* - -\begin{code} -import Ix(Ix) -import Monad(when) - -unimp :: String -> a -unimp s = error ("IO library: function not implemented: " ++ s) - -type FILE_STAR = Addr -type Ptr = Addr -nULL = nullAddr - -data Handle - = Handle { name :: FilePath, - file :: FILE_STAR, -- C handle - mut :: IORef Handle_Mut, -- open/closed/semiclosed - mode :: IOMode, - seekable :: Bool - } - -data Handle_Mut - = Handle_Mut { state :: HState - } - deriving Show - -set_state :: Handle -> HState -> IO () -set_state hdl new_state - = writeIORef (mut hdl) (Handle_Mut { state = new_state }) -get_state :: Handle -> IO HState -get_state hdl - = readIORef (mut hdl) >>= \m -> return (state m) - -mkErr :: Handle -> String -> IO a -mkErr h msg - = do mut <- readIORef (mut h) - when (state mut /= HClosed) - (nh_close (file h) >> set_state h HClosed) - dummy <- nh_errno - ioError (IOError msg) - -stdin - = Handle { - name = "stdin", - file = unsafePerformIO nh_stdin, - mut = unsafePerformIO (newIORef (Handle_Mut { state = HOpen })), - mode = ReadMode - } - -stdout - = Handle { - name = "stdout", - file = unsafePerformIO nh_stdout, - mut = unsafePerformIO (newIORef (Handle_Mut { state = HOpen })), - mode = WriteMode - } - -stderr - = Handle { - name = "stderr", - file = unsafePerformIO nh_stderr, - mut = unsafePerformIO (newIORef (Handle_Mut { state = HOpen })), - mode = WriteMode - } - - -instance Eq Handle where - h1 == h2 = file h1 == file h2 - -instance Show Handle where - showsPrec _ h = showString ("`" ++ name h ++ "'") - -data HandlePosn - = HandlePosn - deriving (Eq, Show) - - -data IOMode = ReadMode | WriteMode | AppendMode | ReadWriteMode - deriving (Eq, Ord, Ix, Bounded, Enum, Read, Show) - -data BufferMode = NoBuffering | LineBuffering - | BlockBuffering (Maybe Int) - deriving (Eq, Ord, Read, Show) - -data SeekMode = AbsoluteSeek | RelativeSeek | SeekFromEnd - deriving (Eq, Ord, Ix, Bounded, Enum, Read, Show) - -data HState = HOpen | HSemiClosed | HClosed - deriving (Show, Eq) - - --- A global variable holding a list of all open handles. --- Each handle is present as many times as it has been opened. --- Any given file is allowed to have _either_ one writeable handle --- or many readable handles in this list. The list is used to --- enforce single-writer multiple reader semantics. It also --- provides a list of handles for System.exitWith to flush and --- close. In order not to have to put all this stuff in the --- Prelude, System.exitWith merely runs prelExitWithAction, --- which is originally Nothing, but which we set to Just ... --- once handles appear in the list. - -allHandles :: IORef [Handle] -allHandles = unsafePerformIO (newIORef []) - -elemWriterHandles :: FilePath -> IO Bool -elemAllHandles :: FilePath -> IO Bool -addHandle :: Handle -> IO () -delHandle :: Handle -> IO () -cleanupHandles :: IO () - -cleanupHandles - = do hdls <- readIORef allHandles - mapM_ cleanupHandle hdls - where - cleanupHandle h - | mode h == ReadMode - = nh_close (file h) - >> nh_errno >>= \_ -> return () - | otherwise - = nh_flush (file h) >> nh_close (file h) - >> nh_errno >>= \_ -> return () - -elemWriterHandles fname - = do hdls <- readIORef allHandles - let hdls_w = filter ((/= ReadMode).mode) hdls - return (fname `elem` (map name hdls_w)) - -elemAllHandles fname - = do hdls <- readIORef allHandles - return (fname `elem` (map name hdls)) - -addHandle hdl - = do cleanup_action <- readIORef prelCleanupAfterRunAction - case cleanup_action of - Nothing - -> writeIORef prelCleanupAfterRunAction (Just cleanupHandles) - Just xx - -> return () - hdls <- readIORef allHandles - writeIORef allHandles (hdl : hdls) - -delHandle hdl - = do hdls <- readIORef allHandles - let hdls' = takeWhile (/= hdl) hdls - ++ drop 1 (dropWhile (/= hdl) hdls) - writeIORef allHandles hdls' - - - -openFile :: FilePath -> IOMode -> IO Handle -openFile f mode - - | null f - = (ioError.IOError) "openFile: empty file name" - - | mode == ReadMode - = do not_ok <- elemWriterHandles f - if not_ok - then (ioError.IOError) - ("openFile: `" ++ f ++ "' in " ++ show mode - ++ ": is already open for writing") - else openFile_main f mode - - | mode /= ReadMode - = do not_ok <- elemAllHandles f - if not_ok - then (ioError.IOError) - ("openFile: `" ++ f ++ "' in " ++ show mode - ++ ": is already open for reading or writing") - else openFile_main f mode - - | otherwise - = openFile_main f mode - -openFile_main f mode - = copy_String_to_cstring f >>= \nameptr -> - nh_open nameptr (mode2num mode) >>= \fh -> - nh_free nameptr >> - if fh == nULL - then (ioError.IOError) - ("openFile: can't open <<" ++ f ++ ">> in " ++ show mode) - else do r <- newIORef (Handle_Mut { state = HOpen }) - let hdl = Handle { name = f, file = fh, - mut = r, mode = mode } - addHandle hdl - return hdl - where - mode2num :: IOMode -> Int - mode2num ReadMode = 0 - mode2num WriteMode = 1 - mode2num AppendMode = 2 - mode2num ReadWriteMode - = error - ("openFile <<" ++ f ++ ">>: ReadWriteMode not supported") - -hClose :: Handle -> IO () -hClose h - = do mut <- readIORef (mut h) - if state mut == HClosed - then mkErr h - ("hClose on closed handle " ++ show h) - else - do set_state h HClosed - delHandle h - nh_close (file h) - err <- nh_errno - if err == 0 - then return () - else mkErr h - ("hClose: error closing " ++ name h) - -hGetContents :: Handle -> IO String -hGetContents h - | mode h /= ReadMode - = mkErr h ("hGetContents on non-ReadMode handle " ++ show h) - | otherwise - = do mut <- readIORef (mut h) - if state mut /= HOpen - then mkErr h - ("hGetContents on closed/semiclosed handle " ++ show h) - else - do set_state h HSemiClosed - read_all (file h) - where - read_all f - = nh_read f >>= \ci -> - if ci == -1 - then return [] - else read_all f >>= \rest -> - return ((primIntToChar ci):rest) - -hPutStr :: Handle -> String -> IO () -hPutStr h s - | mode h == ReadMode - = mkErr h ("hPutStr on ReadMode handle " ++ show h) - | otherwise - = do mut <- readIORef (mut h) - if state mut /= HOpen - then mkErr h - ("hPutStr on closed/semiclosed handle " ++ show h) - else write_all (file h) s - where - write_all f [] - = return () - write_all f (c:cs) - = nh_write f c >> write_all f cs - -hFileSize :: Handle -> IO Integer -hFileSize h - = do sz <- nh_filesize (file h) - er <- nh_errno - if er == 0 - then return (fromIntegral sz) - else mkErr h ("hFileSize on " ++ show h) - -hIsEOF :: Handle -> IO Bool -hIsEOF h - = do iseof <- nh_iseof (file h) - er <- nh_errno - if er == 0 - then return (iseof /= 0) - else mkErr h ("hIsEOF on " ++ show h) - -isEOF :: IO Bool -isEOF = hIsEOF stdin - -hSetBuffering :: Handle -> BufferMode -> IO () -hSetBuffering = unimp "IO.hSetBuffering" -hGetBuffering :: Handle -> IO BufferMode -hGetBuffering = unimp "IO.hGetBuffering" - -hFlush :: Handle -> IO () -hFlush h - = do mut <- readIORef (mut h) - if state mut /= HOpen - then mkErr h - ("hFlush on closed/semiclosed file " ++ name h) - else nh_flush (file h) - -hGetPosn :: Handle -> IO HandlePosn -hGetPosn = unimp "IO.hGetPosn" -hSetPosn :: HandlePosn -> IO () -hSetPosn = unimp "IO.hSetPosn" -hSeek :: Handle -> SeekMode -> Integer -> IO () -hSeek = unimp "IO.hSeek" -hWaitForInput :: Handle -> Int -> IO Bool -hWaitForInput = unimp "hWaitForInput" -hReady :: Handle -> IO Bool -hReady h = unimp "hReady" -- hWaitForInput h 0 - -hGetChar :: Handle -> IO Char -hGetChar h - = nh_read (file h) >>= \ci -> - return (primIntToChar ci) - -hGetLine :: Handle -> IO String -hGetLine h = do c <- hGetChar h - if c=='\n' then return "" - else do cs <- hGetLine h - return (c:cs) - -hLookAhead :: Handle -> IO Char -hLookAhead = unimp "IO.hLookAhead" - - -hPutChar :: Handle -> Char -> IO () -hPutChar h c = hPutStr h [c] - -hPutStrLn :: Handle -> String -> IO () -hPutStrLn h s = do { hPutStr h s; hPutChar h '\n' } - -hPrint :: Show a => Handle -> a -> IO () -hPrint h = hPutStrLn h . show - -hIsOpen, hIsClosed, hIsReadable, hIsWritable :: Handle -> IO Bool -hIsOpen h = do { s <- get_state h; return (s == HOpen) } -hIsClosed h = do { s <- get_state h; return (s == HClosed) } -hIsReadable h = return (mode h == ReadMode) -hIsWritable h = return (mode h `elem` [WriteMode, AppendMode]) - -hIsSeekable :: Handle -> IO Bool -hIsSeekable = unimp "IO.hIsSeekable" - -isIllegalOperation, - isAlreadyExistsError, - isDoesNotExistError, - isAlreadyInUseError, - isFullError, - isEOFError, - isPermissionError, - isUserError :: IOError -> Bool - -isIllegalOperation = unimp "IO.isIllegalOperation" -isAlreadyExistsError = unimp "IO.isAlreadyExistsError" -isDoesNotExistError = unimp "IO.isDoesNotExistError" -isAlreadyInUseError = unimp "IO.isAlreadyInUseError" -isFullError = unimp "IO.isFullError" -isEOFError = unimp "IO.isEOFError" -isPermissionError = unimp "IO.isPermissionError" -isUserError = unimp "IO.isUserError" - - -ioeGetErrorString :: IOError -> String -ioeGetErrorString = unimp "IO.ioeGetErrorString" -ioeGetHandle :: IOError -> Maybe Handle -ioeGetHandle = unimp "IO.ioeGetHandle" -ioeGetFileName :: IOError -> Maybe FilePath -ioeGetFileName = unimp "IO.ioeGetFileName" - -try :: IO a -> IO (Either IOError a) -try p = catch (p >>= (return . Right)) (return . Left) - -bracket :: IO a -> (a -> IO b) -> (a -> IO c) -> IO c -bracket before after m = do - x <- before - rs <- try (m x) - after x - case rs of - Right r -> return r - Left e -> ioError e - --- variant of the above where middle computation doesn't want x -bracket_ :: IO a -> (a -> IO b) -> IO c -> IO c -bracket_ before after m = do - x <- before - rs <- try m - after x - case rs of - Right r -> return r - Left e -> ioError e - --- TODO: Hugs/slurpFile -slurpFile = unimp "IO.slurpFile" \end{code} - -#endif /* #ifndef __HUGS__ */