From 25cc7a3c6e912c72c058b5d488c61e827b5b6753 Mon Sep 17 00:00:00 2001 From: Joris Date: Tue, 31 Jan 2023 16:39:15 +0100 Subject: [PATCH 1/2] Remove `Act` datatype and scrutinous application of diffs --- diff-containers/diff-containers.cabal | 1 - diff-containers/src/Data/Map/Diff/Strict.hs | 195 +----------------- .../test/Test/Data/Map/Diff/Strict.hs | 17 -- 3 files changed, 5 insertions(+), 208 deletions(-) diff --git a/diff-containers/diff-containers.cabal b/diff-containers/diff-containers.cabal index 7f1d463..67a2d8e 100644 --- a/diff-containers/diff-containers.cabal +++ b/diff-containers/diff-containers.cabal @@ -27,7 +27,6 @@ library , groups , nonempty-containers , nothunks - , simple-semigroupoids ghc-options: -Wall -Wcompat diff --git a/diff-containers/src/Data/Map/Diff/Strict.hs b/diff-containers/src/Data/Map/Diff/Strict.hs index 2f2d59e..2f61b75 100644 --- a/diff-containers/src/Data/Map/Diff/Strict.hs +++ b/diff-containers/src/Data/Map/Diff/Strict.hs @@ -33,27 +33,21 @@ module Data.Map.Diff.Strict ( -- * Class instances for @'DiffHistory'@ , areInverses -- * Applying diffs - , ApplyDiffError (..) , applyDiff , applyDiffForKeys - , applyDiffForKeysScrutinous - , applyDiffScrutinous - -- * Folds over actions - , Act (..) - , foldMapAct - , traverseActs_ + -- * Folds and traversals , traverseLastDiffEntries , unsafeFoldMapDiffEntry ) where import Prelude hiding (last, length, null, splitAt) +import Control.Monad (void) import Data.Bifunctor import Data.Group import qualified Data.Map.Merge.Strict as Merge import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map -import Data.Semigroupoid.Simple import Data.Sequence (Seq (..)) import qualified Data.Sequence as Seq import Data.Sequence.NonEmpty (NESeq (..)) @@ -237,19 +231,6 @@ areInverses e1 e2 = invertDiffEntry e1 == e2 ------------------------------------------------------------------------------} -- | Applies a diff to a @'Map'@. --- --- FIXME(jdral): In this section, we distinguish between scrutinous and --- non-scrutinous application of diffs. For now, `consensus` libraries uses the --- non-scrutinous version, since the scrutinous version will consistently throw --- errors as sanity checks fail due to era translations and the multi-era nature --- of on-disk ledger values like the UTxO. In particular, a UTxO that is read --- from disk can either be from the current era, but also any one era before it. --- A UTxO is translated to the current era such that we can use it in the --- current era's ledger rules, but this translation information is then lost. A --- translation to a new era is essentially an update, and as such should be --- reflected in diffs, but that is currently not the case. We should use the --- scrutinous version once the ledger implements tracking maps, in which case we --- can keep track of exactly which era translations have happened. applyDiff :: Ord k => Map k v @@ -274,9 +255,6 @@ applyDiff m (Diff diffs) = Delete _x -> Nothing -- | Applies a diff to a @'Map'@ for a specific set of keys. --- --- See @'applyDiff'@ for more information about the scenarios in which --- @'applyDiffForKeys'@ fail. applyDiffForKeys :: Ord k => Map k v @@ -288,184 +266,21 @@ applyDiffForKeys m ks (Diff diffs) = m (Diff $ diffs `Map.restrictKeys` (Map.keysSet m `Set.union` ks)) -data ApplyDiffError k v = - FoldToActFailed k (NEDiffHistory v) - | DelMissingKey k v (NEDiffHistory v) - | DelInsMissingKey k v v (NEDiffHistory v) - | InsMatchingKey k v v (NEDiffHistory v) - | BadDelMatchingKey k v v (NEDiffHistory v) - | BadDelInsMatchingKey k v v v (NEDiffHistory v) - | InsDelMatchingKey k v (NEDiffHistory v) - deriving (Show, Eq) - --- | Applies a diff to a @'Map'@, performs sanity checks. --- --- This a /scrutinous/ version of @'applyDiff'@ in the sense that --- @'applyDiffScrutinous'@ performs sanity checks like (i) a diff history should --- be sensible (if we insert x, we can only delete x), (ii) we can not delete a --- key from a @'Map'@ if it is not already present, etc. If a sanity check --- fails, an @'ApplyDiffError'@ will be returned. -applyDiffScrutinous :: - forall k v. (Ord k, Eq v) - => Map k v - -> Diff k v - -> Either (ApplyDiffError k v) (Map k v) -applyDiffScrutinous m (Diff d) = - Merge.mergeA - Merge.preserveMissing - (Merge.traverseMaybeMissing newKeys) - (Merge.zipWithMaybeAMatched oldKeys) - m - d - where - newKeys :: k -> NEDiffHistory v -> Either (ApplyDiffError k v) (Maybe v) - newKeys k h = case foldToAct h of - Nothing -> Left $ FoldToActFailed k h - Just a -> case a of - Ins x -> Right $ Just x - Del x -> Left $ DelMissingKey k x h - DelIns x y -> Left $ DelInsMissingKey k x y h - InsDel -> Right Nothing - - oldKeys :: k -> v -> NEDiffHistory v -> Either (ApplyDiffError k v) (Maybe v) - oldKeys k v1 h = case foldToAct h of - Nothing -> Left $ FoldToActFailed k h - Just a -> case a of - Ins x -> Left $ InsMatchingKey k v1 x h - Del x | x == v1 -> Right Nothing - | otherwise -> Left $ BadDelMatchingKey k v1 x h - DelIns x y | x == v1 -> Right $ Just y - | otherwise -> Left $ BadDelInsMatchingKey k v1 x y h - InsDel -> Left $ InsDelMatchingKey k v1 h - --- | Applies a diff to a @'Map'@ for a specific set of keys, performs sanity --- checks. --- --- See @'applyDiffScrutinous'@ for more information about the sanity checks --- this function performs, and how this affects the result of --- @'applyDiffForKeysScrutinous'@. -applyDiffForKeysScrutinous :: - (Ord k, Eq v) - => Map k v - -> Set k - -> Diff k v - -> Either (ApplyDiffError k v) (Map k v) -applyDiffForKeysScrutinous m ks (Diff diffs) = - applyDiffScrutinous - m - (Diff $ diffs `Map.restrictKeys` (Map.keysSet m `Set.union` ks)) - {------------------------------------------------------------------------------ - Folding diff entries to concrete actions + Folds and traversals ------------------------------------------------------------------------------} --- | A diff action to apply to a key-value pair. -data Act v = Del !v | Ins !v | DelIns !v !v | InsDel - deriving stock (Generic, Show, Eq, Functor) - deriving anyclass (NoThunks) - -instance Eq v => Semigroupoid (Act v) where - l <>? r = case l of - Del x -> case r of - Del{} -> Nothing -- disallow double delete - Ins y -> Just $ DelIns x y - - DelIns{} -> Nothing -- disallow double delete - - InsDel -> Just $ Del x - - Ins x -> case r of - Del y -> - if x /= y then Nothing -- disallow inaccurate delete - else Just InsDel - Ins{} -> Nothing -- disallow overwrite - - DelIns y z -> - if x /= y then Nothing -- disallow inaccurate delete - else Just $ Ins z - - InsDel{} -> Nothing -- disallow overwrite - - DelIns x y -> case r of - Del z -> - if y /= z then Nothing -- disallow inaccurate delete - else Just $ Del x - Ins{} -> Nothing -- disallow overwrite - - DelIns z aa -> - if y /= z then Nothing -- disallow inaccurate delete - else Just $ DelIns x aa - - InsDel{} -> Nothing -- disallow overwrite - - InsDel -> case r of - Del{} -> Nothing -- disallow double delete - Ins x -> Just $ Ins x - - DelIns{} -> Nothing -- disallow double delete - - InsDel -> Just InsDel - -instance Eq v => Groupoid (Act v) where - pinv = \case - Del v -> Ins v - Ins v -> Del v - - DelIns x y -> DelIns y x - - InsDel -> InsDel - --- | Given a valid @'NEDiffHistory'@, its @'DiffEntry'@s should fold to a sensible --- @'Act'@. --- --- Note: Only @'Insert'@s and @'Delete'@s translate to an @'Act'@. --- --- Note: For a diff history to be valid, the diff entries in the diff history --- should not fail to fold to a sensible action. -foldToAct :: Eq v => NEDiffHistory v -> Maybe (Act v) -foldToAct (NEDiffHistory (z NESeq.:<|| zs)) = - foldl (\x y -> pappendM x (fromDiffEntry y)) (fromDiffEntry z) zs - where - fromDiffEntry = \case - Insert x -> Just $ Ins x - Delete x -> Just $ Del x - --- | Like @'foldToAct'@, but errors if the fold fails. -unsafeFoldToAct :: Eq v => NEDiffHistory v -> Act v -unsafeFoldToAct dh = case foldToAct dh of - Nothing -> error "Could not fold diff history to a sensible action." - Just act -> act - --- | Traverse over folded actions and discard the result. --- --- Note: Errors if a fold of a diff history to an action fails. -traverseActs_ :: - (Applicative t, Eq v) - => (k -> Act v -> t a) - -> Diff k v - -> t () -traverseActs_ f (Diff m) = () <$ Map.traverseWithKey g m - where - g k dh = f k (unsafeFoldToAct dh) - -foldMapAct :: (Monoid m, Eq v) => (Act v -> m) -> Diff k v -> Maybe m -foldMapAct f (Diff m) = foldMap (fmap f . foldToAct) m - -- | @'foldMap'@ over the last diff entry in each diff history. --- --- Deemed unsafe, because the diff history can be invalid and we bypass the --- validity check. unsafeFoldMapDiffEntry :: (Monoid m) => (DiffEntry v -> m) -> Diff k v -> m unsafeFoldMapDiffEntry f (Diff m) = foldMap (f . NESeq.last . getNEDiffHistory) m --- | Like @'traverseActs_'@, but traverses over the last diff entry in each diff --- history, instead of folded actions. +-- | Traversal with keys over the last diff entry in each diff history. traverseLastDiffEntries :: Applicative t => (k -> DiffEntry v -> t a) -> Diff k v -> t () -traverseLastDiffEntries f (Diff m) = () <$ Map.traverseWithKey g m +traverseLastDiffEntries f (Diff m) = void $ Map.traverseWithKey g m where g k dh = f k (last dh) diff --git a/diff-containers/test/Test/Data/Map/Diff/Strict.hs b/diff-containers/test/Test/Data/Map/Diff/Strict.hs index bb1f3d5..12917c9 100644 --- a/diff-containers/test/Test/Data/Map/Diff/Strict.hs +++ b/diff-containers/test/Test/Data/Map/Diff/Strict.hs @@ -45,10 +45,6 @@ tests = testGroup "Data.Map.Diff.Strict" [ testSemigroupoidLaws , testGroupoidLaws ] - , testGroupWithProxy (Proxy @(Act (Smaller Int))) [ - testSemigroupoidLaws - , testGroupoidLaws - ] , testProperty "prop_diffThenApply @(Smaller Int)" $ prop_diffThenApply @(Smaller Int) @(Smaller Int) , testProperty "prop_diffThenApply @Int" $ @@ -118,16 +114,3 @@ instance Arbitrary v => Arbitrary (DiffEntry v) where shrink = \case Insert x -> Insert <$> shrink x Delete x -> Delete <$> shrink x - -instance Arbitrary v => Arbitrary (Act v) where - arbitrary = oneof [ - Ins <$> arbitrary - , Del <$> arbitrary - , pure InsDel - , DelIns <$> arbitrary <*> arbitrary - ] - shrink = \case - Ins x -> Ins <$> shrink x - Del x -> Del <$> shrink x - InsDel -> [] - DelIns x y -> DelIns <$> shrink x <*> shrink y From c26c5c60258d47b25db012c646d0b3861e93ef77 Mon Sep 17 00:00:00 2001 From: Joris Date: Tue, 31 Jan 2023 17:15:25 +0100 Subject: [PATCH 2/2] Rename folds and traverals --- diff-containers/src/Data/Map/Diff/Strict.hs | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/diff-containers/src/Data/Map/Diff/Strict.hs b/diff-containers/src/Data/Map/Diff/Strict.hs index 2f61b75..54dc4bb 100644 --- a/diff-containers/src/Data/Map/Diff/Strict.hs +++ b/diff-containers/src/Data/Map/Diff/Strict.hs @@ -36,8 +36,8 @@ module Data.Map.Diff.Strict ( , applyDiff , applyDiffForKeys -- * Folds and traversals - , traverseLastDiffEntries - , unsafeFoldMapDiffEntry + , foldMapDiffEntry + , traverseDiffEntryWithKey_ ) where import Prelude hiding (last, length, null, splitAt) @@ -271,16 +271,16 @@ applyDiffForKeys m ks (Diff diffs) = ------------------------------------------------------------------------------} -- | @'foldMap'@ over the last diff entry in each diff history. -unsafeFoldMapDiffEntry :: (Monoid m) => (DiffEntry v -> m) -> Diff k v -> m -unsafeFoldMapDiffEntry f (Diff m) = +foldMapDiffEntry :: (Monoid m) => (DiffEntry v -> m) -> Diff k v -> m +foldMapDiffEntry f (Diff m) = foldMap (f . NESeq.last . getNEDiffHistory) m -- | Traversal with keys over the last diff entry in each diff history. -traverseLastDiffEntries :: +traverseDiffEntryWithKey_ :: Applicative t => (k -> DiffEntry v -> t a) -> Diff k v -> t () -traverseLastDiffEntries f (Diff m) = void $ Map.traverseWithKey g m +traverseDiffEntryWithKey_ f (Diff m) = void $ Map.traverseWithKey g m where g k dh = f k (last dh)