{- |
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 :: forall a e. 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   -> (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 [] -- [Nothing]?
   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 [] -- [Nothing]?
   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


-- * Monad transformer

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