patch 0.0.7.0 → 0.0.8.0
raw patch · 6 files changed
+119/−34 lines, 6 filesdep ~constraints-extras
Dependency ranges changed: constraints-extras
Files
- ChangeLog.md +6/−0
- patch.cabal +8/−4
- src/Data/Monoid/DecidablyEmpty.hs +4/−2
- src/Data/Patch/Class.hs +13/−1
- src/Data/Patch/MapWithPatchingMove.hs +67/−22
- test/tests.hs +21/−5
ChangeLog.md view
@@ -1,5 +1,11 @@ # Revision history for patch +## 0.0.8.0 - 2022-12-09++* Drop support for GHC 8.0 and 8.2. It may still be possible to use this library with those versions of GHC, but we do not guarantee or test it anymore.+* Fix an issue where (<>) crashed for some `PatchMapWithPatchingMove`s.+* Change `DecidablyEmpty` for `Sum` and `Product` to use `Num` and `Eq` rather than delegating to the argument type's `DecidablyEmpty` class. Since `Sum` and `Product` have `Monoid` actions and units that are inherently based on `Num`, it makes sense to have a `DecidablyEmpty` instances that inherently agree with that. Also, since `Int` and other numeric types don't have (and can't reasonably have) `DecidablyEmpty` instances, this is necessary to make them actually usable in this context.+ ## 0.0.7.0 - 2022-06-23 * Use `commutative-semigroups` for `Commutative`, making `Additive` a
patch.cabal view
@@ -1,5 +1,5 @@ Name: patch-Version: 0.0.7.0+Version: 0.0.8.0 Synopsis: Data structures for describing changes to other data structures. Description: Data structures for describing changes to other data structures.@@ -22,7 +22,7 @@ ChangeLog.md tested-with:- GHC ==8.0.2 || ==8.2.2 || ==8.4.4 || ==8.6.5 || ==8.8.4 || ==8.10.7 || ==9.0.1 || ==9.2.2+ GHC ==8.4.4 || ==8.6.5 || ==8.8.4 || ==8.10.7 || ==9.0.1 || ==9.2.2 GHCJS ==8.4 flag split-these@@ -30,11 +30,15 @@ manual: False default: True +flag hlint+ description: Enable hlint test+ default: True+ library hs-source-dirs: src default-language: Haskell2010 build-depends: base >= 4.9 && < 4.17- , constraints-extras >= 0.3 && < 0.4+ , constraints-extras >= 0.3 && < 0.5 , commutative-semigroups >= 0.0 && < 0.2 , containers >= 0.6 && < 0.7 , dependent-map >= 0.3 && < 0.5@@ -95,7 +99,7 @@ , filepath , filemanip , hlint (< 2.1 || >= 2.2.2) && < 3.5- if impl(ghcjs)+ if impl(ghcjs) || !flag(hlint) buildable: False source-repository head
src/Data/Monoid/DecidablyEmpty.hs view
@@ -61,8 +61,10 @@ #endif => DecidablyEmpty (Maybe a) where isEmpty = isNothing-deriving instance (Num a, DecidablyEmpty a) => DecidablyEmpty (Product a)-deriving instance (DecidablyEmpty a, Num a) => DecidablyEmpty (Sum a)+instance (Num a, Eq a) => DecidablyEmpty (Product a) where+ isEmpty = (== 1)+instance (Num a, Eq a) => DecidablyEmpty (Sum a) where+ isEmpty = (== 0) deriving instance DecidablyEmpty a => DecidablyEmpty (Dual a) instance DecidablyEmpty (First a) where isEmpty (First a) = isNothing a
src/Data/Patch/Class.hs view
@@ -12,9 +12,13 @@ import Data.Functor.Identity import Data.Kind (Type) import Data.Maybe+import Data.Semigroup+ ( Sum (..)+ , Product (..) #if !MIN_VERSION_base(4,11,0)-import Data.Semigroup (Semigroup(..))+ , Semigroup(..) #endif+ ) import Data.Proxy -- | A 'Patch' type represents a kind of change made to a datastructure.@@ -40,6 +44,14 @@ instance forall (a :: Type). Patch (Proxy a) where type PatchTarget (Proxy a) = a apply ~Proxy _ = Nothing++instance (Num a, Eq a) => Patch (Sum a) where+ type PatchTarget (Sum a) = a+ apply (Sum a) b = if a == 0 then Nothing else Just $ a + b++instance (Num a, Eq a) => Patch (Product a) where+ type PatchTarget (Product a) = a+ apply (Product a) b = if a == 1 then Nothing else Just $ a * b -- | Like '(.)', but composes functions that return patches rather than -- functions that return new values. The Semigroup instance for patches must
src/Data/Patch/MapWithPatchingMove.hs view
@@ -23,6 +23,7 @@ , patchMapWithPatchingMoveInsertAll , insertMapKey , moveMapKey+ , patchMapKey , swapMapKey , deleteMapKey , unsafePatchMapWithPatchingMove@@ -135,6 +136,18 @@ , (src, NodeInfo From_Delete (Just dst)) ] +patchMapKey+ :: ( DecidablyEmpty p+#if !MIN_VERSION_base(4,11,0)+ , Semigroup p+#endif+ )+ => k -> p -> PatchMapWithPatchingMove k p+patchMapKey k p+ | isEmpty p = PatchMapWithPatchingMove Map.empty+ | otherwise =+ PatchMapWithPatchingMove $ Map.singleton k $ NodeInfo (From_Move k p) (Just k)+ -- |Make a @'PatchMapWithPatchingMove' k p@ which has the effect of swapping two keys in the mapping, equivalent to: -- -- @@@ -369,46 +382,78 @@ , DecidablyEmpty p , Patch p ) => Semigroup (PatchMapWithPatchingMove k p) where- PatchMapWithPatchingMove ma <> PatchMapWithPatchingMove mb = PatchMapWithPatchingMove m+ PatchMapWithPatchingMove mNew <> PatchMapWithPatchingMove mOld = PatchMapWithPatchingMove m where- connections = Map.toList $ Map.intersectionWithKey (\_ a b -> (_nodeInfo_to a, _nodeInfo_from b)) ma mb- h :: (k, (Maybe k, From k p)) -> [(k, Fixup k p)]- h (_, (mToAfter, editBefore)) = case (mToAfter, editBefore) of+ connections = Map.elems $ Map.intersectionWithKey (\_ new old -> (_nodeInfo_to new, _nodeInfo_from old)) mNew mOld+ h :: (Maybe k, From k p) -> [(k, Fixup k p)]+ h = \case (Just toAfter, From_Move fromBefore p) | fromBefore == toAfter && isEmpty p- -> [(toAfter, Fixup_Delete)]+ -> [ (toAfter, Fixup_Delete)+ ] | otherwise- -> [ (toAfter, Fixup_Update (This editBefore))- , (fromBefore, Fixup_Update (That mToAfter))+ -> [ (toAfter, Fixup_Update (This (From_Move fromBefore p)))+ , (fromBefore, Fixup_Update (That (Just toAfter))) ]- (Nothing, From_Move fromBefore _) -> [(fromBefore, Fixup_Update (That mToAfter))] -- The item is destroyed in the second patch, so indicate that it is destroyed in the source map- (Just toAfter, _) -> [(toAfter, Fixup_Update (This editBefore))]+ (Nothing, From_Move fromBefore _) -> [(fromBefore, Fixup_Update (That Nothing))] -- The item is destroyed in the second patch, so indicate that it is destroyed in the source map+ (Just toAfter, editBefore) -> [(toAfter, Fixup_Update (This editBefore))] (Nothing, _) -> []- mergeFixups _ Fixup_Delete Fixup_Delete = Fixup_Delete- mergeFixups _ (Fixup_Update a) (Fixup_Update b)+ mergeFixups Fixup_Delete Fixup_Delete = Fixup_Delete+ mergeFixups (Fixup_Update a) (Fixup_Update b) | This x <- a, That y <- b = Fixup_Update $ These x y | That y <- a, This x <- b = Fixup_Update $ These x y- mergeFixups _ _ _ = error "PatchMapWithPatchingMove: incompatible fixups"- fixups = Map.fromListWithKey mergeFixups $ concatMap h connections- combineNodeInfos _ nia nib = NodeInfo- { _nodeInfo_from = _nodeInfo_from nia- , _nodeInfo_to = _nodeInfo_to nib+ mergeFixups _ _ = error "PatchMapWithPatchingMove: incompatible fixups"+ fixups = Map.fromListWithKey (\_ -> mergeFixups) $ concatMap h connections+ combineNodeInfos niNew niOld = NodeInfo+ { _nodeInfo_from = _nodeInfo_from niNew+ , _nodeInfo_to = _nodeInfo_to niOld }- applyFixup _ ni = \case+ applyFixup ni = \case Fixup_Delete -> Nothing Fixup_Update u -> Just $ NodeInfo { _nodeInfo_from = case _nodeInfo_from ni of- f@(From_Move _ p') -> case getHere u of -- The `from` fixup comes from the "old" patch- Nothing -> f -- If there's no `from` fixup, just use the "new" `from`+ -- The new patch has a Move, so it could be affected by the+ -- corresponding From in the old patch. If that From exists, then+ -- it is in the fixup here.+ f@(From_Move _ p') -> case getHere u of+ -- If there's no `From` fixup, just use the "new" `From`+ Nothing -> f+ -- If there's a `From` fixup which is an Insert, we can just apply+ -- our patch to that and turn ourselves into an insert. Just (From_Insert v) -> From_Insert $ applyAlways p' v+ -- If there's a `From` fixup which is a Delete, then we can throw+ -- our patch away because there's nothing to apply it to and+ -- become a Delete ourselves. Just From_Delete -> From_Delete+ -- If there's a `From` fixup which is a Move, we need to apply+ -- both the old patch and the new patch (in that order) to the+ -- value, so we append the patches here. Just (From_Move oldKey p) -> From_Move oldKey $ p' <> p- _ -> error "PatchMapWithPatchingMove: fixup for non-move From"- , _nodeInfo_to = fromMaybe (_nodeInfo_to ni) $ getThere u+ -- If the new patch has an Insert, it doesn't care what the fixup+ -- value is, because it will overwrite it anyway.+ f@(From_Insert _) -> f+ -- If the new patch has an Delete, it doesn't care what the fixup+ -- value is, because it will overwrite it anyway.+ f@From_Delete -> f+ , _nodeInfo_to = case _nodeInfo_to ni of+ -- The old patch deletes this data, so we must delete it as well.+ -- According to the code above, any time we have this situation we+ -- should also have `getThere u == Nothing` because a fixup+ -- shouldn't be generated.+ Nothing -> Nothing+ -- The old patch sends the value to oldToAfter+ Just oldToAfter -> case getThere u of+ -- If there is no fixup, that should mean that the new patch+ -- doesn't do anything with the value in oldToAfter, so we still+ -- send it to oldToAfter+ Nothing -> Just oldToAfter+ -- If there is a fixup, it should tell us where the new patch+ -- sends the value at key oldToAfter. We send our value there.+ Just mNewToAfter -> mNewToAfter }- m = Map.differenceWithKey applyFixup (Map.unionWithKey combineNodeInfos ma mb) fixups+ m = Map.differenceWithKey (\_ -> applyFixup) (Map.unionWith combineNodeInfos mNew mOld) fixups getHere :: These a b -> Maybe a getHere = \case This a -> Just a
test/tests.hs view
@@ -1,9 +1,12 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE TemplateHaskell #-} module Main where import Test.HUnit (runTestTT, (~:), assertEqual, errors, failures, test) import Data.Patch ( Patch(apply) ) import Data.Patch.MapWithMove ( patchThatChangesMap )+import Data.Patch.MapWithPatchingMove (PatchMapWithPatchingMove)+import qualified Data.Patch.MapWithPatchingMove as PatchMapWithPatchingMove import Data.Map as Map ( Map, fromList, singleton ) import Hedgehog (checkParallel, discover, Property, property, forAll, PropertyT, (===)) import Hedgehog.Gen as Gen ( int )@@ -11,18 +14,31 @@ import Control.Monad (replicateM) import System.Exit (exitFailure, exitSuccess) import Data.Sequence as Seq ( foldMapWithIndex, replicateM )+import Data.Semigroup+ ( Sum (..)+#if !MIN_VERSION_base(4,11,0)+ , Semigroup(..)+#endif+ ) main :: IO () main = do- counts <- runTestTT $ test [- "Simple Move" ~: (do+ counts <- runTestTT $ test+ [ "Simple Move" ~: do let mapBefore = Map.fromList [(0,1)] mapAfter = Map.fromList [(0,0),(1,1)] patch = patchThatChangesMap mapBefore mapAfter afterPatch = apply patch mapBefore- assertEqual "Patch creates the same Map" (Just mapAfter) afterPatch),- "Property Checks" ~: propertyChecks- ]+ assertEqual "Patch creates the same Map" (Just mapAfter) afterPatch+ , "Property Checks" ~: propertyChecks+ , "Insert and Patch" ~: do+ let i :: PatchMapWithPatchingMove () (Sum Int)+ i = PatchMapWithPatchingMove.insertMapKey () 1+ p = PatchMapWithPatchingMove.patchMapKey () (Sum 2)+ pAfterI = PatchMapWithPatchingMove.insertMapKey () 3+ assertEqual "Insert after patch is the same as insert" (i <> p) i+ assertEqual "Patch after insert is a patched insert" (p <> i) pAfterI+ ] if errors counts + failures counts == 0 then exitSuccess else exitFailure propertyChecks :: IO Bool