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 :: forall a e. a -> Exceptional e a -> Warnable e a
fromException a
deflt Exceptional e a
x =
let (Maybe e
e,a
y) =
case Exceptional e a
x of
Sync.Success a
y0 -> (forall a. Maybe a
Nothing, a
y0)
Sync.Exception e
e0 -> (forall a. a -> Maybe a
Just e
e0, a
deflt)
in forall e a. [Maybe e] -> a -> Warnable e a
Warnable [Maybe e
e] a
y
fromExceptionNull :: Sync.Exceptional e () -> Warnable e ()
fromExceptionNull :: forall e. Exceptional e () -> Warnable e ()
fromExceptionNull = forall a e. a -> Exceptional e a -> Warnable e a
fromException ()
toException :: ([e0] -> e1) -> Warnable e0 a -> Sync.Exceptional e1 a
toException :: forall e0 e1 a. ([e0] -> e1) -> Warnable e0 a -> Exceptional e1 a
toException [e0] -> e1
summarize Warnable e0 a
x =
case Warnable e0 a
x of
Warnable [Maybe e0]
mes a
y ->
case forall a. [Maybe a] -> [a]
catMaybes [Maybe e0]
mes of
[] -> forall e a. a -> Exceptional e a
Sync.Success a
y
[e0]
es -> forall e a. e -> Exceptional e a
Sync.Exception ([e0] -> e1
summarize [e0]
es)
warn :: e -> Warnable e ()
warn :: forall e. e -> Warnable e ()
warn e
e = forall e a. [Maybe e] -> a -> Warnable e a
Warnable [forall a. a -> Maybe a
Just e
e] ()
instance Functor (Warnable e) where
fmap :: forall a b. (a -> b) -> Warnable e a -> Warnable e b
fmap a -> b
f Warnable e a
x =
case Warnable e a
x of
Warnable [Maybe e]
e a
a -> forall e a. [Maybe e] -> a -> Warnable e a
Warnable [Maybe e]
e (a -> b
f a
a)
instance Applicative (Warnable e) where
pure :: forall a. a -> Warnable e a
pure = forall e a. [Maybe e] -> a -> Warnable e a
Warnable []
Warnable e (a -> b)
f <*> :: forall a b. Warnable e (a -> b) -> Warnable e a -> Warnable e b
<*> Warnable e a
x =
case Warnable e (a -> b)
f of
Warnable [Maybe e]
e0 a -> b
g ->
case Warnable e a
x of
Warnable [Maybe e]
e1 a
y -> forall e a. [Maybe e] -> a -> Warnable e a
Warnable (forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
mplus [Maybe e]
e0 [Maybe e]
e1) (a -> b
g a
y)
instance Monad (Warnable e) where
return :: forall a. a -> Warnable e a
return = forall e a. [Maybe e] -> a -> Warnable e a
Warnable []
Warnable e a
x >>= :: forall a b. Warnable e a -> (a -> Warnable e b) -> Warnable e b
>>= a -> Warnable e b
f =
case Warnable e a
x of
Warnable [Maybe e]
e0 a
y ->
case a -> Warnable e b
f a
y of
Warnable [Maybe e]
e1 b
z -> forall e a. [Maybe e] -> a -> Warnable e a
Warnable ([Maybe e]
e0 forall a. [a] -> [a] -> [a]
++ [Maybe e]
e1) b
z
newtype WarnableT e m a =
WarnableT {forall e (m :: * -> *) a. WarnableT e m a -> m (Warnable e a)
runWarnableT :: m (Warnable e a)}
fromSynchronousT :: Functor m =>
a -> Sync.ExceptionalT e m a -> WarnableT e m a
fromSynchronousT :: forall (m :: * -> *) a e.
Functor m =>
a -> ExceptionalT e m a -> WarnableT e m a
fromSynchronousT a
deflt (Sync.ExceptionalT m (Exceptional e a)
mx) =
forall e (m :: * -> *) a. m (Warnable e a) -> WarnableT e m a
WarnableT forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a e. a -> Exceptional e a -> Warnable e a
fromException a
deflt) m (Exceptional e a)
mx
warnT :: (Monad m) =>
e -> WarnableT e m ()
warnT :: forall (m :: * -> *) e. Monad m => e -> WarnableT e m ()
warnT = forall e (m :: * -> *) a. m (Warnable e a) -> WarnableT e m a
WarnableT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e. e -> Warnable e ()
warn
instance Functor m => Functor (WarnableT e m) where
fmap :: forall a b. (a -> b) -> WarnableT e m a -> WarnableT e m b
fmap a -> b
f (WarnableT m (Warnable e a)
x) =
forall e (m :: * -> *) a. m (Warnable e a) -> WarnableT e m a
WarnableT (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f) m (Warnable e a)
x)
instance Applicative m => Applicative (WarnableT e m) where
pure :: forall a. a -> WarnableT e m a
pure = forall e (m :: * -> *) a. m (Warnable e a) -> WarnableT e m a
WarnableT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Applicative f => a -> f a
pure
WarnableT m (Warnable e (a -> b))
f <*> :: forall a b.
WarnableT e m (a -> b) -> WarnableT e m a -> WarnableT e m b
<*> WarnableT m (Warnable e a)
x =
forall e (m :: * -> *) a. m (Warnable e a) -> WarnableT e m a
WarnableT (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
(<*>) m (Warnable e (a -> b))
f forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> m (Warnable e a)
x)
instance Monad m => Monad (WarnableT e m) where
return :: forall a. a -> WarnableT e m a
return = forall e (m :: * -> *) a. m (Warnable e a) -> WarnableT e m a
WarnableT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. Monad m => a -> m a
return
WarnableT e m a
x0 >>= :: forall a b.
WarnableT e m a -> (a -> WarnableT e m b) -> WarnableT e m b
>>= a -> WarnableT e m b
f =
forall e (m :: * -> *) a. m (Warnable e a) -> WarnableT e m a
WarnableT forall a b. (a -> b) -> a -> b
$
do Warnable [Maybe e]
ex a
x <- forall e (m :: * -> *) a. WarnableT e m a -> m (Warnable e a)
runWarnableT WarnableT e m a
x0
Warnable [Maybe e]
ey b
y <- forall e (m :: * -> *) a. WarnableT e m a -> m (Warnable e a)
runWarnableT (a -> WarnableT e m b
f a
x)
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall e a. [Maybe e] -> a -> Warnable e a
Warnable ([Maybe e]
ex forall a. [a] -> [a] -> [a]
++ [Maybe e]
ey) b
y