From 82a6e5dfb1d4eb492eb3f276cfdb8ad68ba0c6f0 Mon Sep 17 00:00:00 2001
From: Philip Kamenarsky <p.kamenarsky@gmail.com>
Date: Sat, 9 Apr 2022 11:47:11 +0100
Subject: [PATCH] First draft of a ChronicleT.CPS

---
 monad-chronicle/monad-chronicle.cabal         |   1 +
 .../src/Control/Monad/Trans/Chronicle/CPS.hs  | 272 ++++++++++++++++++
 2 files changed, 273 insertions(+)
 create mode 100644 monad-chronicle/src/Control/Monad/Trans/Chronicle/CPS.hs

diff --git a/monad-chronicle/monad-chronicle.cabal b/monad-chronicle/monad-chronicle.cabal
index ef98a35..c0dd699 100644
--- a/monad-chronicle/monad-chronicle.cabal
+++ b/monad-chronicle/monad-chronicle.cabal
@@ -52,6 +52,7 @@ library
     Control.Monad.Chronicle
     Control.Monad.Chronicle.Class
     Control.Monad.Trans.Chronicle
+    Control.Monad.Trans.Chronicle.CPS
 
   -- ghc boot libs
   build-depends:
diff --git a/monad-chronicle/src/Control/Monad/Trans/Chronicle/CPS.hs b/monad-chronicle/src/Control/Monad/Trans/Chronicle/CPS.hs
new file mode 100644
index 0000000..189474f
--- /dev/null
+++ b/monad-chronicle/src/Control/Monad/Trans/Chronicle/CPS.hs
@@ -0,0 +1,272 @@
+{-# 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.CPS (
+    -- * 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 :: Semigroup c => Monad m => These c a -> ChronicleT c m a
+chronicle (This c')    = ChronicleT $ \c -> let ct = c <> c' in ct `seq` pure (This ct)
+chronicle (That     a) = ChronicleT $ \c -> pure (These c a)
+chronicle (These c' a) = ChronicleT $ \c -> let ct = c <> c' in ct `seq` pure (These ct a)
+{-# INLINE chronicle #-}
+
+runChronicle :: Monoid c => Chronicle c a -> These c a
+runChronicle = runIdentity . flip runChronicleT mempty
+{-# INLINE runChronicle #-}
+
+-- --------------------------------------------------------------------------
+-- | 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 :: c -> m (These c a) }
+
+instance (Functor m) => Functor (ChronicleT c m) where
+    fmap f m = ChronicleT $ \c -> g <$> runChronicleT m c
+      where
+        g (This c)    = This c
+        g (That    a) = That (f a)
+        g (These c a) = These c (f a)
+    {-# INLINE fmap #-}
+
+#ifdef MIN_VERSION_semigroupoids
+instance (Semigroup c, Monad m) => Apply (ChronicleT c m) where
+    (<.>) = (<*>)
+
+instance (Semigroup c, Monad m) => Bind (ChronicleT c m) where
+    (>>-) = (>>=)
+#endif
+
+instance (Semigroup c, Monad m) => Applicative (ChronicleT c m) where
+    pure a = ChronicleT $ \c -> pure (These c a)
+    {-# INLINE pure #-}
+
+    ChronicleT f <*> ChronicleT x = ChronicleT $ \c -> do
+      t <- f c
+      case t of
+        This c' -> do
+          t' <- x c'
+          case t' of
+            This  c''   -> pure (This c'')
+            That      _ -> pure (This c')
+            These c'' _ -> pure (This c'')
+        That f' -> do
+          t' <- x c
+          case t' of
+            This  c''     -> pure (This c'')
+            That      x'' -> pure (That (f' x''))
+            These c'' x'' -> pure (These c'' (f' x''))
+        These c' f' -> do
+          t' <- x c'
+          case t' of
+            This  c''     -> pure (This c'')
+            That      x'' -> pure (These c' (f' x''))
+            These c'' x'' -> pure (These c'' (f' x''))
+    {-# INLINE (<*>) #-}
+
+instance (Semigroup c, Monad m) => Monad (ChronicleT c m) where
+    return a = ChronicleT $ \c -> return (These c a)
+    {-# INLINE return #-}
+
+    m >>= k = ChronicleT $ \c -> do
+      t <- runChronicleT m c
+      case t of
+        This c'    -> return (This c')
+        That    a  -> runChronicleT (k a) c
+        These c' a -> runChronicleT (k a) c'
+    {-# INLINE (>>=) #-}
+
+instance (Semigroup c) => MonadTrans (ChronicleT c) where
+    lift m = ChronicleT $ \c -> (These c `liftM` m)
+    {-# INLINE lift #-}
+
+instance (Semigroup c, MonadIO m) => MonadIO (ChronicleT c m) where
+    liftIO = lift . liftIO
+    {-# INLINE liftIO #-}
+
+instance (Semigroup c, Monoid c, Applicative m, Monad m) => Alternative (ChronicleT c m) where
+    empty = mzero
+    {-# INLINE empty #-}
+    (<|>) = mplus
+    {-# INLINE (<|>) #-}
+
+instance (Semigroup c, Monoid c, Monad m) => MonadPlus (ChronicleT c m) where
+    mzero = confess mempty
+    {-# INLINE mzero #-}
+    mplus x y = do x' <- memento x
+                   case x' of
+                       Left  _ -> y
+                       Right r -> return r
+    {-# INLINE mplus #-}
+
+instance (Semigroup c, MonadError e m) => MonadError e (ChronicleT c m) where
+    throwError = lift . throwError
+    {-# INLINE throwError #-}
+    catchError (ChronicleT m) c = ChronicleT $ \c' -> catchError (m c') (flip runChronicleT c' . c)
+    {-# INLINE catchError #-}
+
+instance (Semigroup c, MonadReader r m) => MonadReader r (ChronicleT c m) where
+    ask = lift ask
+    {-# INLINE ask #-}
+    local f (ChronicleT m) = ChronicleT $ \c -> local f (m c)
+    {-# INLINE local #-}
+    reader = lift . reader
+    {-# INLINE 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
+    {-# INLINE get #-}
+    put = lift . put
+    {-# INLINE put #-}
+    state = lift . state
+    {-# INLINE state #-}
+
+instance (Semigroup c, MonadWriter w m) => MonadWriter w (ChronicleT c m) where
+    tell = lift . tell
+    {-# INLINE tell #-}
+    listen (ChronicleT m) = ChronicleT $ \c' -> do
+        (m', w) <- listen (m c')
+        return $ case m' of
+                     This  c   -> This c
+                     That    x -> That (x, w)
+                     These c x -> These c (x, w)
+    {-# INLINE listen #-}
+    pass (ChronicleT m) = ChronicleT $ \c' -> do
+        pass $ these (\c -> (This c, id))
+                     (\(x, f) -> (That x, f))
+                     (\c (x, f) -> (These c x, f)) `liftM` (m c')
+    {-# INLINE pass #-}
+    writer = lift . writer
+    {-# INLINE 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 $ \c -> (mfix (flip runChronicleT c . f . these (const bomb) id (flip const)))
+      where bomb = error "mfix (ChronicleT): inner compuation returned This value"
+    {-# INLINE mfix #-}
+
+-- | @'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 -> let ct = c <> c' in ct `seq` pure (These ct ())
+{-# INLINE dictate #-}
+
+-- | @'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
+{-# INLINE disclose #-}
+
+-- | @'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 -> let ct = c <> c' in ct `seq` pure (This ct)
+{-# INLINE confess #-}
+
+-- | @'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 $ \c ->
+    do cx <- runChronicleT m c
+       return $ case cx of
+                    This  a   -> That (Left a)
+                    That    x -> That (Right x)
+                    These a x -> These a (Right x)
+{-# INLINE memento #-}
+
+-- | @'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 $ \c ->
+    do cy <- runChronicleT m c
+       return $ case cy of
+                    This  _   -> That x
+                    That    y -> That y
+                    These _ y -> That y
+{-# INLINE absolve #-}
+
+
+-- | @'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 $ \c -> do
+    m' <- m c
+    return $ case m' of
+        This  x   -> This x
+        That    y -> That y
+        These x _ -> This x
+{-# INLINE condemn #-}
+
+
+-- | @'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 $ \c -> mapHere f `liftM` runChronicleT m c
+{-# INLINE retcon #-}