Lift.hs

{-# LANGUAGE CPP #-}

{-| Many actions in base monad transformers cannot be automatically
    'Control.Monad.Trans.Class.lift'ed.  These functions lift these remaining
    actions so that they work in the 'Proxy' monad transformer.

    See the mini-tutorial at the bottom of this module for example code and
    typical use cases where this module will come in handy.
-}

module Pipes.Lift (
    -- * Utilities
      distribute

    -- * ExceptT
    , exceptP
    , runExceptP
    , catchError
    , liftCatchError

    -- * MaybeT
    , maybeP
    , runMaybeP

    -- * ReaderT
    , readerP
    , runReaderP

    -- * StateT
    , stateP
    , runStateP
    , evalStateP
    , execStateP

    -- * WriterT
    -- $writert
    , writerP
    , runWriterP
    , execWriterP

    -- * RWST
    , rwsP
    , runRWSP
    , evalRWSP
    , execRWSP

    -- * Tutorial
    -- $tutorial
    ) where

import Control.Monad.Trans.Class (lift, MonadTrans(..))
import qualified Control.Monad.Trans.Except as E
import qualified Control.Monad.Trans.Maybe as M
import qualified Control.Monad.Trans.Reader as R
import qualified Control.Monad.Trans.State.Strict as S
import qualified Control.Monad.Trans.Writer.Strict as W
import qualified Control.Monad.Trans.RWS.Strict as RWS
import Pipes.Internal (Proxy(..), unsafeHoist)
import Control.Monad.Morph (hoist, MFunctor(..))
import Pipes.Core (runEffect, request, respond, (//>), (>\\))

#if MIN_VERSION_base(4,8,0)
#else
import Data.Monoid
#endif

-- | Distribute 'Proxy' over a monad transformer
distribute
    ::  ( Monad m
        , MonadTrans t
        , MFunctor t
        , Monad (t m)
        , Monad (t (Proxy a' a b' b m))
        )
    => Proxy a' a b' b (t m) r
    -- ^ 
    -> t (Proxy a' a b' b m) r
    -- ^ 
distribute p =  runEffect $ request' >\\ unsafeHoist (hoist lift) p //> respond'
  where
    request' = lift . lift . request
    respond' = lift . lift . respond
{-# INLINABLE distribute #-}

-- | Wrap the base monad in 'E.ExceptT'
exceptP
    :: Monad m
    => Proxy a' a b' b m (Either e r)
    -> Proxy a' a b' b (E.ExceptT e m) r
exceptP p = do
    x <- unsafeHoist lift p
    lift $ E.ExceptT (return x)
{-# INLINABLE exceptP #-}

-- | Run 'E.ExceptT' in the base monad
runExceptP
    :: Monad m
    => Proxy a' a b' b (E.ExceptT e m) r
    -> Proxy a' a b' b m (Either e r)
runExceptP    = E.runExceptT . distribute 
{-# INLINABLE runExceptP #-}

-- | Catch an error in the base monad
catchError
    :: Monad m
    => Proxy a' a b' b (E.ExceptT e m) r
    -- ^
    -> (e -> Proxy a' a b' b (E.ExceptT e m) r)
    -- ^
    -> Proxy a' a b' b (E.ExceptT e m) r
catchError e h = exceptP . E.runExceptT $ 
    E.catchE (distribute e) (distribute . h)
{-# INLINABLE catchError #-}

-- | Catch an error using a catch function for the base monad
liftCatchError
    :: Monad m
    => (   m (Proxy a' a b' b m r)
        -> (e -> m (Proxy a' a b' b m r))
        -> m (Proxy a' a b' b m r) )
    -- ^
    ->    (Proxy a' a b' b m r
        -> (e -> Proxy a' a b' b m r)
        -> Proxy a' a b' b m r)
    -- ^
liftCatchError c p0 f = go p0
  where
    go p = case p of
        Request a' fa  -> Request a' (\a  -> go (fa  a ))
        Respond b  fb' -> Respond b  (\b' -> go (fb' b'))
        Pure    r      -> Pure r
        M          m   -> M ((do
            p' <- m
            return (go p') ) `c` (\e -> return (f e)) )
{-# INLINABLE liftCatchError #-}

-- | Wrap the base monad in 'M.MaybeT'
maybeP
    :: Monad m
    => Proxy a' a b' b m (Maybe r) -> Proxy a' a b' b (M.MaybeT m) r
maybeP p = do
    x <- unsafeHoist lift p
    lift $ M.MaybeT (return x)
{-# INLINABLE maybeP #-}

-- | Run 'M.MaybeT' in the base monad
runMaybeP
    :: Monad m
    => Proxy a' a b' b (M.MaybeT m) r
    -> Proxy a' a b' b m (Maybe r)
runMaybeP p = M.runMaybeT $ distribute p
{-# INLINABLE runMaybeP #-}

-- | Wrap the base monad in 'R.ReaderT'
readerP
    :: Monad m
    => (i -> Proxy a' a b' b m r) -> Proxy a' a b' b (R.ReaderT i m) r
readerP k = do
    i <- lift R.ask
    unsafeHoist lift (k i)
{-# INLINABLE readerP #-}

-- | Run 'R.ReaderT' in the base monad
runReaderP
    :: Monad m
    => i
    -> Proxy a' a b' b (R.ReaderT i m) r
    -> Proxy a' a b' b m r
runReaderP r p = (`R.runReaderT` r) $ distribute p
{-# INLINABLE runReaderP #-}

-- | Wrap the base monad in 'S.StateT'
stateP
    :: Monad m
    => (s -> Proxy a' a b' b m (r, s)) -> Proxy a' a b' b (S.StateT s m) r
stateP k = do
    s <- lift S.get
    (r, s') <- unsafeHoist lift (k s)
    lift (S.put s')
    return r
{-# INLINABLE stateP #-}

-- | Run 'S.StateT' in the base monad
runStateP
    :: Monad m
    => s
    -> Proxy a' a b' b (S.StateT s m) r
    -> Proxy a' a b' b m (r, s)
runStateP s p = (`S.runStateT` s) $ distribute p
{-# INLINABLE runStateP #-}

-- | Evaluate 'S.StateT' in the base monad
evalStateP
    :: Monad m
    => s
    -> Proxy a' a b' b (S.StateT s m) r
    -> Proxy a' a b' b m r
evalStateP s p = fmap fst $ runStateP s p
{-# INLINABLE evalStateP #-}

-- | Execute 'S.StateT' in the base monad
execStateP
    :: Monad m
    => s
    -> Proxy a' a b' b (S.StateT s m) r
    -> Proxy a' a b' b m s
execStateP s p = fmap snd $ runStateP s p
{-# INLINABLE execStateP #-}

{- $writert
    Note that 'runWriterP' and 'execWriterP' will keep the accumulator in
    weak-head-normal form so that folds run in constant space when possible.

    This means that until @transformers@ adds a truly strict 'W.WriterT', you
    should consider unwrapping 'W.WriterT' first using 'runWriterP' or
    'execWriterP' before running your 'Proxy'.  You will get better performance
    this way and eliminate space leaks if your accumulator doesn't have any lazy
    fields.
-}

-- | Wrap the base monad in 'W.WriterT'
writerP
    :: (Monad m, Monoid w)
    => Proxy a' a b' b m (r, w) -> Proxy a' a b' b (W.WriterT w m) r
writerP p = do
    (r, w) <- unsafeHoist lift p
    lift $ W.tell w
    return r
{-# INLINABLE writerP #-}

-- | Run 'W.WriterT' in the base monad
runWriterP
    :: (Monad m, Monoid w)
    => Proxy a' a b' b (W.WriterT w m) r
    -> Proxy a' a b' b m (r, w)
runWriterP p = W.runWriterT $ distribute p
{-# INLINABLE runWriterP #-}

-- | Execute 'W.WriterT' in the base monad
execWriterP
    :: (Monad m, Monoid w)
    => Proxy a' a b' b (W.WriterT w m) r
    -> Proxy a' a b' b m w
execWriterP p = fmap snd $ runWriterP p
{-# INLINABLE execWriterP #-}

-- | Wrap the base monad in 'RWS.RWST'
rwsP
    :: (Monad m, Monoid w)
    => (i -> s -> Proxy a' a b' b m (r, s, w))
    -> Proxy a' a b' b (RWS.RWST i w s m) r
rwsP k = do
    i <- lift RWS.ask
    s <- lift RWS.get
    (r, s', w) <- unsafeHoist lift (k i s)
    lift $ do
        RWS.put s'
        RWS.tell w
    return r
{-# INLINABLE rwsP #-}

-- | Run 'RWS.RWST' in the base monad
runRWSP
    :: (Monad m, Monoid w)
    => r
    -> s
    -> Proxy a' a b' b (RWS.RWST r w s m) d
    -> Proxy a' a b' b m (d, s, w)
runRWSP  i s p = (\b -> RWS.runRWST b i s) $ distribute p
{-# INLINABLE runRWSP #-}

-- | Evaluate 'RWS.RWST' in the base monad
evalRWSP
    :: (Monad m, Monoid w)
    => r
    -> s
    -> Proxy a' a b' b (RWS.RWST r w s m) d
    -> Proxy a' a b' b m (d, w)
evalRWSP i s p = fmap f $ runRWSP i s p
  where
    f x = let (r, _, w) = x in (r, w)
{-# INLINABLE evalRWSP #-}

-- | Execute 'RWS.RWST' in the base monad
execRWSP
    :: (Monad m, Monoid w)
    => r
    -> s
    -> Proxy a' a b' b (RWS.RWST r w s m) d
    -> Proxy a' a b' b m (s, w)
execRWSP i s p = fmap f $ runRWSP i s p
  where
    f x = let (_, s', w) = x in (s', w)
{-# INLINABLE execRWSP #-}

{- $tutorial
    Probably the most useful functionality in this module is lifted error
    handling.  Suppose that you have a 'Pipes.Pipe' whose base monad can fail
    using 'E.ExceptT':

> import Control.Monad.Trans.Error
> import Pipes
>
> example :: Monad m => Pipe Int Int (ExceptT String m) r
> example = for cat $ \n ->
>     if n == 0
>     then lift $ throwError "Zero is forbidden"
>     else yield n

    Without the tools in this module you cannot recover from any potential error
    until after you compose and run the pipeline:

>>> import qualified Pipes.Prelude as P
>>> runExceptT $ runEffect $ P.readLn >-> example >-> P.print
42<Enter>
42
1<Enter>
1
0<Enter>
Zero is forbidden
>>>

    This module provides `catchError`, which lets you catch and recover from
    errors inside the 'Pipe':

>  import qualified Pipes.Lift as Lift
> 
>  caught :: Pipe Int Int (ExceptT String IO) r
>  caught = example `Lift.catchError` \str -> do
>      liftIO (putStrLn str)
>      caught

    This lets you resume streaming in the face of errors raised within the base
    monad:

>>> runExceptT $ runEffect $ P.readLn >-> caught >-> P.print
0<Enter>
Zero is forbidden
42<Enter>
42
0<Enter>
Zero is forbidden
1<Enter>
1
...

    Another common use case is running a base monad before running the pipeline.
    For example, the following contrived 'Producer' uses 'S.StateT' gratuitously
    to increment numbers:

> import Control.Monad (forever)
> import Control.Monad.Trans.State.Strict
> import Pipes
> 
> numbers :: Monad m => Producer Int (StateT Int m) r
> numbers = forever $ do
>     n <- lift get
>     yield n
>     lift $ put $! n + 1

    You can run the 'StateT' monad by supplying an initial state, before you
    ever compose the 'Producer':

> import Pipes.Lift
>
> naturals :: Monad m => Producer Int m r
> naturals = evalStateP 0 numbers

    This deletes 'StateT' from the base monad entirely, give you a completely
    pure 'Pipes.Producer':

>>> Pipes.Prelude.toList naturals
[0,1,2,3,4,5,6...]

    Note that the convention for the 'S.StateT' run functions is backwards from
    @transformers@ for convenience: the initial state is the first argument.

    All of these functions internally use 'distribute', which can pull out most
    monad transformers from the base monad.  For example, 'evalStateP' is
    defined in terms of 'distribute':

> evalStateP s p = evalStateT (distribute p) s

    Therefore you can use 'distribute' to run other monad transformers, too, as
    long as they implement the 'MFunctor' type class from the @mmorph@ library.
-}