@@ -1,122 +0,0 @@
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) => PatchHet (PatchDMapWithReset k p) where
97−
98− type PatchSource (PatchDMapWithReset k p) = DMap k (Patches1LocallyTarget p)
99− type PatchTarget (PatchDMapWithReset k p) = DMap k (Patches1LocallyTarget p)
100−
101−instance (GCompare k, Has (Patches1Locally p) k) => Patch (PatchDMapWithReset k p) where
102− apply = go
103− where
104− go :: PatchDMapWithReset k p -> DMap k (Patches1LocallyTarget p) -> Maybe (DMap k (Patches1LocallyTarget p))
105− go (PatchDMapWithReset diff) old = Just $! mergeWithKey (\_ -> Just) inserts updates old diff
106− where
107− updates :: forall x. k x -> Patches1LocallyTarget p x -> By p x -> Maybe (Patches1LocallyTarget p x)
108− updates k ys = has @(Patches1Locally p) k $ \case
109− By_Insert x -> Just x
110− By_Delete -> Nothing
111− By_Patch x -> Just $ applyAlways x ys
112−
113− inserts :: forall x. k x -> By p x -> Maybe (Patches1LocallyTarget p x)
114− inserts k = has @(Patches1Locally p) k $ \case
115− By_Insert x -> Just x
116− By_Delete -> Nothing
117− By_Patch _ -> Nothing
118−
119−deriving instance (Patch (p a), Eq (p a), Eq (PatchTarget (p a))) => Eq (By p a)
120−deriving instance (Patch (p a), Show (p a), Show (PatchTarget (p a))) => Show (By p a)
121−deriving instance (Eq (DMap k (By p))) => Eq (PatchDMapWithReset k p)
122−deriving instance (Show (DMap k (By p))) => Show (PatchDMapWithReset k p)