@@ -0,0 +1,120 @@
1+{-# LANGUAGE FlexibleContexts #-}
2+{-# LANGUAGE FlexibleInstances #-}
3+{-# LANGUAGE LambdaCase #-}
4+{-# LANGUAGE MultiParamTypeClasses #-}
5+{-# LANGUAGE PolyKinds #-}
6+{-# LANGUAGE Rank2Types #-}
7+{-# LANGUAGE ScopedTypeVariables #-}
8+{-# LANGUAGE StandaloneDeriving #-}
9+{-# LANGUAGE TypeApplications #-}
10+{-# LANGUAGE TypeFamilies #-}
11+{-# LANGUAGE UndecidableInstances #-}
12+
13+{-# OPTIONS_GHC -Wall #-}
14+
15+-- | 'Patch'es on 'DMap' that consist only of insertions (or overwrites) and deletions.
16+module Data.Patch.DMapWithReset where
17+
18+import Data.Patch.Class
19+
20+import Data.Dependent.Map (DMap, GCompare (..))
21+import qualified Data.Dependent.Map as DMap
22+import Data.Semigroup (Semigroup (..))
23+import Data.Constraint.Extras
24+
25+-- | A set of changes to a 'DMap'. Any element may be inserted/updated or deleted.
26+-- Insertions are represented as @'ComposeMaybe' (Just value)@,
27+-- while deletions are represented as @'ComposeMaybe' Nothing@.
28+newtype PatchDMapWithReset k p = PatchDMapWithReset { unPatchDMapWithReset :: DMap k (By p) }
29+
30+-- | Holds the information about each key: where its new value should come from,
31+-- and where its old value should go to
32+data By p a
33+ = By_Insert (PatchTarget (p a)) -- ^ Insert the given value here
34+ | By_Delete -- ^ Delete the existing value, if any, from here
35+ | By_Patch (p a) -- ^ Patch the value here with the given patch
36+
37+instance (Semigroup (p a), Patch (p a)) => Semigroup (By p a) where
38+ x@(By_Insert _) <> _ = x
39+ By_Delete <> _ = By_Delete
40+ By_Patch x <> By_Insert y = By_Insert (applyAlways x y)
41+ By_Patch x <> By_Patch y = By_Patch (x <> y)
42+ By_Patch _ <> By_Delete = By_Delete
43+
44+instance (Monoid (p a), Patch (p a)) => Monoid (By p a) where
45+ mappend = (<>)
46+ mempty = By_Patch mempty
47+
48+instance
49+ ( GCompare k
50+ , Has' Semigroup k p
51+ , Has' Patch k p
52+ )
53+ => Semigroup (PatchDMapWithReset k p) where
54+ PatchDMapWithReset xs <> PatchDMapWithReset ys = PatchDMapWithReset $ DMap.unionWithKey
55+ (\k -> has' @Patch @p k
56+ $ has' @Semigroup @p k
57+ $ (<>)) xs ys
58+
59+instance
60+ ( GCompare k
61+ , Has' Semigroup k p
62+ , Has' Patch k p
63+ )
64+ => Monoid (PatchDMapWithReset k p) where
65+ mappend = (<>)
66+ mempty = PatchDMapWithReset DMap.empty
67+
68+class (Patch (p a), PatchTarget (p a) ~ Patches1LocallyTarget p a) => Patches1Locally p a where
69+ type Patches1LocallyTarget p :: k -> *
70+
71+data These1 f g x
72+ = This1 (f x)
73+ | That1 (g x)
74+ | These1 (f x) (g x)
75+
76+mergeWithKey
77+ :: forall k v1 v2 v.
78+ (GCompare k)
79+ => (forall x. k x -> v1 x -> Maybe (v x))
80+ -> (forall x. k x -> v2 x -> Maybe (v x))
81+ -> (forall x. k x -> v1 x -> v2 x -> Maybe (v x))
82+ -> DMap k v1 -> DMap k v2 -> DMap k v
83+mergeWithKey f g fg = \xs ys -> DMap.mapMaybeWithKey onlyThat $ DMap.unionWithKey doIt (DMap.map This1 xs) (DMap.map That1 ys)
84+ where
85+ doIt _ (This1 xs) (That1 ys) = These1 xs ys
86+ doIt _ _ _ = error "mergeWithKey misalligned keys"
87+
88+ onlyThat :: forall x. k x -> These1 v1 v2 x -> Maybe (v x)
89+ onlyThat k = \case
90+ This1 xs -> f k xs
91+ That1 ys -> g k ys
92+ These1 xs ys -> fg k xs ys
93+{-# INLINE mergeWithKey #-}
94+
95+-- | Apply the insertions or deletions to a given 'DMap'.
96+instance (GCompare k, Has (Patches1Locally p) k) => Patch (PatchDMapWithReset k p) where
97+
98+ type PatchTarget (PatchDMapWithReset k p) = DMap k (Patches1LocallyTarget p)
99+
100+ apply = go
101+ where
102+ go :: PatchDMapWithReset k p -> DMap k (Patches1LocallyTarget p) -> Maybe (DMap k (Patches1LocallyTarget p))
103+ go (PatchDMapWithReset diff) old = Just $! mergeWithKey (\_ -> Just) inserts updates old diff
104+ where
105+ updates :: forall x. k x -> Patches1LocallyTarget p x -> By p x -> Maybe (Patches1LocallyTarget p x)
106+ updates k ys = has @(Patches1Locally p) k $ \case
107+ By_Insert x -> Just x
108+ By_Delete -> Nothing
109+ By_Patch x -> Just $ applyAlways x ys
110+
111+ inserts :: forall x. k x -> By p x -> Maybe (Patches1LocallyTarget p x)
112+ inserts k = has @(Patches1Locally p) k $ \case
113+ By_Insert x -> Just x
114+ By_Delete -> Nothing
115+ By_Patch _ -> Nothing
116+
117+deriving instance (Patch (p a), Eq (p a), Eq (PatchTarget (p a))) => Eq (By p a)
118+deriving instance (Patch (p a), Show (p a), Show (PatchTarget (p a))) => Show (By p a)
119+deriving instance (Eq (DMap k (By p))) => Eq (PatchDMapWithReset k p)
120+deriving instance (Show (DMap k (By p))) => Show (PatchDMapWithReset k p)