monad-chronicle (empty) → 1

raw patch · 6 files changed

+557/−0 lines, 6 filesdep +basedep +data-default-classdep +mtl

Dependencies added: base, data-default-class, mtl, semigroupoids, semigroups, these, transformers, transformers-compat

Files

CHANGELOG.md +3/−0
LICENSE +30/−0
monad-chronicle.cabal +64/−0
src/Control/Monad/Chronicle.hs +17/−0
src/Control/Monad/Chronicle/Class.hs +223/−0
src/Control/Monad/Trans/Chronicle.hs +220/−0

+ CHANGELOG.md view

@@ -0,0 +1,3 @@+# 1++Split out of `these` package.

+ LICENSE view

@@ -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.

+ monad-chronicle.cabal view

@@ -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

+ src/Control/Monad/Chronicle.hs view

@@ -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 (..))

+ src/Control/Monad/Chronicle/Class.hs view

@@ -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+++

+ src/Control/Monad/Trans/Chronicle.hs view

@@ -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+