{-# LANGUAGE CPP #-}
{-# LANGUAGE UnicodeSyntax #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}

-- | Monad type class for short-cicuiting computation.
module Control.Monad.Finish.Class
  ( MonadFinish(..)
  ) where

import Data.Monoid (Monoid)
import Control.Monad.Trans.Identity
import Control.Monad.Trans.Maybe
import Control.Monad.Cont
import Control.Monad.Trans.Except
#if !MIN_VERSION_mtl(2,3,0)
import Control.Monad.List
import Control.Monad.Error
#else
import Control.Monad.Error.Class
#endif
import Control.Monad.Reader
import Control.Monad.State (MonadState(..))
import qualified Control.Monad.State.Lazy as L
import qualified Control.Monad.State.Strict as S
import Control.Monad.Writer (MonadWriter(..))
import qualified Control.Monad.Writer.Lazy as L
import qualified Control.Monad.Writer.Strict as S
import Control.Monad.RWS (MonadRWS)
import qualified Control.Monad.RWS.Lazy as L
import qualified Control.Monad.RWS.Strict as S
import Control.Monad.Abort
import Control.Monad.Trans.Finish (FinishT(..))
import qualified Control.Monad.Trans.Finish as F

-- | Class of monads that support short-circuiting.
class Monad μ ⇒ MonadFinish f μ | μ → f where
  -- | Short-circuit the computation with the provided value.
  --
  -- @
  --     finish f >>= rest = finish f
  -- @
  finish ∷ f → μ α

instance Monad μ ⇒ MonadFinish f (FinishT f μ) where
  finish :: forall α. f -> FinishT f μ α
finish = forall (μ :: * -> *) f α. Monad μ => f -> FinishT f μ α
F.finish

instance MonadCont μ ⇒ MonadCont (FinishT f μ) where
  callCC :: forall a b.
((a -> FinishT f μ b) -> FinishT f μ a) -> FinishT f μ a
callCC (a -> FinishT f μ b) -> FinishT f μ a
k = forall f (μ :: * -> *) α. μ (Either f α) -> FinishT f μ α
FinishT forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a b. MonadCont m => ((a -> m b) -> m a) -> m a
callCC forall a b. (a -> b) -> a -> b
$ \Either f a -> μ b
f → forall f (μ :: * -> *) α. FinishT f μ α -> μ (Either f α)
runFinishT forall a b. (a -> b) -> a -> b
$ (a -> FinishT f μ b) -> FinishT f μ a
k (forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either f a -> μ b
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. b -> Either a b
Right) 

instance MonadError e μ ⇒ MonadError e (FinishT f μ) where
  throwError :: forall a. e -> FinishT f μ a
throwError = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError
  catchError :: forall a. FinishT f μ a -> (e -> FinishT f μ a) -> FinishT f μ a
catchError FinishT f μ a
m e -> FinishT f μ a
h = forall f (μ :: * -> *) α. μ (Either f α) -> FinishT f μ α
FinishT forall a b. (a -> b) -> a -> b
$ forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
catchError (forall f (μ :: * -> *) α. FinishT f μ α -> μ (Either f α)
runFinishT FinishT f μ a
m) (forall f (μ :: * -> *) α. FinishT f μ α -> μ (Either f α)
runFinishT forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> FinishT f μ a
h)

instance MonadReader r μ ⇒ MonadReader r (FinishT f μ) where
  ask :: FinishT f μ r
ask = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall r (m :: * -> *). MonadReader r m => m r
ask
  local :: forall a. (r -> r) -> FinishT f μ a -> FinishT f μ a
local r -> r
f = forall f (μ :: * -> *) α. μ (Either f α) -> FinishT f μ α
FinishT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local r -> r
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall f (μ :: * -> *) α. FinishT f μ α -> μ (Either f α)
runFinishT

instance MonadState s μ ⇒ MonadState s (FinishT f μ) where
  get :: FinishT f μ s
get = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall s (m :: * -> *). MonadState s m => m s
get
  put :: s -> FinishT f μ ()
put = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s (m :: * -> *). MonadState s m => s -> m ()
put

instance MonadWriter w μ ⇒ MonadWriter w (FinishT f μ) where
  tell :: w -> FinishT f μ ()
tell = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell
  listen :: forall a. FinishT f μ a -> FinishT f μ (a, w)
listen FinishT f μ a
m = forall f (μ :: * -> *) α. μ (Either f α) -> FinishT f μ α
FinishT forall a b. (a -> b) -> a -> b
$ do
    (Either f a
lr, w
w) ← forall w (m :: * -> *) a. MonadWriter w m => m a -> m (a, w)
listen forall a b. (a -> b) -> a -> b
$ forall f (μ :: * -> *) α. FinishT f μ α -> μ (Either f α)
runFinishT FinishT f μ a
m
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (, w
w) Either f a
lr
  pass :: forall a. FinishT f μ (a, w -> w) -> FinishT f μ a
pass FinishT f μ (a, w -> w)
m = forall f (μ :: * -> *) α. μ (Either f α) -> FinishT f μ α
FinishT forall a b. (a -> b) -> a -> b
$ forall w (m :: * -> *) a. MonadWriter w m => m (a, w -> w) -> m a
pass forall a b. (a -> b) -> a -> b
$ do
    Either f (a, w -> w)
lr ← forall f (μ :: * -> *) α. FinishT f μ α -> μ (Either f α)
runFinishT FinishT f μ (a, w -> w)
m
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ((, forall a. a -> a
id) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> Either a b
Left) (\(a
r, w -> w
f) → (forall a b. b -> Either a b
Right a
r, w -> w
f)) Either f (a, w -> w)
lr

instance MonadRWS r w s μ ⇒ MonadRWS r w s (FinishT f μ)

instance MonadFinish f μ ⇒ MonadFinish f (IdentityT μ) where
  finish :: forall α. f -> IdentityT μ α
finish = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall f (μ :: * -> *) α. MonadFinish f μ => f -> μ α
finish

instance MonadFinish f μ ⇒ MonadFinish f (ContT r μ) where
  finish :: forall α. f -> ContT r μ α
finish = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall f (μ :: * -> *) α. MonadFinish f μ => f -> μ α
finish

instance MonadFinish f μ ⇒ MonadFinish f (MaybeT μ) where
  finish :: forall α. f -> MaybeT μ α
finish = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall f (μ :: * -> *) α. MonadFinish f μ => f -> μ α
finish

#if !MIN_VERSION_mtl(2,3,0)
instance (MonadFinish f μ, Error e) ⇒ MonadFinish f (ErrorT e μ) where
  finish :: forall α. f -> ErrorT e μ α
finish = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall f (μ :: * -> *) α. MonadFinish f μ => f -> μ α
finish
#endif

instance MonadFinish f μ ⇒ MonadFinish f (ExceptT e μ) where
  finish :: forall α. f -> ExceptT e μ α
finish = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall f (μ :: * -> *) α. MonadFinish f μ => f -> μ α
finish

instance MonadFinish f μ ⇒ MonadFinish f (AbortT e μ) where
  finish :: forall α. f -> AbortT e μ α
finish = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall f (μ :: * -> *) α. MonadFinish f μ => f -> μ α
finish

#if !MIN_VERSION_mtl(2,3,0)
instance MonadFinish f μ ⇒ MonadFinish f (ListT μ) where
  finish :: forall α. f -> ListT μ α
finish = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall f (μ :: * -> *) α. MonadFinish f μ => f -> μ α
finish
#endif

instance MonadFinish f μ ⇒ MonadFinish f (ReaderT r μ) where
  finish :: forall α. f -> ReaderT r μ α
finish = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall f (μ :: * -> *) α. MonadFinish f μ => f -> μ α
finish

instance MonadFinish f μ ⇒ MonadFinish f (L.StateT s μ) where
  finish :: forall α. f -> StateT s μ α
finish = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall f (μ :: * -> *) α. MonadFinish f μ => f -> μ α
finish

instance MonadFinish f μ ⇒ MonadFinish f (S.StateT s μ) where
  finish :: forall α. f -> StateT s μ α
finish = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall f (μ :: * -> *) α. MonadFinish f μ => f -> μ α
finish

instance (MonadFinish f μ, Monoid w) ⇒ MonadFinish f (L.WriterT w μ) where
  finish :: forall α. f -> WriterT w μ α
finish = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall f (μ :: * -> *) α. MonadFinish f μ => f -> μ α
finish

instance (MonadFinish f μ, Monoid w) ⇒ MonadFinish f (S.WriterT w μ) where
  finish :: forall α. f -> WriterT w μ α
finish = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall f (μ :: * -> *) α. MonadFinish f μ => f -> μ α
finish

instance (MonadFinish f μ, Monoid w) ⇒ MonadFinish f (L.RWST r w s μ) where
  finish :: forall α. f -> RWST r w s μ α
finish = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall f (μ :: * -> *) α. MonadFinish f μ => f -> μ α
finish

instance (MonadFinish f μ, Monoid w) ⇒ MonadFinish f (S.RWST r w s μ) where
  finish :: forall α. f -> RWST r w s μ α
finish = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall f (μ :: * -> *) α. MonadFinish f μ => f -> μ α
finish