import PrelShow
import PrelMaybe ( Either(..), Maybe(..) )
import PrelAddr ( Addr(..), nullAddr )
-import PrelArr ( ByteArray )
+import PrelByteArr ( ByteArray )
import PrelPack ( unpackNBytesAccST )
import PrelException ( ioError, catch )
\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}
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
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
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
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
\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 = Int
-type Ptr = Int
-nULL = 0 :: Int
+type FILE_STAR = Addr
+type Ptr = Addr
+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 ("<<handle " ++ name h ++ "=" ++ show (file h) ++ ">>")
+ showsPrec _ h = showString ("`" ++ name h ++ "'")
data HandlePosn
= HandlePosn
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"
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"
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
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 (primCharToInt c) >>
- write_all f cs
hPutChar :: Handle -> Char -> IO ()
hPutChar h c = hPutStr h [c]
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"
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)
Right r -> return r
Left e -> ioError e
--- TODO: Hugs/slurbFile
-slurpFile = unimp "slurpFile"
+-- TODO: Hugs/slurpFile
+slurpFile = unimp "IO.slurpFile"
\end{code}
-#endif
+
+#endif /* #ifndef __HUGS__ */
projects / ghc-hetmet.git / blobdiff