module MonadTransformers where

-- Defines the monad transformers State, Env, Error, Failure, Cont

import Monad
import MonadRec

class (Monad m, Monad (t m)) => MonadTransformer t m where
  lift :: m a -> t m a

newtype State s m a = State (s -> m (s, a))

instance Monad m => Monad (State s m) where
  return x = State (\s -> return (s,x))
  State m >>= f = State (\s-> do (s',a)<-m s
                                 let State m' = f a
			         m' s')

instance (Monad m) => MonadTransformer (State s) m where
  lift m = State (\s-> do x<-m
			  return (s,x))

class Monad m => StateMonad s m | m -> s where
  update :: (s->s) -> m s
  
readState :: StateMonad s m => m s
readState = update id
writeState x = do update (const x)
                  return ()

instance Monad m => StateMonad s (State s m) where
  update f = State (\s -> let s' = f s in return (s',s'))

instance EnvMonad r m => EnvMonad r (State s m) where
  inEnv r (State m) = State$ \s -> inEnv r (m s)
  rdEnv = lift rdEnv

instance ErrorMonad m => ErrorMonad (State s m) where
  err s = lift (err s)
  State m `handler` h = State (\s -> 
    m s `handler` (\e -> let State m' = h e in m' s))

instance ContMonad m => ContMonad (State s m) where
  callcc f = State$ \s-> callcc$ \k ->
               let State f' = f (\a -> State (\s' -> k (s',a))) in f' s

instance FailureMonad m => FailureMonad (State s m) where
  failure = lift failure
  State m `handle` State m' = State (\s -> m s `handle` m' s)

runState s (State m) = m s >>= (return.snd)

newtype Env s m a = Env (s -> m a)

instance Monad m => Monad (Env s m) where
  return x = Env (\s -> return x)
  Env m >>= f = Env (\s -> do a<-m s
			      let Env m' = f a
			      m' s)

instance Monad m => MonadTransformer (Env s) m where
  lift m = Env (\s -> m)

class Monad m => EnvMonad s m | m -> s where
  inEnv :: s -> m a -> m a
  rdEnv :: m s

instance Monad m => EnvMonad s (Env s m) where
  inEnv s (Env m) = Env (\_ -> m s)
  rdEnv = Env (\s -> return s)

instance StateMonad s m => StateMonad s (Env r m) where
  update f = lift (update f)

instance ErrorMonad m => ErrorMonad (Env r m) where
  err s = lift (err s)
  Env m `handler` h = Env$ \r -> m r `handler` \s->let Env m' = h s in m' r

instance FailureMonad m => FailureMonad (Env r m) where
  failure = lift failure
  Env m `handle` Env m' = Env$ \r -> m r `handle` m' r

instance ContMonad m => ContMonad (Env r m) where
  callcc f = Env$ \r-> callcc$ \k-> 
               let Env m = f (\a -> lift (k a)) in m r

runEnv s (Env m) = m s

data Perhaps a = OK a | Bad String
newtype Error m a = Error (m (Perhaps a))

instance Monad m => Monad (Error m) where
  return x = Error (return (OK x))
  Error m >>= f = Error (do x<-m
		       	    case x of
			       OK a -> let Error m' = f a in m'
			       Bad s -> return (Bad s))

instance Monad m => MonadTransformer Error m where
  lift m = Error (do a<-m
		     return (OK a))

class Monad m => ErrorMonad m where
  err :: String -> m a
  handler :: m a -> (String -> m a) -> m a

instance Monad m => ErrorMonad (Error m) where
  err s = Error (return (Bad s))
  Error m `handler` h = Error (do x <- m
			          case x of
			            OK a -> return (OK a)
				    Bad s -> let Error m' = h s in m')

instance StateMonad s m => StateMonad s (Error m) where
  update f = lift (update f)

instance EnvMonad r m => EnvMonad r (Error m) where
  inEnv r (Error m) = Error (inEnv r m)
  rdEnv = lift rdEnv

instance FailureMonad m => FailureMonad (Error m) where
  failure = lift failure
  Error m `handle ` Error m' = Error ( m `handle` m' )

instance ContMonad m => ContMonad (Error m) where
  callcc f = Error$ callcc$ \k-> 
               let Error m = f (\a->Error(k (OK a))) in m

runError (Error m) = do x<-m
	         	case x of
		          OK a -> return a
		          Bad s -> error s

newtype Cont ans m a = Cont ((a -> m ans) -> m ans)

instance Monad (Cont ans m) where
  return x = Cont (\k -> k x)
  Cont m >>= f = Cont (\k -> m (\a -> let Cont m' = f a in m' k))

instance Monad m => MonadTransformer (Cont ans) m where
  lift m = Cont (\k -> do a<-m
		          k a)

class Monad m => ContMonad m where
  callcc :: ((a -> m b) -> m a) -> m a

instance ContMonad (Cont ans m) where
  callcc f = Cont (\k -> let Cont m = f (\a -> Cont (\k' -> k a)) in m k)

instance StateMonad s m => StateMonad s (Cont ans m) where
  update f = lift (update f)

instance EnvMonad r m => EnvMonad r (Cont ans m) where
  inEnv r (Cont m) = Cont$ \k-> inEnv r (m k)
  rdEnv = lift rdEnv

instance ErrorMonad m => ErrorMonad (Cont ans m) where
  err = lift . err
  Cont m `handler` h = Cont$ \k-> 
    m k `handler` \s->let Cont m' = h s in m' k

instance FailureMonad m => FailureMonad (Cont ans m) where
  failure = lift failure
  Cont m `handle` Cont m' = Cont$ \k -> m k `handle` m' k

runCont (Cont m) = m return

newtype Failure m a = Failure (m (Maybe a))

instance Monad m => Monad (Failure m) where
  return x = Failure (return (Just x))
  Failure m >>= f = Failure (do x <- m
                                case x of
		                  Nothing -> return Nothing
				  Just a -> let Failure m' = f a in m')

instance Monad m => MonadTransformer Failure m where
  lift m = Failure (do x <- m
                       return (Just x))

class Monad m => FailureMonad m where
  failure :: m a
  handle :: m a -> m a -> m a

instance Monad m => FailureMonad (Failure m) where
  failure = Failure (return Nothing)
  Failure m `handle` Failure m' = 
    Failure (do x <- m
                case x of
	          Nothing -> m'
		  Just a -> return (Just a))

instance StateMonad s m => StateMonad s (Failure m) where
  update f = lift (update f)

instance EnvMonad r m => EnvMonad r (Failure m) where
  inEnv r (Failure m) = Failure (inEnv r m)
  rdEnv = lift rdEnv

instance ErrorMonad m => ErrorMonad (Failure m) where
  err = lift . err
  Failure m `handler` h = Failure (m `handler` \s -> let Failure m' = h s in m')

instance ContMonad m => ContMonad (Failure m) where
  callcc f = Failure$ callcc$ \k->
    let Failure m' = f (\a -> Failure (k (Just a))) in m'

runFailure (Failure m) = do x <- m
                            case x of
			      Just a -> return a

newtype Id a = Id a

instance Monad Id where
  return = Id
  Id x >>= f = f x

instance MonadRec Id where
  mfix f = Id a where ~(Id a) = f a

runId (Id x) = x