Merge pull request #15 from input-output-hk/jdral/diff-containers-bri…

…ng-back-unsafe-constructors

`diff-containers`: Bring back unsafe constructors

diff-containers/diff-containers.cabal

@@ -47,11 +47,13 @@ test-suite test
   main-is:            Main.hs
 
   other-modules:      Test.Data.Map.Diff.Strict
+                      Test.Util
 
   build-depends:      base              >=4.9 && <4.17
                     , containers
                     , diff-containers
                     , nonempty-containers
+                    , QuickCheck
                     , simple-semigroupoids
                     , tasty
                     , tasty-quickcheck

diff-containers/src/Data/Map/Diff/Strict/Internal.hs

@@ -1,7 +1,6 @@
 {-# LANGUAGE DeriveAnyClass             #-}
-{-# LANGUAGE DeriveFoldable             #-}
-{-# LANGUAGE DeriveFunctor              #-}
 {-# LANGUAGE DeriveGeneric              #-}
+{-# LANGUAGE DeriveTraversable          #-}
 {-# LANGUAGE DerivingStrategies         #-}
 {-# LANGUAGE FlexibleInstances          #-}
 {-# LANGUAGE GeneralisedNewtypeDeriving #-}
@@ -49,6 +48,8 @@ module Data.Map.Diff.Strict.Internal (
     -- * Applying diffs
   , applyDiff
   , applyDiffForKeys
+  , unsafeApplyDiff
+  , unsafeApplyDiffForKeys
     -- * Folds and traversals
   , foldMapDiffEntry
   , traverseDiffEntryWithKey_
@@ -60,6 +61,7 @@ import           Prelude hiding (last, length, null, splitAt)
 
 import           Control.Monad (void)
 import           Data.Bifunctor
+import           Data.Either (fromRight)
 import           Data.Group
 import qualified Data.Map.Merge.Strict as Merge
 import           Data.Map.Strict (Map)
@@ -89,19 +91,21 @@ newtype Diff k v = Diff (Map k (NEDiffHistory v))
 -- right. This means that the leftmost element in the history is the /earliest/
 -- change, while the rightmost element in the history is the /latest/ change.
 newtype DiffHistory v = DiffHistory { getDiffHistory :: Seq (DiffEntry v) }
-  deriving stock (Generic, Show, Eq, Functor, Foldable)
+  deriving stock (Generic, Show, Eq, Functor)
   deriving newtype (NoThunks)
 
 -- | A non-empty @'DiffHistory'@.
 newtype NEDiffHistory v = NEDiffHistory { getNEDiffHistory :: NESeq (DiffEntry v) }
-  deriving stock (Generic, Show, Eq, Functor, Foldable)
+  deriving stock (Generic, Show, Eq, Functor)
   deriving newtype (NoThunks)
 
 -- | A change to a value in a key-value store.
 data DiffEntry v =
       Insert !v
     | Delete !v
-  deriving stock (Generic, Show, Eq, Functor, Foldable)
+    | UnsafeAntiInsert !v
+    | UnsafeAntiDelete !v
+  deriving stock (Generic, Show, Eq, Functor)
   deriving anyclass (NoThunks)
 
 {------------------------------------------------------------------------------
@@ -248,8 +252,10 @@ instance Eq v => Group (DiffHistory v) where
 -- identity element, so it is not a @Monoid@ or @Semigroup@.
 invertDiffEntry :: DiffEntry v -> DiffEntry v
 invertDiffEntry = \case
-  Insert x -> Delete x
-  Delete x -> Insert x
+  Insert x           -> UnsafeAntiInsert x
+  Delete x           -> UnsafeAntiDelete x
+  UnsafeAntiInsert x -> Insert x
+  UnsafeAntiDelete x -> Delete x
 
 -- | @'areInverses e1 e2@ checks whether @e1@ and @e2@ are each other's inverse.
 --
@@ -267,37 +273,61 @@ applyDiff ::
      Ord k
   => Map k v
   -> Diff k v
-  -> Map k v
+  -> Either () (Map k v)
 applyDiff m (Diff diffs) =
-    Merge.merge
+    Merge.mergeA
       Merge.preserveMissing
-      (Merge.mapMaybeMissing     newKeys)
-      (Merge.zipWithMaybeMatched oldKeys)
+      (Merge.traverseMaybeMissing newKeys)
+      (Merge.zipWithMaybeAMatched oldKeys)
       m
       diffs
   where
-    newKeys :: k -> NEDiffHistory v -> Maybe v
+    newKeys :: k -> NEDiffHistory v -> Either () (Maybe v)
     newKeys _k h = case last h of
-      Insert x  -> Just x
-      Delete _x -> Nothing
+      Insert x           -> Right $ Just x
+      Delete _           -> Right Nothing
+      UnsafeAntiInsert _ -> Left ()
+      UnsafeAntiDelete _ -> Left ()
 
-    oldKeys :: k -> v -> NEDiffHistory v -> Maybe v
+    oldKeys :: k -> v -> NEDiffHistory v -> Either () (Maybe v)
     oldKeys _k _v1 h = case last h of
-      Insert x  -> Just x
-      Delete _x -> Nothing
+      Insert x           -> Right $ Just x
+      Delete _           -> Right Nothing
+      UnsafeAntiInsert _ -> Left ()
+      UnsafeAntiDelete _ -> Left ()
 
 -- | Applies a diff to a @'Map'@ for a specific set of keys.
 applyDiffForKeys ::
      Ord k
   => Map k v
   -> Set k
   -> Diff k v
-  -> Map k v
+  -> Either () (Map k v)
 applyDiffForKeys m ks (Diff diffs) =
   applyDiff
     m
     (Diff $ diffs `Map.restrictKeys` (Map.keysSet m `Set.union` ks))
 
+-- | Applies a diff to a @'Map'@, throws an error if applying the diff failed.
+unsafeApplyDiff ::
+     Ord k
+  => Map k v
+  -> Diff k v
+  -> Map k v
+unsafeApplyDiff m d = fromRight (error "applyDiff failed") $
+  applyDiff m d
+
+-- | Applies a diff to a @'Map'@ for a specific set of keys, throws an error if
+-- applying the diff failed.
+unsafeApplyDiffForKeys ::
+     Ord k
+  => Map k v
+  -> Set k
+  -> Diff k v
+  -> Map k v
+unsafeApplyDiffForKeys m s d = fromRight (error "applyDiffForKeys failed") $
+  applyDiffForKeys m s d
+
 {------------------------------------------------------------------------------
   Folds and traversals
 ------------------------------------------------------------------------------}

diff-containers/test/Test/Data/Map/Diff/Strict.hs

@@ -1,66 +1,118 @@
 {-# LANGUAGE DerivingStrategies         #-}
 {-# LANGUAGE GeneralisedNewtypeDeriving #-}
-{-# LANGUAGE LambdaCase                 #-}
 {-# LANGUAGE StandaloneDeriving         #-}
 {-# LANGUAGE TypeApplications           #-}
 
 {-# OPTIONS_GHC -Wno-orphans #-}
 
 module Test.Data.Map.Diff.Strict (tests) where
 
-import           Data.Foldable (foldl')
+import           Data.Foldable
 import           Data.Map.Strict (Map)
 import           Data.Maybe
 import           Data.Proxy (Proxy (Proxy))
 import           Data.Sequence.NonEmpty (NESeq (..))
 import qualified Data.Sequence.NonEmpty as NESeq
 
-import           Test.Tasty (TestTree, testGroup)
-import           Test.Tasty.QuickCheck
+import           Test.Tasty (TestTree, localOption, testGroup)
+import           Test.Tasty.QuickCheck hiding (Negative, Positive)
 
-import           Data.Map.Diff.Strict.Internal
+import           Data.Map.Diff.Strict.Internal hiding (null)
 
-import           Data.Semigroupoid.Simple.Auto
 import           Data.Semigroupoid.Simple.Laws
 
+import           Test.Util
+
+-- | Tests for "Data.Map.Diff.Strict".
+--
+-- === The use of @'OftenSmall'@
+--
+-- Throughout these tests, we often use/test the @'Group'@ instances for
+-- @'DiffHistory'@ and @'Diff'@. For @'mappend'@, @'mempty'@ and @'invert'@ to
+-- do interesting things, we should generate values in a small range. Examples:
+--
+-- * An @'Insert' x@ and @'UnsafeAntiInsert' y@ can only cancel out if @x == y@.
+-- If the range that we pick @x@ and @y@ from is large, then the probability
+-- that @x == y@ is small.
+--
+-- * Only if two @'mappend'@ed diffs contain the same key will the corresponding
+-- diff histories be @'mappend'@ed. If we pick keys in diffs from a large range,
+-- then the probability of matching keys is low.
+--
+-- We use the @'OftenSmall'@ wrapper and its @'Arbitrary'@ instance to generate
+-- small values often.
 tests :: TestTree
 tests = testGroup "Data.Map.Diff.Strict" [
-      testGroupWithProxy (Proxy @(DiffEntry (Smaller Int))) [
-      ]
-    , testGroupWithProxy (Proxy @(DiffHistory (Smaller Int))) [
+      localOption (QuickCheckTests 1000) $
+      testGroupWithProxy (Proxy @(DiffHistory (OftenSmall Int))) [
           testSemigroupLaws
         , testMonoidLaws
         , testGroupLaws
         ]
-    , testGroupWithProxy (Proxy @(Auto (DiffHistory (Smaller Int)))) [
-          testSemigroupoidLaws
-        , testGroupoidLaws
-        ]
-    , testGroupWithProxy (Proxy @(Diff (Smaller Int) (Smaller Int))) [
+    , localOption (QuickCheckTests 1000) $
+      testGroupWithProxy (Proxy @(Diff (OftenSmall Int) (OftenSmall Int))) [
           testSemigroupLaws
         , testMonoidLaws
         , testGroupLaws
         ]
-    , testGroupWithProxy (Proxy @(Auto (Diff (Smaller Int) (Smaller Int)))) [
-          testSemigroupoidLaws
-        , testGroupoidLaws
-        ]
-    , testProperty "prop_diffThenApply @(Smaller Int)" $
-        prop_diffThenApply @(Smaller Int) @(Smaller Int)
-    , testProperty "prop_diffThenApply @Int" $
-        prop_diffThenApply @Int @Int
+    , localOption (QuickCheckTests 10000) $
+      testProperty "prop_diffingIsPositive" $
+        prop_diffingIsPositive @(OftenSmall Int) @(OftenSmall Int)
+    , localOption (QuickCheckTests 10000) $
+      testProperty "prop_diffThenApply" $
+        prop_diffThenApply @(OftenSmall Int) @(OftenSmall Int)
+    , localOption (QuickCheckTests 10000) $
+      testProperty "prop_applyMempty" $
+        prop_applyMempty @(OftenSmall Int) @(OftenSmall Int)
+    , localOption (QuickCheckMaxRatio 100) $
+      localOption (QuickCheckTests 1000) $
+      testProperty "prop_applyAllAndApplySum" $
+        prop_applyAllAndApplySum @(OftenSmall Int) @(OftenSmall Int)
+    , localOption (QuickCheckMaxRatio 100) $
+      localOption (QuickCheckTests 1000) $
+      testProperty "prop_unsafeApplyAllAndUnsafeApplySum" $
+        prop_unsafeApplyAllAndUnsafeApplySum @(OftenSmall Int) @(OftenSmall Int)
     ]
 
 {------------------------------------------------------------------------------
   Simple properties
 ------------------------------------------------------------------------------}
 
+prop_diffingIsPositive ::
+     (Ord k, Eq v)
+  => Map k v
+  -> Map k v
+  -> Property
+prop_diffingIsPositive m1 m2 = property $ isPositive (diff m1 m2)
+
 prop_diffThenApply ::
      (Show k, Show v, Ord k, Eq v)
   => Map k v
   -> Map k v
   -> Property
-prop_diffThenApply m1 m2 = applyDiff m1 (diff m1 m2) === m2
+prop_diffThenApply m1 m2 = applyDiff m1 (diff m1 m2) === Right m2
+
+prop_applyMempty ::
+     (Show k, Show v, Ord k, Eq v)
+  => Map k v
+  -> Property
+prop_applyMempty m = applyDiff m mempty === Right m
+
+prop_applyAllAndApplySum ::
+     (Show k, Show v, Ord k, Eq v)
+  => Map k v
+  -> [Diff k v]
+  -> Property
+prop_applyAllAndApplySum m ds =
+  all isPositive ds ==> foldlM applyDiff m ds === applyDiff m (mconcat ds)
+
+prop_unsafeApplyAllAndUnsafeApplySum ::
+     (Show k, Show v, Ord k, Eq v)
+  => Map k v
+  -> [Diff k v]
+  -> Property
+prop_unsafeApplyAllAndUnsafeApplySum m ds =
+  all isPositive ds ==> foldl' unsafeApplyDiff m ds === unsafeApplyDiff m (mconcat ds)
 
 {------------------------------------------------------------------------------
   Preconditions
@@ -81,17 +133,21 @@ isNormal (DiffHistory vs) =
       Nothing   -> (Just cur, b)
       Just prev -> (Just cur, b && not (areInverses prev cur))
 
+isPositive :: Diff k v -> Bool
+isPositive (Diff m) = all (isPositiveDiffHistory . toDiffHistory) m
+
+isPositiveDiffHistory :: DiffHistory v -> Bool
+isPositiveDiffHistory (DiffHistory vs) = all p vs
+  where
+    p (Insert _)           = True
+    p (Delete _)           = True
+    p (UnsafeAntiInsert _) = False
+    p (UnsafeAntiDelete _) = False
+
 {------------------------------------------------------------------------------
   Types
 ------------------------------------------------------------------------------}
 
-newtype Smaller a = Smaller a
-  deriving newtype (Show, Eq, Ord)
-
-instance Integral a => Arbitrary (Smaller a) where
-  arbitrary = Smaller . fromIntegral <$> chooseInt (-5, 5)
-  shrink (Smaller x) = Smaller . fromIntegral <$> shrink @Int (fromIntegral x)
-
 deriving newtype instance (Ord k, Eq v, Arbitrary k, Arbitrary v)
                        => Arbitrary (Diff k v)
 
@@ -110,7 +166,11 @@ instance Arbitrary v => Arbitrary (DiffEntry v) where
   arbitrary = oneof [
       Insert <$> arbitrary
     , Delete <$> arbitrary
+    , UnsafeAntiInsert <$> arbitrary
+    , UnsafeAntiDelete <$> arbitrary
     ]
-  shrink = \case
+  shrink de = case de of
     Insert x           -> Insert <$> shrink x
     Delete x           -> Delete <$> shrink x
+    UnsafeAntiInsert x -> UnsafeAntiInsert <$> shrink x
+    UnsafeAntiDelete x -> UnsafeAntiDelete <$> shrink x

diff-containers/test/Test/Util.hs

@@ -0,0 +1,25 @@
+{-# LANGUAGE DerivingStrategies         #-}
+{-# LANGUAGE GeneralisedNewtypeDeriving #-}
+
+module Test.Util (OftenSmall (..)) where
+
+import           Test.QuickCheck
+
+-- | See the @'Arbitrary'@ instance for this type.
+newtype OftenSmall a = OftenSmall a
+  deriving newtype (Show, Eq, Ord)
+
+-- | This instance will generate a small @a@ with high probability, and it will
+-- defer to @a@'s generator with a low probability. Shrinking is deferred to
+-- @a@'s shrinker.
+--
+-- Generating @a@'s in a small range can sometimes be essential for hitting
+-- interesting cases in property tests. See "Test.Data.Map.Diff.Strict" for
+-- examples. We defer to @a@'s generator with low probability to diversify the
+-- test cases we hit.
+instance (Arbitrary a, Integral a) => Arbitrary (OftenSmall a) where
+  arbitrary = frequency [
+      (10, OftenSmall . fromIntegral <$> chooseInt (-5, 5))
+    , (1, OftenSmall <$> arbitrary)
+    ]
+  shrink (OftenSmall x) = OftenSmall <$> shrink x