module Supplemented
(
Supplemented,
runSupplemented,
essence,
supplement,
)
where
import Supplemented.Prelude
newtype Supplemented m a =
Supplemented (Either (a, m ()) (m (a, m ())))
instance Functor m => Functor (Supplemented m) where
fmap f (Supplemented either1) =
Supplemented either2
where
either2 =
case either1 of
Left (result1, supplement1) ->
Left (f result1, supplement1)
Right m1 ->
Right $
fmap (\(result1, supplement1) -> (f result1, supplement1)) $
m1
instance Monad m => Applicative (Supplemented m) where
pure a =
Supplemented (Left (a, pure ()))
(<*>) (Supplemented either1) (Supplemented either2) =
Supplemented either3
where
either3 =
case either1 of
Left (result1, supplement1) ->
case either2 of
Left (result2, supplement2) ->
Left (result1 result2, supplement1 *> supplement2)
Right m2 ->
Right $
liftM (\(result2, supplement2) -> (result1 result2, supplement2)) $
supplement1 *> m2
Right m1 ->
case either2 of
Left (result2, supplement2) ->
Right $
liftM (\(result1, supplement1) -> (result1 result2, supplement1 *> supplement2)) $
m1
Right m2 ->
Right $
do
(result1, supplement1) <- m1
supplement1
(result2, supplement2) <- m2
return (result1 result2, supplement2)
instance MonadPlus m => Alternative (Supplemented m) where
empty =
Supplemented (Right mzero)
(<|>) (Supplemented either1) (Supplemented either2) =
Supplemented either3
where
either3 =
Right (mplus (m either1) (m either2))
where
m =
either (\(result, supplement) -> (result, return ()) <$ supplement) id
instance Monad m => Monad (Supplemented m) where
return =
pure
(>>=) (Supplemented either1) k2 =
Supplemented either3
where
either3 =
case either1 of
Left (result1, supplement1) ->
case k2 result1 of
Supplemented either2 ->
case either2 of
Left (result2, supplement2) ->
Left (result2, supplement1 *> supplement2)
Right m2 ->
Right (supplement1 *> m2)
Right m1 ->
Right $
do
(result1, supplement1) <- m1
case k2 result1 of
Supplemented either2 ->
case either2 of
Left (result2, supplement2) ->
return (result2, supplement1 *> supplement2)
Right m2 ->
do
supplement1
m2
instance MonadPlus m => MonadPlus (Supplemented m) where
mzero =
empty
mplus =
(<|>)
instance MonadTrans Supplemented where
lift =
essence
runSupplemented :: Monad m => Supplemented m a -> m (a, m ())
runSupplemented (Supplemented either1) =
either return id either1
essence :: Monad m => m a -> Supplemented m a
essence essence =
Supplemented (Right (liftM (\r -> (r, return ())) essence))
supplement :: Monad m => m () -> Supplemented m ()
supplement supplement =
Supplemented (Left ((), supplement))
essenceAndSupplement :: Monad m => m a -> m () -> Supplemented m a
essenceAndSupplement essence supplement =
Supplemented (Right (liftM (\r -> (r, supplement)) essence))
mapSupplement :: Monad m => (m () -> m ()) -> Supplemented m a -> Supplemented m a
mapSupplement mapping (Supplemented either1) =
Supplemented $
case either1 of
Left (result1, supplement1) ->
Left (result1, mapping supplement1)
Right m1 ->
Right $
liftM (\(result1, supplement1) -> (result1, mapping supplement1)) $
m1