changeset 0.1.0.3 → 0.1.1

raw patch · 7 files changed

+812/−24 lines, 7 filesdep +indexed-traversabledep +profunctorsdep +semialigndep ~monoid-extrasPVP ok

version bump matches the API change (PVP)

Dependencies added: indexed-traversable, profunctors, semialign, these

Dependency ranges changed: monoid-extras

API changes (from Hackage documentation)

Files

• CHANGELOG.md +6/−2
• changeset.cabal +12/−2
• src/Control/Monad/Changeset/Class.hs +47/−2
• src/Control/Monad/Trans/Changeset.hs +262/−15
• src/Data/Monoid/RightAction.hs +75/−1
• src/Data/Monoid/RightAction/Generic.hs +259/−0
• test/Main.hs +151/−2

@@ -1,5 +1,9 @@ # Revision history for changeset -## 0.1.0.0 -- YYYY-mm-dd+## 0.1.1 -* First version. Released on an unsuspecting world.+* Add support for generic deriving+* Add `RightTorsor` class+* Add support for `FunctorWithIndex`, `Semialign`, and `Filterable`+* Default methods for `MonadChangeset`+* Document `MonadChangeset` laws

@@ -1,6 +1,6 @@ cabal-version: 2.4 name: changeset-version: 0.1.0.3+version: 0.1.1 synopsis: Stateful monad transformer based on monoidal actions description:   A general state monad transformer with separate types for the state and the possible changes.@@ -47,6 +47,7 @@   default-extensions:     BangPatterns     DeriveFunctor+    DeriveGeneric     DeriveTraversable     DerivingStrategies     FlexibleContexts@@ -58,10 +59,13 @@     LambdaCase     MultiParamTypeClasses     NamedFieldPuns+    QuantifiedConstraints     RankNTypes     ScopedTypeVariables     StandaloneDeriving+    StrictData     TupleSections+    TypeApplications     TypeOperators  library@@ -71,12 +75,17 @@     Control.Monad.Trans.Changeset     Data.Monoid.RightAction     Data.Monoid.RightAction.Coproduct+    Data.Monoid.RightAction.Generic    build-depends:     base >=4.12 && <4.22,     containers >=0.6 && <0.8,+    indexed-traversable ^>=0.1,     mmorph >=1.1 && <1.3,-    monoid-extras ^>=0.6,+    monoid-extras ^>=0.7,+    profunctors >=5.5 && <=5.7,+    semialign >=1.1 && <1.4,+    these >=1.1 && <1.3,     transformers >=0.5.6.2 && <0.7,     witherable >=0.4 && <0.6, @@ -106,6 +115,7 @@   build-depends:     base,     changeset,+    containers >=0.6 && <0.8,     monoid-extras,     tasty >=1.4.2 && <1.6,     tasty-hunit ^>=0.10.2,

@@ -10,12 +10,42 @@ import Control.Monad.Morph (MFunctor (..))  -- changeset-import Data.Monoid.RightAction (RightAction)+import Data.Monoid.RightAction (RightAction, RightTorsor (differenceRight))  {- | 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.++Two laws for these methods boil down to the requirement that 'change' and 'current' are special cases of 'changeset':++@+  change w = changeset $ const ((), w)+  current = changeset (, mempty)+@++The central law ensures that future  states are affected by the past changes through right action:++@+forall MonadChangeset s w m+       f :: s -> (a, w)+       g :: a -> s -> (b, w) .+changeset f >>= (changeset . g)+  =+changeset $ \s -> let (a, w) = f s in g a $ s `actRight` w+@++This law has several easier to grasp corollaries:+@+change w >> current = do+  s <- current+  change w+  return $ s 'actRight' w++change w1 >> change w2 = change (w1 <> w2)++current s1 >> current s2 = current s2+@ -} class (Monad m, Monoid w, RightAction w s) => MonadChangeset s w m | m -> s, m -> w where   -- | Apply a changeset to the state.@@ -25,13 +55,28 @@     m a    -- | Apply a change to the state.-  -- The 'Action' instance is used to mutate the state.+  --+  --   The 'Action' instance is used to mutate the state.+  --+  --   This is a special case of 'changeset' where the current state is disregarded.   change :: w -> m ()+  change w = changeset $ const ((), w)    -- | Observe the current state.+  --+  --   This is a special case of 'changeset' where the state is not changed.   current :: m s+  current = changeset (,mempty)  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++{- | Calculate the difference from the current state to the explicitly given state, and return it.++With a lawful @'RightTorsor' w s@ instance, it can be expected that after then applying the difference, the state is the explicitly given one:+After @diff s >>= change@, the current state is @s@.+-}+diff :: (RightTorsor w s, MonadChangeset s w m) => s -> m w+diff s = (`differenceRight` s) <$> current

@@ -56,12 +56,19 @@ -- base import Control.Applicative (Alternative (..)) import Control.Monad (MonadPlus)+import Data.Bifoldable (Bifoldable (..)) import Data.Bifunctor (Bifunctor (..))+import Data.Bitraversable (Bitraversable (..))+import Data.Coerce (coerce) import Data.Foldable (Foldable (..)) import Data.Function ((&)) import Data.Functor ((<&>))+import Data.Functor.Classes (Eq1, Ord1, Read1, Show1) import Data.Functor.Identity (Identity (runIdentity))+import Data.Kind (Type)+import Data.Monoid (Last (..)) import Data.Tuple (swap)+import GHC.Generics (Generic) import Prelude hiding (Foldable ())  -- containers@@ -79,13 +86,22 @@ import Control.Monad.Writer.Class (MonadWriter (..))  -- witherable-import Witherable (Filterable (mapMaybe), Witherable (wither))+import Witherable (Filterable (..), FilterableWithIndex (..), Witherable (wither), (<&?>)) +-- these+import Data.These (these)++-- semialign+import Data.Semialign (Align (..), Semialign (..), salign)++-- indexed-traversable+import Data.Foldable.WithIndex (FoldableWithIndex (..))+import Data.Functor.WithIndex (FunctorWithIndex (..))+import Data.Traversable.WithIndex (TraversableWithIndex (..))+ -- changeset import Control.Monad.Changeset.Class-import Data.Kind (Type)-import Data.Monoid (Last (..))-import Data.Monoid.RightAction (RightAction, actRight)+import Data.Monoid.RightAction (RightAction (..), RightTorsor (..))  -- * The 'ChangesetT' monad transformer @@ -221,7 +237,10 @@ 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.+{- | Adds the to-be-applied changes to the foreground value.++This is similar to 'Control.Monad.Trans.Writer.listen'.+-} 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 @@ -331,18 +350,32 @@  {- | 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.+Often, we only want to define a type for a single change to a state, like:++@+data Increment = Increment+instance RightAction Increment Int where+  actRight n Increment = n + 1+@++While the definition is succinct, such a type is not automatically a 'Monoid' or 'Semigroup'.+But these are often needed, e.g. for making 'Changeset' a monad.++In that situation, 'Changes' is handy. It serves as a container for changes that don't have a 'Monoid' or 'Semigroup' instance. All changes are applied sequentially. +Mathematically, this is the free monoid over the type of single changes.+ 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)+  deriving stock (Show, Read, Eq, Ord, Traversable, Generic)+  deriving newtype (Semigroup, Monoid, Foldable, Functor, Applicative, Alternative, Monad, FunctorWithIndex Int, FoldableWithIndex Int) +instance TraversableWithIndex Int Changes where+  itraverse f = fmap Changes . itraverse f . getChanges+ instance Filterable Changes where   mapMaybe f = Changes . mapMaybe f . getChanges @@ -358,7 +391,7 @@ 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+addChange w = coerce (|> w)  -- | Create a 'Changes' from a single change. singleChange :: w -> Changes w@@ -372,6 +405,10 @@ instance (RightAction w s) => RightAction (Changes w) s where   actRight s Changes {getChanges} = foldl' actRight s getChanges +-- Marked as overlappable so that generically defined instances with differenceRightGenericChanges are selected+instance {-# OVERLAPPABLE #-} (RightTorsor w s) => RightTorsor (Changes w) s where+  differenceRight = (singleChange .) . differenceRight+ -- * Change examples  -- ** Changing lists@@ -385,7 +422,7 @@     Cons a   | -- | Remove the first element (noop on an empty list)     Pop-  deriving (Eq, Show)+  deriving stock (Eq, Ord, Show, Read, Generic, Functor, Foldable, Traversable)  instance RightAction (ListChange a) [a] where   actRight as (Cons a) = a : as@@ -395,7 +432,7 @@  -- | An integer can be incremented by 1. data Count = Increment-  deriving (Eq, Show)+  deriving stock (Eq, Ord, Show, Read, Generic)  instance RightAction Count Int where   actRight count Increment = count + 1@@ -404,11 +441,17 @@  -- | 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)+  deriving newtype (Eq, Ord, Semigroup, Monoid)+  deriving stock (Show, Read, Generic, Functor, Foldable, Traversable)  instance RightAction (MaybeChange a) (Maybe a) where   actRight aMaybe MaybeChange {getMaybeChange} = actRight aMaybe getMaybeChange +instance (Eq a) => RightTorsor (MaybeChange a) (Maybe a) where+  differenceRight Nothing Nothing = mempty+  differenceRight (Just aOrig) (Just aChanged) = if aOrig == aChanged then mempty else setJust aChanged+  differenceRight _ ma = setMaybe ma+ -- | Set the state to the given 'Maybe' value. setMaybe :: Maybe a -> MaybeChange a setMaybe = MaybeChange . Last . Just@@ -425,7 +468,8 @@  -- | 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)+  deriving newtype (Eq, Ord, Semigroup, Monoid)+  deriving stock (Read, Show, Functor, Foldable, Traversable, Generic)  instance (Functor f, RightAction w s) => RightAction (FmapChange f w) (f s) where   actRight fs FmapChange {getFmapChange} = flip actRight getFmapChange <$> fs@@ -438,3 +482,206 @@ -- | Apply changes only to 'Just' values. justChange :: w -> JustChange w justChange = FmapChange++-- ** Changing 'Bifunctor's++-- | Change a 'Bifunctor' such as 'Either' or a tuple by changing each type separately.+data BimapChange w1 w2 = BimapChange+  { firstChange :: w1+  -- ^ The change to apply to the first type, e.g. a 'Left', or the first element of a tuple+  , secondChange :: w2+  -- ^ The change to apply to the second type, e.g. a 'Right', or the second element of a tuple+  }+  deriving stock (Eq, Ord, Show, Read, Functor, Foldable, Traversable, Generic)++instance Bifunctor BimapChange where+  bimap f g BimapChange {firstChange, secondChange} =+    BimapChange+      { firstChange = f firstChange+      , secondChange = g secondChange+      }++instance Bifoldable BimapChange where+  bifoldMap f g BimapChange {firstChange, secondChange} = f firstChange <> g secondChange++instance Bitraversable BimapChange where+  bitraverse f g BimapChange {firstChange, secondChange} = BimapChange <$> f firstChange <*> g secondChange++instance (Bifunctor f, RightAction w1 s1, RightAction w2 s2) => RightAction (BimapChange w1 w2) (f s1 s2) where+  fs1s2 `actRight` BimapChange {firstChange, secondChange} = bimap (`actRight` firstChange) (`actRight` secondChange) fs1s2++-- ** Changing 'Filterable's++{- | Change all positions in a 'Filterable' in the same way.++For a 'Filterable' @f s@, the change type must have a 'RightAction' instance on @'Maybe' s@, not @s@,+where 'Nothing' denotes deletion of the position.++(If you don't want to delete positions, you are probably looking for 'FmapChange' or 'JustChange' instead.)+-}+newtype FilterableChange w = FilterableChange {getFilterableChange :: w}+  deriving newtype (Eq, Ord)+  deriving stock (Show, Read, Foldable, Functor, Traversable)++instance (Filterable f, RightAction w (Maybe s)) => RightAction (FilterableChange w) (f s) where+  actRight fs FilterableChange {getFilterableChange} = fs <&?> flip actRight getFilterableChange . Just++{- | Change or delete a position in a 'Filterable'.++This type in itself is not a 'RightAction',+but it is a building block for 'FilterableChange', which in turn is a 'RightAction' for a 'Filterable'.+-}+data FilterablePositionChange w+  = -- | Delete the value at this position+    FilterablePositionDelete+  | -- | Change the value at this position by acting with @w@ on it+    FilterablePositionChange w+  deriving stock (Eq, Ord, Read, Show, Functor, Foldable, Traversable, Generic)++instance (Semigroup w) => Semigroup (FilterablePositionChange w) where+  _ <> FilterablePositionDelete = FilterablePositionDelete+  FilterablePositionDelete <> _ = FilterablePositionDelete+  FilterablePositionChange w1 <> FilterablePositionChange w2 = FilterablePositionChange $ w1 <> w2++instance (Monoid w) => Monoid (FilterablePositionChange w) where+  mempty = FilterablePositionChange mempty++-- | For every position in a 'Filterable', change it according to its value, using 'mapMaybe'.+newtype FilterableChanges s w = FilterableChanges {getFilterableChanges :: s -> FilterablePositionChange w}+  deriving newtype (Semigroup, Monoid)+  deriving stock (Functor, Generic)++{- | Depending on the value at a position, change it or delete it.++@'Just' w@ applies the change @w@, while 'Nothing' deletes it.+-}+changeMaybe :: (s -> Maybe w) -> FilterableChanges s w+changeMaybe = FilterableChanges . fmap (maybe FilterablePositionDelete FilterablePositionChange)++instance (Filterable f, RightAction w s) => RightAction (FilterableChanges s w) (f s) where+  actRight fs FilterableChanges {getFilterableChanges} =+    fs <&?> \s -> case getFilterableChanges s of+      FilterablePositionDelete -> Nothing+      FilterablePositionChange w -> Just $ s `actRight` w++-- | For every position in a 'FilterableWithIndex', change it according to its value, using 'imapMaybe'.+newtype FilterableWithIndexChanges i s w = FilterableWithIndexChanges {getFilterableWithIndexChanges :: i -> s -> FilterablePositionChange w}+  deriving newtype (Semigroup, Monoid)+  deriving stock (Functor, Generic)++instance FunctorWithIndex i (FilterableWithIndexChanges i s) where+  imap f = FilterableWithIndexChanges . (\c i s -> f i <$> c i s) . getFilterableWithIndexChanges++instance (FilterableWithIndex i f, RightAction w s) => RightAction (FilterableWithIndexChanges i s w) (f s) where+  actRight fs FilterableWithIndexChanges {getFilterableWithIndexChanges} = flip imapMaybe fs $ \i s -> case getFilterableWithIndexChanges i s of+    FilterablePositionDelete -> Nothing+    FilterablePositionChange w -> Just $ s `actRight` w++-- ** Changing 'Filterable' 'Semialign's++{- | Change, set, or delete a position in a 'Filterable' that is also an instance of 'Semialign'.++This type is not a 'RightAction',+but it is the building block for 'AlignChanges', which is a 'RightAction' on a 'Filterable' 'Semialign'.+-}+data AlignPositionChange w s+  = -- | Delete the value at this position+    DeleteAlignPosition+  | -- | Change the value at this position (if it exists) by applying @w@+    ChangeAlignPosition w+  | -- | Set the value at this position, possibly creating it if it doesn't yet exist+    SetAlignPosition s+  deriving stock (Eq, Ord, Read, Show, Functor, Foldable, Traversable, Generic)++instance Bifoldable AlignPositionChange where+  bifoldMap _ _ DeleteAlignPosition = mempty+  bifoldMap f _ (ChangeAlignPosition w) = f w+  bifoldMap _ f (SetAlignPosition s) = f s++instance Bifunctor AlignPositionChange where+  bimap _ _ DeleteAlignPosition = DeleteAlignPosition+  bimap f _ (ChangeAlignPosition w) = ChangeAlignPosition $ f w+  bimap _ f (SetAlignPosition s) = SetAlignPosition $ f s++instance Bitraversable AlignPositionChange where+  bitraverse _ _ DeleteAlignPosition = pure DeleteAlignPosition+  bitraverse f _ (ChangeAlignPosition w) = ChangeAlignPosition <$> f w+  bitraverse _ f (SetAlignPosition s) = SetAlignPosition <$> f s++instance (Semigroup w, RightAction w s) => Semigroup (AlignPositionChange w s) where+  _ <> DeleteAlignPosition = DeleteAlignPosition+  _ <> set@(SetAlignPosition _) = set+  DeleteAlignPosition <> ChangeAlignPosition _ = DeleteAlignPosition+  ChangeAlignPosition s1 <> ChangeAlignPosition s2 = ChangeAlignPosition $ s1 <> s2+  SetAlignPosition s <> ChangeAlignPosition w = SetAlignPosition $ s `actRight` w++instance (Monoid w, RightAction w s) => Monoid (AlignPositionChange w s) where+  mempty = ChangeAlignPosition mempty++{- | Change, set, or delete elements in a 'Filterable' that implements 'Semialign'.++Containers implementing 'Filterable' and 'Semialign' are fundamentally those that can be diffed easily.+Therefore, they have a general purpose 'RightTorsor' implementation.++Note that for the more special 'Zip' class, a simpler instance without a custom change type already exists.+-}+newtype AlignChanges (f :: Type -> Type) w s = AlignChanges {getAlignChanges :: f (AlignPositionChange w s)}+  deriving stock (Functor, Foldable, Traversable, Generic)++instance (Functor f) => Bifunctor (AlignChanges f) where+  bimap f g = AlignChanges . fmap (bimap f g) . getAlignChanges++instance (FunctorWithIndex i f) => FunctorWithIndex i (AlignChanges f w) where+  imap f = AlignChanges . imap (fmap . f) . getAlignChanges++instance (Foldable f) => Bifoldable (AlignChanges f) where+  bifoldMap f g AlignChanges {getAlignChanges} = foldMap (bifoldMap f g) getAlignChanges++instance (FoldableWithIndex i f) => FoldableWithIndex i (AlignChanges f w) where+  ifoldMap f = ifoldMap (foldMap . f) . getAlignChanges++instance (Traversable f) => Bitraversable (AlignChanges f) where+  bitraverse f g = fmap AlignChanges . traverse (bitraverse f g) . getAlignChanges++instance (TraversableWithIndex i f) => TraversableWithIndex i (AlignChanges f w) where+  itraverse f = fmap AlignChanges . itraverse (traverse . f) . getAlignChanges++-- The quantified constraints here are only needed for GHC <= 9.4, feel free to remove when support for these is dropped+deriving instance (Show1 f, (forall a. (Show a) => Show (f a)), Show w, Show s) => Show (AlignChanges f w s)++deriving instance (Read1 f, (forall a. (Read a) => Read (f a)), Read w, Read s) => Read (AlignChanges f w s)++deriving instance (Eq1 f, (forall a. (Eq a) => Eq (f a)), Eq w, Eq s) => Eq (AlignChanges f w s)++-- Also the Eq (AlignChanges f w s) superclass is only needed for GHC <= 9.4+deriving instance (Eq (AlignChanges f w s), Ord1 f, (forall b. (Ord b) => Ord (f b)), Ord w, Ord s) => Ord (AlignChanges f w s)++instance (Semialign f, Semigroup w, RightAction w s) => Semigroup (AlignChanges f w s) where+  AlignChanges ac1 <> AlignChanges ac2 = AlignChanges $ salign ac1 ac2++instance (Semigroup w, RightAction w s, Align f) => Monoid (AlignChanges f w s) where+  mempty = AlignChanges nil++instance (Semialign f, Filterable f, RightAction w s) => RightAction (AlignChanges f w s) (f s) where+  actRight fs AlignChanges {getAlignChanges} = catMaybes $ alignWith (these Just maybeCreateNew changeExisting) fs getAlignChanges+    where+      changeExisting sOrig = \case+        (SetAlignPosition sNew) -> Just sNew+        ChangeAlignPosition w -> Just $ sOrig `actRight` w+        DeleteAlignPosition -> Nothing+      maybeCreateNew = \case+        (SetAlignPosition s) -> Just s+        _ -> Nothing++instance (Semialign f, RightTorsor w s) => RightTorsor (AlignChanges f w s) (f s) where+  differenceRight = ((AlignChanges .) .) $ alignWith $ these (const DeleteAlignPosition) SetAlignPosition $ (ChangeAlignPosition .) . differenceRight++-- ** Changing 'FunctorWithIndex'++-- | Change a 'FunctorWithIndex' structure by applying the change to every element through 'imap'.+newtype ImapChange i w = ImapChange {getImapChange :: i -> w}+  deriving newtype (Semigroup, Monoid, Functor)+  deriving stock (Generic)++instance (RightAction w s, FunctorWithIndex i f) => RightAction (ImapChange i w) (f s) where+  actRight fs ImapChange {getImapChange} = imap (flip actRight . getImapChange) fs

@@ -1,13 +1,21 @@+{-# LANGUAGE UndecidableInstances #-}+ module Data.Monoid.RightAction where  -- base import Data.Maybe (fromMaybe)-import Data.Monoid (Dual (..), Endo (..), Last (..))+import Data.Monoid (Dual (..), Endo (..), Last (..), Product (..), Sum (..)) import Data.Void (Void)+import Prelude hiding (zipWith)  -- monoid-extras import Data.Monoid.Action (Action (..), Regular (Regular)) +-- semialign+import Data.Zip (Zip (..))++-- * Right action+ {- | 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@.@@ -33,9 +41,21 @@  instance RightAction Void s +instance (RightAction w1 s1, RightAction w2 s2) => RightAction (w1, w2) (s1, s2) where+  actRight (s1, s2) (w1, w2) = (s1 `actRight` w1, s2 `actRight` w2)++instance (RightAction w1 s1, RightAction w2 s2) => RightAction (w1, w2) (Either s1 s2)+ instance RightAction (Last s) s where   actRight s (Last ms) = fromMaybe s ms +{- | A change that sets the given value.++This can be applied to any type @s@.+-}+set :: s -> Last s+set = Last . Just+ instance (Action m s) => RightAction (Dual m) s where   actRight s (Dual m) = act m s @@ -45,6 +65,15 @@ instance (RightAction m s) => RightAction (Maybe m) s where   actRight s = maybe s (actRight s) +instance (Semigroup w, RightAction w s, Zip f) => RightAction (f w) (f s) where+  actRight = zipWith actRight++instance {-# OVERLAPPING #-} (Num a) => RightAction (Sum a) (Sum a) where+  actRight = (+)++instance {-# OVERLAPPING #-} (Num a) => RightAction (Product a) (Product a) where+  actRight = (*)+ {- | 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).@@@ -60,3 +89,48 @@ -- | Create an endomorphism monoid that has a right action on @s.@ rEndo :: (s -> s) -> REndo s rEndo = Dual . Endo++{- | Find the action that changed a state to another.+In other words, @m@ is a general purpose "diff" type for @s@.++The operation is an inverse to 'actRight'.++Laws:++@+s `differenceRight` (s `actRight` w) = w+sOrig `actRight` (sOrig `differenceRight` sActed) = sActed+@+When @m@ is a 'Monoid':+@+s `differenceRight` s = mempty+@++In group theory, this concept is called a [torsor](https://en.wikipedia.org/wiki/Principal_homogeneous_space).+See also [monoid-extras' @Torsor@](https://hackage-content.haskell.org/package/monoid-extras/docs/Data-Monoid-Action.html#t:Torsor) for the same concept,+but for left actions.+-}+class RightTorsor m s where+  differenceRight ::+    -- | The original state+    s ->+    -- | The changed, new state+    s ->+    m++instance RightTorsor () s where+  differenceRight _ _ = ()++-- | When the new state is equal to the original, produce the empty change, otherwise just 'set' to the new state.+instance (Eq s) => RightTorsor (Last s) s where+  differenceRight sOrig sActed = Last $ if sOrig == sActed then Nothing else Just sActed++-- | Calculate the diff per position of the container.+instance (RightTorsor w s, Zip f) => RightTorsor (f w) (f s) where+  differenceRight = zipWith differenceRight++instance {-# OVERLAPPING #-} (Num a) => RightTorsor (Sum a) (Sum a) where+  differenceRight = flip (-)++instance {-# OVERLAPPING #-} (Fractional a) => RightTorsor (Product a) (Product a) where+  differenceRight (Product aOld) (Product aNew) = Product $ aNew / aOld

@@ -0,0 +1,259 @@+module Data.Monoid.RightAction.Generic where++-- base+import Control.Monad (guard)+import GHC.Generics (Generic (..), K1 (..), M1 (..), Rec1 (..), (:*:) (..), (:+:) (..))+import Prelude hiding (zipWith)++-- changeset+import Control.Monad.Trans.Changeset (Changes, singleChange)+import Data.Monoid.RightAction++{- | A class to define generic instances of 'RightAction'. You will rarely need it directly.++To derive 'RightAction' for your custom datatype generically, see 'actRightGeneric'.+-}+class GRightAction w s where+  gActRight :: s -> w a -> s++instance (RightAction w s) => GRightAction (K1 i w) s where+  gActRight s (K1 w) = actRight s w++instance (GRightAction f s) => GRightAction (M1 i c f) s where+  gActRight s (M1 f) = gActRight s f++instance (GRightAction f1 s, GRightAction f2 s) => GRightAction (f1 :+: f2) s where+  gActRight s = \case+    L1 f -> gActRight s f+    R1 f -> gActRight s f++instance (GRightAction f1 s, GRightAction f2 s) => GRightAction (f1 :*: f2) s where+  gActRight s (f1 :*: f2) = s `gActRight` f1 `gActRight` f2++instance (GRightAction f s) => GRightAction (Rec1 f) s where+  gActRight s (Rec1 f) = gActRight s f++{- | Derive a 'RightAction' instance generically.++If you have a definition of a datatype that contains fields with a 'RightAction' instance,+you can create an instance for the whole datatype with just two lines of boiler plate+by setting 'actRight' to this function:++@+data IntAction+  = IntActionCounts Count (Changes Count)+  | IntActionLast (Last Int)+  | IntActionRec IntAction IntAction+  deriving stock (Generic)++instance RightAction IntAction Int where+  actRight = actRightGeneric+@++Note: This is not implemented as a default method in 'RightAction', since the default already is the trivial action.+That's usually the desired behaviour as unrelated fields in the datatype are not required to implement an instance.++Note: Since the acting type is not the last parameter in the 'RightAction' type class,+it seems to be impossible to derive an instance with deriving via or 'GHC.Generics.Generically'.+If you know a way around this, please open an issue at https://github.com/turion/changeset/issues/new.+-}+actRightGeneric :: (Generic m, GRightAction (Rep m) s) => s -> m -> s+actRightGeneric s m = gActRight s $ from m++{- | Similar to 'GRightAction', but for situations where both the change type and the state type should have a generic instance.++See 'actRightGGeneric' to define generic instances.+-}+class GGRightAction w s where+  ggActRight :: s a -> w a -> s a++instance (RightAction w s) => GGRightAction (K1 i w) (K1 i' s) where+  ggActRight (K1 s) (K1 w) = K1 $ actRight s w++instance {-# OVERLAPPABLE #-} (GGRightAction w s) => GGRightAction (M1 c i w) s where+  ggActRight s (M1 w) = ggActRight s w++instance {-# OVERLAPPABLE #-} (GGRightAction w s) => GGRightAction w (M1 c i s) where+  ggActRight (M1 s) w = M1 $ ggActRight s w++instance (GGRightAction w s) => GGRightAction (M1 c i w) (M1 c' i' s) where+  ggActRight (M1 s) (M1 w) = M1 $ ggActRight s w++instance (GGRightAction wL sL, GGRightAction wR sR) => GGRightAction (wL :+: wR) (sL :+: sR) where+  ggActRight = \case+    s@(L1 sL) -> \case+      L1 wL -> L1 $ ggActRight sL wL+      R1 _ -> s+    s@(R1 sR) -> \case+      L1 _ -> s+      R1 wR -> R1 $ ggActRight sR wR++instance (GGRightAction wL sL, GGRightAction wR sR) => GGRightAction (wL :+: wR) (sL :*: sR) where+  ggActRight (sL :*: sR) = \case+    L1 wL -> ggActRight sL wL :*: sR+    R1 wR -> sL :*: ggActRight sR wR++instance (GGRightAction wL sL, GGRightAction wR sR) => GGRightAction (wL :*: wR) (sL :*: sR) where+  ggActRight (sL :*: sR) (wL :*: wR) = ggActRight sL wL :*: ggActRight sR wR++instance (GGRightAction w s) => GGRightAction (Rec1 w) (Rec1 s) where+  ggActRight (Rec1 s) (Rec1 w) = Rec1 $ ggActRight s w++{- | Derive a 'RightAction' instance generically over the structure of both change and state type.++You can create 'RightAction' instances with just two lines of boiler plate by setting 'actRight' to this function.++There are several situations where this is useful:++1. Wrapping both change and state in @newtype@s:++    @+    newtype Bar = Bar Int+      deriving stock (Generic, Eq, Show)++    newtype BarChange = BarChange Count+      deriving stock (Generic)++    instance RightAction BarChange Bar where+      actRight = actRightGGeneric+    @++2. When the state is a product type, create a sum type where every constructor acts on one field:++    @+    data Foo = Foo Int Int [()]+      deriving stock (Generic, Eq, Show)++    data FooChange = FooChangeInt Count | FooChangeInt2 Count | FooChangeList (ListChange ())+      deriving stock (Generic)++    instance RightAction FooChange Foo where+      actRight = actRightGGeneric+    @++    The order matters, and the number of fields and constructors must match.++3. When the state is a product type, create a product type where every field of the change type acts on one field of the state type.++    @+    data Foo = Foo Int Int [()]+      deriving stock (Generic, Eq, Show)++    data FooChange2 = FooChange2 Count (Maybe Count) (ListChange ())+      deriving stock (Generic)++    instance RightAction FooChange2 Foo where+      actRight = actRightGGeneric+    @+    The order matters, and the number of fields must match.+-}+actRightGGeneric :: (Generic w, Generic s, GGRightAction (Rep w) (Rep s)) => s -> w -> s+actRightGGeneric s w = to $ ggActRight (from s) (from w)++{- | A class to define generic instances of 'RightTorsor' for product change types. You will rarely need it directly.++To derive 'RightTorsor' for your custom datatype generically, see 'differenceRightGGeneric'.+-}+class GGRightTorsor w s where+  ggDifferenceRight :: s a -> s a -> w a++instance (RightTorsor w s) => GGRightTorsor (K1 i w) (K1 i' s) where+  ggDifferenceRight (K1 sOld) (K1 sNew) = K1 $ differenceRight sOld sNew++instance (GGRightTorsor f s) => GGRightTorsor (M1 i c f) (M1 i' c' s) where+  ggDifferenceRight (M1 sOld) (M1 sNew) = M1 $ ggDifferenceRight sOld sNew++instance {-# OVERLAPPABLE #-} (GGRightTorsor f s) => GGRightTorsor (M1 i c f) s where+  ggDifferenceRight sOld sNew = M1 $ ggDifferenceRight sOld sNew++instance {-# OVERLAPPABLE #-} (GGRightTorsor f s) => GGRightTorsor f (M1 i c s) where+  ggDifferenceRight (M1 sOld) (M1 sNew) = ggDifferenceRight sOld sNew++instance (GGRightTorsor fL sL, GGRightTorsor fR sR) => GGRightTorsor (fL :*: fR) (sL :*: sR) where+  ggDifferenceRight (sLOld :*: sROld) (sLNew :*: sRNew) = ggDifferenceRight sLOld sLNew :*: ggDifferenceRight sROld sRNew++instance (GGRightTorsor f s) => GGRightTorsor (Rec1 f) (Rec1 s) where+  ggDifferenceRight (Rec1 sOld) (Rec1 sNew) = Rec1 $ ggDifferenceRight sOld sNew++{- | Derive a 'RightTorsor' instance generically for product change types.++If you have a definition of a datatype that contains fields with a 'RightTorsor' instance,+you can create an instance for the whole datatype with just two lines of boiler plate+by setting 'differenceRight' to this function:++@+data Torsor = Torsor (Sum Integer) (Product Rational)+  deriving stock (Generic)++data TorsorChange2 = TorsorChange2 (Sum Integer) (Product Rational)+  deriving stock (Generic)++instance RightAction TorsorChange2 Torsor where+  actRight = actRightGGeneric++instance RightTorsor TorsorChange2 Torsor where+  differenceRight = differenceRightGGeneric+@++In many cases where this is sensible, the instance can be derived this way.+Whenever it typechecks, it will be the inverse to the automatically derived instance from 'actRightGGeneric'.+-}+differenceRightGGeneric :: (Generic w, Generic s, GGRightTorsor (Rep w) (Rep s)) => s -> s -> w+differenceRightGGeneric sOld sNew = to $ ggDifferenceRight (from sOld) (from sNew)++{- | A class to define generic instances of 'RightTorsor' for sum change types. You will rarely need it directly.++To derive 'RightTorsor' for your custom datatype generically, see 'differenceRightGenericChanges'.+-}+class GCRightTorsor w s where+  gcDifferenceRight :: s a -> s a -> Changes (w a)++instance (RightTorsor w s) => GCRightTorsor (K1 i w) (K1 i' s) where+  gcDifferenceRight (K1 sOld) (K1 sNew) = singleChange $ K1 $ differenceRight sOld sNew++instance (GCRightTorsor f s) => GCRightTorsor (M1 i c f) (M1 i' c' s) where+  gcDifferenceRight (M1 sOld) (M1 sNew) = M1 <$> gcDifferenceRight sOld sNew++instance {-# OVERLAPPABLE #-} (GCRightTorsor f s) => GCRightTorsor (M1 i c f) s where+  gcDifferenceRight sOld sNew = M1 <$> gcDifferenceRight sOld sNew++instance {-# OVERLAPPABLE #-} (GCRightTorsor f s) => GCRightTorsor f (M1 i c s) where+  gcDifferenceRight (M1 sOld) (M1 sNew) = gcDifferenceRight sOld sNew++instance (GCRightTorsor fL sL, GCRightTorsor fR sR, forall a. Eq (sR a), forall a. Eq (sL a)) => GCRightTorsor (fL :+: fR) (sL :*: sR) where+  gcDifferenceRight (sLOld :*: sROld) (sLNew :*: sRNew) =+    (guard (sLOld /= sLNew) >> (L1 <$> gcDifferenceRight sLOld sLNew))+      <> (guard (sROld /= sRNew) >> (R1 <$> gcDifferenceRight sROld sRNew))++instance (GCRightTorsor f s) => GCRightTorsor (Rec1 f) (Rec1 s) where+  gcDifferenceRight (Rec1 sOld) (Rec1 sNew) = Rec1 <$> gcDifferenceRight sOld sNew++{- | Derive a 'RightTorsor' instance generically for sum change types.++If you have a definition of a datatype that contains fields with a 'RightTorsor' instance,+you can create an instance for the whole datatype with just two lines of boiler plate+by setting 'differenceRight' to this function:++@+data Torsor = Torsor (Sum Integer) (Product Rational)+  deriving stock (Generic, Eq, Show)++data TorsorChange = TorsorChangeSum (Sum Integer) | TorsorChangeProduct (Product Rational)+  deriving stock (Generic, Eq, Show)++instance RightAction TorsorChange Torsor where+  actRight = actRightGGeneric++instance RightTorsor (Changes TorsorChange) Torsor where+  differenceRight = differenceRightGenericChanges+@++In this example, @TorsorChangeSum@ will act on the first field of @Torsor@, and @TorsorChangeProduct@ on the second.+When computing the difference, every field will be compared, and for every difference a change will be created.+All the changes are collected in a 'Changes' container.++In many cases where this is sensible, the instance can be derived this way.+Whenever it typechecks, it will be the inverse to the automatically derived instance from 'actRightGGeneric'.+-}+differenceRightGenericChanges :: (Generic w, Generic s, GCRightTorsor (Rep w) (Rep s)) => s -> s -> Changes w+differenceRightGenericChanges sOld sNew = to <$> gcDifferenceRight (from sOld) (from sNew)

@@ -2,7 +2,10 @@  -- base import Control.Monad (replicateM_)+import Data.Char (toUpper) import Data.Function ((&))+import Data.Monoid (Last (Last), Product (..), Sum (..))+import GHC.Generics (Generic) import Prelude hiding (Foldable (..))  -- transformers@@ -14,12 +17,15 @@ -- tasty-hunit import Test.Tasty.HUnit (testCase, (@?=)) +-- containers+import qualified Data.Map as M+ -- 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 (RightAction (..), RightTorsor (..), rEndo, set) import Data.Monoid.RightAction.Coproduct (inL, (:+:))+import Data.Monoid.RightAction.Generic (actRightGGeneric, actRightGeneric, differenceRightGGeneric, differenceRightGenericChanges)  type M = Changeset Int (Changes Count) @@ -81,4 +87,147 @@           [ 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)           ]+      , testGroup+          "FilterableChange"+          [ testCase "Can change a map with FilterableChange" $+              M.fromList [(0 :: Int, "hello"), (1, "world")] `actRight` FilterableChange (justChange $ ImapChange (\i -> if i == 2 then rEndo toUpper else mempty))+                @?= M.fromList [(0 :: Int, "heLlo"), (1, "woRld")]+          ]+      , testGroup+          "FilterableChanges"+          [ testCase "Can change a map depending on content" $+              M.fromList [(0 :: Int, "hello"), (1, "world"), (2, "!")]+                `actRight` FilterableChanges+                  ( \case+                      "hello" -> FilterablePositionChange (set "hi")+                      "!" -> FilterablePositionDelete+                      _ -> mempty+                  )+                @?= M.fromList [(0 :: Int, "hi"), (1, "world")]+          ]+      , testGroup+          "AlignChanges"+          [ testCase "Can change a map with another map" $+              M.fromList+                [ (0 :: Int, "hello")+                , (1, "world")+                , (2, "!")+                ]+                `actRight` AlignChanges+                  ( M.fromList+                      [ (0 :: Int, SetAlignPosition "hi")+                      , (1, ChangeAlignPosition $ FmapChange @[] $ rEndo toUpper)+                      , (2, DeleteAlignPosition)+                      , (3, SetAlignPosition "...")+                      ]+                  )+                @?= M.fromList [(0 :: Int, "hi"), (1, "WORLD"), (3, "...")]+          ]+      , testGroup+          "Generic"+          [ testGroup+              "actRightGeneric"+              [ testCase "single change left" $ 0 `actRight` IntActionCounts Increment mempty @?= (1 :: Int)+              , testCase "single change product" $ 0 `actRight` IntActionCounts Increment (singleChange Increment) @?= (2 :: Int)+              , testCase "single change right" $ 0 `actRight` IntActionLast (set 100) @?= (100 :: Int)+              , testCase "single change recursive" $ 0 `actRight` IntActionRec (IntActionLast (set 100)) (IntActionCounts Increment mempty) @?= (101 :: Int)+              , testCase "changes" $+                  (0 :: Int)+                    `actRight` changes+                      [ IntActionCounts Increment mempty+                      , IntActionLast (set 10)+                      , IntActionCounts Increment (changes [Increment, Increment])+                      , IntActionRec (IntActionRec (IntActionCounts Increment mempty) (IntActionCounts Increment mempty)) (IntActionCounts Increment (changes [Increment, Increment]))+                      ]+                    @?= 18+              ]+          , testGroup+              "actRightGGeneric"+              [ testCase "Wrapper changes wrapper" $ Bar 0 `actRight` BarChange Increment @?= Bar 1+              , testCase "Sum changes product" $ Foo 0 0 [] `actRight` changes [FooChangeInt Increment, FooChangeList (Cons ()), FooChangeInt2 Increment] @?= Foo 1 1 [()]+              , testCase "Product changes product" $ Foo 0 0 [] `actRight` FooChange2 Increment Nothing (Cons ()) @?= Foo 1 0 [()]+              ]+          , testGroup+              "differenceRightGGeneric"+              [ testGroup "Wrapper" $ torsorTestSuite (TorsorWrapper 9) (TorsorWrapper 1) (TorsorWrapper 10)+              , testGroup+                  "Sum"+                  [ testGroup "All fields change" $ torsorTestSuite (changes [TorsorChangeSum 5, TorsorChangeProduct 6, TorsorChangeSum2 7]) (Torsor 2 3 4) (Torsor 7 18 11)+                  , testGroup "One field changes" $ torsorTestSuite (singleChange (TorsorChangeProduct 6)) (Torsor 2 3 4) (Torsor 2 18 4)+                  , testGroup "No fields change" $ torsorTestSuite (mempty :: Changes TorsorChange) (Torsor 2 3 4) (Torsor 2 3 4)+                  ]+              , testGroup "Product" $ torsorTestSuite (TorsorChange2 5 6 7) (Torsor 2 3 4) (Torsor 7 18 11)+              ]+          ]       ]++data IntAction+  = IntActionCounts Count (Changes Count)+  | IntActionLast (Last Int)+  | IntActionRec IntAction IntAction+  deriving stock (Generic)++instance RightAction IntAction Int where+  actRight = actRightGeneric++newtype Bar = Bar Int+  deriving stock (Generic, Eq, Show)++newtype BarChange = BarChange Count+  deriving stock (Generic)++instance RightAction BarChange Bar where+  actRight = actRightGGeneric++data Foo = Foo Int Int [()]+  deriving stock (Generic, Eq, Show)++data FooChange = FooChangeInt Count | FooChangeInt2 Count | FooChangeList (ListChange ())+  deriving stock (Generic)++instance RightAction FooChange Foo where+  actRight = actRightGGeneric++data FooChange2 = FooChange2 Count (Maybe Count) (ListChange ())+  deriving stock (Generic)++instance RightAction FooChange2 Foo where+  actRight = actRightGGeneric++newtype TorsorWrapper = TorsorWrapper (Sum Integer)+  deriving stock (Generic, Eq, Show)++instance RightAction TorsorWrapper TorsorWrapper where+  actRight = actRightGGeneric++instance RightTorsor TorsorWrapper TorsorWrapper where+  differenceRight = differenceRightGGeneric++data Torsor = Torsor (Sum Integer) (Product Rational) (Sum Rational)+  deriving stock (Generic, Eq, Show)++data TorsorChange = TorsorChangeSum (Sum Integer) | TorsorChangeProduct (Product Rational) | TorsorChangeSum2 (Sum Rational)+  deriving stock (Generic, Eq, Show)++instance RightAction TorsorChange Torsor where+  actRight = actRightGGeneric++instance RightTorsor (Changes TorsorChange) Torsor where+  differenceRight = differenceRightGenericChanges++data TorsorChange2 = TorsorChange2 (Sum Integer) (Product Rational) (Sum Rational)+  deriving stock (Generic, Eq, Show)++instance RightAction TorsorChange2 Torsor where+  actRight = actRightGGeneric++instance RightTorsor TorsorChange2 Torsor where+  differenceRight = differenceRightGGeneric++torsorTestSuite :: forall w s. (RightAction w s, RightTorsor w s, Eq w, Show w, Eq s, Show s) => w -> s -> s -> [TestTree]+torsorTestSuite w sOrig sActed =+  [ testCase "act" $ sOrig `actRight` w @?= sActed+  , testCase "difference" $ sOrig `differenceRight` sActed @?= w+  , testCase "law 1" $ sOrig `differenceRight` (sOrig `actRight` w :: s) @?= w+  , testCase "law 2" $ sOrig `actRight` (sOrig `differenceRight` sActed :: w) @?= sActed+  ]