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