module Control.Monad.Exception.Warning where
import qualified Control.Monad.Exception.Synchronous as Sync
import Control.Applicative (Applicative(pure, (<*>)))
import Control.Monad (mplus)
import Data.Maybe (catMaybes)
data Warnable e a =
Warnable [Maybe e] a
fromException :: a -> Sync.Exceptional e a -> Warnable e a
fromException deflt x =
let (e,y) =
case x of
Sync.Success y0 -> (Nothing, y0)
Sync.Exception e0 -> (Just e0, deflt)
in Warnable [e] y
fromExceptionNull :: Sync.Exceptional e () -> Warnable e ()
fromExceptionNull = fromException ()
toException :: ([e0] -> e1) -> Warnable e0 a -> Sync.Exceptional e1 a
toException summarize x =
case x of
Warnable mes y ->
case catMaybes mes of
[] -> Sync.Success y
es -> Sync.Exception (summarize es)
warn :: e -> Warnable e ()
warn e = Warnable [Just e] ()
instance Functor (Warnable e) where
fmap f x =
case x of
Warnable e a -> Warnable e (f a)
instance Applicative (Warnable e) where
pure = Warnable []
f <*> x =
case f of
Warnable e0 g ->
case x of
Warnable e1 y -> Warnable (mplus e0 e1) (g y)
instance Monad (Warnable e) where
return = Warnable []
fail _msg =
Warnable
[Just (error "Warning.fail exception")]
(error "Warning.fail result")
x >>= f =
case x of
Warnable e0 y ->
case f y of
Warnable e1 z -> Warnable (e0 ++ e1) z
newtype WarnableT e m a =
WarnableT {runWarnableT :: m (Warnable e a)}
fromSynchronousT :: Functor m =>
a -> Sync.ExceptionalT e m a -> WarnableT e m a
fromSynchronousT deflt (Sync.ExceptionalT mx) =
WarnableT $ fmap (fromException deflt) mx
warnT :: (Monad m) =>
e -> WarnableT e m ()
warnT = WarnableT . return . warn
instance Functor m => Functor (WarnableT e m) where
fmap f (WarnableT x) =
WarnableT (fmap (fmap f) x)
instance Applicative m => Applicative (WarnableT e m) where
pure = WarnableT . pure . pure
WarnableT f <*> WarnableT x =
WarnableT (fmap (<*>) f <*> x)
instance Monad m => Monad (WarnableT e m) where
return = WarnableT . return . return
x0 >>= f =
WarnableT $
do Warnable ex x <- runWarnableT x0
Warnable ey y <- runWarnableT (f x)
return $ Warnable (ex ++ ey) y