FudgetIOMonad.hs

module FudgetIOMonad where
import Prelude hiding (readFile,writeFile,
		       putStr,putStrLn,getLine,readLn,print,
		       catch,ioError)
import AllFudgets
import AbstractIO
import DialogueIO as D
import MUtils
import MT (MT(..))

newtype FIOM f i o a = M {unM::(a->f i o)->(D.IOError->f i o)->f i o}

runFIOM (M m) = m (const end) (error.show)

instance Functor (FIOM f i o) where
  fmap f (M m) = M $ \ c h -> m (c.f) h

instance Monad (FIOM f i o) where
  return x = M $ \ c h -> c x
  M m1>>=xm2 = M $ \ c h -> m1 (\x->unM (xm2 x) c h) h
  fail s = M $ \ c h -> h (OtherError s)
--------------------------------------------------------------------------------

getFM = M $ \ c h -> get c
putFM x = M $ \ c h -> put x (c ())

{- -- This causes weird type checking problems with GHC. Overlapping instances?
class Monad m => SPIO m i o | m -> i o where
  putM :: o -> m ()
  getM :: m i

instance StreamProcIO f => SPIO (FIOM f i o) i o where
  putM = putFM
  getM = getFM

instance (Monad (t m),MT t,SPIO m i o) => SPIO (t m) i o where
  putM = lift . putM
  getM = lift getM
-}
--------------------------------------------------------------------------------

instance FudgetIO f => FileIO (FIOM f i o) where
  readFile = strIO . ReadFile
  writeFile path s = succIO (WriteFile path s)

instance CatchIO D.IOError (FIOM f i o) where
  M m `catch` h = M $ \ c h' -> m c (\e->unM (h e) c h')
  ioError e = M $ \ _ h -> h e

instance FudgetIO f => DirectoryIO (FIOM f i o) where
  createDirectory path = succIO (CreateDirectory path "")
  removeFile = succIO . DeleteFile
  getDirectoryContents = strListIO . ReadDirectory
  doesDirectoryExist path = (((==)"d").take 1) # statusFile path

statusFile = strIO . StatusFile

instance FudgetIO f => SystemIO (FIOM f i o) where
  system cmd = succIO (System cmd) >> return ExitSuccess -- !!


instance IOErr D.IOError where
  isDoesNotExistError (ReadError _) = True
  isDoesNotExistError _ = False

--------------------------------------------------------------------------------

strIO req = ansIO req (\(Str s)->s)
strListIO req =ansIO req (\(StrList s)->s)
succIO req = ansIO req (\Success->())
ansIO req proj = M $ \ c h -> hIOerr req h (c.proj)