changeset 0.2 → 0.2.1

raw patch · 7 files changed

+442/−59 lines, 7 filesdep +falsifyPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: falsify

API changes (from Hackage documentation)

Files

• changeset.cabal +3/−1
• examples/Control/Monad/Trans/Changeset/Examples.hs +6/−8
• src/Control/Monad/Changeset/Class.hs +40/−25
• src/Control/Monad/Trans/Changeset.hs +28/−13
• src/Data/Monoid/RightAction.hs +13/−7
• src/Data/Monoid/RightAction/Coproduct.hs +6/−0
• test/Main.hs +346/−5

@@ -1,6 +1,6 @@ cabal-version: 2.4 name: changeset-version: 0.2+version: 0.2.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 @@     DeriveGeneric     DeriveTraversable     DerivingStrategies+    DerivingVia     FlexibleContexts     FlexibleInstances     FunctionalDependencies@@ -113,6 +114,7 @@     base,     changeset,     containers >=0.6 && <0.8,+    falsify ^>=0.2.0,     monoid-extras,     tasty >=1.4.2 && <1.6,     tasty-hunit ^>=0.10.2,

@@ -10,9 +10,6 @@ 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)@@ -24,6 +21,7 @@ -- changeset import Control.Monad.Changeset.Class (MonadChangeset (..)) import Control.Monad.Trans.Changeset+import Data.Monoid.RightAction (RightAction (..))  -- tasty import Test.Tasty (TestTree, testGroup)@@ -45,8 +43,8 @@ -- | 'WriterT' is a special case of 'ChangesetT' when the current state is trivial. type TrivialActionWriterT w = ChangesetT () w -instance Action w () where-  act _ _ = ()+instance RightAction w () where+  actRight _ _ = ()  instance {-# OVERLAPPING #-} (Monoid w, Monad m) => MonadWriter w (TrivialActionWriterT w m) where   writer = ChangesetT . pure . pure . swap@@ -61,7 +59,7 @@ 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+  state f = ChangesetT $ \s -> pure $ first pure $ swap $ f s  -- * Another state monad @@ -72,7 +70,7 @@ 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)+  state f = ChangesetT $ \s -> pure (Dual $ Endo $ snd <$> f, fst $ f s)  type M = Changes (ListChange Int) @@ -91,7 +89,7 @@   n <- get   put 2   put 3-  return n+  pure n  tests :: TestTree tests =

@@ -14,37 +14,41 @@  {- | 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.@+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)+  'change' w = 'changeset' $ 'const' ((), w)+  'current' = 'changeset' (, 'mempty') @ -The central law ensures that future  states are affected by the past changes through right action:+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)+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+'changeset' $ \s -> let (a, w) = f s in g a $ s \`'Data.Monoid.RightAction.actRight'\` w @  This law has several easier to grasp corollaries:+ @-change w >> current = do-  s <- current-  change w-  return $ s 'actRight' w+--  Applying a change and then observing the state is the same as observing the state, updating it, and applying the change.+'change' w >> 'current' = do+  s <- 'current'+  'change' w+  'return' $ s \`'Data.Monoid.RightAction.actRight'\` w -change w1 >> change w2 = change (w1 <> w2)+-- Changes are combined through the semigroup product+'change' w1 >> 'change' w2 = 'change' (w1 <> w2) -current s1 >> current s2 = current s2+-- current has no effect other than returning the current state+'current' >> 'current' = 'current' @ -} class (Monad m, Monoid w, RightAction w s) => MonadChangeset s w m | m -> s, m -> w where@@ -54,17 +58,19 @@     (s -> (a, w)) ->     m a -  -- | Apply a change to the state.-  ---  --   The 'Action' instance is used to mutate the state.-  ---  --   This is a special case of 'changeset' where the current state is disregarded.+  {- | Apply a change to the state.++  The 'RightAction' 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.+  {- | Observe the current state.++  This is a special case of 'changeset' where the state is not changed.+  -}   current :: m s   current = changeset (,mempty) @@ -75,8 +81,17 @@  {- | 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@.+Also see 'update'. -} diff :: (RightTorsor w s, MonadChangeset s w m) => s -> m w diff s = (`differenceRight` s) <$> current++{- | Update to a specific state.++Uses 'diff' to calculate the missing change to the intended state.+This is only possible if the change is also a /torsor/, that is, there is a way to calculate a change as a difference between states.++With a lawful @'RightTorsor' w s@ instance, it can be expected that after applying @'update' s@, the state is @s@.+-}+update :: (MonadChangeset s w m, RightTorsor w s) => s -> m ()+update s = diff s >>= change

@@ -31,19 +31,27 @@ @  Changes for such a type (or rather, for the monoid @'Changes' ChangeAddress@) can be inspected.+This then opens several possibilities: +* We can display and edit the planned changes+* We can perform side effects dependent on the particular change that can be made,+  for example redrawing a corresponding UI element or performing a DB query+* We can calculate changes as a diff between states and merge diffs+ '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  |-+--------------------------+---------------+-------------+---------------------------------------------+++--------------------------+---------------+-------------------------+---------------------------------------------++| Transformer special case | State type    | Change 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@           | @'Data.Monoid.Last' s@  | The change overwrites all previous changes  |++--------------------------+---------------+-------------------------+---------------------------------------------++| @'ReaderT' r@            | @r@           | '()'                    | The state cannot be changed                 |++--------------------------+---------------+-------------------------+---------------------------------------------+  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).@@ -112,11 +120,11 @@ 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, @'actRight' :: w -> s -> s@,+This relation is captured by the 'RightAction' type class from "Data.Monoid.RightAction".+It contains a method, @'actRight' :: s -> w -> 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:+A standard example is that of a big record where we only want to change a small portion:  @ data User = User@@ -276,7 +284,7 @@     (w1, a) <- ma s     let !s' = actRight s w1     (w2, b) <- getChangesetT (f a) s'-    return (w1 <> w2, b)+    pure (w1 <> w2, b)  instance (Alternative m, Monoid w, RightAction w s, Monad m) => Alternative (ChangesetT s w m) where   empty = liftF empty@@ -420,6 +428,9 @@ newtype SetTo a = SetTo a   deriving stock (Eq, Show, Read, Ord, Generic, Functor, Foldable, Traversable) +instance Semigroup (SetTo a) where+  _ <> a = a+ instance RightAction (SetTo a) a where   actRight _ (SetTo a) = a @@ -465,6 +476,10 @@ instance RightAction (MaybeChange a) (Maybe a) where   actRight aMaybe MaybeChange {getMaybeChange} = actRight aMaybe getMaybeChange +{- | __Warning:__ This instance does not satisfy the 'RightTorsor' law @differenceRight s (s \`actRight\` w) = w@.+When @w@ sets the value to the same state (e.g. @'setJust' x@ applied to @'Just' x@),+the round-trip produces 'mempty' instead of the original @w@.+-} 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

@@ -37,8 +37,6 @@  instance RightAction () s -instance RightAction m ()- instance RightAction Void s  instance (RightAction w1 s1, RightAction w2 s2) => RightAction (w1, w2) (s1, s2) where@@ -121,16 +119,24 @@ 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.+{- | When the new state is equal to the original, produce the empty change, otherwise just 'set' to the new state.++__Warning:__ This instance does not satisfy the 'RightTorsor' law @differenceRight s (s \`actRight\` w) = w@.+When @w@ sets the value to the same state (e.g. @'Last' ('Just' x)@ applied to @x@),+the round-trip produces 'mempty' instead of the original @w@.+-} 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 (Semigroup w, RightTorsor w s, Zip f) => RightTorsor (f w) (f s) where+{- | Calculate the diff per position of the container.++This instance is marked as @{\-# OVERLAPPABLE #-\}@ so it is possible to define more specific instances for particular container types.+-}+instance {-# OVERLAPPABLE #-} (Semigroup w, RightTorsor w s, Zip f) => RightTorsor (f w) (f s) where   differenceRight = zipWith differenceRight -instance {-# OVERLAPPING #-} (Num a) => RightTorsor (Sum a) (Sum a) where+instance (Num a) => RightTorsor (Sum a) (Sum a) where   differenceRight = flip (-) -instance {-# OVERLAPPING #-} (Fractional a) => RightTorsor (Product a) (Product a) where+instance (Fractional a) => RightTorsor (Product a) (Product a) where   differenceRight (Product aOld) (Product aNew) = Product $ aNew / aOld

@@ -52,5 +52,11 @@ instance (Eq m, Eq n, Semigroup m, Semigroup n) => Eq (m :+: n) where   mns1 == mns2 = normaliseCoproduct mns1 == normaliseCoproduct mns2 +-- | Coproducts are shown after normalising+instance (Show m, Show n, Semigroup m, Semigroup n) => Show (m :+: n) where+  showsPrec d mns =+    showParen (d > 10) $+      showString "Coproduct " . showsPrec 11 (normaliseCoproduct mns)+ 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)

@@ -1,10 +1,14 @@+{-# OPTIONS_GHC -Wno-orphans #-}+ module Main (main) where  -- base import Control.Monad (replicateM_) import Data.Char (toUpper) import Data.Function ((&))+import Data.List.NonEmpty (NonEmpty (..)) import Data.Monoid (Last (Last), Product (..), Sum (..))+import Data.Proxy (Proxy (..)) import GHC.Generics (Generic) import Prelude hiding (Foldable (..)) @@ -17,6 +21,16 @@ -- tasty-hunit import Test.Tasty.HUnit (testCase, (@?=)) +-- falsify+import Test.Falsify.GenDefault (GenDefault (..), ViaGeneric (..))+import Test.Falsify.GenDefault.Std (Std)+import Test.Falsify.Generator (Gen)+import qualified Test.Falsify.Generator as Gen+import Test.Falsify.Predicate ((.$))+import qualified Test.Falsify.Predicate as P+import Test.Falsify.Range (between)+import Test.Tasty.Falsify (assert, gen, testProperty)+ -- containers import qualified Data.Map as M @@ -24,10 +38,11 @@ import Control.Monad.Changeset.Class import Control.Monad.Trans.Changeset import Data.Monoid.RightAction (RightAction (..), RightTorsor (..), rEndo, set)-import Data.Monoid.RightAction.Coproduct (inL, (:+:))+import Data.Monoid.RightAction.Coproduct (inL, inR, (:+:)) import Data.Monoid.RightAction.Generic (actRightGGeneric, actRightGeneric, differenceRightGGeneric, differenceRightGenericChanges)  type M = Changeset Int (Changes Count)+type MT = Changeset Torsor (Changes TorsorChange)  main :: IO () main =@@ -46,7 +61,7 @@                       let action = flip evalChangeset 0 $ do                             n <- current                             changeSingle Increment-                            return n+                            pure n                        in action @?= (0 :: Int)                   ]               , testGroup@@ -70,11 +85,36 @@               ]           ]       , testGroup-          "Changes"-          [ testCase "is lawful monoid action" $ do+          "RightAction"+          [ testCase "Changes is lawful monoid action" $ do               [] `actRight` singleChange (Cons True) `actRight` singleChange (Cons False) @?= ([] :: [Bool]) `actRight` singleChange (Cons True) <> singleChange (Cons False)+          , testGroup "Last" $+              rightActionMonoidLaws @Int @(Last Int) genInt genLastInt+          , -- RightTorsor (Last s) s does not satisfy differenceRight . actRight = id:+            -- when the action sets the value to the same state, differenceRight returns mempty.+            testGroup "Sum" $+              rightActionMonoidLaws genSumInt genSumInt+          , testGroup "Product" $+              rightActionMonoidLaws (genProduct genNonZeroRational) (genProduct genNonZeroRational)+          , testGroup "()" $+              rightActionMonoidLaws @Int @() genInt (pure ())+          , -- RightTorsor () s cannot satisfy actRight sOrig (differenceRight sOrig sActed) = sActed+            -- when sOrig /= sActed, since () carries no information.+            testGroup "Maybe" $+              rightActionMonoidLaws @Int @(Maybe (Last Int)) genInt (genMaybe genLastInt)+          , testGroup "Tuple" $+              rightActionMonoidLaws @(Int, Int) @(Last Int, Last Int)+                ((,) <$> genInt <*> genInt)+                ((,) <$> genLastInt <*> genLastInt)           ]       , testGroup+          "RightTorsor"+          [ testGroup "Sum" $+              allLaws genSumInt genSumInt+          , testGroup "Product" $+              allLaws (genProduct genNonZeroRational) (genProduct genNonZeroRational)+          ]+      , testGroup           "MonadChangeset"           [ testCase "ReaderT lifts changeset operations" $               let action = flip execChangeset (0 :: Int) $ flip runReaderT (100 :: Int) $ do@@ -82,10 +122,64 @@                     replicateM_ env $ changeSingle Increment                in action @?= 100           ]+      , testGroup "SetTo" $+          rightActionSemigroupLaw @Int @(SetTo Int) genInt genSetTo+            : rightTorsorLaws genInt genSetTo       , testGroup+          "Changes"+          [ testGroup "Count" $+              rightActionMonoidLaws @Int @(Changes Count) genInt (genChanges genCount)+          , testGroup "ListChange" $+              rightActionMonoidLaws @[Int] @(Changes (ListChange Int))+                (genSmallList genInt)+                (genChanges genListChangeInt)+          ]+      , testGroup+          "MaybeChange"+          [ testGroup "RightAction" $+              rightActionMonoidLaws @(Maybe Int) @(MaybeChange Int)+                genMaybeInt+                (genMaybeChange genInt)+                -- RightTorsor (MaybeChange a) (Maybe a) does not satisfy differenceRight . actRight = id:+                -- when the action sets the value to the same state, differenceRight returns mempty.+          ]+      , testGroup+          "FmapChange"+          [ testGroup "RightAction" $+              rightActionMonoidLaws @(Maybe Int) @(FmapChange Maybe (Last Int))+                genMaybeInt+                (genFmapChange genLastInt)+          ]+      , testGroup+          "diff and update"+          [ testProperty "diff yields differenceRight from current" $ do+              s0 <- gen genTorsor+              s1 <- gen genTorsor+              assert $+                P.eq+                  .$ ("snd (getChangeset (diff s1) s0)", snd (getChangeset (diff s1 :: MT (Changes TorsorChange)) s0))+                  .$ ("differenceRight s0 s1", differenceRight s0 s1)+          , testProperty "update sets the state" $ do+              s0 <- gen genTorsor+              s1 <- gen genTorsor+              assert $+                P.eq+                  .$ ("execChangeset (update s1) s0", execChangeset (update s1 :: MT ()) s0)+                  .$ ("s1", s1)+          , testProperty "change after update to same state is mempty" $ do+              s <- gen genTorsor+              assert $+                P.expect mempty+                  .$ ("getChange (update s) s", getChange (update s :: MT ()) s)+          ]+      , 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)+          , testGroup "RightAction" $+              rightActionMonoidLaws @Int @(Last Int :+: Last Int)+                genInt+                (Gen.choose (inL <$> genLastInt) (inR <$> genLastInt))           ]       , testGroup           "FilterableChange"@@ -122,6 +216,23 @@                       ]                   )                 @?= M.fromList [(0 :: Int, "hi"), (1, "WORLD"), (3, "...")]+          , testGroup "RightAction" $+              rightActionMonoidLaws @(M.Map Int (Sum Int)) @(AlignChanges (M.Map Int) (Sum Int) (Sum Int))+                genMapIntInt+                (genAlignChangesMap (genDefault (Proxy @Std)))+          , testGroup+              "RightTorsor"+              [ -- The differenceRight . actRight law does not hold for AlignChanges:+                -- ChangeAlignPosition w on an unchanged entry round-trips to ChangeAlignPosition mempty ≠ w.+                -- Only actRight . differenceRight (law 2) holds.+                testProperty "actRight . differenceRight" $ do+                  sOrig <- gen genMapIntInt+                  sActed <- gen genMapIntInt+                  assert $+                    P.eq+                      .$ ("sOrig `actRight` differenceRight sOrig sActed", sOrig `actRight` differenceRight @(AlignChanges (M.Map Int) (Sum Int) (Sum Int)) sOrig sActed)+                      .$ ("sActed", sActed)+              ]           ]       , testGroup           "Generic"@@ -155,8 +266,27 @@                   [ 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 "Property laws" $+                      changesLaws @Torsor @TorsorChange+                        (flip actRight)+                        differenceRight+                        genTorsor+                        genTorsorChange                   ]-              , testGroup "Product" $ torsorTestSuite (TorsorChange2 5 6 7) (Torsor 2 3 4) (Torsor 7 18 11)+              , testGroup+                  "Product"+                  ( torsorTestSuite (TorsorChange2 5 6 7) (Torsor 2 3 4) (Torsor 7 18 11)+                      <> rightTorsorLaws @Torsor @TorsorChange2+                        genTorsor+                        genTorsorChange2+                  )+              , testGroup+                  "Newtype"+                  ( torsorTestSuite (TorsorWrapper 9) (TorsorWrapper 1) (TorsorWrapper 10)+                      <> rightTorsorLaws @TorsorWrapper @TorsorWrapper+                        genTorsorWrapper+                        genTorsorWrapper+                  )               ]           ]       ]@@ -224,6 +354,15 @@ instance RightTorsor TorsorChange2 Torsor where   differenceRight = differenceRightGGeneric +-- * GenDefault instances via ViaGeneric Std++deriving via ViaGeneric Std Count instance GenDefault Std Count+deriving via ViaGeneric Std (Sum Int) instance GenDefault Std (Sum Int)+deriving via ViaGeneric Std (Last Int) instance GenDefault Std (Last Int)+deriving via ViaGeneric Std (SetTo Int) instance GenDefault Std (SetTo Int)+deriving via ViaGeneric Std (ListChange Int) instance GenDefault Std (ListChange Int)+deriving via ViaGeneric Std (AlignPositionChange (Sum Int) (Sum Int)) instance GenDefault Std (AlignPositionChange (Sum Int) (Sum Int))+ 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@@ -231,3 +370,205 @@   , testCase "law 1" $ sOrig `differenceRight` (sOrig `actRight` w :: s) @?= w   , testCase "law 2" $ sOrig `actRight` (sOrig `differenceRight` sActed :: w) @?= sActed   ]++-- * Reusable law tests++-- | Tests for 'RightTorsor' laws that don't require 'Monoid' on the change type.+rightTorsorLaws :: forall s w. (Eq s, Show s, Eq w, Show w, RightAction w s, RightTorsor w s) => Gen s -> Gen w -> [TestTree]+rightTorsorLaws genS genW =+  [ rightTorsorLaw1 genS genW+  , rightTorsorLaw2 genS genW+  ]++rightTorsorLaw1 :: forall s w. (Eq s, Show s, Eq w, Show w, RightAction w s, RightTorsor w s) => Gen s -> Gen w -> TestTree+rightTorsorLaw1 genS genW = testProperty "differenceRight . actRight" $ do+  s <- gen genS+  w <- gen genW+  assert $+    P.eq+      .$ ("differenceRight s (s `actRight` w)", differenceRight s (s `actRight` w))+      .$ ("w", w)+rightTorsorLaw2 :: forall s w proxy. (Eq s, Show s, RightAction w s, RightTorsor w s) => Gen s -> proxy w -> TestTree+rightTorsorLaw2 genS _ = testProperty "actRight . differenceRight" $ do+  sOrig <- gen genS+  sActed <- gen genS+  assert $+    P.eq+      .$ ("sOrig `actRight` differenceRight sOrig sActed", sOrig `actRight` differenceRight @w sOrig sActed)+      .$ ("sActed", sActed)++-- | Tests for 'RightAction' laws that require 'Monoid' on the change type.+rightActionMonoidLaws :: forall s w. (Eq s, Show s, Eq w, Show w, Monoid w, RightAction w s) => Gen s -> Gen w -> [TestTree]+rightActionMonoidLaws genS genW = [rightActionSemigroupLaw genS genW, rightActionMemptyLaw genS genW]++rightActionSemigroupLaw :: forall s w. (Eq s, Show s, Eq w, Show w, Semigroup w, RightAction w s) => Gen s -> Gen w -> TestTree+rightActionSemigroupLaw genS genW =+  testProperty "actRight semigroup" $ do+    s <- gen genS+    m1 <- gen genW+    m2 <- gen genW+    assert $+      P.eq+        .$ ("(s `actRight` m1) `actRight` m2", (s `actRight` m1) `actRight` m2)+        .$ ("s `actRight` (m1 <> m2)", s `actRight` (m1 <> m2))++rightActionMemptyLaw :: forall s w proxy. (Eq s, Show s, Eq w, Show w, Monoid w, RightAction w s) => Gen s -> proxy w -> TestTree+rightActionMemptyLaw genS _ = testProperty "actRight mempty" $ do+  s <- gen genS+  assert $+    P.eq+      .$ ("s `actRight` mempty", s `actRight` (mempty @w))+      .$ ("s", s)++-- | Additional 'RightTorsor' law that requires 'Monoid': @differenceRight s s = mempty@.+rightTorsorMemptyLaw :: forall s w. (Eq s, Show s, Eq w, Show w, Monoid w, RightTorsor w s) => Gen s -> Gen w -> [TestTree]+rightTorsorMemptyLaw genS _genW =+  [ testProperty "differenceRight self = mempty" $ do+      s <- gen genS+      assert $+        P.expect (mempty @w)+          .$ ("differenceRight s s", differenceRight @w s s)+  ]++-- | All 'RightAction' and 'RightTorsor' laws for a 'Monoid' change type.+allLaws :: (Eq s, Show s, Eq w, Show w, Monoid w, RightAction w s, RightTorsor w s) => Gen s -> Gen w -> [TestTree]+allLaws genS genW = rightActionMonoidLaws genS genW <> (rightTorsorLaws genS genW <> rightTorsorMemptyLaw genS genW)++{- | All laws for the common pattern where @RightAction w s@ and @RightTorsor (Changes w) s@.++Note: The @differenceRight . actRight@ test checks that the round-tripped diff has the same /effect/+rather than being structurally equal, since 'Changes' is a free monoid and multiple representations+can encode the same action.+-}+changesLaws ::+  forall s w.+  (Eq s, Show s, Eq w, Show w) =>+  (Changes w -> s -> s) ->+  (s -> s -> Changes w) ->+  Gen s ->+  Gen w ->+  [TestTree]+changesLaws act diffFn genS genW =+  [ testProperty "differenceRight . actRight (effect)" $ do+      s <- gen genS+      w <- gen genChangesW+      -- The diff of the round-trip must produce the same effect, not necessarily the same Changes list+      assert $+        P.eq+          .$ ("act (differenceRight s (act w s)) s", act (diffFn s (act w s)) s)+          .$ ("act w s", act w s)+  , testProperty "actRight . differenceRight" $ do+      sOrig <- gen genS+      sActed <- gen genS+      assert $+        P.eq+          .$ ("act (differenceRight sOrig sActed) sOrig", act (diffFn sOrig sActed) sOrig)+          .$ ("sActed", sActed)+  , testProperty "differenceRight self = mempty" $ do+      s <- gen genS+      assert $+        P.expect mempty+          .$ ("differenceRight s s", diffFn s s)+  ]+  where+    genChangesW :: Gen (Changes w)+    genChangesW = genChanges genW++-- * Generators++genInt :: Gen Int+genInt = Gen.int (between (0, 100))++genSetTo :: Gen (SetTo Int)+genSetTo = genDefault (Proxy @Std)++-- | Generate a non-zero rational (for Product torsor, avoiding division by zero).+genNonZeroRational :: Gen Rational+genNonZeroRational = do+  n <- Gen.int (between (1, 100))+  d <- Gen.int (between (1, 100))+  sign <- Gen.bool True+  pure $ (if sign then 1 else -1) * fromIntegral n / fromIntegral d++genSumInt :: Gen (Sum Int)+genSumInt = genDefault (Proxy @Std)++genProduct :: Gen a -> Gen (Product a)+genProduct = fmap Product++genLastInt :: Gen (Last Int)+genLastInt = genDefault (Proxy @Std)++genMaybe :: Gen a -> Gen (Maybe a)+genMaybe = Gen.shrinkToNothing++genChanges :: Gen w -> Gen (Changes w)+genChanges genW = changes <$> Gen.list (between (0, 5)) genW++genListChangeInt :: Gen (ListChange Int)+genListChangeInt = genDefault (Proxy @Std)++genCount :: Gen Count+genCount = genDefault (Proxy @Std)++genMaybeChange :: Gen a -> Gen (MaybeChange a)+genMaybeChange genA = Gen.choose (pure mempty) (Gen.choose (setJust <$> genA) (pure setNothing))++genFmapChange :: Gen w -> Gen (FmapChange f w)+genFmapChange = fmap FmapChange++genMaybeInt :: Gen (Maybe Int)+genMaybeInt = genDefault (Proxy @Std)++genSmallList :: Gen a -> Gen [a]+genSmallList = Gen.list (between (0, 5))++genAlignChangesMap :: Gen (AlignPositionChange w s) -> Gen (AlignChanges (M.Map Int) w s)+genAlignChangesMap genAPC = do+  kvs <- Gen.list (between (0, 5)) $ do+    k <- Gen.int (between (0, 10))+    v <- genAPC+    pure (k, v)+  pure $ AlignChanges $ M.fromList kvs++genSmallMap :: (Ord k) => Gen k -> Gen v -> Gen (M.Map k v)+genSmallMap genK genV = do+  kvs <- Gen.list (between (0, 5)) ((,) <$> genK <*> genV)+  pure $ M.fromList kvs++genMapIntInt :: Gen (M.Map Int (Sum Int))+genMapIntInt = genSmallMap (Gen.int (between (0, 10))) genSumInt++genSumInteger :: Gen (Sum Integer)+genSumInteger = Sum . fromIntegral <$> Gen.int (between (-100, 100))++genProductRational :: Gen (Product Rational)+genProductRational = do+  n <- Gen.int (between (1, 100))+  d <- Gen.int (between (1, 100))+  sign <- Gen.bool True+  pure $ Product $ (if sign then 1 else -1) * fromIntegral n / fromIntegral d++genSumRational :: Gen (Sum Rational)+genSumRational = do+  n <- Gen.int (between (-100, 100))+  d <- Gen.int (between (1, 100))+  pure $ Sum $ fromIntegral n / fromIntegral d++genTorsorWrapper :: Gen TorsorWrapper+genTorsorWrapper = TorsorWrapper <$> genSumInteger++genTorsor :: Gen Torsor+genTorsor = Torsor <$> genSumInteger <*> genProductRational <*> genSumRational++genTorsorChange :: Gen TorsorChange+genTorsorChange =+  Gen.oneof+    ( (TorsorChangeSum <$> genSumInteger)+        :| [ TorsorChangeProduct <$> genProductRational+           , TorsorChangeSum2 <$> genSumRational+           ]+    )++genTorsorChange2 :: Gen TorsorChange2+genTorsorChange2 = TorsorChange2 <$> genSumInteger <*> genProductRational <*> genSumRational