\begin{code}
{-# OPTIONS -fno-implicit-prelude -#include "cbits/stgio.h" #-}
-#ifndef BODY /* Hugs just includes this in PreludeBuiltin so no header needed */
module IO (
Handle, -- abstract, instance of: Eq, Show.
HandlePosn(..), -- abstract, instance of: Eq, Show.
readIO, -- :: Read a => String -> IO a
readLn, -- :: Read a => IO a
+#ifndef __HUGS__
-- extensions
hPutBuf,
-#ifndef __HUGS__
hPutBufBA,
#endif
slurpFile
) where
#ifdef __HUGS__
-
-import PreludeBuiltin
-
+import Ix(Ix)
#else
-
--import PrelST
import PrelBase
import Char ( ord, chr )
#endif /* ndef __HUGS__ */
-#endif /* ndef BODY */
-
-#ifndef HEAD
-
-#ifdef __HUGS__
-#define __CONCURRENT_HASKELL__
-#define stToIO id
-#define unpackNBytesAccST primUnpackCStringAcc
-#endif
-
\end{code}
+#ifndef __HUGS__
+
Standard instances for @Handle@:
\begin{code}
r <- readIO l
return r
-#endif /* ndef HEAD */
\end{code}
+
+#else
+\begin{code}
+unimp :: String -> a
+unimp s = error ("function not implemented: " ++ s)
+
+type FILE_STAR = Int
+type Ptr = Int
+nULL = 0 :: Int
+
+data Handle
+ = Handle { name :: FilePath,
+ file :: FILE_STAR, -- C handle
+ state :: HState, -- open/closed/semiclosed
+ mode :: IOMode,
+ --seekable :: Bool,
+ bmode :: BufferMode,
+ buff :: Ptr,
+ buffSize :: Int
+ }
+
+instance Eq Handle where
+ h1 == h2 = file h1 == file h2
+
+instance Show Handle where
+ showsPrec _ h = showString ("<<handle " ++ name h ++ "=" ++ show (file 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
+ 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
+
+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
+ = 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)
+ where
+ mode2num :: IOMode -> Int
+ mode2num ReadMode = 0
+ mode2num WriteMode = 1
+ mode2num AppendMode = 2
+
+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)
+
+hFileSize :: Handle -> IO Integer
+hFileSize = unimp "IO.hFileSize"
+hIsEOF :: Handle -> IO Bool
+hIsEOF = unimp "IO.hIsEOF"
+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
+ = if state h /= HOpen
+ then (ioError.IOError) ("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 = 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"
+
+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]
+
+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 = return (state h == HOpen)
+hIsClosed h = return (state h == HClosed)
+hIsReadable h = return (mode h == ReadMode)
+hIsWritable h = return (mode h == WriteMode)
+
+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 "ioeGetErrorString"
+ioeGetHandle :: IOError -> Maybe Handle
+ioeGetHandle = unimp "ioeGetHandle"
+ioeGetFileName :: IOError -> Maybe FilePath
+ioeGetFileName = unimp "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/slurbFile
+slurpFile = unimp "slurpFile"
+\end{code}
+#endif
projects / ghc-hetmet.git / blobdiff