git.iko.soy/patch
on 70f445a help sign in
patch/src/Reflex/Patch/DMapWithMove.hs
281 lines 13 kB history raw
1{-# LANGUAGE CPP #-}
2{-# LANGUAGE FlexibleContexts #-}
3{-# LANGUAGE FlexibleInstances #-}
4{-# LANGUAGE GADTs #-}
5{-# LANGUAGE LambdaCase #-}
6{-# LANGUAGE MultiParamTypeClasses #-}
7{-# LANGUAGE PatternGuards #-}
8{-# LANGUAGE PolyKinds #-}
9{-# LANGUAGE Rank2Types #-}
10{-# LANGUAGE ScopedTypeVariables #-}
11{-# LANGUAGE TypeFamilies #-}
12{-# LANGUAGE UndecidableInstances #-}
13module Reflex.Patch.DMapWithMove where
15import Reflex.Patch.Class
16import Reflex.Patch.MapWithMove (PatchMapWithMove (..))
17import qualified Reflex.Patch.MapWithMove as MapWithMove
19import Data.Dependent.Map (DMap, DSum (..), GCompare (..))
20import qualified Data.Dependent.Map as DMap
21import Data.Dependent.Sum (EqTag (..))
22import Data.Functor.Constant
23import Data.Functor.Misc
24import Data.Functor.Product
25import Data.GADT.Compare (GEq (..))
26import qualified Data.Map as Map
27import Data.Maybe
28import Data.Semigroup (Semigroup (..), (<>))
29import Data.Some (Some)
30import qualified Data.Some as Some
31import Data.These
33#ifdef EXPERIMENTAL_DEPENDENT_SUM_INSTANCES
34import Data.Dependent.Sum (ShowTag (..))
35import Data.GADT.Show (GShow (..))
36import Data.Typeable (Proxy (..))
37#endif
39-- | Like 'PatchMapWithMove', but for 'DMap'.
40data PatchDMapWithMove k v = PatchDMapWithMove (DMap k (NodeInfo k v))
41#ifdef EXPERIMENTAL_DEPENDENT_SUM_INSTANCES
42 deriving (Show)
43#endif
45data NodeInfo k v a = NodeInfo
46 { _nodeInfo_from :: !(From k v a)
47 , _nodeInfo_to :: !(To k a)
48 }
49 deriving (Show)
51#ifdef EXPERIMENTAL_DEPENDENT_SUM_INSTANCES
52instance {-# INCOHERENT #-} (GShow k, ShowTag k v) => ShowTag k (NodeInfo k v) where
53 showTagToShow k _ r = gshowToShow k $ showTagToShow k (Proxy :: Proxy v) r
55instance {-# INCOHERENT #-} (GEq k, EqTag k v) => EqTag k (From k v) where
56 eqTagToEq k _ r = eqTagToEq k (Proxy :: Proxy v) (geqToEq k r)
57#endif
59data From (k :: a -> *) (v :: a -> *) :: a -> * where
60 From_Insert :: v a -> From k v a
61 From_Delete :: From k v a
62 From_Move :: !(k a) -> From k v a
63 deriving (Show, Read, Eq, Ord)
65type To = ComposeMaybe
67validPatchDMapWithMove :: forall k v. (GCompare k, EqTag k (ComposeMaybe k)) => PatchDMapWithMove k v -> Bool
68validPatchDMapWithMove (PatchDMapWithMove m) = src == srcFromDst
69 where
70 src = DMap.map _nodeInfo_to m
71 dst = DMap.map _nodeInfo_from m
72 srcFromDst :: DMap k (ComposeMaybe k)
73 srcFromDst = DMap.fromList $ flip fmap (DMap.toList dst) $ \(to :=> edit) -> case edit of
74 From_Move from -> from :=> ComposeMaybe (Just to)
75 _ -> to :=> ComposeMaybe Nothing
77instance EqTag k (NodeInfo k v) => Eq (PatchDMapWithMove k v) where
78 PatchDMapWithMove a == PatchDMapWithMove b = a == b
80data Pair1 f g a = Pair1 (f a) (g a)
82instance GCompare k => Semigroup (PatchDMapWithMove k v) where
83 (<>) = mappend
85data Fixup k v a
86 = Fixup_Delete
87 | Fixup_Update (These (From k v a) (To k a))
89instance GCompare k => Monoid (PatchDMapWithMove k v) where
90 mempty = PatchDMapWithMove mempty
91 PatchDMapWithMove ma `mappend` PatchDMapWithMove mb = PatchDMapWithMove m
92 where
93 connections = DMap.toList $ DMap.intersectionWithKey (\_ a b -> Pair1 (_nodeInfo_to a) (_nodeInfo_from b)) ma mb
94 h :: DSum k (Pair1 (ComposeMaybe k) (From k v)) -> [DSum k (Fixup k v)]
95 h (_ :=> Pair1 (ComposeMaybe mToAfter) editBefore) = case (mToAfter, editBefore) of
96 (Just toAfter, From_Move fromBefore)
97 | isJust $ fromBefore `geq` toAfter
98 -> [toAfter :=> Fixup_Delete]
99 | otherwise
100 -> [ toAfter :=> Fixup_Update (This editBefore)
101 , fromBefore :=> Fixup_Update (That (ComposeMaybe mToAfter))
102 ]
103 (Nothing, From_Move fromBefore) -> [fromBefore :=> Fixup_Update (That (ComposeMaybe mToAfter))] -- The item is destroyed in the second patch, so indicate that it is destroyed in the source map
104 (Just toAfter, _) -> [toAfter :=> Fixup_Update (This editBefore)]
105 (Nothing, _) -> []
106 mergeFixups _ Fixup_Delete Fixup_Delete = Fixup_Delete
107 mergeFixups _ (Fixup_Update a) (Fixup_Update b)
108 | This x <- a, That y <- b
109 = Fixup_Update $ These x y
110 | That y <- a, This x <- b
111 = Fixup_Update $ These x y
112 mergeFixups _ _ _ = error "PatchDMapWithMove: incompatible fixups"
113 fixups = DMap.fromListWithKey mergeFixups $ concatMap h connections
114 combineNodeInfos _ nia nib = NodeInfo
115 { _nodeInfo_from = _nodeInfo_from nia
116 , _nodeInfo_to = _nodeInfo_to nib
117 }
118 applyFixup _ ni = \case
119 Fixup_Delete -> Nothing
120 Fixup_Update u -> Just $ NodeInfo
121 { _nodeInfo_from = fromMaybe (_nodeInfo_from ni) $ getHere u
122 , _nodeInfo_to = fromMaybe (_nodeInfo_to ni) $ getThere u
123 }
124 m = DMap.differenceWithKey applyFixup (DMap.unionWithKey combineNodeInfos ma mb) fixups
126getHere :: These a b -> Maybe a
127getHere = \case
128 This a -> Just a
129 These a _ -> Just a
130 That _ -> Nothing
132getThere :: These a b -> Maybe b
133getThere = \case
134 This _ -> Nothing
135 These _ b -> Just b
136 That b -> Just b
138{-
139mappendPatchDMapWithMoveSlow :: forall k v. (ShowTag k v, GCompare k) => PatchDMapWithMove k v -> PatchDMapWithMove k v -> PatchDMapWithMove k v
140PatchDMapWithMove dstAfter srcAfter `mappendPatchDMapWithMoveSlow` PatchDMapWithMove dstBefore srcBefore = PatchDMapWithMove dst src
141 where
142 getDstAction k m = fromMaybe (From_Move k) $ DMap.lookup k m -- Any key that isn't present is treated as that key moving to itself
143 removeRedundantDst toKey (From_Move fromKey) | isJust (toKey `geq` fromKey) = Nothing
144 removeRedundantDst _ a = Just a
145 f :: forall a. k a -> From k v a -> Maybe (From k v a)
146 f toKey _ = removeRedundantDst toKey $ case getDstAction toKey dstAfter of
147 From_Move fromKey -> getDstAction fromKey dstBefore
148 nonMove -> nonMove
149 dst = DMap.mapMaybeWithKey f $ DMap.union dstAfter dstBefore
150 getSrcAction k m = fromMaybe (ComposeMaybe $ Just k) $ DMap.lookup k m
151 removeRedundantSrc fromKey (ComposeMaybe (Just toKey)) | isJust (fromKey `geq` toKey) = Nothing
152 removeRedundantSrc _ a = Just a
153 g :: forall a. k a -> ComposeMaybe k a -> Maybe (ComposeMaybe k a)
154 g fromKey _ = removeRedundantSrc fromKey $ case getSrcAction fromKey srcBefore of
155 ComposeMaybe Nothing -> ComposeMaybe Nothing
156 ComposeMaybe (Just toKeyBefore) -> getSrcAction toKeyBefore srcAfter
157 src = DMap.mapMaybeWithKey g $ DMap.union srcAfter srcBefore
158-}
160moveDMapKey :: GCompare k => k a -> k a -> PatchDMapWithMove k v
161moveDMapKey src dst = case src `geq` dst of
162 Nothing -> PatchDMapWithMove $ DMap.fromList
163 [ dst :=> NodeInfo (From_Move src) (ComposeMaybe Nothing)
164 , src :=> NodeInfo From_Delete (ComposeMaybe $ Just dst)
165 ]
166 Just _ -> mempty
168deleteDMapKey :: k a -> PatchDMapWithMove k v
169deleteDMapKey k = PatchDMapWithMove $ DMap.singleton k $ NodeInfo From_Delete $ ComposeMaybe Nothing
171{-
172k1, k2 :: Const2 Int () ()
173k1 = Const2 1
174k2 = Const2 2
175p1, p2 :: PatchDMapWithMove (Const2 Int ()) Identity
176p1 = moveDMapKey k1 k2
177p2 = moveDMapKey k2 k1
178p12 = p1 <> p2
179p21 = p2 <> p1
180p12Slow = p1 `mappendPatchDMapWithMoveSlow` p2
181p21Slow = p2 `mappendPatchDMapWithMoveSlow` p1
183testPatchDMapWithMove = do
184 print p1
185 print p2
186 print $ p12 == deleteDMapKey k1
187 print $ p21 == deleteDMapKey k2
188 print $ p12Slow == deleteDMapKey k1
189 print $ p21Slow == deleteDMapKey k2
191dst (PatchDMapWithMove x _) = x
192src (PatchDMapWithMove _ x) = x
193-}
195unPatchDMapWithMove :: PatchDMapWithMove k v -> DMap k (NodeInfo k v)
196unPatchDMapWithMove (PatchDMapWithMove p) = p
198-- | Warning: when using this function, you must ensure that the invariants of
199-- 'PatchDMapWithMove' are preserved; they will not be checked.
200unsafePatchDMapWithMove :: DMap k (NodeInfo k v) -> PatchDMapWithMove k v
201unsafePatchDMapWithMove = PatchDMapWithMove
203mapPatchDMapWithMove :: forall k v v'. (forall a. v a -> v' a) -> PatchDMapWithMove k v -> PatchDMapWithMove k v'
204mapPatchDMapWithMove f (PatchDMapWithMove p) = PatchDMapWithMove $
205 DMap.map (\ni -> ni { _nodeInfo_from = g $ _nodeInfo_from ni }) p
206 where g :: forall a. From k v a -> From k v' a
207 g = \case
208 From_Insert v -> From_Insert $ f v
209 From_Delete -> From_Delete
210 From_Move k -> From_Move k
212traversePatchDMapWithMove :: forall m k v v'. Applicative m => (forall a. v a -> m (v' a)) -> PatchDMapWithMove k v -> m (PatchDMapWithMove k v')
213traversePatchDMapWithMove f = traversePatchDMapWithMoveWithKey $ const f
215traversePatchDMapWithMoveWithKey :: forall m k v v'. Applicative m => (forall a. k a -> v a -> m (v' a)) -> PatchDMapWithMove k v -> m (PatchDMapWithMove k v')
216traversePatchDMapWithMoveWithKey f (PatchDMapWithMove p) = PatchDMapWithMove <$> DMap.traverseWithKey (nodeInfoMapFromM . g) p
217 where g :: forall a. k a -> From k v a -> m (From k v' a)
218 g k = \case
219 From_Insert v -> From_Insert <$> f k v
220 From_Delete -> pure From_Delete
221 From_Move fromKey -> pure $ From_Move fromKey
223nodeInfoMapFrom :: (From k v a -> From k v' a) -> NodeInfo k v a -> NodeInfo k v' a
224nodeInfoMapFrom f ni = ni { _nodeInfo_from = f $ _nodeInfo_from ni }
226nodeInfoMapFromM :: Functor f => (From k v a -> f (From k v' a)) -> NodeInfo k v a -> f (NodeInfo k v' a)
227nodeInfoMapFromM f ni = fmap (\result -> ni { _nodeInfo_from = result }) $ f $ _nodeInfo_from ni
229weakenPatchDMapWithMoveWith :: forall k v v'. (forall a. v a -> v') -> PatchDMapWithMove k v -> PatchMapWithMove (Some k) v'
230weakenPatchDMapWithMoveWith f (PatchDMapWithMove p) = PatchMapWithMove $ weakenDMapWith g p
231 where g :: forall a. NodeInfo k v a -> MapWithMove.NodeInfo (Some k) v'
232 g ni = MapWithMove.NodeInfo
233 { MapWithMove._nodeInfo_from = case _nodeInfo_from ni of
234 From_Insert v -> MapWithMove.From_Insert $ f v
235 From_Delete -> MapWithMove.From_Delete
236 From_Move k -> MapWithMove.From_Move $ Some.This k
237 , MapWithMove._nodeInfo_to = Some.This <$> getComposeMaybe (_nodeInfo_to ni)
238 }
240patchDMapWithMoveToPatchMapWithMoveWith :: forall k f v v'. (f v -> v') -> PatchDMapWithMove (Const2 k v) f -> PatchMapWithMove k v'
241patchDMapWithMoveToPatchMapWithMoveWith f (PatchDMapWithMove p) = PatchMapWithMove $ dmapToMapWith g p
242 where g :: NodeInfo (Const2 k v) f v -> MapWithMove.NodeInfo k v'
243 g ni = MapWithMove.NodeInfo
244 { MapWithMove._nodeInfo_from = case _nodeInfo_from ni of
245 From_Insert v -> MapWithMove.From_Insert $ f v
246 From_Delete -> MapWithMove.From_Delete
247 From_Move (Const2 k) -> MapWithMove.From_Move k
248 , MapWithMove._nodeInfo_to = unConst2 <$> getComposeMaybe (_nodeInfo_to ni)
249 }
251const2PatchDMapWithMoveWith :: forall k v f a. (v -> f a) -> PatchMapWithMove k v -> PatchDMapWithMove (Const2 k a) f
252const2PatchDMapWithMoveWith f (PatchMapWithMove p) = PatchDMapWithMove $ DMap.fromDistinctAscList $ g <$> Map.toAscList p
253 where g :: (k, MapWithMove.NodeInfo k v) -> DSum (Const2 k a) (NodeInfo (Const2 k a) f)
254 g (k, ni) = Const2 k :=> NodeInfo
255 { _nodeInfo_from = case MapWithMove._nodeInfo_from ni of
256 MapWithMove.From_Insert v -> From_Insert $ f v
257 MapWithMove.From_Delete -> From_Delete
258 MapWithMove.From_Move fromKey -> From_Move $ Const2 fromKey
259 , _nodeInfo_to = ComposeMaybe $ Const2 <$> MapWithMove._nodeInfo_to ni
260 }
262instance GCompare k => Patch (PatchDMapWithMove k v) where
263 type PatchTarget (PatchDMapWithMove k v) = DMap k v
264 apply (PatchDMapWithMove p) old = Just $! insertions `DMap.union` (old `DMap.difference` deletions) --TODO: return Nothing sometimes --Note: the strict application here is critical to ensuring that incremental merges don't hold onto all their prerequisite events forever; can we make this more robust?
265 where insertions = DMap.mapMaybeWithKey insertFunc p
266 insertFunc :: forall a. k a -> NodeInfo k v a -> Maybe (v a)
267 insertFunc _ ni = case _nodeInfo_from ni of
268 From_Insert v -> Just v
269 From_Move k -> DMap.lookup k old
270 From_Delete -> Nothing
271 deletions = DMap.mapMaybeWithKey deleteFunc p
272 deleteFunc :: forall a. k a -> NodeInfo k v a -> Maybe (Constant () a)
273 deleteFunc _ ni = case _nodeInfo_from ni of
274 From_Delete -> Just $ Constant ()
275 _ -> Nothing
277-- | Get the values that will be deleted or moved if the given patch is applied
278-- to the given 'DMap'.
279getDeletionsAndMoves :: GCompare k => PatchDMapWithMove k v -> DMap k v' -> DMap k (Product v' (ComposeMaybe k))
280getDeletionsAndMoves (PatchDMapWithMove p) m = DMap.intersectionWithKey f m p
281 where f _ v ni = Pair v $ _nodeInfo_to ni