X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Flib%2Fstd%2FIO.lhs;h=1a8d4b338ca9cbadbe14ecb68e189f67791b7a4b;hb=e921b2e307532e0f30eefa88b11a124be592bde4;hp=4bd0df114f30e3c0be53d6c282b042efafc66403;hpb=1b3b96644eb935b8c9fc6b4dbea58c4416daffc8;p=ghc-hetmet.git diff --git a/ghc/lib/std/IO.lhs b/ghc/lib/std/IO.lhs index 4bd0df1..1a8d4b3 100644 --- a/ghc/lib/std/IO.lhs +++ b/ghc/lib/std/IO.lhs @@ -107,7 +107,7 @@ import PrelRead ( readParen, Read(..), reads, lex, import PrelShow import PrelMaybe ( Either(..), Maybe(..) ) import PrelAddr ( Addr(..), nullAddr ) -import PrelArr ( ByteArray ) +import PrelByteArr ( ByteArray ) import PrelPack ( unpackNBytesAccST ) import PrelException ( ioError, catch ) @@ -121,35 +121,6 @@ import Char ( ord, chr ) \end{code} #ifndef __HUGS__ - -Standard instances for @Handle@: - -\begin{code} -instance Eq IOError where - (IOError h1 e1 loc1 str1) == (IOError h2 e2 loc2 str2) = - e1==e2 && str1==str2 && h1==h2 && loc1 == loc2 - -instance Eq Handle where - (Handle h1) == (Handle h2) = h1 == h2 - ---Type declared in IOHandle, instance here because it depends on Eq.Handle -instance Eq HandlePosn where - (HandlePosn h1 p1) == (HandlePosn h2 p2) = p1==p2 && h1==h2 - --- Type declared in IOBase, instance here because it --- depends on PrelRead.(Read Maybe) instance. -instance Read BufferMode where - readsPrec _ = - readParen False - (\r -> let lr = lex r - in - [(NoBuffering, rest) | ("NoBuffering", rest) <- lr] ++ - [(LineBuffering,rest) | ("LineBuffering",rest) <- lr] ++ - [(BlockBuffering mb,rest2) | ("BlockBuffering",rest1) <- lr, - (mb, rest2) <- reads rest1]) - -\end{code} - %********************************************************* %* * \subsection{Simple input operations} @@ -428,9 +399,6 @@ writeLines obj buf bufLen initPos s = shoveString n ls = case ls of [] -> - if n == 0 then - setBufWPtr obj 0{-new pos-} - else do {- At the end of a buffer write, update the buffer position in the underlying file object, so that if the handle @@ -476,9 +444,6 @@ writeLines obj buf (I# bufLen) (I# initPos#) s = shoveString n ls = case ls of [] -> - if n ==# 0# then - setBufWPtr obj 0 - else do {- At the end of a buffer write, update the buffer position in the underlying file object, so that if the handle @@ -521,9 +486,6 @@ writeBlocks obj buf bufLen initPos s = shoveString n ls = case ls of [] -> - if n == 0 then - setBufWPtr obj (0::Int) - else do {- At the end of a buffer write, update the buffer position in the underlying file object, so that if the handle @@ -570,9 +532,6 @@ writeBlocks obj buf (I# bufLen) (I# initPos#) s = shoveString n ls = case ls of [] -> - if n ==# 0# then - setBufWPtr obj (0::Int) - else do {- At the end of a buffer write, update the buffer position in the underlying file object, so that if the handle @@ -736,12 +695,14 @@ readLn = do l <- getLine \end{code} -#else +#else /* __HUGS__ */ + \begin{code} import Ix(Ix) +import Monad(when) unimp :: String -> a -unimp s = error ("function not implemented: " ++ s) +unimp s = error ("IO library: function not implemented: " ++ s) type FILE_STAR = Addr type Ptr = Addr @@ -749,20 +710,62 @@ nULL = nullAddr data Handle = Handle { name :: FilePath, - file :: FILE_STAR, -- C handle - state :: HState, -- open/closed/semiclosed + file :: FILE_STAR, -- C handle + mut :: IORef Handle_Mut, -- open/closed/semiclosed mode :: IOMode, - --seekable :: Bool, - bmode :: BufferMode, - buff :: Ptr, - buffSize :: Int + 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 = primRunST nh_stdin, + mut = primRunST (newIORef (Handle_Mut { state = HOpen })), + mode = ReadMode + } + +stdout + = Handle { + name = "stdout", + file = primRunST nh_stdout, + mut = primRunST (newIORef (Handle_Mut { state = HOpen })), + mode = WriteMode + } + +stderr + = Handle { + name = "stderr", + file = primRunST nh_stderr, + mut = primRunST (newIORef (Handle_Mut { state = HOpen })), + mode = WriteMode + } + + instance Eq Handle where h1 == h2 = file h1 == file h2 instance Show Handle where - showsPrec _ h = showString ("<>") + showsPrec _ h = showString ("`" ++ name h ++ "'") data HandlePosn = HandlePosn @@ -773,50 +776,192 @@ data IOMode = ReadMode | WriteMode | AppendMode | ReadWriteMode deriving (Eq, Ord, Ix, Bounded, Enum, Read, Show) data BufferMode = NoBuffering | LineBuffering - | BlockBuffering + | 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 Eq + 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 = primRunST (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' + -stdin = Handle "stdin" (primRunST nh_stdin) HOpen ReadMode NoBuffering nULL 0 -stdout = Handle "stdout" (primRunST nh_stdout) HOpen WriteMode LineBuffering nULL 0 -stderr = Handle "stderr" (primRunST nh_stderr) HOpen WriteMode NoBuffering nULL 0 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 return (Handle f fh HOpen mode BlockBuffering nULL 0) + 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 - | not (state h == HOpen) - = (ioError.IOError) ("hClose on non-open handle " ++ show h) - | otherwise - = nh_close (file h) >> - nh_errno >>= \err -> - if err == 0 - then return () - else (ioError.IOError) ("hClose: error closing " ++ name h) + = do mut <- readIORef (mut h) + putStrLn ( "hClose: state is " ++ show mut) + 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) -hFileSize :: Handle -> IO Integer -hFileSize = unimp "IO.hFileSize" -hIsEOF :: Handle -> IO Bool -hIsEOF = unimp "IO.hIsEOF" -isEOF :: IO Bool -isEOF = hIsEOF stdin +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" @@ -824,10 +969,12 @@ hGetBuffering :: Handle -> IO BufferMode hGetBuffering = unimp "IO.hGetBuffering" hFlush :: Handle -> IO () -hFlush h - = if state h /= HOpen - then (ioError.IOError) ("hFlush on closed/semiclosed file " ++ name h) - else nh_flush (file h) +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" @@ -838,7 +985,7 @@ hSeek = unimp "IO.hSeek" hWaitForInput :: Handle -> Int -> IO Bool hWaitForInput = unimp "hWaitForInput" hReady :: Handle -> IO Bool -hReady h = hWaitForInput h 0 +hReady h = unimp "hReady" -- hWaitForInput h 0 hGetChar :: Handle -> IO Char hGetChar h @@ -854,34 +1001,6 @@ hGetLine h = do c <- hGetChar h hLookAhead :: Handle -> IO Char hLookAhead = unimp "IO.hLookAhead" -hGetContents :: Handle -> IO String -hGetContents h - | not (state h == HOpen && mode h == ReadMode) - = (ioError.IOError) ("hGetContents on invalid handle " ++ show h) - | otherwise - = read_all (file h) - where - read_all f - = unsafeInterleaveIO ( - nh_read f >>= \ci -> - if ci == -1 - then hClose h >> return [] - else read_all f >>= \rest -> - return ((primIntToChar ci):rest) - ) - -hPutStr :: Handle -> String -> IO () -hPutStr h s - | not (state h == HOpen && mode h /= ReadMode) - = (ioError.IOError) ("hPutStr on invalid handle " ++ show h) - | otherwise - = write_all (file h) s - where - write_all f [] - = return () - write_all f (c:cs) - = nh_write f c >> - write_all f cs hPutChar :: Handle -> Char -> IO () hPutChar h c = hPutStr h [c] @@ -893,10 +1012,10 @@ hPrint :: Show a => Handle -> a -> IO () hPrint h = hPutStrLn h . show hIsOpen, hIsClosed, hIsReadable, hIsWritable :: Handle -> IO Bool -hIsOpen h = return (state h == HOpen) -hIsClosed h = return (state h == HClosed) +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 == WriteMode) +hIsWritable h = return (mode h `elem` [WriteMode, AppendMode]) hIsSeekable :: Handle -> IO Bool hIsSeekable = unimp "IO.hIsSeekable" @@ -921,11 +1040,11 @@ isUserError = unimp "IO.isUserError" ioeGetErrorString :: IOError -> String -ioeGetErrorString = unimp "ioeGetErrorString" +ioeGetErrorString = unimp "IO.ioeGetErrorString" ioeGetHandle :: IOError -> Maybe Handle -ioeGetHandle = unimp "ioeGetHandle" +ioeGetHandle = unimp "IO.ioeGetHandle" ioeGetFileName :: IOError -> Maybe FilePath -ioeGetFileName = unimp "ioeGetFileName" +ioeGetFileName = unimp "IO.ioeGetFileName" try :: IO a -> IO (Either IOError a) try p = catch (p >>= (return . Right)) (return . Left) @@ -948,7 +1067,9 @@ bracket_ before after m = do case rs of Right r -> return r Left e -> ioError e + -- TODO: Hugs/slurpFile -slurpFile = unimp "slurpFile" +slurpFile = unimp "IO.slurpFile" \end{code} -#endif + +#endif /* #ifndef __HUGS__ */