Transformer.hs

{-# LANGUAGE ScopedTypeVariables #-}

module Control.Monatron.Transformer (
  StateT, stateT, runStateT,
  WriterT, writerT, runWriterT,
  ReaderT, readerT, runReaderT,
  ExcT, excT, runExcT,
  ContT, contT, runContT,
  StepT, stepT, runStepT, caseStepT, unfoldStepT,
  ListT, listT, runListT, foldListT, collectListT, emptyL, appendL,
--  module Monatron.Operations,
  module Control.Monatron.MonadT,
  module Data.Monoid
) where

--import Monatron.Operations
import Control.Monad.Fix
import Control.Monatron.MonadT
-- for Writer
import Data.Monoid hiding ((<>))
-- for Error (and Reader?)
--import Monatron.Codensity
import Control.Monatron.AutoInstances()

--State Monad Transformer
newtype StateT s m a = S { unS :: s -> m (a,s) }

stateT ::  (s -> m (a, s)) -> StateT s m a
stateT = S

runStateT :: s -> StateT s m a -> m (a,s) 
runStateT s m = unS m s

instance MonadT (StateT s) where
    lift  m           = S $ \s -> m >>= \a -> return (a,s)
    m `tbind` k       = S $ \s -> unS m s >>= \ ~(a, s') -> unS (k a) s'

instance (MonadFix m) => MonadFix (StateT s m) where
  mfix f  = S $ \s -> mfix (runStateT s . f . fst)

instance FMonadT (StateT s) where
    tmap' d1 _d2 g f (S m) = S (f . fmapD d1 (\(x,s) -> (g x,s)) . m)

instance MMonadT (StateT s) where
    flift t          = S (\s -> fmap (\a -> (a,s)) t)
    monoidalT (S t)  = S (\s -> Comp $ fmap (\(S t',s') -> t' s') (t s))

{-
-- StateT implementation of operations
withStateT :: Monad m => Fop (With s) (StateT s m)
withStateT (With f)  = S $ \s  -> runStateT s (f s)

makeStateT :: Monad m => Fop (Make s) (StateT s m)
makeStateT (Make (m,s)) = S $ \_ -> runStateT s m
-}

--------------------------------------------------------------
-- Writer Monad Transformer

newtype WriterT w m a = W {unW :: m (a,w) } 

writerT :: (Monoid w, Monad m) => m (a,w) -> WriterT w m a
writerT = W

runWriterT :: (Monoid w) => WriterT w m a -> m (a,w)
runWriterT = unW
                 
instance Monoid w => MonadT (WriterT w) where  
    tbind (W m) f  = W (do  (a,w) <- m
                            (a',w') <- unW (f a)
                            return (a',w `mappend` w'))
    lift m         = W (liftM (\a -> (a,mempty)) m)

{-
instance (MonadFix m, Monoid w) => MonadFix (WriterT w m) where
    mfix f = W $ mfix (unW. f) 
-}

instance Monoid w => FMonadT (WriterT w) where
    tmap' d1 _d2 g f  = W . f . fmapD d1 (\(x,s) -> (g x,s)) . unW

instance Monoid w => MMonadT (WriterT w) where
    flift t          = W (fmap (\a -> (a,mempty)) t)
    monoidalT (W t)  = W $ Comp $  fmap (\(W t',w) -> 
                                   fmap (\(a,w') -> (a,w `mappend` w')) t') $ t

{-
-- WriterT implementation of operations
withWriterT :: (Monoid w, Monad m) => Fop (With w) (WriterT w m)
withWriterT (With c)   = W $ S $ \w -> runWriterT (c w)


makeWriterT :: (Monoid w, Monad m) => Fop (Make w) (WriterT w m)
makeWriterT (Make (m, w)) = writerT $ runWriterT m >>= \(a,w') -> 
                            return (a,w' `mappend` w)
-}
--------------------------------------------------------------
-- Reader Monad Transformer
newtype ReaderT s m a = R { unR :: s -> m a }

runReaderT      :: s -> ReaderT s m a -> m a
runReaderT s m  = unR m s

instance MonadT (ReaderT s) where
    tbind m k  = R (\s -> unR m s >>= \a -> unR (k a) s)
    lift  m    = R (\_ -> m)

readerT :: Monad m => (e -> m a) -> ReaderT e m a
readerT = R

{-
instance (MonadFix m) => MonadFix (ReaderT w m) where
    mfix f = R $ mfix (unR. f) 
-}

instance FMonadT (ReaderT s) where
    tmap' d1 _d2 g f (R m) = R (f . fmapD d1 g . m)

instance MMonadT (ReaderT s) where
    flift t          = R (\_ -> t)
    monoidalT (R t)  = R (\s -> Comp $ fmap (($ s) . unR) (t s))

{-
-- ReaderT implementation of operations
makeReaderT :: Monad m => Fop (Make e) (ReaderT e m)
makeReaderT = R . makeStateT . fmap unR

withReaderT :: Monad m => Fop (With e) (ReaderT e m)
withReaderT = R . withStateT . fmap unR
-}
--------------------------------------------------------------
-- Exceptions Monad Transformer
newtype ExcT x m a = X {unX :: m (Either x a)}

excT :: Monad m => m (Either x a) -> ExcT x m a
excT = X

runExcT :: Monad m => ExcT x m a -> m (Either x a)
runExcT = unX
--
instance (MonadFix m) => MonadFix (ExcT x m) where
  mfix f  = X $ mfix (unX . f . fromRight)
    where fromRight (Right a) = a
          fromRight _         = error "ExceptionT: mfix looped."


--
instance MonadT (ExcT x) where
    lift m           = X (liftM Right m)
    (X m) `tbind` f  = X (do a <- m
                             case a of
                                Left x  -> return (Left x)
                                Right b -> unX (f b))


instance FMonadT (ExcT x) where
    tmap' d1 _d2 g f  = X . f . fmapD d1 func . unX where
      func (Left x)   = Left x
      func (Right y)  = Right (g y)

{-
-- internal operations
throwExcT :: Monad m => Fop (Throw x) (ExcT x m)
throwExcT (Throw x) = X $ return (Left x)
--
handleExcT :: Monad m => Fop (Handle x) (ExcT x m)
handleExcT (Handle (m, h)) = X (unX m >>= \exa ->
                                    case exa of
                                      Left x  -> unX (h x)
                                      Right a -> return (Right a))

-- Instances of the operations for IO exceptions
throwIO :: Fop (Throw IO.SomeException) IO
throwIO (Throw x) = IO.throwIO x
--
handleIO :: Fop (Handle IO.SomeException) IO
handleIO (Handle (m, h)) = IO.catch m h
-}

--------------------------------------------------------------
-- Continuations Monad Transformer

newtype ContT r m a = C {unC :: (a -> m r) -> m r}

runContT :: (a -> m r) -> ContT r m a -> m r
runContT = flip unC

contT ::  ((a -> m r) -> m r) -> ContT r m a
contT = C

instance MonadT (ContT r) where
    lift m = C (m >>=)
    m `tbind` k   = C $ \c -> unC m (\a -> unC (k a) c)

{-
callCCContT :: Monad m => Fop (CallCC (m r)) (ContT r m)
callCCContT (CallCC f) = C $ \k -> unC (f (\a -> unC a k)) k

abortContT :: Monad m => Fop (Abort (m r)) (ContT r m)
abortContT (Abort mr) = C $ \_ -> mr
-}
--------------------------------------------------------------
-- List monad transformer

data LSig f a b = NilT b
                | ConsT a (f a)

newtype ListT m a = L {unL :: m (LSig (ListT m) a ())}

runListT :: ListT m a -> m (LSig (ListT m) a ())
runListT = unL

listT :: m (LSig (ListT m) a ()) -> ListT m a
listT = L

emptyL :: Monad m => ListT m a
emptyL = L $ return $ NilT ()

appendL :: Monad m=> ListT m a -> ListT m a -> ListT m a
appendL (L m1) (L m2) = L $ do
            l <- m1
            case l of
              NilT ()    -> m2
              ConsT a l1 -> return (ConsT a (appendL l1 (L m2)))

foldListT :: Monad m => (a -> m b -> m b) -> m b -> ListT m a -> m b
foldListT c n (L m) = do l <- m 
                         case l of 
                            NilT ()    -> n 
                            ConsT a l1 -> c a (foldListT c n l1)

collectListT :: Monad m => ListT m a -> m [a]
collectListT lt = foldListT (\a m -> m >>= return. (a:)) (return []) lt

instance MonadT ListT where
    lift m       = L $ liftM (`ConsT` emptyL) m
    m `tbind` f  = L $ foldListT (\a l -> unL $ f a `appendL` L l)
                                 (return $ NilT ())
                                 m

instance FMonadT ListT where
    tmap' d1 d2 g t (L m) = L $ t $ fmapD d1 (\lsig  -> case lsig of
                                            NilT ()    -> NilT ()
                                            ConsT a l  -> ConsT (g a) (tmap' d1 d2 g t l)) m

{-
mZeroListT :: Monad m => Fop MZero (ListT m)
mZeroListT (MZero _) = emptyL 

mPlusListT :: (Monad m) => Fop MPlus (ListT m)
mPlusListT (MPlus (a, b)) = appendL a b
-}
------------------------------------------------
-- Step Monad Transformer
------------------------------------------------
      
newtype StepT f m x = T {runT :: m (Either x (f (StepT f m x)))}

stepT :: m (Either x (f (StepT f m x))) -> StepT f m x
stepT = T

runStepT :: StepT f m x ->  m (Either x (f (StepT f m x)))
runStepT = runT

{-
instance (Functor f, Monad m) => Monad (StepT f m) where
    return  = treturn
    (>>=)   = tbind
-}

--instance (Functor f, Monad m) => Functor (StepT f m) where fmap = liftM

caseStepT            ::  (Functor f, Monad m) =>  
                         (a -> StepT f m x) -> (f (StepT f m a) -> StepT f m x)
                         -> StepT f m a -> StepT f m x
caseStepT v c (T m)  = T (m >>= either (runT . v) (runT . c))

unfoldStepT      :: (Functor f, Monad m) => (y -> m (Either x (f y))) -> y -> StepT f m x
unfoldStepT k y  = T (liftM (fmap (fmap (unfoldStepT k))) (k y))

instance (Functor f) => MonadT (StepT f) where
    tbind t f  = caseStepT f (T . return . Right . fmap (`tbind` f)) t
    lift       = T . liftM Left

instance (Functor f) => FMonadT (StepT f) where
    tmap' d1 d2 g t (T m) = T (t (fmapD d1 (either (Left . g) (Right . fmap (tmap' d1 d2 g t))) m))