{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Control.Monad.Exception.Label where
import qualified Control.Monad.Exception.Synchronous as Exception
import qualified Control.Monad.Label as Label
import Control.Monad.Exception.Synchronous (ExceptionalT, mapExceptionT, )
import Control.Monad.Label (LabelT, )
import Control.Applicative (Applicative, )
import Control.Monad (liftM, )
import Control.Monad.Fix (MonadFix, )
import Control.Monad.Trans.Class (MonadTrans, lift, )
data LabeledException l e =
LabeledException {labels :: [l], exception :: e}
newtype LabeledExceptionalT l e m a =
LabeledExceptionalT
{runLabeledExceptionalT :: LabelT l (ExceptionalT (LabeledException l e) m) a}
deriving (Functor, Applicative, Monad, MonadFix)
runLabelT :: (Monad m) =>
LabeledExceptionalT l e m a ->
[l] ->
ExceptionalT (LabeledException l e) m a
runLabelT =
Label.runLabelT . runLabeledExceptionalT
labelT :: (Monad m) =>
ExceptionalT (LabeledException l e) m a ->
LabeledExceptionalT l e m a
labelT =
LabeledExceptionalT . lift
stripLabelT :: (Monad m) =>
LabeledExceptionalT l e m a -> ExceptionalT e m a
stripLabelT action =
mapExceptionT exception (runLabelT action [])
decorateLabelT :: (Monad m) =>
ExceptionalT e m a -> LabeledExceptionalT l e m a
decorateLabelT =
labelT . mapExceptionT (LabeledException [])
getLabels :: (Monad m) =>
LabeledExceptionalT l e m [l]
getLabels = LabeledExceptionalT $ Label.askT
throwT :: (Monad m) =>
e -> LabeledExceptionalT l e m a
throwT e =
do l <- getLabels
labelT $ Exception.throwT (LabeledException l e)
catchT :: (Monad m) =>
LabeledExceptionalT l e0 m a ->
([l] -> e0 -> LabeledExceptionalT l e1 m a) ->
LabeledExceptionalT l e1 m a
catchT action handler =
do ls <- getLabels
labelT $ Exception.catchT
(runLabelT action ls)
(\(LabeledException l e) -> runLabelT (handler l e) ls)
bracketT :: (Monad m) =>
l ->
LabeledExceptionalT l e m h ->
(h -> LabeledExceptionalT l e m ()) ->
(h -> LabeledExceptionalT l e m a) ->
LabeledExceptionalT l e m a
bracketT label open close action =
do ls <- liftM (label:) getLabels
labelT $
Exception.bracketT
(runLabelT open ls)
(\h -> runLabelT (close h) ls)
(\h -> runLabelT (action h) ls)
instance MonadTrans (LabeledExceptionalT l e) where
lift m = labelT $ lift m