monad-chronicle-1.0.0.1/0000755000000000000000000000000007346545000013102 5ustar0000000000000000monad-chronicle-1.0.0.1/CHANGELOG.md0000755000000000000000000000004307346545000014713 0ustar0000000000000000# 1 Split out of `these` package. monad-chronicle-1.0.0.1/LICENSE0000644000000000000000000000300407346545000014104 0ustar0000000000000000Copyright (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-1.0.0.1/monad-chronicle.cabal0000644000000000000000000000353107346545000017132 0ustar0000000000000000cabal-version: >=1.10 name: monad-chronicle version: 1.0.0.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 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.3 || ==8.10.1 , GHCJS ==8.4 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.15 , mtl >=2.1.3 && <2.3 , transformers >=0.3.0.0 && <0.6 build-depends: these >=1 && <1.2 -- 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 monad-chronicle-1.0.0.1/src/Control/Monad/0000755000000000000000000000000007346545000016347 5ustar0000000000000000monad-chronicle-1.0.0.1/src/Control/Monad/Chronicle.hs0000644000000000000000000000130107346545000020604 0ustar0000000000000000{-# 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, ChronicleT (..), runChronicle) monad-chronicle-1.0.0.1/src/Control/Monad/Chronicle/0000755000000000000000000000000007346545000020255 5ustar0000000000000000monad-chronicle-1.0.0.1/src/Control/Monad/Chronicle/Class.hs0000644000000000000000000002277707346545000021675 0ustar0000000000000000{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE Trustworthy #-} {-# 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 monad-chronicle-1.0.0.1/src/Control/Monad/Trans/0000755000000000000000000000000007346545000017436 5ustar0000000000000000monad-chronicle-1.0.0.1/src/Control/Monad/Trans/Chronicle.hs0000644000000000000000000002016607346545000021705 0ustar0000000000000000{-# 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 = 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