{-# LANGUAGE CPP                   #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE Trustworthy           #-}
{-# LANGUAGE UndecidableInstances  #-}
-----------------------------------------------------------------------------
-- | Module     :  Control.Monad.Chronicle
--
-- Hybrid error/writer monad class that allows both accumulating outputs and
-- aborting computation with a final output.
--
-- The expected use case is for computations with a notion of fatal vs.
-- non-fatal errors.

-----------------------------------------------------------------------------
module Control.Monad.Trans.Chronicle (
    -- * The Chronicle monad
    Chronicle, chronicle, runChronicle,
    -- * The ChronicleT monad transformer
    ChronicleT(..),
    -- * Chronicle operations
    dictate, disclose, confess,
    memento, absolve, condemn,
    retcon,
    ) where

import Control.Applicative
import Control.Monad
import Control.Monad.Fix
import Control.Monad.Trans
import Data.Default.Class
import Data.Functor.Identity
import Data.Semigroup

import Control.Monad.Error.Class
import Control.Monad.Reader.Class
import Control.Monad.RWS.Class
import Data.These
import Data.These.Combinators     (mapHere)
import Prelude

#ifdef MIN_VERSION_semigroupoids
import Data.Functor.Apply (Apply (..))
import Data.Functor.Bind  (Bind (..))
#endif

-- --------------------------------------------------------------------------
-- | A chronicle monad parameterized by the output type @c@.
--
--   The 'return' function produces a computation with no output, and '>>='
--   combines multiple outputs with '<>'.
type Chronicle c = ChronicleT c Identity

chronicle :: Monad m => These c a -> ChronicleT c m a
chronicle :: These c a -> ChronicleT c m a
chronicle = m (These c a) -> ChronicleT c m a
forall c (m :: * -> *) a. m (These c a) -> ChronicleT c m a
ChronicleT (m (These c a) -> ChronicleT c m a)
-> (These c a -> m (These c a)) -> These c a -> ChronicleT c m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. These c a -> m (These c a)
forall (m :: * -> *) a. Monad m => a -> m a
return

runChronicle :: Chronicle c a -> These c a
runChronicle :: Chronicle c a -> These c a
runChronicle = Identity (These c a) -> These c a
forall a. Identity a -> a
runIdentity (Identity (These c a) -> These c a)
-> (Chronicle c a -> Identity (These c a))
-> Chronicle c a
-> These c a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Chronicle c a -> Identity (These c a)
forall c (m :: * -> *) a. ChronicleT c m a -> m (These c a)
runChronicleT

-- --------------------------------------------------------------------------
-- | The `ChronicleT` monad transformer.
--
--   The 'return' function produces a computation with no output, and '>>='
--   combines multiple outputs with '<>'.
newtype ChronicleT c m a = ChronicleT { ChronicleT c m a -> m (These c a)
runChronicleT :: m (These c a) }

instance (Functor m) => Functor (ChronicleT c m) where
    fmap :: (a -> b) -> ChronicleT c m a -> ChronicleT c m b
fmap a -> b
f (ChronicleT m (These c a)
c) =  m (These c b) -> ChronicleT c m b
forall c (m :: * -> *) a. m (These c a) -> ChronicleT c m a
ChronicleT ((a -> b) -> These c a -> These c b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f (These c a -> These c b) -> m (These c a) -> m (These c b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (These c a)
c)

#ifdef MIN_VERSION_semigroupoids
instance (Semigroup c, Apply m) => Apply (ChronicleT c m) where
    ChronicleT m (These c (a -> b))
f <.> :: ChronicleT c m (a -> b) -> ChronicleT c m a -> ChronicleT c m b
<.> ChronicleT m (These c a)
x = m (These c b) -> ChronicleT c m b
forall c (m :: * -> *) a. m (These c a) -> ChronicleT c m a
ChronicleT (These c (a -> b) -> These c a -> These c b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
(<*>) (These c (a -> b) -> These c a -> These c b)
-> m (These c (a -> b)) -> m (These c a -> These c b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (These c (a -> b))
f m (These c a -> These c b) -> m (These c a) -> m (These c b)
forall (f :: * -> *) a b. Apply f => f (a -> b) -> f a -> f b
<.> m (These c a)
x)

instance (Semigroup c, Apply m, Monad m) => Bind (ChronicleT c m) where
    >>- :: ChronicleT c m a -> (a -> ChronicleT c m b) -> ChronicleT c m b
(>>-) = ChronicleT c m a -> (a -> ChronicleT c m b) -> ChronicleT c m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
(>>=)
#endif

instance (Semigroup c, Applicative m) => Applicative (ChronicleT c m) where
    pure :: a -> ChronicleT c m a
pure = m (These c a) -> ChronicleT c m a
forall c (m :: * -> *) a. m (These c a) -> ChronicleT c m a
ChronicleT (m (These c a) -> ChronicleT c m a)
-> (a -> m (These c a)) -> a -> ChronicleT c m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. These c a -> m (These c a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (These c a -> m (These c a))
-> (a -> These c a) -> a -> m (These c a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> These c a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    ChronicleT m (These c (a -> b))
f <*> :: ChronicleT c m (a -> b) -> ChronicleT c m a -> ChronicleT c m b
<*> ChronicleT m (These c a)
x = m (These c b) -> ChronicleT c m b
forall c (m :: * -> *) a. m (These c a) -> ChronicleT c m a
ChronicleT ((These c (a -> b) -> These c a -> These c b)
-> m (These c (a -> b)) -> m (These c a) -> m (These c b)
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 These c (a -> b) -> These c a -> These c b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
(<*>) m (These c (a -> b))
f m (These c a)
x)

instance (Semigroup c, Monad m) => Monad (ChronicleT c m) where
    return :: a -> ChronicleT c m a
return = m (These c a) -> ChronicleT c m a
forall c (m :: * -> *) a. m (These c a) -> ChronicleT c m a
ChronicleT (m (These c a) -> ChronicleT c m a)
-> (a -> m (These c a)) -> a -> ChronicleT c m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. These c a -> m (These c a)
forall (m :: * -> *) a. Monad m => a -> m a
return (These c a -> m (These c a))
-> (a -> These c a) -> a -> m (These c a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> These c a
forall (m :: * -> *) a. Monad m => a -> m a
return
    ChronicleT c m a
m >>= :: ChronicleT c m a -> (a -> ChronicleT c m b) -> ChronicleT c m b
>>= a -> ChronicleT c m b
k = m (These c b) -> ChronicleT c m b
forall c (m :: * -> *) a. m (These c a) -> ChronicleT c m a
ChronicleT (m (These c b) -> ChronicleT c m b)
-> m (These c b) -> ChronicleT c m b
forall a b. (a -> b) -> a -> b
$
        do These c a
cx <- ChronicleT c m a -> m (These c a)
forall c (m :: * -> *) a. ChronicleT c m a -> m (These c a)
runChronicleT ChronicleT c m a
m
           case These c a
cx of
               This  c
a   -> These c b -> m (These c b)
forall (m :: * -> *) a. Monad m => a -> m a
return (c -> These c b
forall a b. a -> These a b
This c
a)
               That    a
x -> ChronicleT c m b -> m (These c b)
forall c (m :: * -> *) a. ChronicleT c m a -> m (These c a)
runChronicleT (a -> ChronicleT c m b
k a
x)
               These c
a a
x -> do These c b
cy <- ChronicleT c m b -> m (These c b)
forall c (m :: * -> *) a. ChronicleT c m a -> m (These c a)
runChronicleT (a -> ChronicleT c m b
k a
x)
                               These c b -> m (These c b)
forall (m :: * -> *) a. Monad m => a -> m a
return (These c b -> m (These c b)) -> These c b -> m (These c b)
forall a b. (a -> b) -> a -> b
$ case These c b
cy of
                                            This  c
b   -> c -> These c b
forall a b. a -> These a b
This (c
a c -> c -> c
forall a. Semigroup a => a -> a -> a
<> c
b)
                                            That    b
y -> c -> b -> These c b
forall a b. a -> b -> These a b
These c
a b
y
                                            These c
b b
y -> c -> b -> These c b
forall a b. a -> b -> These a b
These (c
a c -> c -> c
forall a. Semigroup a => a -> a -> a
<> c
b) b
y

instance (Semigroup c) => MonadTrans (ChronicleT c) where
    lift :: m a -> ChronicleT c m a
lift m a
m = m (These c a) -> ChronicleT c m a
forall c (m :: * -> *) a. m (These c a) -> ChronicleT c m a
ChronicleT (a -> These c a
forall a b. b -> These a b
That (a -> These c a) -> m a -> m (These c a)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` m a
m)

instance (Semigroup c, MonadIO m) => MonadIO (ChronicleT c m) where
    liftIO :: IO a -> ChronicleT c m a
liftIO = m a -> ChronicleT c m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m a -> ChronicleT c m a)
-> (IO a -> m a) -> IO a -> ChronicleT c m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO


instance (Semigroup c, Monoid c, Applicative m, Monad m) => Alternative (ChronicleT c m) where
    empty :: ChronicleT c m a
empty = ChronicleT c m a
forall (m :: * -> *) a. MonadPlus m => m a
mzero
    <|> :: ChronicleT c m a -> ChronicleT c m a -> ChronicleT c m a
(<|>) = ChronicleT c m a -> ChronicleT c m a -> ChronicleT c m a
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
mplus

instance (Semigroup c, Monoid c, Monad m) => MonadPlus (ChronicleT c m) where
    mzero :: ChronicleT c m a
mzero = c -> ChronicleT c m a
forall c (m :: * -> *) a.
(Semigroup c, Monad m) =>
c -> ChronicleT c m a
confess c
forall a. Monoid a => a
mempty
    mplus :: ChronicleT c m a -> ChronicleT c m a -> ChronicleT c m a
mplus ChronicleT c m a
x ChronicleT c m a
y = do Either c a
x' <- ChronicleT c m a -> ChronicleT c m (Either c a)
forall c (m :: * -> *) a.
(Semigroup c, Monad m) =>
ChronicleT c m a -> ChronicleT c m (Either c a)
memento ChronicleT c m a
x
                   case Either c a
x' of
                       Left  c
_ -> ChronicleT c m a
y
                       Right a
r -> a -> ChronicleT c m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
r


instance (Semigroup c, MonadError e m) => MonadError e (ChronicleT c m) where
    throwError :: e -> ChronicleT c m a
throwError = m a -> ChronicleT c m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m a -> ChronicleT c m a) -> (e -> m a) -> e -> ChronicleT c m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError
    catchError :: ChronicleT c m a -> (e -> ChronicleT c m a) -> ChronicleT c m a
catchError (ChronicleT m (These c a)
m) e -> ChronicleT c m a
c = m (These c a) -> ChronicleT c m a
forall c (m :: * -> *) a. m (These c a) -> ChronicleT c m a
ChronicleT (m (These c a) -> ChronicleT c m a)
-> m (These c a) -> ChronicleT c m a
forall a b. (a -> b) -> a -> b
$ m (These c a) -> (e -> m (These c a)) -> m (These c a)
forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
catchError m (These c a)
m (ChronicleT c m a -> m (These c a)
forall c (m :: * -> *) a. ChronicleT c m a -> m (These c a)
runChronicleT (ChronicleT c m a -> m (These c a))
-> (e -> ChronicleT c m a) -> e -> m (These c a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> ChronicleT c m a
c)


instance (Semigroup c, MonadReader r m) => MonadReader r (ChronicleT c m) where
    ask :: ChronicleT c m r
ask = m r -> ChronicleT c m r
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m r
forall r (m :: * -> *). MonadReader r m => m r
ask
    local :: (r -> r) -> ChronicleT c m a -> ChronicleT c m a
local r -> r
f (ChronicleT m (These c a)
m) = m (These c a) -> ChronicleT c m a
forall c (m :: * -> *) a. m (These c a) -> ChronicleT c m a
ChronicleT (m (These c a) -> ChronicleT c m a)
-> m (These c a) -> ChronicleT c m a
forall a b. (a -> b) -> a -> b
$ (r -> r) -> m (These c a) -> m (These c a)
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local r -> r
f m (These c a)
m
    reader :: (r -> a) -> ChronicleT c m a
reader = m a -> ChronicleT c m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m a -> ChronicleT c m a)
-> ((r -> a) -> m a) -> (r -> a) -> ChronicleT c m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (r -> a) -> m a
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
reader

instance (Semigroup c, MonadRWS r w s m) => MonadRWS r w s (ChronicleT c m) where

instance (Semigroup c, MonadState s m) => MonadState s (ChronicleT c m) where
    get :: ChronicleT c m s
get = m s -> ChronicleT c m s
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m s
forall s (m :: * -> *). MonadState s m => m s
get
    put :: s -> ChronicleT c m ()
put = m () -> ChronicleT c m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> ChronicleT c m ())
-> (s -> m ()) -> s -> ChronicleT c m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. s -> m ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put
    state :: (s -> (a, s)) -> ChronicleT c m a
state = m a -> ChronicleT c m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m a -> ChronicleT c m a)
-> ((s -> (a, s)) -> m a) -> (s -> (a, s)) -> ChronicleT c m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (s -> (a, s)) -> m a
forall s (m :: * -> *) a. MonadState s m => (s -> (a, s)) -> m a
state

instance (Semigroup c, MonadWriter w m) => MonadWriter w (ChronicleT c m) where
    tell :: w -> ChronicleT c m ()
tell = m () -> ChronicleT c m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> ChronicleT c m ())
-> (w -> m ()) -> w -> ChronicleT c m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. w -> m ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell
    listen :: ChronicleT c m a -> ChronicleT c m (a, w)
listen (ChronicleT m (These c a)
m) = m (These c (a, w)) -> ChronicleT c m (a, w)
forall c (m :: * -> *) a. m (These c a) -> ChronicleT c m a
ChronicleT (m (These c (a, w)) -> ChronicleT c m (a, w))
-> m (These c (a, w)) -> ChronicleT c m (a, w)
forall a b. (a -> b) -> a -> b
$ do
        (These c a
m', w
w) <- m (These c a) -> m (These c a, w)
forall w (m :: * -> *) a. MonadWriter w m => m a -> m (a, w)
listen m (These c a)
m
        These c (a, w) -> m (These c (a, w))
forall (m :: * -> *) a. Monad m => a -> m a
return (These c (a, w) -> m (These c (a, w)))
-> These c (a, w) -> m (These c (a, w))
forall a b. (a -> b) -> a -> b
$ case These c a
m' of
                     This  c
c   -> c -> These c (a, w)
forall a b. a -> These a b
This c
c
                     That    a
x -> (a, w) -> These c (a, w)
forall a b. b -> These a b
That (a
x, w
w)
                     These c
c a
x -> c -> (a, w) -> These c (a, w)
forall a b. a -> b -> These a b
These c
c (a
x, w
w)
    pass :: ChronicleT c m (a, w -> w) -> ChronicleT c m a
pass (ChronicleT m (These c (a, w -> w))
m) = m (These c a) -> ChronicleT c m a
forall c (m :: * -> *) a. m (These c a) -> ChronicleT c m a
ChronicleT (m (These c a) -> ChronicleT c m a)
-> m (These c a) -> ChronicleT c m a
forall a b. (a -> b) -> a -> b
$ do
        m (These c a, w -> w) -> m (These c a)
forall w (m :: * -> *) a. MonadWriter w m => m (a, w -> w) -> m a
pass (m (These c a, w -> w) -> m (These c a))
-> m (These c a, w -> w) -> m (These c a)
forall a b. (a -> b) -> a -> b
$ (c -> (These c a, w -> w))
-> ((a, w -> w) -> (These c a, w -> w))
-> (c -> (a, w -> w) -> (These c a, w -> w))
-> These c (a, w -> w)
-> (These c a, w -> w)
forall a c b.
(a -> c) -> (b -> c) -> (a -> b -> c) -> These a b -> c
these (\c
c -> (c -> These c a
forall a b. a -> These a b
This c
c, w -> w
forall a. a -> a
id))
                     (\(a
x, w -> w
f) -> (a -> These c a
forall a b. b -> These a b
That a
x, w -> w
f))
                     (\c
c (a
x, w -> w
f) -> (c -> a -> These c a
forall a b. a -> b -> These a b
These c
c a
x, w -> w
f)) (These c (a, w -> w) -> (These c a, w -> w))
-> m (These c (a, w -> w)) -> m (These c a, w -> w)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` m (These c (a, w -> w))
m
    writer :: (a, w) -> ChronicleT c m a
writer = m a -> ChronicleT c m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m a -> ChronicleT c m a)
-> ((a, w) -> m a) -> (a, w) -> ChronicleT c m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a, w) -> m a
forall w (m :: * -> *) a. MonadWriter w m => (a, w) -> m a
writer

-- this is basically copied from the instance for Either in transformers
-- need to test this to make sure it's actually sensible...?
instance (Semigroup c, MonadFix m) => MonadFix (ChronicleT c m) where
    mfix :: (a -> ChronicleT c m a) -> ChronicleT c m a
mfix a -> ChronicleT c m a
f = m (These c a) -> ChronicleT c m a
forall c (m :: * -> *) a. m (These c a) -> ChronicleT c m a
ChronicleT ((These c a -> m (These c a)) -> m (These c a)
forall (m :: * -> *) a. MonadFix m => (a -> m a) -> m a
mfix (ChronicleT c m a -> m (These c a)
forall c (m :: * -> *) a. ChronicleT c m a -> m (These c a)
runChronicleT (ChronicleT c m a -> m (These c a))
-> (These c a -> ChronicleT c m a) -> These c a -> m (These c a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> ChronicleT c m a
f (a -> ChronicleT c m a)
-> (These c a -> a) -> These c a -> ChronicleT c m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (c -> a) -> (a -> a) -> (c -> a -> a) -> These c a -> a
forall a c b.
(a -> c) -> (b -> c) -> (a -> b -> c) -> These a b -> c
these (a -> c -> a
forall a b. a -> b -> a
const a
forall a. a
bomb) a -> a
forall a. a -> a
id ((a -> c -> a) -> c -> a -> a
forall a b c. (a -> b -> c) -> b -> a -> c
flip a -> c -> a
forall a b. a -> b -> a
const)))
      where bomb :: a
bomb = [Char] -> a
forall a. HasCallStack => [Char] -> a
error [Char]
"mfix (ChronicleT): inner compuation returned This value"


-- | @'dictate' c@ is an action that records the output @c@.
--
--   Equivalent to 'tell' for the 'Writer' monad.
dictate :: (Semigroup c, Monad m) => c -> ChronicleT c m ()
dictate :: c -> ChronicleT c m ()
dictate c
c = m (These c ()) -> ChronicleT c m ()
forall c (m :: * -> *) a. m (These c a) -> ChronicleT c m a
ChronicleT (m (These c ()) -> ChronicleT c m ())
-> m (These c ()) -> ChronicleT c m ()
forall a b. (a -> b) -> a -> b
$ These c () -> m (These c ())
forall (m :: * -> *) a. Monad m => a -> m a
return (c -> () -> These c ()
forall a b. a -> b -> These a b
These c
c ())

-- | @'disclose' c@ is an action that records the output @c@ and returns a
--   @'Default'@ value.
--
--   This is a convenience function for reporting non-fatal errors in one
--   branch a @case@, or similar scenarios when there is no meaningful
--   result but a placeholder of sorts is needed in order to continue.
disclose :: (Default a, Semigroup c, Monad m) => c -> ChronicleT c m a
disclose :: c -> ChronicleT c m a
disclose c
c = c -> ChronicleT c m ()
forall c (m :: * -> *).
(Semigroup c, Monad m) =>
c -> ChronicleT c m ()
dictate c
c ChronicleT c m () -> ChronicleT c m a -> ChronicleT c m a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> a -> ChronicleT c m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
forall a. Default a => a
def

-- | @'confess' c@ is an action that ends with a final output @c@.
--
--   Equivalent to 'throwError' for the 'Error' monad.
confess :: (Semigroup c, Monad m) => c -> ChronicleT c m a
confess :: c -> ChronicleT c m a
confess c
c = m (These c a) -> ChronicleT c m a
forall c (m :: * -> *) a. m (These c a) -> ChronicleT c m a
ChronicleT (m (These c a) -> ChronicleT c m a)
-> m (These c a) -> ChronicleT c m a
forall a b. (a -> b) -> a -> b
$ These c a -> m (These c a)
forall (m :: * -> *) a. Monad m => a -> m a
return (c -> These c a
forall a b. a -> These a b
This c
c)

-- | @'memento' m@ is an action that executes the action @m@, returning either
--   its record if it ended with 'confess', or its final value otherwise, with
--   any record added to the current record.
--
--   Similar to 'catchError' in the 'Error' monad, but with a notion of
--   non-fatal errors (which are accumulated) vs. fatal errors (which are caught
--   without accumulating).
memento :: (Semigroup c, Monad m) => ChronicleT c m a -> ChronicleT c m (Either c a)
memento :: ChronicleT c m a -> ChronicleT c m (Either c a)
memento ChronicleT c m a
m = m (These c (Either c a)) -> ChronicleT c m (Either c a)
forall c (m :: * -> *) a. m (These c a) -> ChronicleT c m a
ChronicleT (m (These c (Either c a)) -> ChronicleT c m (Either c a))
-> m (These c (Either c a)) -> ChronicleT c m (Either c a)
forall a b. (a -> b) -> a -> b
$
    do These c a
cx <- ChronicleT c m a -> m (These c a)
forall c (m :: * -> *) a. ChronicleT c m a -> m (These c a)
runChronicleT ChronicleT c m a
m
       These c (Either c a) -> m (These c (Either c a))
forall (m :: * -> *) a. Monad m => a -> m a
return (These c (Either c a) -> m (These c (Either c a)))
-> These c (Either c a) -> m (These c (Either c a))
forall a b. (a -> b) -> a -> b
$ case These c a
cx of
                    This  c
a   -> Either c a -> These c (Either c a)
forall a b. b -> These a b
That (c -> Either c a
forall a b. a -> Either a b
Left c
a)
                    That    a
x -> Either c a -> These c (Either c a)
forall a b. b -> These a b
That (a -> Either c a
forall a b. b -> Either a b
Right a
x)
                    These c
a a
x -> c -> Either c a -> These c (Either c a)
forall a b. a -> b -> These a b
These c
a (a -> Either c a
forall a b. b -> Either a b
Right a
x)

-- | @'absolve' x m@ is an action that executes the action @m@ and discards any
--   record it had. The default value @x@ will be used if @m@ ended via
--   'confess'.
absolve :: (Semigroup c, Monad m) => a -> ChronicleT c m a -> ChronicleT c m a
absolve :: a -> ChronicleT c m a -> ChronicleT c m a
absolve a
x ChronicleT c m a
m = m (These c a) -> ChronicleT c m a
forall c (m :: * -> *) a. m (These c a) -> ChronicleT c m a
ChronicleT (m (These c a) -> ChronicleT c m a)
-> m (These c a) -> ChronicleT c m a
forall a b. (a -> b) -> a -> b
$
    do These c a
cy <- ChronicleT c m a -> m (These c a)
forall c (m :: * -> *) a. ChronicleT c m a -> m (These c a)
runChronicleT ChronicleT c m a
m
       These c a -> m (These c a)
forall (m :: * -> *) a. Monad m => a -> m a
return (These c a -> m (These c a)) -> These c a -> m (These c a)
forall a b. (a -> b) -> a -> b
$ case These c a
cy of
                    This  c
_   -> a -> These c a
forall a b. b -> These a b
That a
x
                    That    a
y -> a -> These c a
forall a b. b -> These a b
That a
y
                    These c
_ a
y -> a -> These c a
forall a b. b -> These a b
That a
y


-- | @'condemn' m@ is an action that executes the action @m@ and keeps its value
--   only if it had no record. Otherwise, the value (if any) will be discarded
--   and only the record kept.
--
--   This can be seen as converting non-fatal errors into fatal ones.
condemn :: (Semigroup c, Monad m) => ChronicleT c m a -> ChronicleT c m a
condemn :: ChronicleT c m a -> ChronicleT c m a
condemn (ChronicleT m (These c a)
m) = m (These c a) -> ChronicleT c m a
forall c (m :: * -> *) a. m (These c a) -> ChronicleT c m a
ChronicleT (m (These c a) -> ChronicleT c m a)
-> m (These c a) -> ChronicleT c m a
forall a b. (a -> b) -> a -> b
$ do
    These c a
m' <- m (These c a)
m
    These c a -> m (These c a)
forall (m :: * -> *) a. Monad m => a -> m a
return (These c a -> m (These c a)) -> These c a -> m (These c a)
forall a b. (a -> b) -> a -> b
$ case These c a
m' of
        This  c
x   -> c -> These c a
forall a b. a -> These a b
This c
x
        That    a
y -> a -> These c a
forall a b. b -> These a b
That a
y
        These c
x a
_ -> c -> These c a
forall a b. a -> These a b
This c
x


-- | @'retcon' f m@ is an action that executes the action @m@ and applies the
--   function @f@ to its output, leaving the return value unchanged.
--
--   Equivalent to 'censor' for the 'Writer' monad.
retcon :: (Semigroup c, Monad m) => (c -> c) -> ChronicleT c m a -> ChronicleT c m a
retcon :: (c -> c) -> ChronicleT c m a -> ChronicleT c m a
retcon c -> c
f ChronicleT c m a
m = m (These c a) -> ChronicleT c m a
forall c (m :: * -> *) a. m (These c a) -> ChronicleT c m a
ChronicleT (m (These c a) -> ChronicleT c m a)
-> m (These c a) -> ChronicleT c m a
forall a b. (a -> b) -> a -> b
$ (c -> c) -> These c a -> These c a
forall a c b. (a -> c) -> These a b -> These c b
mapHere c -> c
f (These c a -> These c a) -> m (These c a) -> m (These c a)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` ChronicleT c m a -> m (These c a)
forall c (m :: * -> *) a. ChronicleT c m a -> m (These c a)
runChronicleT ChronicleT c m a
m