IO.hs

{-# OPTIONS_JHC -fffi #-}
module System.IO(
    module System.IO.Error,
    BufferMode(..),
    Handle,
    IOMode(..),
    SeekMode(..),
    hClose,
    hFileSize,
    hSeek,
    hTell,
    hFlush,
    hGetBuf,
    hGetPosn,
    hSetPosn,
    hGetContents,
    hGetChar,
    hGetLine,
    hIsOpen,
    hIsClosed,
    hPrint,
    hPutBuf,
    hPutChar,
    hPutStr,
    hPutStrLn,
    hIsEOF,
    isEOF,
    hWaitForInput,
    openFile,
    openBinaryFile,
    withFile,
    fixIO,
    HandlePosn,
    stdin,stdout,stderr,
    hIsReadable,
    hIsSeekable,
    hIsWritable,
    hLookAhead,
    hReady,
    hSetBuffering,
    hGetBuffering
    ) where

import Foreign.Ptr
import Jhc.Handle
import Jhc.IO
import Jhc.Num
import Jhc.Type.C
import System.C.Stdio

data BufferMode = NoBuffering | LineBuffering | BlockBuffering (Maybe Int)
    deriving(Eq, Ord, Read, Show)
data SeekMode = AbsoluteSeek | RelativeSeek | SeekFromEnd
    deriving(Eq,Ord,Bounded,Enum,Read,Show)

type HandlePosn = Integer

hIsReadable h = return $ handleIOMode h `elem` [ReadMode,ReadWriteMode]
hIsWritable h = return $ handleIOMode h `elem` [AppendMode,WriteMode,ReadWriteMode]

withFile :: FilePath -> IOMode -> (Handle -> IO r) -> IO r
withFile fp iom action = do
    h <- openFile fp iom
    r <- action h
    hClose h
    return r

hIsClosed h = not `fmap` hIsOpen h

hFlush :: Handle -> IO ()
hFlush h = withHandle h c_fflush

isEOF :: IO Bool
isEOF = hIsEOF stdin

hIsEOF :: Handle -> IO Bool
hIsEOF h = withHandle h $ \ptr -> do
    r <- c_feof ptr
    return (r /= 0)

hWaitForInput :: Handle -> Int -> IO Bool
hWaitForInput h to = withHandle h $ \ptr -> c_wait_for_input ptr to

hPutChar h ch = withHandle h $ \ptr -> do
    c_fputwc (fromInt (ord ch)) ptr
    return ()

hPutStr     :: Handle -> String -> IO ()
hPutStr h s   = withHandle h $ \ptr -> do
    sequence_ [ c_fputwc (fromInt (ord ch)) ptr | ch <- s ]

hPutStrLn   :: Handle -> String -> IO ()
hPutStrLn h s = do
    hPutStr h s
    hPutChar h '\n'

hPrint      :: Show a => Handle -> a -> IO ()
hPrint h x  =  hPutStrLn h (show x)

hGetLine    :: Handle -> IO String
hGetLine h  =  do c <- hGetChar h
                  if c == '\n' then return "" else
                    do s <- hGetLine h
                       return (c:s)

hGetChar :: Handle -> IO Char
hGetChar h = withHandle h $ \ptr -> do
    ch <- c_fgetwc ptr
    case ch of
        -1 -> fail "hGetChar: EOF"
        _  -> return (unsafeChr ch)

hGetContents :: Handle -> IO String
hGetContents h = withHandle h $ \ptr -> do
    let getContents' = do
            ch <- c_fgetwc ptr
            case ch of
                -1 -> return []
                _ -> do
                    xs <- unsafeInterleaveIO getContents'
                    return (unsafeChr ch:xs)
    unsafeInterleaveIO getContents'

hTell :: Handle -> IO Integer
hTell h = withHandle h $ \ptr -> fmap fromIntegral (c_ftell ptr)

hSeek :: Handle -> SeekMode -> Integer -> IO ()
hSeek h v w = withHandle h $ \ptr -> do
    let sm x = case x of
            AbsoluteSeek -> c_SEEK_SET
            RelativeSeek -> c_SEEK_CUR
            SeekFromEnd  -> c_SEEK_END
    c_fseek ptr (fromIntegral w) (sm v)
    return ()

hGetPosn :: Handle -> IO HandlePosn
hGetPosn h = hTell h

hSetPosn :: Handle -> HandlePosn -> IO ()
hSetPosn h hp = hSeek h AbsoluteSeek hp

hPutBuf :: Handle -> Ptr a -> Int -> IO ()
hPutBuf h p c = do
    let count = fromIntegral c
    rc <- withHandle h $ c_fwrite p 1 count
    if rc /= count then fail "hPutBuf: short write" else return ()

hGetBuf :: Handle -> Ptr a -> Int -> IO Int
hGetBuf h p c = do
    let count = fromIntegral c
    rc <- withHandle h $ c_fread p 1 count
    return $ fromIntegral rc

hIsSeekable :: Handle -> IO Bool
hIsSeekable _ = return True

hLookAhead :: Handle -> IO Char
hLookAhead = error "hLookAhead"

hReady :: Handle -> IO Bool
hReady _ = return True

hSetBuffering :: Handle -> BufferMode -> IO ()
hSetBuffering _ _ = return ()

hGetBuffering :: Handle -> IO BufferMode
hGetBuffering _ = error "hGetBuffering"

hFileSize :: Handle -> IO Integer
hFileSize h = do
    cp <- hTell h
    hSeek h SeekFromEnd 0
    fl <- hTell h
    hSeek h AbsoluteSeek cp
    return fl

foreign import primitive "I2I" cwintToChar :: CWint -> Char
foreign import ccall "jhc_wait_for_input" c_wait_for_input :: FILE -> Int -> IO Bool