Control/Monad/X/ResumeT.hs

   1 module Control.Monad.X.ResumeT
   2   (ResumeT,
   3    hyper,
   4    module T
   5   ) where
   6
   7 import Prelude(Functor(..),Monad(..),error)
   8 import Control.Monad(liftM,MonadPlus(..))
   9
  10 import Control.Monad.X.Trans as T
  11 import Control.Monad.X.Utils
  12 import Control.Monad.X.Types (ResumeT(..), Res(..))
  13
  14 -- resumptions:
  15 -- a transformer for explicit "lazyness"
  16
  17
  18 instance MonadTrans ResumeT where
  19   lift m  = Re (liftM Value m)
  20
  21 instance Monad m => Functor (ResumeT m) where
  22   fmap    = liftM
  23
  24 instance Monad m => Monad (ResumeT m) where
  25   return  = return'
  26   m >>= f = Re (do x <- unRe m
  27                    case x of
  28                      Value a -> unRe (f a)
  29                      Delay m -> return (Delay (m >>= f)))
  30
  31 instance HasBaseMonad m n => HasBaseMonad (ResumeT m) n where
  32   inBase    = inBase'
  33
  34 instance Monad m => Functor (Res m) where
  35   fmap f (Value a)      = Value (f a)
  36   fmap f (Delay m)      = Delay (liftM f m)
  37
  38
  39
  40 hyper       :: Monad m => ResumeT m a -> m a
  41 hyper m     = do x <- unRe m
  42                  case x of
  43                    Value a -> return a
  44                    Delay m -> hyper m
  45
  46 mapResumeT f m  = Re (f (unRe m))
  47
  48 instance MonadReader r m => MonadReader r (ResumeT m) where
  49   ask       = ask'
  50   local     = local' mapResumeT
  51
  52 instance MonadWriter w m => MonadWriter w (ResumeT m) where
  53   tell      = tell'
  54   listen    = listen1' Re unRe (\w -> fmap (\a -> (a,w)))
  55
  56 instance MonadState s m => MonadState s (ResumeT m) where
  57   get       = get'
  58   put       = put'
  59
  60 instance MonadError e m => MonadError e (ResumeT m) where
  61   throwError  = throwError'
  62   catchError  = catchError1' Re unRe
  63
  64 instance MonadPlus m => MonadPlus (ResumeT m) where
  65   mzero     = mzero'
  66   mplus     = mplus1' Re unRe
  67
  68 instance MonadNondet m => MonadNondet (ResumeT m) where
  69   findAll   = error "findAll ResumeT TODO"
  70   commit    = mapResumeT commit
  71
  72 instance Monad m => MonadResume (ResumeT m) where
  73   delay m   = Re (return (Delay m))
  74   force m   = Re (do x <- unRe m
  75                      case x of
  76                        Value a  -> return (Value a)
  77                        Delay m' -> unRe m')
  78
  79 instance MonadCont m => MonadCont (ResumeT m) where
  80   callCC = callCC1' Re unRe Value
  81
  82
  83