{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE UndecidableInstances #-}
-- Later GHCs infer DerivingVia as not Safe
-- We just downgrade to Trustworthy and go fish
{-# OPTIONS_GHC -Wno-trustworthy-safe #-}

-- | Module: Control.Monad.Accum
-- Copyright: (C) Koz Ross 2022, Manuel Bärenz 2021
-- License: BSD-3-Clause (see the LICENSE file)
-- Maintainer: koz.ross@retro-freedom.nz
-- Stability: Experimental
-- Portability: GHC only
--
-- [Computation type:] Accumulation (either append-only state, or writer with
-- the ability to read all previous input).
--
-- [Binding strategy:] Binding a function to a monadic value monoidally
-- accumulates the subcomputations (that is, using '<>').
--
-- [Useful for:] Logging, patch-style tracking.
--
-- [Zero and plus:] None.
--
-- [Example type:] @'Control.Monad.Trans.Accum.Accum' w a@
--
-- = A note on commutativity
--
-- Some effects are /commutative/: it doesn't matter which you resolve first, as
-- all possible orderings of commutative effects are isomorphic. Consider, for
-- example, the reader and state effects, as exemplified by 'ReaderT' and
-- 'StrictState.StateT' respectively. If we have
-- @'ReaderT' r ('StrictState.State' s) a@, this is
-- effectively @r -> 'StrictState.State' s a ~ r -> s -> (a, s)@; if we instead have
-- @'StrictState.StateT' s ('Control.Monad.Trans.Reader.Reader' r) a@, this is effectively
-- @s -> 'Control.Monad.Trans.Reader' r (a, s) ~ s -> r -> (a, s)@. Since we
-- can always reorder function arguments (for example, using 'flip', as in
-- this case) without changing the result, these are
-- isomorphic, showing that reader and state are /commutative/, or, more
-- precisely, /commute with each other/.
--
-- However, this isn't generally the case. Consider instead the error and state
-- effects, as exemplified by 'MaybeT' and 'StrictState.StateT' respectively.
-- If we have @'MaybeT' ('Control.Monad.Trans.State.Strict.State' s) a@, this
-- is effectively @'State' s ('Maybe' a) ~ s -> ('Maybe' a, s)@: put simply,
-- the error can occur only in the /result/, but
-- not the state, which always \'survives\'. On the other hand, if we have
-- @'StrictState.StateT' s 'Maybe' a@, this is instead @s -> 'Maybe' (a, s)@: here,
-- if we error, we lose /both/ the state and the result! Thus, error and state effects
-- do /not/ commute with each other.
--
-- As the MTL is capability-based, we support any ordering of non-commutative
-- effects on an equal footing. Indeed, if you wish to use
-- 'Control.Monad.State.Class.MonadState', for
-- example, whether your final monadic stack ends up being @'MaybeT'
-- ('Control.Monad.Trans.State.Strict.State' s)
-- a@, @'StrictState.StateT' s 'Maybe' a@, or anything else, you will be able to write your
-- desired code without having to consider such differences. However, the way we
-- /implement/ these capabilities for any given transformer (or rather, any
-- given transformed stack) /is/ affected by this ordering unless the effects in
-- question are commutative.
--
-- We note in this module which effects the accumulation effect does and doesn't
-- commute with; we also note on implementations with non-commutative
-- transformers what the outcome will be. Note that, depending on how the
-- \'inner monad\' is structured, this may be more complex than we note: we
-- describe only what impact the \'outer effect\' has, not what else might be in
-- the stack.
--
-- = Commutativity of accumulation
--
-- The accumulation effect commutes with the identity effect ('IdentityT'),
-- reader, writer or state effects ('ReaderT', 'StrictWriter.WriterT', 'StrictState.StateT' and any
-- combination, including 'StrictRWS.RWST' for example) and with itself. It does /not/
-- commute with anything else.
module Control.Monad.Accum
  ( -- * Type class
    MonadAccum (..),

    -- * Lifting helper type
    LiftingAccum (..),

    -- * Other functions
    looks,
  )
where

import Control.Monad.Trans.Accum (AccumT)
import qualified Control.Monad.Trans.Accum as Accum
import Control.Monad.Trans.Class (MonadTrans (lift))
import Control.Monad.Trans.Cont (ContT)
import Control.Monad.Trans.Except (ExceptT)
import Control.Monad.Trans.Identity (IdentityT)
import Control.Monad.Trans.Maybe (MaybeT)
import qualified Control.Monad.Trans.RWS.CPS as CPSRWS
import qualified Control.Monad.Trans.RWS.Lazy as LazyRWS
import qualified Control.Monad.Trans.RWS.Strict as StrictRWS
import Control.Monad.Trans.Reader (ReaderT)
import Control.Monad.Trans.Select (SelectT)
import qualified Control.Monad.Trans.State.Lazy as LazyState
import qualified Control.Monad.Trans.State.Strict as StrictState
import qualified Control.Monad.Trans.Writer.CPS as CPSWriter
import qualified Control.Monad.Trans.Writer.Lazy as LazyWriter
import qualified Control.Monad.Trans.Writer.Strict as StrictWriter
import Data.Functor (($>))
import Data.Functor.Identity (Identity)
import Data.Kind (Type)

-- | The capability to accumulate. This can be seen in one of two ways:
--
-- * A 'Control.Monad.State.Class.MonadState' which can only append (using '<>'); or
-- * A 'Control.Monad.Writer.Class.MonadWriter' (limited to
-- 'Control.Monad.Writer.Class.tell') with the ability to view the result of all previous
-- 'Control.Monad.Writer.Class.tell's.
--
-- = Laws
--
-- 'accum' should obey the following:
--
-- 1. @'accum' ('const' (x, 'mempty'))@ @=@ @'pure' x@
-- 2. @'accum' f '*>' 'accum' g@ @=@
-- @'accum' '$' \acc -> let (_, v) = f acc
--                          (res, w) = g (acc '<>' v) in (res, v '<>' w)@
--
-- If you choose to define 'look' and 'add' instead, their definitions must obey
-- the following:
--
-- 1. @'look' '*>' 'look'@ @=@ @'look'@
-- 2. @'add' 'mempty'@ @=@ @'pure' ()@
-- 3. @'add' x '*>' 'add' y@ @=@ @'add' (x '<>' y)@
-- 4. @'add' x '*>' 'look'@ @=@ @'look' '>>=' \w -> 'add' x '$>' w '<>' x@
--
-- If you want to define both, the relationship between them is as follows.
-- These are also the default definitions.
--
-- 1. @'look'@ @=@ @'accum' '$' \acc -> (acc, mempty)@
-- 2. @'add' x@ @=@ @'accum' '$' \acc -> ('()', x)@
-- 3. @'accum' f@ @=@ @'look' >>= \acc -> let (res, v) = f acc in 'add' v '$>' res@
--
-- @since 2.3
class (Monoid w, Monad m) => MonadAccum w m | m -> w where
  -- | Retrieve the accumulated result so far.
  look :: m w
  look = (w -> (w, w)) -> m w
forall a. (w -> (a, w)) -> m a
forall w (m :: * -> *) a. MonadAccum w m => (w -> (a, w)) -> m a
accum (,w
forall a. Monoid a => a
mempty)

  -- | Append a value to the result.
  add :: w -> m ()
  add w
x = (w -> ((), w)) -> m ()
forall a. (w -> (a, w)) -> m a
forall w (m :: * -> *) a. MonadAccum w m => (w -> (a, w)) -> m a
accum ((w -> ((), w)) -> m ()) -> (w -> ((), w)) -> m ()
forall a b. (a -> b) -> a -> b
$ ((), w) -> w -> ((), w)
forall a b. a -> b -> a
const ((), w
x)

  -- | Embed a simple accumulation action into the monad.
  accum :: (w -> (a, w)) -> m a
  accum w -> (a, w)
f = m w
forall w (m :: * -> *). MonadAccum w m => m w
look m w -> (w -> m a) -> m a
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \w
acc -> let (a
res, w
v) = w -> (a, w)
f w
acc in w -> m ()
forall w (m :: * -> *). MonadAccum w m => w -> m ()
add w
v m () -> a -> m a
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> a
res

  {-# MINIMAL accum | look, add #-}

-- | @since 2.3
instance (Monoid w) => MonadAccum w (AccumT w Identity) where
  look :: AccumT w Identity w
look = AccumT w Identity w
forall w (m :: * -> *). (Monoid w, Monad m) => AccumT w m w
Accum.look
  add :: w -> AccumT w Identity ()
add = w -> AccumT w Identity ()
forall (m :: * -> *) w. Monad m => w -> AccumT w m ()
Accum.add
  accum :: forall a. (w -> (a, w)) -> AccumT w Identity a
accum = (w -> (a, w)) -> AccumT w Identity a
forall (m :: * -> *) w a. Monad m => (w -> (a, w)) -> AccumT w m a
Accum.accum

-- | The accumulated value \'survives\' an error: even if the
-- computation fails to deliver a result, we still have an accumulated value.
--
-- @since 2.3
deriving via
  (LiftingAccum MaybeT m)
  instance
    (MonadAccum w m) =>
    MonadAccum w (MaybeT m)

-- | The continuation can see, and interact with, the accumulated value.
--
-- @since 2.3
deriving via
  (LiftingAccum (ContT r) m)
  instance
    (MonadAccum w m) =>
    MonadAccum w (ContT r m)

-- | The accumulated value \'survives\' an exception: even if the computation
-- fails to deliver a result, we still have an accumulated value.
--
-- @since 2.3
deriving via
  (LiftingAccum (ExceptT e) m)
  instance
    (MonadAccum w m) =>
    MonadAccum w (ExceptT e m)

-- | @since 2.3
deriving via
  (LiftingAccum IdentityT m)
  instance
    (MonadAccum w m) =>
    MonadAccum w (IdentityT m)

-- | @since 2.3
deriving via
  (LiftingAccum (CPSRWS.RWST r w s) m)
  instance
    (MonadAccum w' m) =>
    MonadAccum w' (CPSRWS.RWST r w s m)

-- | @since 2.3
deriving via
  (LiftingAccum (LazyRWS.RWST r w s) m)
  instance
    (MonadAccum w' m, Monoid w) =>
    MonadAccum w' (LazyRWS.RWST r w s m)

-- | @since 2.3
deriving via
  (LiftingAccum (StrictRWS.RWST r w s) m)
  instance
    (MonadAccum w' m, Monoid w) =>
    MonadAccum w' (StrictRWS.RWST r w s m)

-- | @since 2.3
deriving via
  (LiftingAccum (ReaderT r) m)
  instance
    (MonadAccum w m) =>
    MonadAccum w (ReaderT r m)

-- | The \'ranking\' function gains the ability to accumulate @w@s each time it
-- is called. The final result will include the entire log of all such calls.
--
-- @since 2.3
deriving via
  (LiftingAccum (SelectT r) m)
  instance
    (MonadAccum w m) =>
    MonadAccum w (SelectT r m)

-- | @since 2.3
deriving via
  (LiftingAccum (LazyState.StateT s) m)
  instance
    (MonadAccum w m) =>
    MonadAccum w (LazyState.StateT s m)

-- | @since 2.3
deriving via
  (LiftingAccum (StrictState.StateT s) m)
  instance
    (MonadAccum w m) =>
    MonadAccum w (StrictState.StateT s m)

-- | @since 2.3
deriving via
  (LiftingAccum (CPSWriter.WriterT w) m)
  instance
    (MonadAccum w' m) =>
    MonadAccum w' (CPSWriter.WriterT w m)

-- | @since 2.3
deriving via
  (LiftingAccum (LazyWriter.WriterT w) m)
  instance
    (MonadAccum w' m, Monoid w) =>
    MonadAccum w' (LazyWriter.WriterT w m)

-- | @since 2.3
deriving via
  (LiftingAccum (StrictWriter.WriterT w) m)
  instance
    (MonadAccum w' m, Monoid w) =>
    MonadAccum w' (StrictWriter.WriterT w m)

-- | A helper type to decrease boilerplate when defining new transformer
-- instances of 'MonadAccum'.
--
-- Most of the instances in this module are derived using this method; for
-- example, our instance of 'ExceptT' is derived as follows:
--
-- > deriving via (LiftingAccum (ExceptT e) m) instance (MonadAccum w m) =>
-- >  MonadAccum w (ExceptT e m)
--
-- @since 2.3
newtype LiftingAccum (t :: (Type -> Type) -> Type -> Type) (m :: Type -> Type) (a :: Type)
  = LiftingAccum (t m a)
  deriving
    ( -- | @since 2.3
      (forall a b. (a -> b) -> LiftingAccum t m a -> LiftingAccum t m b)
-> (forall a b. a -> LiftingAccum t m b -> LiftingAccum t m a)
-> Functor (LiftingAccum t m)
forall a b. a -> LiftingAccum t m b -> LiftingAccum t m a
forall a b. (a -> b) -> LiftingAccum t m a -> LiftingAccum t m b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a b.
Functor (t m) =>
a -> LiftingAccum t m b -> LiftingAccum t m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a b.
Functor (t m) =>
(a -> b) -> LiftingAccum t m a -> LiftingAccum t m b
$cfmap :: forall (t :: (* -> *) -> * -> *) (m :: * -> *) a b.
Functor (t m) =>
(a -> b) -> LiftingAccum t m a -> LiftingAccum t m b
fmap :: forall a b. (a -> b) -> LiftingAccum t m a -> LiftingAccum t m b
$c<$ :: forall (t :: (* -> *) -> * -> *) (m :: * -> *) a b.
Functor (t m) =>
a -> LiftingAccum t m b -> LiftingAccum t m a
<$ :: forall a b. a -> LiftingAccum t m b -> LiftingAccum t m a
Functor,
      -- | @since 2.3
      Functor (LiftingAccum t m)
Functor (LiftingAccum t m) =>
(forall a. a -> LiftingAccum t m a)
-> (forall a b.
    LiftingAccum t m (a -> b)
    -> LiftingAccum t m a -> LiftingAccum t m b)
-> (forall a b c.
    (a -> b -> c)
    -> LiftingAccum t m a -> LiftingAccum t m b -> LiftingAccum t m c)
-> (forall a b.
    LiftingAccum t m a -> LiftingAccum t m b -> LiftingAccum t m b)
-> (forall a b.
    LiftingAccum t m a -> LiftingAccum t m b -> LiftingAccum t m a)
-> Applicative (LiftingAccum t m)
forall a. a -> LiftingAccum t m a
forall a b.
LiftingAccum t m a -> LiftingAccum t m b -> LiftingAccum t m a
forall a b.
LiftingAccum t m a -> LiftingAccum t m b -> LiftingAccum t m b
forall a b.
LiftingAccum t m (a -> b)
-> LiftingAccum t m a -> LiftingAccum t m b
forall a b c.
(a -> b -> c)
-> LiftingAccum t m a -> LiftingAccum t m b -> LiftingAccum t m c
forall (f :: * -> *).
Functor f =>
(forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
forall (t :: (* -> *) -> * -> *) (m :: * -> *).
Applicative (t m) =>
Functor (LiftingAccum t m)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
Applicative (t m) =>
a -> LiftingAccum t m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a b.
Applicative (t m) =>
LiftingAccum t m a -> LiftingAccum t m b -> LiftingAccum t m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a b.
Applicative (t m) =>
LiftingAccum t m a -> LiftingAccum t m b -> LiftingAccum t m b
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a b.
Applicative (t m) =>
LiftingAccum t m (a -> b)
-> LiftingAccum t m a -> LiftingAccum t m b
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a b c.
Applicative (t m) =>
(a -> b -> c)
-> LiftingAccum t m a -> LiftingAccum t m b -> LiftingAccum t m c
$cpure :: forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
Applicative (t m) =>
a -> LiftingAccum t m a
pure :: forall a. a -> LiftingAccum t m a
$c<*> :: forall (t :: (* -> *) -> * -> *) (m :: * -> *) a b.
Applicative (t m) =>
LiftingAccum t m (a -> b)
-> LiftingAccum t m a -> LiftingAccum t m b
<*> :: forall a b.
LiftingAccum t m (a -> b)
-> LiftingAccum t m a -> LiftingAccum t m b
$cliftA2 :: forall (t :: (* -> *) -> * -> *) (m :: * -> *) a b c.
Applicative (t m) =>
(a -> b -> c)
-> LiftingAccum t m a -> LiftingAccum t m b -> LiftingAccum t m c
liftA2 :: forall a b c.
(a -> b -> c)
-> LiftingAccum t m a -> LiftingAccum t m b -> LiftingAccum t m c
$c*> :: forall (t :: (* -> *) -> * -> *) (m :: * -> *) a b.
Applicative (t m) =>
LiftingAccum t m a -> LiftingAccum t m b -> LiftingAccum t m b
*> :: forall a b.
LiftingAccum t m a -> LiftingAccum t m b -> LiftingAccum t m b
$c<* :: forall (t :: (* -> *) -> * -> *) (m :: * -> *) a b.
Applicative (t m) =>
LiftingAccum t m a -> LiftingAccum t m b -> LiftingAccum t m a
<* :: forall a b.
LiftingAccum t m a -> LiftingAccum t m b -> LiftingAccum t m a
Applicative,
      -- | @since 2.3
      Applicative (LiftingAccum t m)
Applicative (LiftingAccum t m) =>
(forall a b.
 LiftingAccum t m a
 -> (a -> LiftingAccum t m b) -> LiftingAccum t m b)
-> (forall a b.
    LiftingAccum t m a -> LiftingAccum t m b -> LiftingAccum t m b)
-> (forall a. a -> LiftingAccum t m a)
-> Monad (LiftingAccum t m)
forall a. a -> LiftingAccum t m a
forall a b.
LiftingAccum t m a -> LiftingAccum t m b -> LiftingAccum t m b
forall a b.
LiftingAccum t m a
-> (a -> LiftingAccum t m b) -> LiftingAccum t m b
forall (m :: * -> *).
Applicative m =>
(forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
forall (t :: (* -> *) -> * -> *) (m :: * -> *).
Monad (t m) =>
Applicative (LiftingAccum t m)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
Monad (t m) =>
a -> LiftingAccum t m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a b.
Monad (t m) =>
LiftingAccum t m a -> LiftingAccum t m b -> LiftingAccum t m b
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a b.
Monad (t m) =>
LiftingAccum t m a
-> (a -> LiftingAccum t m b) -> LiftingAccum t m b
$c>>= :: forall (t :: (* -> *) -> * -> *) (m :: * -> *) a b.
Monad (t m) =>
LiftingAccum t m a
-> (a -> LiftingAccum t m b) -> LiftingAccum t m b
>>= :: forall a b.
LiftingAccum t m a
-> (a -> LiftingAccum t m b) -> LiftingAccum t m b
$c>> :: forall (t :: (* -> *) -> * -> *) (m :: * -> *) a b.
Monad (t m) =>
LiftingAccum t m a -> LiftingAccum t m b -> LiftingAccum t m b
>> :: forall a b.
LiftingAccum t m a -> LiftingAccum t m b -> LiftingAccum t m b
$creturn :: forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
Monad (t m) =>
a -> LiftingAccum t m a
return :: forall a. a -> LiftingAccum t m a
Monad
    )
    via (t m)

-- | @since 2.3
instance (MonadTrans t, Monad (t m), MonadAccum w m) => MonadAccum w (LiftingAccum t m) where
  look :: LiftingAccum t m w
look = t m w -> LiftingAccum t m w
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
t m a -> LiftingAccum t m a
LiftingAccum (t m w -> LiftingAccum t m w)
-> (m w -> t m w) -> m w -> LiftingAccum t m w
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m w -> t m w
forall (m :: * -> *) a. Monad m => m a -> t m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m w -> LiftingAccum t m w) -> m w -> LiftingAccum t m w
forall a b. (a -> b) -> a -> b
$ m w
forall w (m :: * -> *). MonadAccum w m => m w
look
  add :: w -> LiftingAccum t m ()
add w
x = t m () -> LiftingAccum t m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
t m a -> LiftingAccum t m a
LiftingAccum (t m () -> LiftingAccum t m ())
-> (m () -> t m ()) -> m () -> LiftingAccum t m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m () -> t m ()
forall (m :: * -> *) a. Monad m => m a -> t m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> LiftingAccum t m ()) -> m () -> LiftingAccum t m ()
forall a b. (a -> b) -> a -> b
$ w -> m ()
forall w (m :: * -> *). MonadAccum w m => w -> m ()
add w
x
  accum :: forall a. (w -> (a, w)) -> LiftingAccum t m a
accum w -> (a, w)
f = t m a -> LiftingAccum t m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
t m a -> LiftingAccum t m a
LiftingAccum (t m a -> LiftingAccum t m a)
-> (m a -> t m a) -> m a -> LiftingAccum t m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m a -> t m a
forall (m :: * -> *) a. Monad m => m a -> t m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m a -> LiftingAccum t m a) -> m a -> LiftingAccum t m a
forall a b. (a -> b) -> a -> b
$ (w -> (a, w)) -> m a
forall a. (w -> (a, w)) -> m a
forall w (m :: * -> *) a. MonadAccum w m => (w -> (a, w)) -> m a
accum w -> (a, w)
f

-- | Retrieve a function of the accumulated value.
--
-- @since 2.3
looks ::
  forall (a :: Type) (m :: Type -> Type) (w :: Type).
  (MonadAccum w m) =>
  (w -> a) ->
  m a
looks :: forall a (m :: * -> *) w. MonadAccum w m => (w -> a) -> m a
looks w -> a
f = w -> a
f (w -> a) -> m w -> m a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m w
forall w (m :: * -> *). MonadAccum w m => m w
look