PreludeIO

module PreludeIO(
    -- * IO monad
    IO(..), -- should be abstract
    -- * StdIO
    putChar, putStr, putStrLn, print,
    getChar, getLine, readIO, readLn,
    -- * Lazy IO
    getContents, interact,
    -- * File IO
    FilePath, readFile, writeFile, appendFile,
    -- * IO errors and error handling
    IOError(..), -- should be abstract
    ioError, userError, catch,
    -- * Extra (not part of Haskell 98)
    IOErrorType(..), ioeAddPath
  ) where
import Prelude
import MonadicIO0
import Monad(liftM,MonadPlus(..))

type  FilePath = String

data IOErrorType = EOFError          
                 | OtherError
                 | UserError
                 | AlreadyExistsError 
                 | DoesNotExistError 
                 | AlreadyInUseError 
                 | FullError         
                 | IllegalOperation  
                 | PermissionError
                 | ThreadDone
                 deriving (Eq,Show)

data IOError = IOE IOErrorType String deriving (Eq)

instance  Show IOError  where show (IOE k s) = "IO error: "++s

userError        ::  String -> IOError
userError        =   IOE UserError

newtype IO a = IO {unIO::(a->Main)->(IOError->Main)->Main}
-- Note: Main is the empty type, functions of type t->Main never return

-- Not in Haskell 98:
returnIO x = IO $ \ ok err -> ok x
fmapIO f (IO m) = IO $ \ ok err -> m (ok . f) err
bindIO (IO m1) xm2 = IO $ \ ok err -> m1 (\x->unIO (xm2 x) ok err) err
thenIO (IO m1) m2  = IO $ \ ok err -> m1 (\x->unIO m2      ok err) err
--thenIO m1 m2 = bindIO m1 (const m2)
failIO = ioError . userError
apIO (IO mf) (IO mx) = IO $ \ ok err -> mf (\f->mx (\x->ok (f x)) err) err

ioeAddPath :: IO a -> FilePath -> IO a
io `ioeAddPath` path = io `catch` \ (IOE k s) -> ioError (IOE k (path++": "++s))

instance Monad IO where
  return = returnIO
  (>>=) = bindIO
  (>>) = thenIO
--fail s = error s -- agrees with the original Haskell 98 report, appendix A
  fail = failIO    -- agrees with the revised  Haskell 98 report, section  8
--ap = apIO

-- Not in Haskell 98:
instance MonadPlus IO where
  mzero = fail "mzero"
  io1 `mplus` io2 = io1 `catch` const io2

instance Functor IO where fmap = fmapIO

ioError e = IO $ \ ok err -> err e

catch :: IO a -> (IOError -> IO a) -> IO a
catch (IO m) h = IO $ \ ok err -> m ok $ \ e -> unIO (h e) ok err

putChar          :: Char -> IO ()
putChar c        =  primPutChar c

putStr           :: String -> IO ()
putStr           =  primPutStr

putStrLn         :: String -> IO ()
putStrLn s       =  do putStr s
                       putChar '\n'

print            :: Show a => a -> IO ()
print x          =  putStrLn (show x)

getChar          :: IO Char
getChar          = primGetChar

getLine          :: IO String
getLine          =  do c <- getChar
                       if c == '\n' then return "" else 
                          do s <- getLine
                             return (c:s)

getContents      :: IO String
getContents      =  primGetContents

interact         ::  (String -> String) -> IO ()
interact f       =  putStr . f =<< getContents

readFile         :: FilePath -> IO String
readFile path    =  primReadFile path `ioeAddPath` path

writeFile        :: FilePath -> String -> IO ()
writeFile path s =  primWriteFile path s
                    `ioeAddPath` path

appendFile       :: FilePath -> String -> IO ()
appendFile path s = primAppendFile path s
                    `ioeAddPath` path

  -- raises an exception instead of an error
readIO   :: Read a => String -> IO a
readIO s =  case [x | (x,t) <- reads s, ("","") <- lex t] of
              [x] -> return x
              []  -> ioError (userError "Prelude.readIO: no parse")
              _   -> ioError (userError "Prelude.readIO: ambiguous parse")

readLn           :: Read a => IO a
readLn           =  readIO =<< getLine