Merge pull request #48 from reflex-frp/ryantrinkle/fix-fixups

Fix an exception that occurs when mappending certain `PatchMapWithPatchingMove`s

Author: ali-abrar

.github/workflows/haskell.yml

@@ -5,15 +5,10 @@ on: [push, pull_request]
 jobs:
   build:
     strategy:
+      fail-fast: false
       matrix:
-        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']
         os: ['ubuntu-latest', 'macos-latest']
-        exclude:
-          # There are some linker warnings in 802 on darwin that
-          # cause compilation to fail
-          # See https://github.com/NixOS/nixpkgs/issues/25139
-          - ghc: '8.0.2'
-            os: 'macos-latest'
     runs-on: ${{ matrix.os }}
 
     name: GHC ${{ matrix.ghc }} on ${{ matrix.os }}
@@ -42,6 +37,7 @@ jobs:
     - name: Build
       run: cabal build --enable-tests --enable-benchmarks all
     - name: Run tests
-      run: cabal test --enable-tests all
+      # We don't run hlint tests, because different versions of hlint have different suggestions, and we don't want to worry about satisfying them all.
+      run: cabal test --enable-tests -f-hlint all
     - name: Build Docs
       run: cabal haddock

ChangeLog.md

@@ -1,5 +1,11 @@
 # Revision history for patch
 
+## Unreleased
+
+* 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

dep/reflex-platform/github.json

@@ -3,6 +3,6 @@
   "repo": "reflex-platform",
   "branch": "develop",
   "private": false,
-  "rev": "ac66356c8839d1dc16cc60887c2db5988a60e6c4",
-  "sha256": "0zk8pf72lid6cqq4mlr1mcwh6zd5lz9i83kw519aci6mfba1afvq"
+  "rev": "34c75631e7f2dd1409847b9df57252b96737e73a",
+  "sha256": "1nwyybjy65b7qnb62wcm74nqfndr8prr2xsfvaianps0yzm366d0"
 }

dep/reflex-platform/thunk.nix

@@ -2,7 +2,10 @@
 let fetch = { private ? false, fetchSubmodules ? false, owner, repo, rev, sha256, ... }:
   if !fetchSubmodules && !private then builtins.fetchTarball {
     url = "https://github.com/${owner}/${repo}/archive/${rev}.tar.gz"; inherit sha256;
-  } else (import <nixpkgs> {}).fetchFromGitHub {
+  } else (import (builtins.fetchTarball {
+  url = "https://github.com/NixOS/nixpkgs/archive/3aad50c30c826430b0270fcf8264c8c41b005403.tar.gz";
+  sha256 = "0xwqsf08sywd23x0xvw4c4ghq0l28w2ki22h0bdn766i16z9q2gr";
+}) {}).fetchFromGitHub {
     inherit owner repo rev sha256 fetchSubmodules private;
   };
   json = builtins.fromJSON (builtins.readFile ./github.json);

patch.cabal

@@ -22,14 +22,18 @@ extra-source-files:
   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
   description: Use split these/semialign packages
   manual:      False
   default:     True
 
+flag hlint
+  description: Enable hlint test
+  default:     True
+
 library
   hs-source-dirs: src
   default-language: Haskell2010
@@ -95,7 +99,7 @@ test-suite hlint
                , 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

@@ -61,8 +61,10 @@ instance
 #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

@@ -12,9 +12,13 @@ module Data.Patch.Class where
 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.
@@ -41,6 +45,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
 -- apply patches right-to-left, like '(.)'.

src/Data/Patch/MapWithPatchingMove.hs

@@ -23,6 +23,7 @@ module Data.Patch.MapWithPatchingMove
   , patchMapWithPatchingMoveInsertAll
   , insertMapKey
   , moveMapKey
+  , patchMapKey
   , swapMapKey
   , deleteMapKey
   , unsafePatchMapWithPatchingMove
@@ -135,6 +136,18 @@ moveMapKey src dst
         , (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 @@ instance ( Ord k
          , 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

@@ -1,28 +1,44 @@
+{-# 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 )
 import Hedgehog.Range as Range ( linear )
 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