{- |
This module is currently not in use and may be considered a design study.
Warning monad is like 'Control.Monad.Writer.Writer' monad,
it can be used to record exceptions that do not break program flow.

TODO:

* Better name for 'Warnable'
-}
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)


-- * Plain monad

{- |
Contains a value and
possibly warnings that were generated while the computation of that value.
-}
data Warnable e a =
   Warnable [Maybe e] a


{- |
Convert an exception to a warning.
-}
fromException :: a -> Sync.Exceptional e a -> Warnable e a
fromException :: a -> Exceptional e a -> Warnable e a
fromException a
deflt Exceptional e a
x =
{- Here the list item can only be constructed after the constructor of x is known
   case x of
      Sync.Success y   -> Warnable [Nothing] y
      Sync.Exception e -> Warnable [Just e] deflt
-}
   let (Maybe e
e,a
y) =
           case Exceptional e a
x of
              Sync.Success a
y0   -> (Maybe e
forall a. Maybe a
Nothing, a
y0)
              Sync.Exception 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 [e0] -> e1
summarize Warnable e0 a
x =
   case Warnable e0 a
x of
      Warnable [Maybe e0]
mes 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
            [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 = [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 a -> b
f Warnable e a
x =
      case Warnable e a
x of
         Warnable [Maybe e]
e 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 [] -- [Nothing]?
   Warnable e (a -> b)
f <*> :: 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 -> [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 [] -- [Nothing]?
   Warnable e a
x >>= :: 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 -> [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


-- * Monad transformer

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 a
deflt (Sync.ExceptionalT 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 a -> b
f (WarnableT 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 m (Warnable e (a -> b))
f <*> :: WarnableT e m (a -> b) -> WarnableT e m a -> WarnableT e m b
<*> WarnableT 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
   WarnableT e m a
x0 >>= :: WarnableT e m a -> (a -> WarnableT e m b) -> WarnableT e m b
>>= 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 [Maybe e]
ex 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 [Maybe e]
ey 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