readIO, -- :: Read a => String -> IO a
readLn, -- :: Read a => IO a
-#ifndef __HUGS__
- -- extensions
- hPutBuf,
- hPutBufBA,
-#endif
- slurpFile
-
) where
#ifdef __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
+ )
#else
--import PrelST
import PrelBase
import PrelShow
import PrelMaybe ( Either(..), Maybe(..) )
import PrelAddr ( Addr(..), nullAddr )
-import PrelArr ( ByteArray )
+import PrelByteArr ( ByteArray )
import PrelPack ( unpackNBytesAccST )
import PrelException ( ioError, catch )
+import PrelConc
#ifndef __PARALLEL_HASKELL__
import PrelForeign ( ForeignObj )
\begin{code}
hGetChar :: Handle -> IO Char
-hGetChar handle =
- wantReadableHandle "hGetChar" handle $ \ handle_ -> do
- let fo = haFO__ handle_
- intc <- mayBlock fo (fileGetc fo) -- ConcHask: UNSAFE, may block
- if intc /= ((-1)::Int)
- then return (chr intc)
- else constructErrorAndFail "hGetChar"
+hGetChar handle = do
+ c <- mayBlockRead "hGetChar" handle fileGetc
+ return (chr c)
{-
If EOF is reached before EOL is encountered, ignore the
\begin{code}
hLookAhead :: Handle -> IO Char
-hLookAhead handle =
- wantReadableHandle "hLookAhead" handle $ \ handle_ -> do
- let fo = haFO__ handle_
- intc <- mayBlock fo (fileLookAhead fo) -- ConcHask: UNSAFE, may block
- if intc /= (-1)
- then return (chr intc)
- else constructErrorAndFail "hLookAhead"
-
+hLookAhead handle = do
+ rc <- mayBlockRead "hLookAhead" handle fileLookAhead
+ return (chr rc)
\end{code}
Left e -> ioError e
\end{code}
-%*********************************************************
-%* *
-\subsection{Standard IO}
-%* *
-%*********************************************************
-
-The Prelude has from Day 1 provided a collection of common
-IO functions. We define these here, but let the Prelude
-export them.
-
-\begin{code}
-putChar :: Char -> IO ()
-putChar c = hPutChar stdout c
-
-putStr :: String -> IO ()
-putStr s = hPutStr stdout s
-
-putStrLn :: String -> IO ()
-putStrLn s = do putStr s
- putChar '\n'
-
-print :: Show a => a -> IO ()
-print x = putStrLn (show x)
-
-getChar :: IO Char
-getChar = hGetChar stdin
-
-getLine :: IO String
-getLine = hGetLine stdin
-
-getContents :: IO String
-getContents = hGetContents stdin
-
-interact :: (String -> String) -> IO ()
-interact f = do s <- getContents
- putStr (f s)
-
-readFile :: FilePath -> IO String
-readFile name = openFile name ReadMode >>= hGetContents
-writeFile :: FilePath -> String -> IO ()
-writeFile name str = do
- hdl <- openFile name WriteMode
- hPutStr hdl str
- hClose hdl
-appendFile :: FilePath -> String -> IO ()
-appendFile name str = do
- hdl <- openFile name AppendMode
- hPutStr hdl str
- hClose hdl
-
-readLn :: Read a => IO a
-readLn = do l <- getLine
- r <- readIO l
- return r
-
-
-\end{code}
+%*********************************************************
+%* *
+\subsection{The HUGS version of IO
+%* *
+%*********************************************************
#else /* __HUGS__ */
\begin{code}
import Ix(Ix)
+import Monad(when)
unimp :: String -> a
unimp s = error ("IO library: function not implemented: " ++ s)
data Handle_Mut
= Handle_Mut { state :: HState
}
+ deriving Show
set_state :: Handle -> HState -> IO ()
set_state hdl new_state
mkErr :: Handle -> String -> IO a
mkErr h msg
- = do nh_close (file h)
+ = 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 })),
+ file = unsafePerformIO nh_stdin,
+ mut = unsafePerformIO (newIORef (Handle_Mut { state = HOpen })),
mode = ReadMode
}
stdout
= Handle {
name = "stdout",
- file = primRunST nh_stdout,
- mut = primRunST (newIORef (Handle_Mut { state = HOpen })),
+ file = unsafePerformIO nh_stdout,
+ mut = unsafePerformIO (newIORef (Handle_Mut { state = HOpen })),
mode = WriteMode
}
stderr
= Handle {
name = "stderr",
- file = primRunST nh_stderr,
- mut = primRunST (newIORef (Handle_Mut { state = HOpen })),
+ file = unsafePerformIO nh_stderr,
+ mut = unsafePerformIO (newIORef (Handle_Mut { state = HOpen })),
mode = WriteMode
}
h1 == h2 = file h1 == file h2
instance Show Handle where
- showsPrec _ h = showString ("<<" ++ name 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 = 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 })
- return (Handle {
- name = f,
- file = fh,
- mut = r,
- mode = 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
("hClose on closed handle " ++ show h)
else
do set_state h HClosed
+ delHandle h
nh_close (file h)
err <- nh_errno
if err == 0
case rs of
Right r -> return r
Left e -> ioError e
+
-- TODO: Hugs/slurpFile
slurpFile = unimp "IO.slurpFile"
\end{code}
projects / ghc-hetmet.git / blobdiff