--------------------------------------------------------------------------------
--                                                                            --
--  A long file which contains a lot of special monad instances               --
--                                                                            --
--------------------------------------------------------------------------------

-- Id 

type Id x = x in mapId, resultId, joinId, 
                 zeroError, plusError, writeId,
                 orelse

mapId :: (x -> y) -> Id x -> Id y
mapId = id

instance Functor Id where
  map = mapId

resultId :: x -> Id x
resultId = id

joinId :: Id (Id x) -> Id x
joinId = id

instance Monad Id where
  result = resultId
  join = joinId
 
writeId :: Write x => Id x -> IO ()  
writeId = write

instance Write x => Write (Id x) where
  write = writeId

-- Error

type Error x = SUM Msg x in mapError, resultError, joinError,
                            zeroError, plusError, swaprError,
                            errError, writeError, orelse
                            
mapError :: (x -> y) -> Error x -> Error y
mapError f = inl <+> inr . f

instance Functor Error where
  map = mapError

resultError :: x -> Error x
resultError = inr

joinError :: Error (Error x) -> Error x
joinError = inl <+> id

instance Monad Error where
  result = resultError
  join = joinError

swaprError :: Monad m => Error (m x) -> m (Error x)
swaprError = (result . inl) <+> map inr

instance SwapR Error where
  swapr = swaprError

writeError :: Write x => Error x -> IO ()
writeError = error <+> write
            where
             error msg = put ("ERROR: " ++ msg)             

instance Write x => Write (Error x) where
  write = writeError

-- Reader

type Reader r x = r -> x in mapRead, resultRead, joinRead, 
                            swaplRead, univRW, counivRW,
                            readRead, withRead,
                            liftRW,
                            actRW,
                            withRW, readRW,
                            runIORead, runIORW,
                            zeroRW, plusRW,
                            invokeRW                            

mapRead :: (x -> y) -> Reader r x -> Reader r y  
mapRead f g = f . g

instance Functor (Reader r) where
  map = mapRead

resultRead :: x -> Reader r x
resultRead x r = x

joinRead :: Reader r (Reader r x) -> Reader r x
joinRead m r = m r r

instance Monad (Reader r) where
  result = resultRead
  join = joinRead

swaplRead :: Monad m => m (Reader r x) -> Reader r (m x)
swaplRead m r = do { f <- m ; result (f r) }

instance SwapL (Reader r) where
  swapl = swaplRead

-- Writer

type Writer s x = (s,x) in mapWrite, resultWrite, joinWrite,
                           swaprWrite, univRW, counivRW,
                           genWrite, 
                           writeWrite,
                           liftRW,
                           actRW,
                           withRW, readRW,
                           runIORW,
                           zeroRW, plusRW,
                           invokeRW
                           
mapWrite :: (x -> y) -> Writer s x -> Writer s y
mapWrite f (s,x) = (s,f x)

instance Functor (Writer s) where
  map = mapWrite 
  
resultWrite :: Monoid s => x -> Writer s x
resultWrite x = (e,x)

joinWrite :: Monoid s => Writer s (Writer s x) -> Writer s x
joinWrite (s,(t,x)) = ((s|+|t),x)

instance Monoid s => Monad (Writer s) where
  join = joinWrite
  result = resultWrite

swaprWrite :: Monad m => Writer s (m x) -> m (Writer s x)
swaprWrite (s,m) = do { x <- m ; result (s,x) }

instance SwapR (Writer s) where
  swapr = swaprWrite
    
-- Reader-Writer Adjoint

counivRW :: (Writer s x -> y) -> x -> Reader s y
counivRW f x s = f (s,x) 

univRW :: (x -> Reader s y) -> Writer s x -> y
univRW f (s,x) = f x s

instance Adjoint (Writer s) (Reader s) where
  couniv = counivRW
  univ = univRW
   
-- Composing at the right
                              
type RComp m n x = n (m x) in mapR, resultR, joinR,             
                              liftR,
                              errError,
                              genWrite,
                              readR,withR,
                              runIOR,
                              zeroError, plusError, 
                              orelse

mapR :: (Functor m, Functor n) => (x -> y) -> RComp m n x -> RComp m n y
mapR = map . map

instance (Functor m, Functor n) => Functor (RComp m n) where
  map = mapR

resultR :: (Monad m, Monad n) => x -> RComp m n x
resultR = result . result

joinR :: (SwapR m, Monad n) => RComp m n (RComp m n x) -> RComp m n x
joinR = map join . join . map swapr

instance (SwapR m, Monad n) => Monad (RComp m n) where
  result = resultR
  join = joinR

liftR :: (Functor n, Monad m) => n x -> RComp m n x
liftR = map result

instance Monad m => MonadT (RComp m) where
  lift = liftR

liftRT :: (Monad n, MonadT (RComp m)) => n x -> RComp m n x
liftRT = lift

withR :: EnvMonad env n => env -> RComp m n x -> RComp m n x
withR e m = with e m

readR :: (EnvMonad env n, MonadT (RComp m)) => RComp m n env
readR = liftRT read

instance (EnvMonad env n, MonadT (RComp m))
        => EnvMonad env (RComp m n) where
  with = withR
  read = readR            

runIOR :: RunIO m (n x) => RComp n m x -> IO ()
runIOR = runIO 

instance RunIO m (n x) => RunIO (RComp n m) x where
  runIO = runIOR

-- Composing at the left

type LComp m n x = m (n x) in mapL, resultL, joinL, 
                              liftL,
                              readRead, withRead,
                              runIORead

mapL :: (Functor m, Functor n) => (x -> y) -> LComp m n x -> LComp m n y
mapL = map . map

instance (Functor m, Functor n) => Functor (LComp m n) where
  map = mapL

resultL :: (Monad m, Monad n) => x -> LComp m n x
resultL = result . result

joinL :: (Monad n, SwapL m) => LComp m n (LComp m n x) -> LComp m n x
joinL = map join . join . map swapl

instance (Monad n, SwapL m) => Monad (LComp m n) where
  result = resultL
  join = joinL

liftL :: Monad m => n x -> LComp m n x
liftL = result

instance Monad m => MonadT (LComp m) where
  lift = liftL

-- Composing in the middle

type MComp r l m x = r (m (l x)) in mapM, resultM, joinM,
                                    liftM, 
                                    liftRW, 
                                    actRW,
                                    withRW, readRW,
                                    runIORW,
                                    zeroRW, plusRW,
                                    invokeRW

mapM :: (Functor r, Functor m, Functor l)
       => (x -> y) -> MComp r l m x -> MComp r l m y
mapM = map . map . map       

instance (Functor r, Functor m, Functor l) => Functor (MComp r l m) where
  map = mapM

resultM :: (Adjoint l r, Monad m) => x -> MComp r l m x
resultM = couniv result

joinM :: (Adjoint l r, Monad m) => MComp r l m (MComp r l m x) -> MComp r l m x
joinM = map (join . map counit)

instance (Adjoint l r, Monad m) => Monad (MComp r l m) where
  result = resultM
  join = joinM
  
liftM :: (Monad r, Monad l, Functor m) => m x -> MComp r l m x
liftM = result . map result

instance (Monad r, Monad l) => MonadT (MComp r l) where
  lift = liftM
  
-- ErrT

type ErrT = RComp Error

errError :: Monad m => String -> ErrT m x
errError msg = result (L msg)

instance Monad m => ErrMonad (ErrT m) where
  err = errError
 

orelse :: (String -> y) -> (x -> y) -> ErrT Id x -> y
orelse = (<+>)

zeroError :: ErrT Id x
zeroError = inl "   error!"

plusError :: ErrT Id x -> ErrT Id x -> ErrT Id x
x `plusError` y = (const y <+> inr) x

instance Monad0 (ErrT Id) where     
  zero = zeroError

instance MonadPlus (ErrT Id) where 
  (++) = plusError
  
-- EnvT

type EnvT r = LComp (Reader r)

readRead :: Monad m => EnvT env m env
readRead env = result env

withRead :: Monad m => env -> EnvT env m x -> EnvT env m x
withRead env m = \_ -> m env

instance Monad m => EnvMonad env (EnvT env m) where
  read = readRead
  with = withRead

runIORead :: (RunIO m x, Initial env) => EnvT env m x -> IO ()
runIORead m = runIO (m initial)

instance (RunIO m x, Initial env) => RunIO (EnvT env m) x where
  runIO = runIORead
  
-- GenT

type GenT s = RComp (Writer s)

genWrite :: Monad m => s -> GenT s m ()
genWrite s = result (s,())

instance Monad m => GenMonad s (GenT s m) where
  gen = genWrite
   
writeWrite :: (Write x, Write s) => Writer s x -> IO ()   
writeWrite (s,x) 
  = do { put "\n    " ; write s ; put "--> result " ; write x ; put "\n   " }

instance (Write x, Write s) => Write (Writer s x) where
  write = writeWrite
  
-- StateT

type StateT s = MComp (Reader s) (Writer s) 

zeroRW :: Monad0 m => StateT x m y
zeroRW x = zero

plusRW :: MonadPlus m => StateT x m y -> StateT x m y -> StateT x m y
s `plusRW` t = \x -> s x ++ t x
  
instance Monad0 m => Monad0 (StateT x m) where
  zero = zeroRW

instance MonadPlus m => MonadPlus (StateT x m) where
  (++) = plusRW  
  
-- liftM cannot be used!

liftRW :: Monad m => m x -> StateT s m x
liftRW m = \s -> do { x <- m ; result (s,x) }

instance MonadT (StateT s) where
  lift = liftRW
  
actRW :: Monad m => (s -> s) -> StateT s m s
actRW f = \s -> result (f s,s)

instance Monad m => StateMonad state (StateT state m) where
  act = actRW 

-- lift env through state
  
withRW :: EnvMonad env m => env -> StateT state m x -> StateT state m x
withRW e m = \s -> with e (m s) 

liftSt :: (Monad m, MonadT (StateT state)) => m x -> StateT state m x
liftSt = lift

readRW :: (EnvMonad env m, MonadT (StateT state)) 
            => StateT state m env
readRW = liftSt read

instance (EnvMonad env m, MonadT (StateT state)) 
        => EnvMonad env (StateT state m) where
  with = withRW
  read = readRW

runIORW :: (RunIO m (s,x), Initial s) => StateT s m x -> IO ()
runIORW m = runIO (m initial)

instance (RunIO m (s,x), Initial s) => RunIO (StateT s m) x where
  runIO = runIORW

invokeRW :: Monad0 m => StateT [y] m x -> [y] -> m x
invokeRW p ys = do { ([],x) <- p ys ; result x }
 
invokeWithRW :: StateT [y] (ErrT Id) x -> (x -> IO ()) -> [y] -> IO ()
p `invokeWithRW` cont = (put `orelse` cont) . invokeRW p 
 
--------------------------------------------------------------------------------
