Backtracking.hs

{-# LANGUAGE
    FlexibleInstances,
    UndecidableInstances,
    MultiParamTypeClasses,
    GeneralizedNewtypeDeriving,
    RankNTypes #-}
{- |
Module : Control.Monad.Except.Backtracking
Copyright : (c) Jamaal Malek <mjm540@york.ac.uk> 2014
License : BSD3
Maintainer : mjm540@york.ac.uk
Stability : experimental
Portability : non-portable
-}
module Control.Monad.Except.Backtracking (
        -- * The BExceptT monad transformer
        BExceptT(),
        bExceptT,
        runBExceptT,
        hoistEither,
        module Control.Monad.Error.Class
        -- * Usage example and explanation
        -- $Example
    )where

    import Control.Monad.Trans.Either hiding (hoistEither)
    import Control.Monad.Codensity
    import Control.Monad.Trans.Class
    import Control.Applicative
    import Data.Functor.Bind
    import Control.Monad.Free.Class
    import Control.Monad.IO.Class
    import Control.Monad.Reader.Class
    import Control.Monad.State.Class
    import Control.Monad.State.Lazy
    import Control.Monad.Error.Class
    import Control.Monad.Writer.Class
    import Control.Monad.RWS.Class
    import Control.Monad.Except
    import Data.Functor.Alt
    import Data.Functor.Plus
    import Data.Semigroup
    import Control.Monad



    {-|
        'BExceptT' is a monad transformer that adds backtracking
        exception handling to its base monad.
    -}
    newtype BExceptT e m a = BExceptT {
        unwrapBExceptT' :: Codensity (EitherT e m) a } deriving
            (Functor, Applicative, Monad, Apply, MonadIO)

    {-|
        'bExceptT' constructs a 'BExceptT' from the base monad.
    -}
    bExceptT :: (Monad m) => m (Either e a) -> BExceptT e m a
    bExceptT = BExceptT . lift . EitherT
    {-# INLINE bExceptT #-}

    {-|
        'runBExceptT' does the opposite of 'bExceptT'
    -}
    runBExceptT :: (Monad m) => BExceptT e m a -> m (Either e a)
    runBExceptT = runEitherT . lowerCodensity . unwrapBExceptT'
    {-# INLINE runBExceptT #-}



    unwrapBExceptT :: (Monad m) =>
        BExceptT e m a -> forall b. (a -> EitherT e m b) -> EitherT e m b
    unwrapBExceptT = runCodensity . unwrapBExceptT'
    {-# INLINE unwrapBExceptT #-}



    instance (Functor f, MonadFree f m) =>
        MonadFree f (BExceptT e m) where
            wrap t = BExceptT $ Codensity $ \h -> wrap $
                fmap (\p -> unwrapBExceptT p h) t
            {-# INLINE wrap #-}

    instance MonadTrans (BExceptT e) where
        lift = BExceptT . lift . lift
        {-# INLINE lift #-}

    instance (MonadReader r m) => MonadReader r (BExceptT e m) where
        ask = lift ask
        {-# INLINE ask #-}
        local f = bExceptT . local f . runBExceptT
        {-# INLINE local #-}
        reader = lift . reader
        {-# INLINE reader #-}

    instance (MonadState s m) => MonadState s (BExceptT e m) where
        get = lift get
        {-# INLINE get #-}
        put = lift . put
        {-# INLINE put #-}
        state = lift . state
        {-# INLINE state #-}

    instance (Functor m, MonadWriter w m) => MonadWriter w (BExceptT e m) where
        writer = lift . writer
        {-# INLINE writer #-}
        tell = lift . tell
        {-# INLINE tell #-}
        listen = bExceptT . fmap f . listen . runBExceptT where
            f (Left e, _) = Left e
            f (Right a, w) = Right (a, w)
        {-# INLINE listen #-}
        pass = bExceptT . pass . fmap f . runBExceptT where
            f (Left e) = (Left e, id)
            f (Right (a, f)) = (Right a, f)
        {-# INLINE pass #-}

    instance (Functor m, MonadRWS r w s m) => MonadRWS r w s (BExceptT e m)

    instance (Monad m) => MonadError e (BExceptT e m) where
        throwError e = BExceptT $ lift $ throwError e
        {-# INLINE throwError #-}
        catchError m handler = BExceptT $ Codensity $ \c ->
            unwrapBExceptT m c `catchError` handler' c where
                handler' c e = unwrapBExceptT (handler e) c

    instance (Monad m, Semigroup e) => Alt (BExceptT e m) where
        a <!> b = catchError a $ \e -> catchError b $ \e' ->
            throwError $ e <> e'
        {-# INLINE (<!>) #-}

    instance (Monad m, Semigroup e, Monoid e) => Plus (BExceptT e m) where
        zero = throwError mempty
        {-# INLINE zero #-}

    instance (Monad m, Semigroup e, Monoid e) =>
        Alternative (BExceptT e m) where
            (<|>) = (<!>)
            empty = zero

    instance (Monad m, Semigroup e, Monoid e) =>
        MonadPlus (BExceptT e m) where
            mplus = (<!>)
            mzero = zero



    {-|
        'hoistEither' constructs a 'BExceptT' from an 'Either' value.
    -}
    hoistEither :: (Monad m) => Either e a -> BExceptT e m a
    hoistEither = bExceptT . return
    {-# INLINE hoistEither #-}



    {- $Example
        The following example shows the basic operation of the 'BExceptT'
        monad.

        > example1 :: StateT Int (BExceptT String IO) ()
        > example1 = do
        >     put 1
        >     catchError (put 2) $ \e -> do
        >         i <- get
        >         liftIO $ do
        >             putStrLn $ "caught an error: '" <|> e <|> "'"
        >             putStrLn $ "setting i to 4, current value is " <|> show i
        >         put 4
        >     i <- get
        >     when (i /= 4) $ put 3
        >     liftIO $ putStrLn "reading i"
        >     i <- get
        >     when (i /= 4) $ throwError "i isnt 4"
        >
        > runexample1 :: IO (Either String ((), Int))
        > runexample1 = runBExceptT $ flip runStateT 0 example1

        The output produced is:

        > reading i
        > caught an error: 'i isnt 4'
        > setting i to 4, current value is 1
        > reading i
        > Right ((),4)

        At first, the execution proceeds normally, setting the state to 1,
        then 2, then 3. The final line throws an exception because the state
        is 3, not 4. The execution then backtracks to before @put 2@ was
        executed. The state has been restored to 1 at this stage. The exception
        handler applied to @put 2@ is executed, and execution continues from
        the line below.

        Replacing @when (i /= 4) $ put 3@ with @put 3@ will not
        create an infinite loop, after the failure of each exception handler
        (in this case there is only one) execution will stop and return an
        error.

        Using @'BExceptT' 'String' ('StateT' 'Int' 'IO') ()@ instead of
        @'StateT' 'Int' ('BExceptT' 'String' 'IO') ()@ means that the state
        will not be restored after an error.

        The 'Alternative' and 'MonadPlus' instances of 'BExceptT' can be used
        like the instances in a nondeterminism monad, such as the list monad,
        except only one successful result at most will be returned.
    -}