packages feed

changeset (empty) → 0.1.0.0

raw patch · 14 files changed

+1061/−0 lines, 14 filesdep +basedep +changesetdep +containers

Dependencies added: base, changeset, containers, falsify, mmorph, monoid-extras, mtl, tasty, tasty-hunit, transformers, witherable

Files

+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# Revision history for changeset++## 0.1.0.0 -- YYYY-mm-dd++* First version. Released on an unsuspecting world.
+ LICENSE view
@@ -0,0 +1,20 @@+Copyright (c) 2023 Manuel Bärenz++Permission is hereby granted, free of charge, to any person obtaining+a copy of this software and associated documentation files (the+"Software"), to deal in the Software without restriction, including+without limitation the rights to use, copy, modify, merge, publish,+distribute, sublicense, and/or sell copies of the Software, and to+permit persons to whom the Software is furnished to do so, subject to+the following conditions:++The above copyright notice and this permission notice shall be included+in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.+IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY+CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,+TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE+SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+ changeset.cabal view
@@ -0,0 +1,143 @@+cabal-version: 3.0+name: changeset+-- PVP summary:     +-+------- breaking API changes+--                  | | +----- non-breaking API additions+--                  | | | +--- code changes with no API change+version: 0.1.0.0+synopsis: Stateful monad transformer based on monoidal actions+description:+  A general state monad transformer with separate types for the state and the possible changes.+  It can be defined for any monoid action.+  The monoid represents "changes", "updates", "edits" or "diffs" on the state.+  The @changeset@ ecosystem has support for standard @containers@ and optics from @lens@+  by providing the packages @changeset-containers@ and @changeset-lens@.++license: MIT+license-file: LICENSE+author: Manuel Bärenz+maintainer: programming@manuelbaerenz.de+copyright: MIT+category: Control+build-type: Simple+extra-doc-files: CHANGELOG.md+tested-with:+  ghc ==8.6+  ghc ==8.8+  ghc ==8.10+  ghc ==9.0+  ghc ==9.2+  ghc ==9.4+  ghc ==9.6+  ghc ==9.8+  ghc ==9.10++source-repository head+  type: git+  location: https://github.com/turion/changeset++flag dev+  description: Enable warnings as errors. Active on ci.+  default: False+  manual: True++common opts+  ghc-options:+    -Wall++  if flag(dev)+    ghc-options:+      -Werror+  default-extensions:+    BangPatterns+    DeriveFunctor+    DeriveTraversable+    DerivingStrategies+    FlexibleContexts+    FlexibleInstances+    FunctionalDependencies+    GADTs+    GeneralizedNewtypeDeriving+    KindSignatures+    LambdaCase+    MultiParamTypeClasses+    NamedFieldPuns+    RankNTypes+    ScopedTypeVariables+    StandaloneDeriving+    TupleSections+    TypeOperators++library+  import: opts+  exposed-modules:+    Control.Monad.Changeset.Class+    Control.Monad.Trans.Changeset+    Data.Monoid.RightAction+    Data.Monoid.RightAction.Coproduct++  build-depends:+    base >=4.12 && <4.22,+    containers >=0.6 && <0.8,+    mmorph >=1.1 && <1.3,+    monoid-extras ^>=0.6,+    transformers >=0.5.6.2 && <0.7,+    witherable >=0.4 && <0.6,++  hs-source-dirs: src++  if impl(ghc >= 9.6)+    build-depends:+      mtl ^>=2.3.1++    hs-source-dirs: src-mtl23+  else+    build-depends:+      mtl ^>=2.2.2++    hs-source-dirs: src-mtl22++  default-language: Haskell2010+  other-modules:+    Control.Monad.Trans.Changeset.Orphan++test-suite changeset-test+  import: opts+  default-language: Haskell2010+  type: exitcode-stdio-1.0+  hs-source-dirs: test+  main-is: Main.hs+  build-depends:+    base,+    changeset,+    falsify ^>=0.2,+    monoid-extras,+    tasty ^>=1.4.2,+    tasty-hunit ^>=0.10.2,+    transformers,++test-suite changeset-examples+  import: opts+  default-language: Haskell2010+  type: exitcode-stdio-1.0+  hs-source-dirs: examples++  if impl(ghc >= 9.6)+    hs-source-dirs: examples-mtl23+  else+    hs-source-dirs: examples-mtl22++  main-is: Main.hs+  build-depends:+    base,+    changeset,+    falsify ^>=0.2,+    monoid-extras,+    mtl,+    tasty ^>=1.4.2,+    tasty-hunit ^>=0.10.2,+    transformers,+    witherable,++  other-modules:+    Control.Monad.Trans.Changeset.AccumExample+    Control.Monad.Trans.Changeset.Examples
+ examples-mtl22/Control/Monad/Trans/Changeset/AccumExample.hs view
@@ -0,0 +1,7 @@+module Control.Monad.Trans.Changeset.AccumExample where++-- tasty+import Test.Tasty (TestTree, testGroup)++tests :: TestTree+tests = testGroup "Accum" []
+ examples-mtl23/Control/Monad/Trans/Changeset/AccumExample.hs view
@@ -0,0 +1,46 @@+{-# OPTIONS_GHC -Wno-orphans #-}++module Control.Monad.Trans.Changeset.AccumExample where++-- base+import Data.Functor.Identity (Identity)+import Data.Tuple (swap)++-- transformers+import Control.Monad.Trans.Accum (runAccum)++-- mtl+import Control.Monad.Accum (MonadAccum (..))+import Control.Monad.Changeset.Class (MonadChangeset (changeset))++-- monoid-extras+import Data.Monoid.Action (Regular (Regular, getRegular))++-- changeset+import Control.Monad.Trans.Changeset++-- tasty+import Test.Tasty (TestTree)++-- tasty-hunit+import Test.Tasty.HUnit (testCase, (@?=))++-- | The 'AccumT' monad transformer is a special case of 'ChangesetT' when both state and change are the same type.+type RegularAccumT w = ChangesetT (Regular w) w++instance {-# OVERLAPPING #-} (Monoid w, Monad m) => MonadAccum w (RegularAccumT w m) where+  accum = changeset . (. getRegular)++exampleProgram :: (MonadAccum (Changes (ListChange Int)) m) => m (Changes (ListChange Int))+exampleProgram = do+  add $ singleChange (Cons 1)+  add $ singleChange (Cons 2)+  ns <- look+  add $ singleChange (Cons 3)+  pure ns++initialState :: Changes (ListChange Int)+initialState = singleChange $ Cons 0++tests :: TestTree+tests = testCase "Accum" $ runAccum exampleProgram initialState @?= swap (getChangeset (exampleProgram :: RegularAccumT (Changes (ListChange Int)) Identity (Changes (ListChange Int))) (Regular initialState))
+ examples/Control/Monad/Trans/Changeset/Examples.hs view
@@ -0,0 +1,111 @@+{-# OPTIONS_GHC -Wno-orphans #-}++module Control.Monad.Trans.Changeset.Examples where++-- base+import Control.Monad (guard)+import Data.Bifunctor (Bifunctor (first))+import Data.Functor (($>))+import Data.Functor.Identity (Identity)+import Data.Monoid (Dual (..), Endo (..), Last)+import Data.Tuple (swap)++-- monoid-extras+import Data.Monoid.Action++-- mtl+import Control.Monad.Reader (MonadReader (..))+import Control.Monad.State (MonadState (..), modify, runState)+import Control.Monad.Writer (MonadWriter (..), runWriter)++-- witherable+import Witherable (mapMaybe)++-- changeset+import Control.Monad.Changeset.Class (MonadChangeset (..))+import Control.Monad.Trans.Changeset++-- tasty+import Test.Tasty (TestTree, testGroup)++-- tasty-hunit+import Test.Tasty.HUnit (testCase, (@?=))++-- * 'ReaderT'++-- | 'ReaderT' is a special case of 'ChangesetT' when the changes are trivial.+type TrivialChangeReaderT r = ChangesetT r ()++instance {-# OVERLAPPING #-} (Monad m) => MonadReader r (TrivialChangeReaderT r m) where+  ask = current+  local = withCurrent++-- * 'WriterT'++-- | 'WriterT' is a special case of 'ChangesetT' when the current state is trivial.+type TrivialActionWriterT w = ChangesetT () w++instance Action w () where+  act _ _ = ()++instance {-# OVERLAPPING #-} (Monoid w, Monad m) => MonadWriter w (TrivialActionWriterT w m) where+  writer = ChangesetT . pure . pure . swap+  listen = ChangesetT . fmap (fmap (\(w, a) -> (w, (a, w)))) . getChangesetT+  pass = ChangesetT . fmap (fmap (\(w, (a, f)) -> (f w, a))) . getChangesetT++-- * 'StateT'++{- | 'StateT' is a special case of 'ChangesetT' when the changes are whole state values,+and only the last write matters.+-}+type LastWriteT s = ChangesetT s (Last s)++instance {-# OVERLAPPING #-} (Monad m) => MonadState s (LastWriteT s m) where+  state f = ChangesetT $ \s -> return $ first pure $ swap $ f s++-- * Another state monad++{- | Endomorphism state monad.++There is a further, not so much studied state monad by choosing any state type @s@ and the @Endo s@ monoid.+-}+type EndoStateT s = ChangesetT s (Dual (Endo s))++instance {-# OVERLAPPING #-} (Monad m) => MonadState s (EndoStateT s m) where+  state f = ChangesetT $ \s -> return (Dual $ Endo $ snd <$> f, fst $ f s)++type M = Changes (ListChange Int)++writerExample :: (MonadWriter M m) => m ((), M)+writerExample = listen $ pass $ do+  tell $ singleChange $ Cons 0+  tell $ singleChange $ Cons 23+  tell $ singleChange $ Cons 99+  tell $ singleChange Pop+  pure ((), mapMaybe $ \c -> guard (c /= Cons 23) $> c)++stateExample :: (MonadState Int m) => m Int+stateExample = do+  put 0+  put 1+  n <- get+  put 2+  put 3+  return n++tests :: TestTree+tests =+  testGroup+    "Examples"+    [ testCase "Writer" $ runWriter writerExample @?= swap (getChangeset (writerExample :: TrivialActionWriterT M Identity ((), M)) mempty)+    , testCase "State" $ runState stateExample 99 @?= runChangeset (stateExample :: LastWriteT Int Identity Int) 99+    , testGroup+        "EndoStateT"+        [ testCase "modify" $ execChangeset (modify (+ 1) >> modify (+ 1) :: EndoStateT Int Identity ()) 0 @?= execChangeset (modify (+ 2) :: EndoStateT Int Identity ()) 0+        , testCase "get & put" $+            let inc = do+                  n <- get+                  put $ n + 1+             in execChangeset (inc >> inc :: EndoStateT Int Identity ()) 0 @?= 2+        ]+    ]
+ examples/Main.hs view
@@ -0,0 +1,19 @@+module Main (main) where++-- tasty+import Test.Tasty++-- changeset-examples+import Control.Monad.Trans.Changeset.AccumExample as AccumExample+import Control.Monad.Trans.Changeset.Examples as Examples++-- type M = Changeset Int (Changes Count)++main :: IO ()+main =+  defaultMain $+    testGroup+      "examples"+      [ Examples.tests+      , AccumExample.tests+      ]
+ src-mtl22/Control/Monad/Trans/Changeset/Orphan.hs view
@@ -0,0 +1,4 @@+{- | This module only exists because mtl-2.2 lacks certain type classes which mtl-2.3 has,+but older GHCs don't work with mtl-2.3 for complicated reasons+-}+module Control.Monad.Trans.Changeset.Orphan where
+ src-mtl23/Control/Monad/Trans/Changeset/Orphan.hs view
@@ -0,0 +1,26 @@+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -Wno-orphans #-}++{- | Orphan instances for 'MonadAccum' and 'MonadSelect'.++Unfortunately @mtl-2.3@ is not very compatible with GHC < 9.6.+Therefore these instances are only defined for GHC >= 9.6.+-}+module Control.Monad.Trans.Changeset.Orphan where++-- transformers+import Control.Monad.Trans.Class (lift)++-- changeset+import Control.Monad.Trans.Changeset++-- mtl+import Control.Monad.Accum (MonadAccum (..))+import Control.Monad.Select (MonadSelect (..))+import Data.Monoid.RightAction++instance (MonadAccum w m, RightAction w' s, Monoid w') => MonadAccum w (ChangesetT s w' m) where+  accum = lift . accum++instance (MonadSelect r m, RightAction w s, Monoid w) => MonadSelect r (ChangesetT s w m) where+  select = lift . select
+ src/Control/Monad/Changeset/Class.hs view
@@ -0,0 +1,37 @@+{-# LANGUAGE UndecidableInstances #-}++-- | A type class generalising the API of 'Control.Monad.Trans.Changeset.ChangesetT'.+module Control.Monad.Changeset.Class where++-- transformers+import Control.Monad.Trans.Class (MonadTrans (..))++-- mmorph+import Control.Monad.Morph (MFunctor (..))++-- changeset+import Data.Monoid.RightAction (RightAction)++{- | Monads containing changeset state.++This usually implies that the 'Control.Monad.Trans.Changeset.ChangesetT' monad transformer is part of the monad transformer stack of @m.@+See its documentation for details.+-}+class (Monad m, Monoid w, RightAction w s) => MonadChangeset s w m | m -> s, m -> w where+  -- | Apply a changeset to the state.+  changeset ::+    -- | Receives the current state and has to output a value and a change.+    (s -> (a, w)) ->+    m a++  -- | Apply a change to the state.+  -- The 'Action' instance is used to mutate the state.+  change :: w -> m ()++  -- | Observe the current state.+  current :: m s++instance {-# OVERLAPPABLE #-} (Monad m, Monad (t m), MonadTrans t, MFunctor t, MonadChangeset s w m) => MonadChangeset s w (t m) where+  changeset = lift . changeset+  change = lift . change+  current = lift current
+ src/Control/Monad/Trans/Changeset.hs view
@@ -0,0 +1,440 @@+{-# LANGUAGE UndecidableInstances #-}++{- | A general state monad transformer with separate types for the state and the possible changes, updates, commits, or diffs.++A typical example is a large state type (e.g., a user entry in a database of a webshop)+which only allows small changes (e.g., adding or deleting a delivery address):++@+data User = User+  { userName :: Text+  , password :: Hash+  , ...+  , addresses :: Map Text Address+  , ...+  }+@++When we want to be able to /restrict/ to specific changes (e.g., only the addresses should be changed),+and we want to be able to /inspect/ the changes,+then 'ChangesetT' is a good choice.+In our example, a general function on addresses, or even on the whole user, cannot be inspected.+But if we restrict to only adding or deleting addresses,+we can define a custom datatype such as:++@+data ChangeAddress+  -- | Add an address under a given key+  = Add Text Address+  -- | Delete the address for the given key+  | Delete Text+@++Changes for such a type (or rather, for the monoid @'Changes' ChangeAddress@) can be inspected.++'ChangesetT' is a very general state monad transformer.+It has all the standard state monads from @transformers@ as special cases:+++--------------------------+---------------+-------------+---------------------------------------------++| Transformer special case | State type    | Monoid type | Intuition                                   |++==========================+===============+=============+=============================================++| @'WriterT' w@            | '()'          | @w@         | No possibility to observe the current state |++--------------------------+---------------+-------------+---------------------------------------------++| @'AccumT' w@             | @'Regular' w@ | @w@         | The state is the same type as the changes   |++--------------------------+---------------+-------------+---------------------------------------------++| @'StateT' s@             | @s@           | @First s@   | The change overwrites all previous changes  |++--------------------------+---------------+-------------+---------------------------------------------+++The @changeset@ ecosystem has support for standard @containers@ and optics from @lens@+by providing the packages [@changeset-containers@](https://hackage.haskell.org/package/changeset-containers) and [@changeset-lens@](https://hackage.haskell.org/package/changeset-lens).++Orphan instances for newer (2.3) @mtl@ classes such as 'Control.Monad.Accum.MonadAccum' and 'Control.Monad.Selet.MonadSelect' can be found in "Control.Monad.Trans.Changeset.Orphan".+These are only provided for GHC >= 9.6.+-}+module Control.Monad.Trans.Changeset where++-- base+import Control.Applicative (Alternative (..))+import Control.Monad (MonadPlus)+import Data.Bifunctor (Bifunctor (..))+import Data.Foldable (Foldable (..))+import Data.Function ((&))+import Data.Functor ((<&>))+import Data.Functor.Identity (Identity (runIdentity))+import Data.Tuple (swap)+import Prelude hiding (Foldable ())++-- containers+import Data.Sequence (Seq, fromList, (|>))++-- transformers+import Control.Monad.Trans.Class++-- mtl+import Control.Monad.Error.Class (MonadError (..))+import Control.Monad.Morph (MFunctor (..), MMonad (..))+import Control.Monad.RWS.Class (MonadRWS)+import Control.Monad.Reader.Class (MonadReader (..))+import Control.Monad.State.Class (MonadState (..))+import Control.Monad.Writer.Class (MonadWriter (..))++-- witherable+import Witherable (Filterable (mapMaybe), Witherable (wither))++-- changeset+import Control.Monad.Changeset.Class+import Data.Kind (Type)+import Data.Monoid (Last (..))+import Data.Monoid.RightAction (RightAction, actRight)++-- * The 'ChangesetT' monad transformer++{- | Hold a state of type @s@, which is allowed to be mutated by an action of a monoid @w.@++The state @s@ has the role of the current state.+An @a@ is computed while performing a side effect in @m@,+and these can depend on the current state.++The type @w@ encodes /changes/ (or updates, edits, commits, diffs, patches ...) to the state @s.@+This relation is captured by the 'RightAction' type class from @monoid-extras.@+It contains a method, @'act' :: w -> s -> s@,+which implements the semantics of @w@ as the type of updates to @s.@++The standard example is that of a big record where we only want to change a small portion:++@+data User = User+  { name :: Text+  , password :: Hash+  , ...+  , addresses :: Map Text Address+  , ...+  }+@++If all changes that our business logic should be able to perform are adding or deleting an address,+it would be cumbersome to work in a @'State' User@ monad, since we only want to modify a small portion.+Instead, we define a type of /changes/ to @User@:++@+data ChangeAddress+  -- | Add an address under a given key+  = Add Text Address+  -- | Delete the address for the given key+  | Delete Text++instance RightAction ChangeAddress User where+  act = ...+@++Now we can conveniently work in the monad @'ChangesetT' User [ChangeAddress] m.@+(Note the list type which gives us a free 'Monoid' instance.)+Here we can perform operations like @'change' [Add "home" homeAddress]@ or @'change' [Delete "work"]@ to modify the addresses,+'current' to view the current state (containing all changes so far),+or apply a more complex function like @'revise' $ const $ filter (/= Delete "default")@ which would remove all changes that attempt to delete the @"default"@ address.++As a further example, if @s@ represents some type of time stamps, then @w@ can be a type of durations:+Two timestamps cannot be added, but two durations can.+A computation in @'ChangesetT' s w@ could then have access to some simulated notion of "current time",+while being able to add symbolic "delays".++Another class of examples arises operation based or commutative Conflict-free Replicated Data Type (CRDT).+Then @s@ is the internal state (the "payload") of the CRDT, and @w@ is the update operation.+For example @s = Int@, and for @w@ we would define @data Count = Increment | Decrement.@++The 'Monad' and 'Applicative' classes are defined by performing the first action,+then 'act'ing with the monoid output onto the state, and then perform the second action with the updated state.+So for example, @'change' Increment >> 'current'@ is different from @'current' >>= (\n -> 'change' Increment >> return n)@:+If we apply @'flip' 'evalChangeset' 0@ to each,+the first one would return 1, while the second returns 0.++So, if at any point in a @do@ notation we want to inspect the current state,+we can assume that all previous changes have been applied.+In that sense, this monad behaves very much like any other state monad transformer.+-}+newtype ChangesetT s w m a = ChangesetT+  { getChangesetT :: s -> m (w, a)+  -- ^ Extract the changeset function without applying it to the state.+  }+  deriving (Functor)++-- ** Running a 'ChangesetT' action++-- | Extract the changes that would be applied.+getChangeT :: (Functor m) => ChangesetT s w m a -> s -> m w+getChangeT ChangesetT {getChangesetT} s = getChangesetT s <&> fst++-- | Run the action with an initial state and apply all resulting changes to it.+runChangesetT :: (Functor m, RightAction w s) => ChangesetT s w m a -> s -> m (a, s)+runChangesetT ChangesetT {getChangesetT} s = getChangesetT s <&> \(w, a) -> (a, actRight s w)++-- | Run the action with an initial state and extract only the value.+evalChangesetT :: (Functor m, RightAction w s) => ChangesetT s w m a -> s -> m a+evalChangesetT = fmap (fmap fst) . runChangesetT++-- | Run the action with an initial state and extract only the state.+execChangesetT :: (Functor m, RightAction w s) => ChangesetT s w m a -> s -> m s+execChangesetT = fmap (fmap snd) . runChangesetT++-- * 'ChangesetT' API with relaxed constraints++{- | See 'changeset'.++The @A@ suffix means that only 'Applicative' is required, not 'Monad'.+-}+changesetA :: (Applicative m) => (s -> (a, w)) -> ChangesetT s w m a+changesetA = ChangesetT . fmap (pure . swap)++{- | See 'change'.++The @A@ suffix means that only 'Applicative' is required, not 'Monad'.+-}+changeA :: (Applicative m) => w -> ChangesetT s w m ()+changeA w = ChangesetT $ const $ pure (w, ())++{- | See 'current'.++The @A@ suffix means that only 'Applicative' is required, not 'Monad'.+-}+currentA :: (Applicative m, Monoid w) => ChangesetT s w m s+currentA = ChangesetT $ \s -> pure (mempty, s)++instance (RightAction w s, Monoid w, Monad m) => MonadChangeset s w (ChangesetT s w m) where+  change = changeA+  current = currentA+  changeset = changesetA++-- | Like 'lift' from the 'MonadTrans' class, but with fewer constraints.+liftF :: (Functor m, Monoid w) => m a -> ChangesetT s w m a+liftF = ChangesetT . const . fmap (mempty,)++instance (RightAction w s, Monoid w) => MonadTrans (ChangesetT s w) where+  lift = liftF++-- ** Transforming 'ChangesetT' operations++{- | Change the action that would be applied.++The function in the second position of the tuple receives the initial state and the change that would be applied.+It has to output the action that will be applied instead.+-}+revise :: (Functor m) => ChangesetT s w m (a, s -> w -> w) -> ChangesetT s w m a+revise ChangesetT {getChangesetT} = ChangesetT $ \s -> getChangesetT s <&> \(w, (a, f)) -> (f s w, a)++-- | Adds the to-be-applied changes to the foreground value.+changelog :: (Functor m) => ChangesetT s w m a -> ChangesetT s w m (a, w)+changelog ChangesetT {getChangesetT} = ChangesetT $ fmap (\(w, a) -> (w, (a, w))) . getChangesetT++-- | Precomposes the current state with a function to  before computing the change.+withCurrent :: (s2 -> s1) -> ChangesetT s1 w m a -> ChangesetT s2 w m a+withCurrent f = ChangesetT . (. f) . getChangesetT++-- | Apply a function to the change.+mapChange :: (Functor m) => (w1 -> w2) -> ChangesetT s w1 m a -> ChangesetT s w2 m a+mapChange f = ChangesetT . fmap (fmap (first f)) . getChangesetT++-- ** Combining 'ChangesetT' operations++{- | Like '(<*>)' from 'Applicative', but ignore the change from the first action in the initial state for the second action.++This only needs an 'Applicative' constraint on @m@, not 'Monad'.+-}+(|*>) :: (Semigroup w, Applicative m) => ChangesetT s w m (a -> b) -> ChangesetT s w m a -> ChangesetT s w m b+ChangesetT mf |*> ChangesetT ma = ChangesetT $ \s -> (\(w1, f) (w2, a) -> (w1 <> w2, f a)) <$> mf s <*> ma s++-- | The @'Monad' m@ constraint is indeed necessary, since we need the log from the first action to change it to the state for the second action.+instance (Monoid w, RightAction w s, Monad m) => Applicative (ChangesetT s w m) where+  pure a = ChangesetT $ const $ pure (mempty, a)++  ChangesetT mf <*> ChangesetT ma = ChangesetT $ \s -> do+    (w1, f) <- mf s+    let !s' = actRight s w1+    (w2, a) <- ma s'+    pure (w1 <> w2, f a)++instance (RightAction w s, Monoid w, Monad m) => Monad (ChangesetT s w m) where+  ChangesetT ma >>= f = ChangesetT $ \s -> do+    (w1, a) <- ma s+    let !s' = actRight s w1+    (w2, b) <- getChangesetT (f a) s'+    return (w1 <> w2, b)++instance (Alternative m, Monoid w, RightAction w s, Monad m) => Alternative (ChangesetT s w m) where+  empty = liftF empty+  ChangesetT ma1 <|> ChangesetT ma2 = ChangesetT $ \s -> ma1 s <|> ma2 s++instance (Alternative m, Monoid w, RightAction w s, Monad m) => MonadPlus (ChangesetT s w m)++instance MFunctor (ChangesetT s w) where+  hoist = hoistF++-- | Like 'hoist' from the @mmorph@ package, but with no constraints.+hoistF :: (forall x. m x -> n x) -> ChangesetT s w m a -> ChangesetT s w n a+hoistF morph ma = ChangesetT $ morph . getChangesetT ma++instance (RightAction w s, Monoid w) => MMonad (ChangesetT s w) where+  embed f (ChangesetT g) = ChangesetT $ \s ->+    s+      & g+      & f+      & flip getChangesetT s+      <&> \(w1, (w2, b)) -> (w1 <> w2, b)++instance (MonadError e m, RightAction w s, Monoid w) => MonadError e (ChangesetT s w m) where+  throwError = lift . throwError+  catchError ma handler = ChangesetT $ \s -> getChangesetT ma s `catchError` (\e -> getChangesetT (handler e) s)++instance (MonadReader r m, RightAction w s, Monoid w) => MonadReader r (ChangesetT s w m) where+  ask = lift ask+  local f = hoist $ local f++instance (MonadRWS r w s m, RightAction w' s', Monoid w') => MonadRWS r w s (ChangesetT s' w' m)++instance (MonadState s m, RightAction w' s', Monoid w') => MonadState s (ChangesetT s' w' m) where+  state = lift . state++instance (MonadWriter w m, RightAction w' s, Monoid w') => MonadWriter w (ChangesetT s w' m) where+  writer = lift . writer+  listen = ChangesetT . fmap (fmap (\((w', a), w) -> (w', (a, w))) . listen) . getChangesetT+  pass = ChangesetT . fmap (pass . fmap (\(w', (a, f)) -> ((w', a), f))) . getChangesetT++-- * Pure changesets++{- | A pure changeset acts in the 'Identity' monad.+The only effects it has are inspecting the current state, and adding a change.++@'Changeset' s w a@ is isomorphic to @s -> (w, a).@+-}+type Changeset s w = ChangesetT s w Identity++-- | Like 'getChangesetT'.+getChangeset :: Changeset s w a -> s -> (w, a)+getChangeset swa s = runIdentity $ getChangesetT swa s++-- | Like 'getChangeT'.+getChange :: Changeset s w a -> s -> w+getChange swa s = runIdentity $ getChangeT swa s++-- | Like 'runChangesetT'.+runChangeset :: (RightAction w s) => Changeset s w a -> s -> (a, s)+runChangeset swa s = runIdentity $ runChangesetT swa s++-- | Like 'evalChangesetT'.+evalChangeset :: (RightAction w s) => Changeset s w a -> s -> a+evalChangeset swa s = runIdentity $ evalChangesetT swa s++-- | Like 'execChangesetT'.+execChangeset :: (RightAction w s) => Changeset s w a -> s -> s+execChangeset swa s = runIdentity $ execChangesetT swa s++-- * 'Changes': container for changes that don't have a 'Monoid' instance++{- | A collection of individual changes.++Often, we only want to define a type for single changes to a state.+In that case, 'Changes' is handy.+It serves as a container for changes that don't have a 'Monoid' or 'Semigroup' instance.+All changes are applied sequentially.++To inspect or edit 'Changes', see the type classes 'Functor', 'Foldable', 'Traversable', 'Filterable' and 'Witherable'.+-}+newtype Changes w = Changes {getChanges :: Seq w}+  deriving (Show, Read, Eq, Ord)+  deriving newtype (Semigroup, Monoid, Foldable, Functor)+  deriving (Traversable)++instance Filterable Changes where+  mapMaybe f = Changes . mapMaybe f . getChanges++instance Witherable Changes where+  wither f = fmap Changes . wither f . getChanges++-- | Create 'Changes' from a list of changes.+changes :: [w] -> Changes w+changes = Changes . fromList++{- | Append a single change.++When @'addChange' w cs@ acts on a state with 'actRight', @w@ will be applied last.+-}+addChange :: w -> Changes w -> Changes w+addChange w = Changes . (|> w) . getChanges++-- | Create a 'Changes' from a single change.+singleChange :: w -> Changes w+singleChange = Changes . pure++-- | Apply a single change.+changeSingle :: (MonadChangeset s (Changes w) m) => w -> m ()+changeSingle = change . singleChange++-- | Apply all changes sequentially+instance (RightAction w s) => RightAction (Changes w) s where+  actRight s Changes {getChanges} = foldl' actRight s getChanges++-- * Change examples++-- ** Changing lists++{- | A list can be changed by prepending an element, or removing one.++To change an element of a list, see the indexed changes from [@changeset-lens@](hackage.haskell.org/package/changeset-lens).+-}+data ListChange a+  = -- | Prepend an element+    Cons a+  | -- | Remove the first element (noop on an empty list)+    Pop+  deriving (Eq, Show)++instance RightAction (ListChange a) [a] where+  actRight as (Cons a) = a : as+  actRight as Pop = drop 1 as++-- ** Changing integers++-- | An integer can be incremented by 1.+data Count = Increment+  deriving (Eq, Show)++instance RightAction Count Int where+  actRight count Increment = count + 1++-- ** Changing 'Maybe's++-- | Change a 'Maybe' by either deleting the value or forcing it to be present.+newtype MaybeChange a = MaybeChange {getMaybeChange :: Last (Maybe a)}+  deriving newtype (Eq, Ord, Show, Read, Semigroup, Monoid)++instance RightAction (MaybeChange a) (Maybe a) where+  actRight aMaybe MaybeChange {getMaybeChange} = actRight aMaybe getMaybeChange++-- | Set the state to the given 'Maybe' value.+setMaybe :: Maybe a -> MaybeChange a+setMaybe = MaybeChange . Last . Just++-- | Set the state to 'Just'.+setJust :: a -> MaybeChange a+setJust = setMaybe . Just++-- | Set the state to 'Nothing'.+setNothing :: MaybeChange a+setNothing = setMaybe Nothing++-- ** Changing 'Functor's++-- | Change a 'Functor' structure by applying a change for every element through 'fmap'.+newtype FmapChange (f :: Type -> Type) w = FmapChange {getFmapChange :: w}+  deriving (Eq, Ord, Read, Show, Semigroup, Monoid, Functor)++instance (Functor f, RightAction w s) => RightAction (FmapChange f w) (f s) where+  actRight fs FmapChange {getFmapChange} = flip actRight getFmapChange <$> fs++-- *** Changing 'Maybe's as 'Functor's++-- | Apply changes only to 'Just' values.+type JustChange = FmapChange Maybe++-- | Apply changes only to 'Just' values.+justChange :: w -> JustChange w+justChange = FmapChange
+ src/Data/Monoid/RightAction.hs view
@@ -0,0 +1,62 @@+module Data.Monoid.RightAction where++-- base+import Data.Maybe (fromMaybe)+import Data.Monoid (Dual (..), Endo (..), Last (..))+import Data.Void (Void)++-- monoid-extras+import Data.Monoid.Action (Action (..), Regular (Regular))++{- | A [right action](https://en.wikipedia.org/wiki/Group_action#Right_group_action) of @m@ on @s@.++Imagine @s@ to be a type of states, and @m@ a type of changes to @s@.++Laws:++* When @m@ is a 'Semigroup': @s \`actRight\` m1 \`actRight\` m2 == s \`actRight\` (m1 <> m2)@+* When @m@ is a 'Monoid': @s \`actRight\` 'mempty' == s@++The default implementation is the trivial action which leaves @s@ unchanged.++See also 'Action' from @monoid-extras@, which is a /left/ action.+-}+class RightAction m s where+  actRight :: s -> m -> s+  actRight s _ = s++infixl 5 `actRight`++instance RightAction () s++instance RightAction m ()++instance RightAction Void s++instance RightAction (Last s) s where+  actRight s (Last ms) = fromMaybe s ms++instance (Action m s) => RightAction (Dual m) s where+  actRight s (Dual m) = act m s++instance (Semigroup m) => RightAction m (Regular m) where+  actRight (Regular m1) m2 = Regular $ m1 <> m2++instance (RightAction m s) => RightAction (Maybe m) s where+  actRight s = maybe s (actRight s)++{- | Endomorphism type with reverse 'Monoid' instance.++The standard 'Endo' type has a left action on @s@ since its composition is defined as @Endo f <> Endo g = Endo (f . g).@+The "Right Endomorphism" type, on the other hand, has a right action.+Intuitively, it behaves like the 'Data.Function.&' operator:++@+s & f & g == s \`'actRight'\` rEndo f <> rEndo g+@+-}+type REndo s = Dual (Endo s)++-- | Create an endomorphism monoid that has a right action on @s.@+rEndo :: (s -> s) -> REndo s+rEndo = Dual . Endo
+ src/Data/Monoid/RightAction/Coproduct.hs view
@@ -0,0 +1,57 @@+module Data.Monoid.RightAction.Coproduct where++-- base+import Data.Foldable (Foldable (foldl'), toList)+import Data.Typeable (Typeable)+import Prelude hiding (Foldable (..))++-- containers+import Data.Sequence (Seq)++-- changeset+import Data.Monoid.RightAction++{- | The coproduct of two monoids is a monoid that can contain values of either constituent.++This is useful if you have two different actions on the same state type,+and want to combine them.++Note: The multiplication of this monoid is formal, so the same semantic values may have differing representations.+Therefore it's not advised to inspect the contents of a coproduct.+You should usually want to use 'normaliseCoproduct'.+-}+newtype (:+:) m n = Coproduct {getCoproduct :: Seq (Either m n)}+  deriving (Typeable, Semigroup, Monoid)++{- | Construct a coproduct value from the left constituent monoid.++Semantically, this is a monoid homomorphism: @inL m1 <> inL m2@ acts the same as @inL (m1 <> m2).@+-}+inL :: m -> m :+: n+inL = Coproduct . pure . Left++{- | Construct a coproduct value from the right constituent monoid.++Semantically, this is a monoid homomorphism: @inR m1 <> inR m2@ acts the same as @inR (m1 <> m2).@+-}+inR :: n -> m :+: n+inR = Coproduct . pure . Right++{- | Brings a coproduct into a canonical form, which is an alternating list of 'Left's and 'Right's.++(The list may start with a 'Left' or a 'Right', or be empty.)+-}+normaliseCoproduct :: (Semigroup m, Semigroup n) => m :+: n -> [Either m n]+normaliseCoproduct = normaliseCoproduct' . toList . getCoproduct+  where+    normaliseCoproduct' (Left m1 : Left m2 : emns) = normaliseCoproduct' $ Left (m1 <> m2) : emns+    normaliseCoproduct' (Right n1 : Right n2 : emns) = normaliseCoproduct' $ Right (n1 <> n2) : emns+    normaliseCoproduct' [] = []+    normaliseCoproduct' (emn : emns) = emn : normaliseCoproduct' emns++-- | Coproducts are compared after normalising+instance (Eq m, Eq n, Semigroup m, Semigroup n) => Eq (m :+: n) where+  mns1 == mns2 = normaliseCoproduct mns1 == normaliseCoproduct mns2++instance (RightAction m s, RightAction n s) => RightAction (m :+: n) s where+  actRight s mns = foldl' (flip $ either (flip actRight) (flip actRight)) s (getCoproduct mns)
+ test/Main.hs view
@@ -0,0 +1,84 @@+module Main (main) where++-- base+import Control.Monad (replicateM_)+import Data.Function ((&))+import Prelude hiding (Foldable (..))++-- transformers+import Control.Monad.Trans.Reader (ReaderT (..), ask)++-- tasty+import Test.Tasty++-- tasty-hunit+import Test.Tasty.HUnit (testCase, (@?=))++-- changeset+import Control.Monad.Changeset.Class+import Control.Monad.Trans.Changeset+import Data.Monoid (Last (Last))+import Data.Monoid.RightAction (RightAction (..))+import Data.Monoid.RightAction.Coproduct (inL, (:+:))++type M = Changeset Int (Changes Count)++main :: IO ()+main =+  defaultMain $+    testGroup+      "changeset"+      [ testGroup+          "Changeset"+          [ testGroup+              "commutative monoids"+              [ testGroup+                  "Order of change and current matters"+                  [ testCase "change, current" $+                      evalChangeset (changeSingle Increment >> current) 0 @?= (1 :: Int)+                  , testCase "current, change" $+                      let action = flip evalChangeset 0 $ do+                            n <- current+                            changeSingle Increment+                            return n+                       in action @?= (0 :: Int)+                  ]+              , testGroup+                  "execChangeset"+                  [ testCase "pure doesn't change state" $ execChangeset (pure () :: M ()) 0 @?= 0+                  , testCase "change changes state" $ execChangeset (changeSingle Increment :: M ()) 0 @?= 1+                  ]+              ]+          , testGroup+              "noncommutative monoids"+              [ testGroup+                  "Changes"+                  [ testCase "change is monoid homomorphism" $ do+                      execChangeset (changeSingle (Cons True) >> changeSingle (Cons False)) [] @?= execChangeset (change (singleChange (Cons True) <> singleChange (Cons False))) ([] :: [Bool])+                      execChangeset (changeSingle (Cons True) >> changeSingle (Cons False)) [] @?= execChangeset (change (addChange (Cons False) (singleChange (Cons True)))) ([] :: [Bool])+                      execChangeset (changeSingle (Cons True) >> changeSingle (Cons False)) [] @?= execChangeset (change (changes [Cons True, Cons False])) ([] :: [Bool])+                      execChangeset (changeSingle (Cons True) >> changeSingle (Cons False)) [] @?= ([False, True] :: [Bool])+                  , testCase "execChangeset is monoid homomorphism" $+                      execChangeset (changeSingle (Cons True) >> changeSingle (Cons False)) [] @?= (([] :: [Bool]) & execChangeset (changeSingle (Cons True)) & execChangeset (changeSingle (Cons False)))+                  ]+              ]+          ]+      , testGroup+          "Changes"+          [ testCase "is lawful monoid action" $ do+              [] `actRight` singleChange (Cons True) `actRight` singleChange (Cons False) @?= ([] :: [Bool]) `actRight` singleChange (Cons True) <> singleChange (Cons False)+          ]+      , testGroup+          "MonadChangeset"+          [ testCase "ReaderT lifts changeset operations" $+              let action = flip execChangeset (0 :: Int) $ flip runReaderT (100 :: Int) $ do+                    env <- ask+                    replicateM_ env $ changeSingle Increment+               in action @?= 100+          ]+      , testGroup+          "Coproduct"+          [ testCase ":+: is monoid morphism" $+              (0 :: Int) `actRight` (inL (Last (Just 1)) <> inL (Last (Just 2)) :: Last Int :+: Last Int) @?= 0 `actRight` (inL (Last (Just (1 :: Int)) <> Last (Just 2)) :: Last Int :+: Last Int)+          ]+      ]