Control/Monad/Cont.hs

   1 -----------------------------------------------------------------------------
   2 -- |
   3 -- Module      :  Control.Monad.Cont
   4 -- Copyright   :  (c) The University of Glasgow 2001
   5 -- License     :  BSD-style (see the file libraries/base/LICENSE)
   6 --
   7 -- Maintainer  :  libraries@haskell.org
   8 -- Stability   :  experimental
   9 -- Portability :  non-portable (multi-parameter type classes)
  10 --
  11 -- Continuation monads.
  12 --
  13 -----------------------------------------------------------------------------
  14
  15 module Control.Monad.Cont (
  16         MonadCont(..),
  17         Cont(..),
  18         mapCont,
  19         withCont,
  20         ContT(..),
  21         mapContT,
  22         withContT,
  23         module Control.Monad,
  24         module Control.Monad.Trans,
  25   ) where
  26
  27 import Prelude
  28
  29 import Control.Monad
  30 import Control.Monad.Trans
  31 import Control.Monad.Reader
  32 import Control.Monad.Writer
  33 import Control.Monad.State
  34 import Control.Monad.RWS
  35
  36 class (Monad m) => MonadCont m where
  37         callCC :: ((a -> m b) -> m a) -> m a
  38
  39 -- ---------------------------------------------------------------------------
  40 -- Our parameterizable continuation monad
  41
  42 newtype Cont r a = Cont { runCont :: (a -> r) -> r }
  43
  44 instance Functor (Cont r) where
  45         fmap f m = Cont $ \c -> runCont m (c . f)
  46
  47 instance Monad (Cont r) where
  48         return a = Cont ($ a)
  49         m >>= k  = Cont $ \c -> runCont m $ \a -> runCont (k a) c
  50
  51 instance MonadCont (Cont r) where
  52         callCC f = Cont $ \c -> runCont (f (\a -> Cont $ \_ -> c a)) c
  53
  54 mapCont :: (r -> r) -> Cont r a -> Cont r a
  55 mapCont f m = Cont $ f . runCont m
  56
  57 withCont :: ((b -> r) -> (a -> r)) -> Cont r a -> Cont r b
  58 withCont f m = Cont $ runCont m . f
  59
  60 -- ---------------------------------------------------------------------------
  61 -- Our parameterizable continuation monad, with an inner monad
  62
  63 newtype ContT r m a = ContT { runContT :: (a -> m r) -> m r }
  64
  65 instance (Monad m) => Functor (ContT r m) where
  66         fmap f m = ContT $ \c -> runContT m (c . f)
  67
  68 instance (Monad m) => Monad (ContT r m) where
  69         return a = ContT ($ a)
  70         m >>= k  = ContT $ \c -> runContT m (\a -> runContT (k a) c)
  71
  72 instance (Monad m) => MonadCont (ContT r m) where
  73         callCC f = ContT $ \c -> runContT (f (\a -> ContT $ \_ -> c a)) c
  74
  75 instance MonadTrans (ContT r) where
  76         lift m = ContT (m >>=)
  77
  78 instance (MonadIO m) => MonadIO (ContT r m) where
  79         liftIO = lift . liftIO
  80
  81 instance (MonadReader r' m) => MonadReader r' (ContT r m) where
  82         ask       = lift ask
  83         local f m = ContT $ \c -> do
  84                 r <- ask
  85                 local f (runContT m (local (const r) . c))
  86
  87 instance (MonadState s m) => MonadState s (ContT r m) where
  88         get = lift get
  89         put = lift . put
  90
  91 -- -----------------------------------------------------------------------------
  92 -- MonadCont instances for other monad transformers
  93
  94 instance (MonadCont m) => MonadCont (ReaderT r m) where
  95         callCC f = ReaderT $ \r ->
  96                 callCC $ \c ->
  97                 runReaderT (f (\a -> ReaderT $ \_ -> c a)) r
  98
  99 instance (MonadCont m) => MonadCont (StateT s m) where
 100         callCC f = StateT $ \s ->
 101                 callCC $ \c ->
 102                 runStateT (f (\a -> StateT $ \s' -> c (a, s'))) s
 103
 104 instance (Monoid w, MonadCont m) => MonadCont (WriterT w m) where
 105         callCC f = WriterT $
 106                 callCC $ \c ->
 107                 runWriterT (f (\a -> WriterT $ c (a, mempty)))
 108
 109 instance (Monoid w, MonadCont m) => MonadCont (RWST r w s m) where
 110         callCC f = RWST $ \r s ->
 111                 callCC $ \c ->
 112                 runRWST (f (\a -> RWST $ \_ s' -> c (a, s', mempty))) r s
 113
 114 mapContT :: (m r -> m r) -> ContT r m a -> ContT r m a
 115 mapContT f m = ContT $ f . runContT m
 116
 117 withContT :: ((b -> m r) -> (a -> m r)) -> ContT r m a -> ContT r m b
 118 withContT f m = ContT $ runContT m . f