diff --git a/changeset.cabal b/changeset.cabal --- a/changeset.cabal +++ b/changeset.cabal @@ -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, diff --git a/examples/Control/Monad/Trans/Changeset/Examples.hs b/examples/Control/Monad/Trans/Changeset/Examples.hs --- a/examples/Control/Monad/Trans/Changeset/Examples.hs +++ b/examples/Control/Monad/Trans/Changeset/Examples.hs @@ -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 = diff --git a/src/Control/Monad/Changeset/Class.hs b/src/Control/Monad/Changeset/Class.hs --- a/src/Control/Monad/Changeset/Class.hs +++ b/src/Control/Monad/Changeset/Class.hs @@ -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 diff --git a/src/Control/Monad/Trans/Changeset.hs b/src/Control/Monad/Trans/Changeset.hs --- a/src/Control/Monad/Trans/Changeset.hs +++ b/src/Control/Monad/Trans/Changeset.hs @@ -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 diff --git a/src/Data/Monoid/RightAction.hs b/src/Data/Monoid/RightAction.hs --- a/src/Data/Monoid/RightAction.hs +++ b/src/Data/Monoid/RightAction.hs @@ -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 diff --git a/src/Data/Monoid/RightAction/Coproduct.hs b/src/Data/Monoid/RightAction/Coproduct.hs --- a/src/Data/Monoid/RightAction/Coproduct.hs +++ b/src/Data/Monoid/RightAction/Coproduct.hs @@ -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) diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -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