summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorphadej <>2019-06-02 13:55:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2019-06-02 13:55:00 (GMT)
commit1b64561374bb733658d8dc662e32c828af5c4394 (patch)
tree848fab7438ab7f92ececb7f349da2a72c1098cdf
version 11
-rwxr-xr-xCHANGELOG.md3
-rw-r--r--LICENSE30
-rw-r--r--monad-chronicle.cabal64
-rw-r--r--src/Control/Monad/Chronicle.hs17
-rw-r--r--src/Control/Monad/Chronicle/Class.hs223
-rw-r--r--src/Control/Monad/Trans/Chronicle.hs220
6 files changed, 557 insertions, 0 deletions
diff --git a/CHANGELOG.md b/CHANGELOG.md
new file mode 100755
index 0000000..a2aecd0
--- /dev/null
+++ b/CHANGELOG.md
@@ -0,0 +1,3 @@
+# 1
+
+Split out of `these` package.
diff --git a/LICENSE b/LICENSE
new file mode 100644
index 0000000..9d6d650
--- /dev/null
+++ b/LICENSE
@@ -0,0 +1,30 @@
+Copyright (c) 2012, C. McCann, 2015-2019 Oleg Grenrus
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+ * Redistributions of source code must retain the above copyright
+ notice, this list of conditions and the following disclaimer.
+
+ * Redistributions in binary form must reproduce the above
+ copyright notice, this list of conditions and the following
+ disclaimer in the documentation and/or other materials provided
+ with the distribution.
+
+ * Neither the name of C. McCann nor the names of other
+ contributors may be used to endorse or promote products derived
+ from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
diff --git a/monad-chronicle.cabal b/monad-chronicle.cabal
new file mode 100644
index 0000000..053ab7e
--- /dev/null
+++ b/monad-chronicle.cabal
@@ -0,0 +1,64 @@
+cabal-version: >=1.10
+name: monad-chronicle
+version: 1
+synopsis: These as a transformer, ChronicleT
+homepage: https://github.com/isomorphism/these
+license: BSD3
+license-file: LICENSE
+author: C. McCann, Oleg Grenrus
+maintainer: Oleg Grenrus <oleg.grenrus@iki.fi>
+category: Control, These
+build-type: Simple
+extra-source-files: CHANGELOG.md
+description:
+ This packages provides @ChronicleT@, a monad transformer based on
+ the @Monad@ instance for @These a@, along with the usual monad
+ transformer bells and whistles.
+
+tested-with:
+ GHC ==7.4.2 || ==7.6.3 || ==7.8.4 || ==7.10.3 || ==8.0.2 || ==8.2.2 || ==8.4.4 || ==8.6.5 || ==8.8.1
+
+source-repository head
+ type: git
+ location: https://github.com/isomorphism/these.git
+
+flag semigroupoids
+ description: Build with semigroupoids dependency
+ manual: True
+ default: True
+
+library
+ default-language: Haskell2010
+ ghc-options: -Wall
+
+ if impl(ghc >=8.0)
+ ghc-options: -Wno-trustworthy-safe
+
+ hs-source-dirs: src
+ exposed-modules:
+ Control.Monad.Chronicle
+ Control.Monad.Chronicle.Class
+ Control.Monad.Trans.Chronicle
+
+ -- ghc boot libs
+ build-depends:
+ base >=4.5.1.0 && <4.13
+ , mtl >=2.1.3 && <2.3
+ , transformers >=0.3.0.0 && <0.6
+
+ build-depends: these >=1 && <1.1
+
+ -- other dependencies
+ build-depends:
+ data-default-class >=0.1.2.0 && <0.2
+ , transformers-compat >=0.6.5 && <0.7
+
+ if !impl(ghc >=8.0)
+ build-depends: semigroups >=0.18.5 && <0.20
+
+ -- Ensure Data.Functor.Classes is always available
+ if impl(ghc >=7.10)
+ build-depends: transformers >=0.4.2.0
+
+ if flag(semigroupoids)
+ build-depends: semigroupoids >=5.3.2 && <5.4
diff --git a/src/Control/Monad/Chronicle.hs b/src/Control/Monad/Chronicle.hs
new file mode 100644
index 0000000..e34ead2
--- /dev/null
+++ b/src/Control/Monad/Chronicle.hs
@@ -0,0 +1,17 @@
+{-# LANGUAGE Trustworthy #-}
+-----------------------------------------------------------------------------
+-- | Module : Control.Monad.Trans.Chronicle
+--
+-- The 'ChronicleT' monad, a hybrid error/writer monad that allows
+-- both accumulating outputs and aborting computation with a final
+-- output.
+-----------------------------------------------------------------------------
+module Control.Monad.Chronicle (
+ -- * Type class for Chronicle-style monads
+ MonadChronicle(..)
+ -- * The ChronicleT monad transformer
+ , Chronicle, runChronicle, ChronicleT(..)
+ ) where
+
+import Control.Monad.Chronicle.Class
+import Control.Monad.Trans.Chronicle (Chronicle, runChronicle, ChronicleT (..))
diff --git a/src/Control/Monad/Chronicle/Class.hs b/src/Control/Monad/Chronicle/Class.hs
new file mode 100644
index 0000000..7d6fdd8
--- /dev/null
+++ b/src/Control/Monad/Chronicle/Class.hs
@@ -0,0 +1,223 @@
+{-# LANGUAGE Trustworthy #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE FunctionalDependencies #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-} -- for the ErrorT instances
+-----------------------------------------------------------------------------
+-- | Module : Control.Monad.Chronicle.Class
+--
+-- 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.Chronicle.Class (
+ MonadChronicle(..),
+ ) where
+
+import Control.Applicative
+import Control.Monad.Trans.Chronicle (ChronicleT)
+import qualified Control.Monad.Trans.Chronicle as Ch
+import Data.These
+import Data.These.Combinators
+
+import Control.Monad.Trans.Error as Error
+import Control.Monad.Trans.Except as Except
+import Control.Monad.Trans.Identity as Identity
+import Control.Monad.Trans.Maybe as Maybe
+import Control.Monad.Trans.Reader as Reader
+import Control.Monad.Trans.RWS.Lazy as LazyRWS
+import Control.Monad.Trans.RWS.Strict as StrictRWS
+import Control.Monad.Trans.State.Lazy as LazyState
+import Control.Monad.Trans.State.Strict as StrictState
+import Control.Monad.Trans.Writer.Lazy as LazyWriter
+import Control.Monad.Trans.Writer.Strict as StrictWriter
+
+import Control.Monad (liftM)
+import Control.Monad.Trans.Class (lift)
+import Data.Default.Class
+import Data.Semigroup
+import Prelude
+
+class (Monad m) => MonadChronicle c m | m -> c where
+ -- | @'dictate' c@ is an action that records the output @c@.
+ --
+ -- Equivalent to 'tell' for the 'Writer' monad.
+ dictate :: c -> m ()
+
+ -- | @'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) => c -> m a
+ disclose c = dictate c >> return def
+
+ -- | @'confess' c@ is an action that ends with a final record @c@.
+ --
+ -- Equivalent to 'throwError' for the 'Error' monad.
+ confess :: c -> m a
+
+ -- | @'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 :: m a -> m (Either c a)
+
+ -- | @'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 :: a -> m a -> m a
+
+ -- | @'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 :: m a -> m a
+
+ -- | @'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 :: (c -> c) -> m a -> m a
+
+ -- | @'chronicle' m@ lifts a plain @'These' c a@ value into a 'MonadChronicle' instance.
+ chronicle :: These c a -> m a
+
+
+instance (Semigroup c) => MonadChronicle c (These c) where
+ dictate c = These c ()
+ confess c = This c
+ memento (This c) = That (Left c)
+ memento m = mapThere Right m
+ absolve x (This _) = That x
+ absolve _ (That x) = That x
+ absolve _ (These _ x) = That x
+ condemn (These c _) = This c
+ condemn m = m
+ retcon = mapHere
+ chronicle = id
+
+instance (Semigroup c, Monad m) => MonadChronicle c (ChronicleT c m) where
+ dictate = Ch.dictate
+ confess = Ch.confess
+ memento = Ch.memento
+ absolve = Ch.absolve
+ condemn = Ch.condemn
+ retcon = Ch.retcon
+ chronicle = Ch.ChronicleT . return
+
+instance (MonadChronicle c m) => MonadChronicle c (IdentityT m) where
+ dictate = lift . dictate
+ confess = lift . confess
+ memento (IdentityT m) = lift $ memento m
+ absolve x (IdentityT m) = lift $ absolve x m
+ condemn (IdentityT m) = lift $ condemn m
+ retcon f (IdentityT m) = lift $ retcon f m
+ chronicle = lift . chronicle
+
+instance (MonadChronicle c m) => MonadChronicle c (MaybeT m) where
+ dictate = lift . dictate
+ confess = lift . confess
+ memento (MaybeT m) = MaybeT $ either (Just . Left) (Right <$>) `liftM` memento m
+ absolve x (MaybeT m) = MaybeT $ absolve (Just x) m
+ condemn (MaybeT m) = MaybeT $ condemn m
+ retcon f (MaybeT m) = MaybeT $ retcon f m
+ chronicle = lift . chronicle
+
+instance (Error e, MonadChronicle c m) => MonadChronicle c (ErrorT e m) where
+ dictate = lift . dictate
+ confess = lift . confess
+ memento (ErrorT m) = ErrorT $ either (Right . Left) (Right <$>) `liftM` memento m
+ absolve x (ErrorT m) = ErrorT $ absolve (Right x) m
+ condemn (ErrorT m) = ErrorT $ condemn m
+ retcon f (ErrorT m) = ErrorT $ retcon f m
+ chronicle = lift . chronicle
+
+instance (MonadChronicle c m) => MonadChronicle c (ExceptT e m) where
+ dictate = lift . dictate
+ confess = lift . confess
+ memento (ExceptT m) = ExceptT $ either (Right . Left) (Right <$>) `liftM` memento m
+ absolve x (ExceptT m) = ExceptT $ absolve (Right x) m
+ condemn (ExceptT m) = ExceptT $ condemn m
+ retcon f (ExceptT m) = ExceptT $ retcon f m
+ chronicle = lift . chronicle
+
+instance (MonadChronicle c m) => MonadChronicle c (ReaderT r m) where
+ dictate = lift . dictate
+ confess = lift . confess
+ memento (ReaderT m) = ReaderT $ memento . m
+ absolve x (ReaderT m) = ReaderT $ absolve x . m
+ condemn (ReaderT m) = ReaderT $ condemn . m
+ retcon f (ReaderT m) = ReaderT $ retcon f . m
+ chronicle = lift . chronicle
+
+instance (MonadChronicle c m) => MonadChronicle c (LazyState.StateT s m) where
+ dictate = lift . dictate
+ confess = lift . confess
+ memento (LazyState.StateT m) = LazyState.StateT $ \s -> do
+ either (\c -> (Left c, s)) (\(a, s') -> (Right a, s')) `liftM` memento (m s)
+ absolve x (LazyState.StateT m) = LazyState.StateT $ \s -> absolve (x, s) $ m s
+ condemn (LazyState.StateT m) = LazyState.StateT $ condemn . m
+ retcon f (LazyState.StateT m) = LazyState.StateT $ retcon f . m
+ chronicle = lift . chronicle
+
+instance (MonadChronicle c m) => MonadChronicle c (StrictState.StateT s m) where
+ dictate = lift . dictate
+ confess = lift . confess
+ memento (StrictState.StateT m) = StrictState.StateT $ \s -> do
+ either (\c -> (Left c, s)) (\(a, s') -> (Right a, s')) `liftM` memento (m s)
+ absolve x (StrictState.StateT m) = StrictState.StateT $ \s -> absolve (x, s) $ m s
+ condemn (StrictState.StateT m) = StrictState.StateT $ condemn . m
+ retcon f (StrictState.StateT m) = StrictState.StateT $ retcon f . m
+ chronicle = lift . chronicle
+
+instance (Monoid w, MonadChronicle c m) => MonadChronicle c (LazyWriter.WriterT w m) where
+ dictate = lift . dictate
+ confess = lift . confess
+ memento (LazyWriter.WriterT m) = LazyWriter.WriterT $
+ either (\c -> (Left c, mempty)) (\(a, w) -> (Right a, w)) `liftM` memento m
+ absolve x (LazyWriter.WriterT m) = LazyWriter.WriterT $ absolve (x, mempty) m
+ condemn (LazyWriter.WriterT m) = LazyWriter.WriterT $ condemn m
+ retcon f (LazyWriter.WriterT m) = LazyWriter.WriterT $ retcon f m
+ chronicle = lift . chronicle
+
+instance (Monoid w, MonadChronicle c m) => MonadChronicle c (StrictWriter.WriterT w m) where
+ dictate = lift . dictate
+ confess = lift . confess
+ memento (StrictWriter.WriterT m) = StrictWriter.WriterT $
+ either (\c -> (Left c, mempty)) (\(a, w) -> (Right a, w)) `liftM` memento m
+ absolve x (StrictWriter.WriterT m) = StrictWriter.WriterT $ absolve (x, mempty) m
+ condemn (StrictWriter.WriterT m) = StrictWriter.WriterT $ condemn m
+ retcon f (StrictWriter.WriterT m) = StrictWriter.WriterT $ retcon f m
+ chronicle = lift . chronicle
+
+instance (Monoid w, MonadChronicle c m) => MonadChronicle c (LazyRWS.RWST r w s m) where
+ dictate = lift . dictate
+ confess = lift . confess
+ memento (LazyRWS.RWST m) = LazyRWS.RWST $ \r s ->
+ either (\c -> (Left c, s, mempty)) (\(a, s', w) -> (Right a, s', w)) `liftM` memento (m r s)
+ absolve x (LazyRWS.RWST m) = LazyRWS.RWST $ \r s -> absolve (x, s, mempty) $ m r s
+ condemn (LazyRWS.RWST m) = LazyRWS.RWST $ \r s -> condemn $ m r s
+ retcon f (LazyRWS.RWST m) = LazyRWS.RWST $ \r s -> retcon f $ m r s
+ chronicle = lift . chronicle
+
+instance (Monoid w, MonadChronicle c m) => MonadChronicle c (StrictRWS.RWST r w s m) where
+ dictate = lift . dictate
+ confess = lift . confess
+ memento (StrictRWS.RWST m) = StrictRWS.RWST $ \r s ->
+ either (\c -> (Left c, s, mempty)) (\(a, s', w) -> (Right a, s', w)) `liftM` memento (m r s)
+ absolve x (StrictRWS.RWST m) = StrictRWS.RWST $ \r s -> absolve (x, s, mempty) $ m r s
+ condemn (StrictRWS.RWST m) = StrictRWS.RWST $ \r s -> condemn $ m r s
+ retcon f (StrictRWS.RWST m) = StrictRWS.RWST $ \r s -> retcon f $ m r s
+ chronicle = lift . chronicle
+
+
+
diff --git a/src/Control/Monad/Trans/Chronicle.hs b/src/Control/Monad/Trans/Chronicle.hs
new file mode 100644
index 0000000..7fcb88b
--- /dev/null
+++ b/src/Control/Monad/Trans/Chronicle.hs
@@ -0,0 +1,220 @@
+{-# LANGUAGE Trustworthy #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE FlexibleInstances #-}
+-----------------------------------------------------------------------------
+-- | 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 Prelude
+import Data.These
+import Data.These.Combinators (mapHere)
+
+#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 = ChronicleT . return
+
+runChronicle :: Chronicle c a -> These c a
+runChronicle = runIdentity . 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 { runChronicleT :: m (These c a) }
+
+instance (Functor m) => Functor (ChronicleT c m) where
+ fmap f (ChronicleT c) = ChronicleT (fmap f <$> c)
+
+#ifdef MIN_VERSION_semigroupoids
+instance (Semigroup c, Apply m) => Apply (ChronicleT c m) where
+ ChronicleT f <.> ChronicleT x = ChronicleT ((<.>) <$> f <.> x)
+
+instance (Semigroup c, Apply m, Monad m) => Bind (ChronicleT c m) where
+ (>>-) = (>>=)
+#endif
+
+instance (Semigroup c, Applicative m) => Applicative (ChronicleT c m) where
+ pure = ChronicleT . pure . pure
+ ChronicleT f <*> ChronicleT x = ChronicleT (liftA2 (<*>) f x)
+
+instance (Semigroup c, Monad m) => Monad (ChronicleT c m) where
+ return = ChronicleT . return . return
+ m >>= k = ChronicleT $
+ do cx <- runChronicleT m
+ case cx of
+ This a -> return (This a)
+ That x -> runChronicleT (k x)
+ These a x -> do cy <- runChronicleT (k x)
+ return $ case cy of
+ This b -> This (a <> b)
+ That y -> These a y
+ These b y -> These (a <> b) y
+
+instance (Semigroup c) => MonadTrans (ChronicleT c) where
+ lift m = ChronicleT (That `liftM` m)
+
+instance (Semigroup c, MonadIO m) => MonadIO (ChronicleT c m) where
+ liftIO = lift . liftIO
+
+
+instance (Semigroup c, Monoid c, Applicative m, Monad m) => Alternative (ChronicleT c m) where
+ empty = mzero
+ (<|>) = mplus
+
+instance (Semigroup c, Monoid c, Monad m) => MonadPlus (ChronicleT c m) where
+ mzero = confess mempty
+ mplus x y = do x' <- memento x
+ case x' of
+ Left _ -> y
+ Right r -> return r
+
+
+instance (Semigroup c, MonadError e m) => MonadError e (ChronicleT c m) where
+ throwError = lift . throwError
+ catchError (ChronicleT m) c = ChronicleT $ catchError m (runChronicleT . c)
+
+
+instance (Semigroup c, MonadReader r m) => MonadReader r (ChronicleT c m) where
+ ask = lift ask
+ local f (ChronicleT m) = ChronicleT $ local f m
+ reader = lift . 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 = lift get
+ put = lift . put
+ state = lift . state
+
+instance (Semigroup c, MonadWriter w m) => MonadWriter w (ChronicleT c m) where
+ tell = lift . tell
+ listen (ChronicleT m) = ChronicleT $ do
+ (m', w) <- listen m
+ return $ case m' of
+ This c -> This c
+ That x -> That (x, w)
+ These c x -> These c (x, w)
+ pass (ChronicleT m) = ChronicleT $ do
+ pass $ these (\c -> (This c, id))
+ (\(x, f) -> (That x, f))
+ (\c (x, f) -> (These c x, f)) `liftM` m
+ writer = lift . 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 f = ChronicleT (mfix (runChronicleT . f . these (const bomb) id (flip const)))
+ where bomb = error "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 $ return (These 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 = dictate c >> return 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 $ return (This 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 m = ChronicleT $
+ do cx <- runChronicleT m
+ return $ case cx of
+ This a -> That (Left a)
+ That x -> That (Right x)
+ These a x -> These a (Right 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 x m = ChronicleT $
+ do cy <- runChronicleT m
+ return $ case cy of
+ This _ -> That x
+ That y -> That y
+ These _ y -> That 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 m) = ChronicleT $ do
+ m' <- m
+ return $ case m' of
+ This x -> This x
+ That y -> That y
+ These x _ -> This 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 f m = ChronicleT $ mapHere f `liftM` runChronicleT m
+