@@ -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 #-}
13+{-# OPTIONS_GHC -Wall #-}
15+-- | 'Patch'es on 'DMap' that consist only of insertions (or overwrites) and deletions.
16+module Data.Patch.DMapWithReset where
18+import Data.Patch.Class
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
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) }
30+-- | Holds the information about each key: where its new value should come from,
31+-- and where its old value should go to
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
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
44+instance (Monoid (p a), Patch (p a)) => Monoid (By p a) where
46+ mempty = By_Patch mempty
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
64+ => Monoid (PatchDMapWithReset k p) where
66+ mempty = PatchDMapWithReset DMap.empty
68+class (Patch (p a), PatchTarget (p a) ~ Patches1LocallyTarget p a) => Patches1Locally p a where
69+ type Patches1LocallyTarget p :: 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)
85+ doIt _ (This1 xs) (That1 ys) = These1 xs ys
86+ doIt _ _ _ = error "mergeWithKey misalligned keys"
88+ onlyThat :: forall x. k x -> These1 v1 v2 x -> Maybe (v x)
92+ These1 xs ys -> fg k xs ys
93+{-# INLINE mergeWithKey #-}
95+-- | Apply the insertions or deletions to a given 'DMap'.
96+instance (GCompare k, Has (Patches1Locally p) k) => Patch (PatchDMapWithReset k p) where
98+ type PatchTarget (PatchDMapWithReset k p) = DMap k (Patches1LocallyTarget p)
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
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
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
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)