From 240ed9dd324ac0ef379e092887141866cf14842e Mon Sep 17 00:00:00 2001 From: Joris Date: Tue, 31 Jan 2023 16:19:54 +0100 Subject: [PATCH 1/2] Simplify the implementation of `DiffHistory` and `NEDiffHistory`. The current definitions are too verbose, and unnecessarily generalised. This commit simplifies the definitions at no cost to the functionality. --- diff-containers/diff-containers.cabal | 1 + diff-containers/src/Data/Map/Diff/Strict.hs | 65 ++++--------------- .../src/Data/Sequence/NonEmpty/Extra.hs | 17 +++++ .../test/Test/Data/Map/Diff/Strict.hs | 8 +-- 4 files changed, 36 insertions(+), 55 deletions(-) create mode 100644 diff-containers/src/Data/Sequence/NonEmpty/Extra.hs diff --git a/diff-containers/diff-containers.cabal b/diff-containers/diff-containers.cabal index f280959..7f1d463 100644 --- a/diff-containers/diff-containers.cabal +++ b/diff-containers/diff-containers.cabal @@ -20,6 +20,7 @@ library hs-source-dirs: src exposed-modules: Data.Map.Diff.Strict + other-modules: Data.Sequence.NonEmpty.Extra build-depends: base >=4.9 && <4.17 , containers diff --git a/diff-containers/src/Data/Map/Diff/Strict.hs b/diff-containers/src/Data/Map/Diff/Strict.hs index 5b791c3..0d17ebd 100644 --- a/diff-containers/src/Data/Map/Diff/Strict.hs +++ b/diff-containers/src/Data/Map/Diff/Strict.hs @@ -6,20 +6,15 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralisedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} -{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE ViewPatterns #-} module Data.Map.Diff.Strict ( Diff (..) , DiffEntry (..) - , DiffHistory (.., DiffHistory) - , NEDiffHistory (.., NEDiffHistory) - , UnsafeDiffHistory (..) - , unDiffHistory - , unNEDiffHistory + , DiffHistory (..) + , NEDiffHistory (..) -- * Conversions between empty and non-empty diff histories , nonEmptyDiffHistory , toDiffHistory @@ -54,7 +49,6 @@ module Data.Map.Diff.Strict ( import Prelude hiding (last, length, null, splitAt) import Data.Bifunctor -import Data.Foldable (toList) import Data.Group import qualified Data.Map.Merge.Strict as Merge import Data.Map.Strict (Map) @@ -64,20 +58,17 @@ import Data.Sequence (Seq (..)) import qualified Data.Sequence as Seq import Data.Sequence.NonEmpty (NESeq (..)) import qualified Data.Sequence.NonEmpty as NESeq +import Data.Sequence.NonEmpty.Extra () import Data.Set (Set) import qualified Data.Set as Set import GHC.Generics (Generic) -import NoThunks.Class (NoThunks (..), noThunksInValues) +import NoThunks.Class (NoThunks (..)) {------------------------------------------------------------------------------ - General-purposes diffs for key-value stores + Types ------------------------------------------------------------------------------} -- | A diff for key-value stores. --- --- INVARIANT: A key @k@ is present in the @'Map'@, iff the corresponding --- @'DiffHistory'@ is non-empty. This prevents the @'Map'@ from getting bloated with --- empty diff histories. newtype Diff k v = Diff (Map k (NEDiffHistory v)) deriving stock (Generic, Show, Eq, Functor) deriving anyclass (NoThunks) @@ -87,42 +78,14 @@ newtype Diff k v = Diff (Map k (NEDiffHistory v)) -- A history has an implicit sense of ordering according to time: from left to -- 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 UnsafeDiffHistory t v = UnsafeDiffHistory (t (DiffEntry v)) - deriving stock (Generic, Functor, Foldable) - -deriving stock instance Show v => Show (UnsafeDiffHistory Seq v) -deriving stock instance Show v => Show (UnsafeDiffHistory NESeq v) -deriving stock instance Eq v => Eq (UnsafeDiffHistory Seq v) -deriving stock instance Eq v => Eq (UnsafeDiffHistory NESeq v) - -{-# COMPLETE DiffHistory #-} - -newtype DiffHistory v = MkDiffHistory (UnsafeDiffHistory Seq v) - deriving stock (Generic, Show, Eq, Functor) - deriving newtype (NoThunks, Foldable) - -{-# COMPLETE NEDiffHistory #-} - --- | A non-empty diff history. -newtype NEDiffHistory v = MkNEDiffHistory (UnsafeDiffHistory NESeq v) - deriving stock (Generic, Show, Eq, Functor) - deriving newtype (NoThunks, Foldable) - -pattern DiffHistory :: Seq (DiffEntry v) -> DiffHistory v -pattern DiffHistory { unDiffHistory } = - MkDiffHistory (UnsafeDiffHistory unDiffHistory) - -pattern NEDiffHistory :: NESeq (DiffEntry v) -> NEDiffHistory v -pattern NEDiffHistory { unNEDiffHistory } = - MkNEDiffHistory (UnsafeDiffHistory unNEDiffHistory) +newtype DiffHistory v = DiffHistory { getDiffHistory :: Seq (DiffEntry v) } + deriving stock (Generic, Show, Eq, Functor, Foldable) + deriving newtype (NoThunks) --- | Instance for @'Seq'@ checks elements only --- --- The internal fingertree in @'Seq'@ might have thunks, which is essential for --- its asymptotic complexity. -instance (NoThunks v, Foldable t) => NoThunks (UnsafeDiffHistory t v) where - showTypeOf _ = "DiffHistory" - wNoThunks ctxt = noThunksInValues ctxt . toList +-- | A non-empty @'DiffHistory'@. +newtype NEDiffHistory v = NEDiffHistory { getNEDiffHistory :: NESeq (DiffEntry v) } + deriving stock (Generic, Show, Eq, Functor, Foldable) + deriving newtype (NoThunks) -- | A change to a value in a key-value store. -- @@ -197,7 +160,7 @@ singletonDelete = singleton . Delete ------------------------------------------------------------------------------} last :: NEDiffHistory v -> DiffEntry v -last (unNEDiffHistory -> _ NESeq.:||> e) = e +last (getNEDiffHistory -> _ NESeq.:||> e) = e {------------------------------------------------------------------------------ Predicates @@ -526,7 +489,7 @@ foldMapAct f (Diff m) = foldMap (fmap f . foldToAct) m -- validity check. unsafeFoldMapDiffEntry :: (Monoid m) => (DiffEntry v -> m) -> Diff k v -> m unsafeFoldMapDiffEntry f (Diff m) = - foldMap (f . NESeq.last . unNEDiffHistory) m + foldMap (f . NESeq.last . getNEDiffHistory) m -- | Like @'traverseActs_'@, but traverses over the last diff entry in each diff -- history, instead of folded actions. diff --git a/diff-containers/src/Data/Sequence/NonEmpty/Extra.hs b/diff-containers/src/Data/Sequence/NonEmpty/Extra.hs new file mode 100644 index 0000000..fd1e5ea --- /dev/null +++ b/diff-containers/src/Data/Sequence/NonEmpty/Extra.hs @@ -0,0 +1,17 @@ +{-# OPTIONS_GHC -Wno-orphans #-} + +module Data.Sequence.NonEmpty.Extra () where + +import Data.Foldable +import Data.Sequence.NonEmpty +import NoThunks.Class + +-- | Instance for @'NESeq'@ checks elements only +-- +-- The internal fingertree in @'NESeq'@ might have thunks, which is essential for +-- its asymptotic complexity. +-- +-- Note: see documentation of @'NoThunks' ('Seq' a)@ +instance NoThunks a => NoThunks (NESeq a) where + showTypeOf _ = "NESeq" + wNoThunks ctxt = noThunksInValues ctxt . toList diff --git a/diff-containers/test/Test/Data/Map/Diff/Strict.hs b/diff-containers/test/Test/Data/Map/Diff/Strict.hs index 00073c0..1d37500 100644 --- a/diff-containers/test/Test/Data/Map/Diff/Strict.hs +++ b/diff-containers/test/Test/Data/Map/Diff/Strict.hs @@ -77,8 +77,8 @@ prop_diffThenApply m1 m2 = applyDiff m1 (diff m1 m2) === m2 -- other words, we can normalise the diff history further by cancelling out the -- diff entries. If so, we can conclude that the input diff history is not in -- normal form. -isNormal :: (Foldable t, Eq v) => UnsafeDiffHistory t v -> Bool -isNormal (UnsafeDiffHistory vs) = +isNormal :: Eq v => DiffHistory v -> Bool +isNormal (DiffHistory vs) = snd $ foldl' f (Nothing, True) vs where f (prevMay, b) cur = case prevMay of @@ -101,13 +101,13 @@ deriving newtype instance (Ord k, Eq v, Arbitrary k, Arbitrary v) instance (Arbitrary v, Eq v) => Arbitrary (NEDiffHistory v) where arbitrary = (NEDiffHistory <$> ((:<||) <$> arbitrary <*> arbitrary)) - `suchThat` (\(MkNEDiffHistory h) -> isNormal h) + `suchThat` (isNormal . toDiffHistory) shrink (NEDiffHistory h) = fmap NEDiffHistory $ mapMaybe NESeq.nonEmptySeq $ shrink (NESeq.toSeq h) instance (Arbitrary v, Eq v) => Arbitrary (DiffHistory v) where arbitrary = (DiffHistory <$> arbitrary) - `suchThat` (\(MkDiffHistory h) -> isNormal h) + `suchThat` isNormal shrink (DiffHistory s) = DiffHistory <$> shrink s instance Arbitrary v => Arbitrary (DiffEntry v) where From 2d4edb44b27b0c5d36d41136c2507721db637a6d Mon Sep 17 00:00:00 2001 From: Joris Date: Wed, 1 Feb 2023 13:41:31 +0100 Subject: [PATCH 2/2] Process PR comments: improve haddock comment. --- diff-containers/src/Data/Sequence/NonEmpty/Extra.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/diff-containers/src/Data/Sequence/NonEmpty/Extra.hs b/diff-containers/src/Data/Sequence/NonEmpty/Extra.hs index fd1e5ea..04c0988 100644 --- a/diff-containers/src/Data/Sequence/NonEmpty/Extra.hs +++ b/diff-containers/src/Data/Sequence/NonEmpty/Extra.hs @@ -6,7 +6,7 @@ import Data.Foldable import Data.Sequence.NonEmpty import NoThunks.Class --- | Instance for @'NESeq'@ checks elements only +-- | Instance for @'NESeq'@ which only checks for thunks on the elements -- -- The internal fingertree in @'NESeq'@ might have thunks, which is essential for -- its asymptotic complexity.