git.iko.soy/patch
on patch-dmap-reset help sign in
patch/src/Data/Patch/DMapWithReset.hs
120 lines 4.4 kB history raw
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.
16module Data.Patch.DMapWithReset where
18import Data.Patch.Class
20import Data.Dependent.Map (DMap, GCompare (..))
21import qualified Data.Dependent.Map as DMap
22import Data.Semigroup (Semigroup (..))
23import 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@.
28newtype 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
32data 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
37instance (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
44instance (Monoid (p a), Patch (p a)) => Monoid (By p a) where
45 mappend = (<>)
46 mempty = By_Patch mempty
48instance
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
59instance
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
68class (Patch (p a), PatchTarget (p a) ~ Patches1LocallyTarget p a) => Patches1Locally p a where
69 type Patches1LocallyTarget p :: k -> *
71data These1 f g x
72 = This1 (f x)
73 | That1 (g x)
74 | These1 (f x) (g x)
76mergeWithKey
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
83mergeWithKey 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"
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 #-}
95-- | Apply the insertions or deletions to a given 'DMap'.
96instance (GCompare k, Has (Patches1Locally p) k) => Patch (PatchDMapWithReset k p) where
98 type PatchTarget (PatchDMapWithReset k p) = DMap k (Patches1LocallyTarget p)
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
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
117deriving instance (Patch (p a), Eq (p a), Eq (PatchTarget (p a))) => Eq (By p a)
118deriving instance (Patch (p a), Show (p a), Show (PatchTarget (p a))) => Show (By p a)
119deriving instance (Eq (DMap k (By p))) => Eq (PatchDMapWithReset k p)
120deriving instance (Show (DMap k (By p))) => Show (PatchDMapWithReset k p)