module Control.Monad.Trans.Abort
( AbortT(..)
, abort
, recover
, Abort
, runAbort
) where
import Data.Monoid (mempty)
import Data.Foldable (Foldable(..))
import Data.Traversable (Traversable(..))
import Data.Pointed
import Data.Functor.Identity
import Data.Functor.Bind
import Data.Functor.Bind.Trans
#if MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,5,0)
import Data.Functor.Classes
#endif
#if !MIN_VERSION_base(4,9,0)
import Control.Applicative (Applicative(..))
#endif
import Control.Applicative (liftA2)
import Control.Monad (ap)
#if !MIN_VERSION_monad_control(1,0,0)
import Control.Monad (liftM)
#endif
#if MIN_VERSION_base(4,9,0)
import qualified Control.Monad.Fail as Fail
#endif
import Control.Monad.Base
import Control.Monad.Fix
#if MIN_VERSION_base(4,4,0)
import Control.Monad.Zip (MonadZip(..))
#endif
import Control.Monad.Trans.Class
import Control.Monad.Trans.Control
import Control.Monad.IO.Class
newtype AbortT e μ α = AbortT { runAbortT ∷ μ (Either e α) }
#if MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,5,0)
instance (Eq f, Eq1 μ) ⇒ Eq1 (AbortT f μ) where
liftEq f m₁ m₂ = liftEq (liftEq f) (runAbortT m₁) (runAbortT m₂)
instance (Ord f, Ord1 μ) ⇒ Ord1 (AbortT f μ) where
liftCompare f m₁ m₂ =
liftCompare (liftCompare f) (runAbortT m₁) (runAbortT m₂)
instance (Show f, Show1 μ) ⇒ Show1 (AbortT f μ) where
liftShowsPrec sp sl d =
showsUnaryWith (liftShowsPrec sp' sl') "AbortT" d . runAbortT
where
sp' = liftShowsPrec sp sl
sl' = liftShowList sp sl
instance (Read f, Read1 μ) ⇒ Read1 (AbortT f μ) where
liftReadsPrec rp rl =
readsData $ readsUnaryWith (liftReadsPrec rp' rl') "AbortT" AbortT
where
rp' = liftReadsPrec rp rl
rl' = liftReadList rp rl
instance (Eq f, Eq1 μ, Eq α) ⇒ Eq (AbortT f μ α) where
(==) = eq1
instance (Ord f, Ord1 μ, Ord α) ⇒ Ord (AbortT f μ α) where
compare = compare1
instance (Show f, Show1 μ, Show α) ⇒ Show (AbortT f μ α) where
showsPrec = showsPrec1
instance (Read f, Read1 μ, Read α) ⇒ Read (AbortT f μ α) where
readsPrec = readsPrec1
#endif
instance Foldable μ ⇒ Foldable (AbortT e μ) where
foldMap f = foldMap (either (const mempty) f) . runAbortT
instance Traversable μ ⇒ Traversable (AbortT e μ) where
traverse f = fmap AbortT
. traverse (either (pure . Left) (fmap Right . f))
. runAbortT
instance Pointed μ ⇒ Pointed (AbortT e μ) where
point = AbortT . point . Right
instance Functor μ ⇒ Functor (AbortT e μ) where
fmap f = AbortT . fmap (fmap f) . runAbortT
instance (Functor μ, Monad μ) ⇒ Apply (AbortT e μ) where
(<.>) = ap
instance (Functor μ, Monad μ) ⇒ Applicative (AbortT e μ) where
pure = return
(<*>) = ap
instance (Functor μ, Monad μ) ⇒ Bind (AbortT e μ) where
(>>-) = (>>=)
instance Monad μ ⇒ Monad (AbortT e μ) where
return = AbortT . return . Right
m >>= f = AbortT $ runAbortT m >>= either (return . Left) (runAbortT . f)
fail = AbortT . fail
#if MIN_VERSION_base(4,9,0)
instance Fail.MonadFail μ ⇒ Fail.MonadFail (AbortT f μ) where
fail = AbortT . Fail.fail
#endif
instance MonadFix μ ⇒ MonadFix (AbortT e μ) where
mfix f = AbortT $ mfix $
runAbortT . f . either (error "mfix(AbortT): Left") id
#if MIN_VERSION_base(4,4,0)
instance MonadZip μ ⇒ MonadZip (AbortT f μ) where
mzipWith f m₁ m₂ =
AbortT $ mzipWith (liftA2 f) (runAbortT m₁) (runAbortT m₂)
#endif
instance MonadIO μ ⇒ MonadIO (AbortT e μ) where
liftIO = lift . liftIO
instance MonadBase η μ ⇒ MonadBase η (AbortT e μ) where
liftBase = lift . liftBase
instance BindTrans (AbortT e) where
liftB = AbortT . fmap Right
instance MonadTrans (AbortT e) where
lift = AbortT . ap (return Right)
instance MonadTransControl (AbortT e) where
#if MIN_VERSION_monad_control(1,0,0)
type StT (AbortT e) α = Either e α
liftWith f = lift $ f $ runAbortT
restoreT = AbortT
#else
newtype StT (AbortT e) α = StAbort { unStAbort ∷ Either e α }
liftWith f = lift $ f $ liftM StAbort . runAbortT
restoreT = AbortT . liftM unStAbort
#endif
instance MonadBaseControl η μ ⇒ MonadBaseControl η (AbortT e μ) where
#if MIN_VERSION_monad_control(1,0,0)
type StM (AbortT e μ) α = ComposeSt (AbortT e) μ α
liftBaseWith = defaultLiftBaseWith
restoreM = defaultRestoreM
#else
newtype StM (AbortT e μ) α =
StMAbort { unStMAbort ∷ ComposeSt (AbortT e) μ α }
liftBaseWith = defaultLiftBaseWith StMAbort
restoreM = defaultRestoreM unStMAbort
#endif
abort ∷ Monad μ ⇒ e → AbortT e μ α
abort = AbortT . return . Left
recover ∷ Monad μ ⇒ AbortT e μ α → (e → AbortT e μ α) → AbortT e μ α
recover m h = AbortT $ runAbortT m >>= either (runAbortT . h) (return . Right)
type Abort e α = AbortT e Identity α
runAbort ∷ Abort e α → Either e α
runAbort = runIdentity . runAbortT