git.iko.soy/patch
on 1964a5b help sign in
patch/src/Data/Patch/MapWithMove.hs
243 lines 13 kB history raw
1{-# LANGUAGE FlexibleContexts #-}
2{-# LANGUAGE LambdaCase #-}
3{-# LANGUAGE PatternGuards #-}
4{-# LANGUAGE ScopedTypeVariables #-}
5{-# LANGUAGE StandaloneDeriving #-}
6{-# LANGUAGE TypeFamilies #-}
7{-# LANGUAGE UndecidableInstances #-}
8-- | 'Patch'es on 'Map' that can insert, delete, and move values from one key to
9-- another
10module Reflex.Patch.MapWithMove where
12import Reflex.Patch.Class
14import Control.Arrow
15import Control.Monad.State
16import Data.Foldable
17import Data.Function
18import Data.List
19import Data.Map (Map)
20import qualified Data.Map as Map
21import Data.Maybe
22import Data.Semigroup
23import qualified Data.Set as Set
24import Data.These
25import Data.Tuple
27-- | Patch a DMap with additions, deletions, and moves. Invariant: If key @k1@
28-- is coming from @From_Move k@, then key @k2@ should be going to @Just k1@,
29-- and vice versa. There should never be any unpaired From/To keys.
30newtype PatchMapWithMove k p = PatchMapWithMove (Map k (NodeInfo k p))
31deriving instance (Show k, Show p, Show (PatchTarget p)) => Show (PatchMapWithMove k p)
32deriving instance (Eq k, Eq p, Eq (PatchTarget p)) => Eq (PatchMapWithMove k p)
33deriving instance (Ord k, Ord p, Ord (PatchTarget p)) => Ord (PatchMapWithMove k p)
35-- | Holds the information about each key: where its new value should come from,
36-- and where its old value should go to
37data NodeInfo k p = NodeInfo
38 { _nodeInfo_from :: !(From k p)
39 -- ^ Where do we get the new value for this key?
40 , _nodeInfo_to :: !(To k)
41 -- ^ If the old value is being kept (i.e. moved rather than deleted or
42 -- replaced), where is it going?
43 }
44deriving instance (Show k, Show p, Show (PatchTarget p)) => Show (NodeInfo k p)
45deriving instance (Read k, Read p, Read (PatchTarget p)) => Read (NodeInfo k p)
46deriving instance (Eq k, Eq p, Eq (PatchTarget p)) => Eq (NodeInfo k p)
47deriving instance (Ord k, Ord p, Ord (PatchTarget p)) => Ord (NodeInfo k p)
49-- | Create a 'PatchMapWithMove', validating it
50patchMapWithMove :: Ord k => Map k (NodeInfo k p) -> Maybe (PatchMapWithMove k p)
51patchMapWithMove m = if valid then Just $ PatchMapWithMove m else Nothing
52 where valid = forwardLinks == backwardLinks
53 forwardLinks = Map.mapMaybe _nodeInfo_to m
54 backwardLinks = Map.fromList $ catMaybes $ flip fmap (Map.toList m) $ \(to, p) ->
55 case _nodeInfo_from p of
56 From_Move from _ -> Just (from, to)
57 _ -> Nothing
59-- | Create a 'PatchMapWithMove' that inserts everything in the given 'Map'
60patchMapWithMoveInsertAll :: Map k (PatchTarget p) -> PatchMapWithMove k p
61patchMapWithMoveInsertAll m = PatchMapWithMove $ flip fmap m $ \v -> NodeInfo
62 { _nodeInfo_from = From_Insert v
63 , _nodeInfo_to = Nothing
64 }
66-- | Extract the internal representation of the 'PatchMapWithMove'
67unPatchMapWithMove :: PatchMapWithMove k p -> Map k (NodeInfo k p)
68unPatchMapWithMove (PatchMapWithMove p) = p
70-- | Warning: when using this function, you must ensure that the invariants of
71-- 'PatchMapWithMove' are preserved; they will not be checked.
72unsafePatchMapWithMove :: Map k (NodeInfo k p) -> PatchMapWithMove k p
73unsafePatchMapWithMove = PatchMapWithMove
75-- | Describe how a key's new value should be produced
76data From k p
77 = From_Insert (PatchTarget p) -- ^ Insert the given value here
78 | From_Delete -- ^ Delete the existing value, if any, from here
79 | From_Move !k !p -- ^ Move the value here from the given key, and apply the given patch
81deriving instance (Show k, Show p, Show (PatchTarget p)) => Show (From k p)
82deriving instance (Read k, Read p, Read (PatchTarget p)) => Read (From k p)
83deriving instance (Eq k, Eq p, Eq (PatchTarget p)) => Eq (From k p)
84deriving instance (Ord k, Ord p, Ord (PatchTarget p)) => Ord (From k p)
86-- | Describe where a key's old value will go. If this is 'Just', that means
87-- the key's old value will be moved to the given other key; if it is 'Nothing',
88-- that means it will be deleted.
89type To = Maybe
91-- | Apply the insertions, deletions, and moves to a given 'Map'
92instance (Ord k, Patch p) => Patch (PatchMapWithMove k p) where
93 type PatchTarget (PatchMapWithMove k p) = Map k (PatchTarget p)
94 apply (PatchMapWithMove m) old = Just $! insertions `Map.union` (old `Map.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?
95 where insertions = flip Map.mapMaybeWithKey m $ \_ ni -> case _nodeInfo_from ni of
96 From_Insert v -> Just v
97 From_Move k p -> applyAlways p <$> Map.lookup k old
98 From_Delete -> Nothing
99 deletions = flip Map.mapMaybeWithKey m $ \_ ni -> case _nodeInfo_from ni of
100 From_Delete -> Just ()
101 _ -> Nothing
103-- | Returns all the new elements that will be added to the 'Map'
104patchMapWithMoveNewElements :: PatchMapWithMove k p -> [PatchTarget p]
105patchMapWithMoveNewElements = Map.elems . patchMapWithMoveNewElementsMap
107patchMapWithMoveNewElementsMap :: PatchMapWithMove k p -> Map k (PatchTarget p)
108patchMapWithMoveNewElementsMap (PatchMapWithMove p) = Map.mapMaybe f p
109 where f ni = case _nodeInfo_from ni of
110 From_Insert v -> Just v
111 From_Move _ _ -> Nothing
112 From_Delete -> Nothing
114-- | Create a 'PatchMapWithMove' that, if applied to the given 'Map', will sort
115-- its values using the given ordering function. The set keys of the 'Map' is
116-- not changed.
117patchThatSortsMapWith :: (Ord k, Monoid p) => (PatchTarget p -> PatchTarget p -> Ordering) -> Map k (PatchTarget p) -> PatchMapWithMove k p
118patchThatSortsMapWith cmp m = PatchMapWithMove $ Map.fromList $ catMaybes $ zipWith g unsorted sorted
119 where unsorted = Map.toList m
120 sorted = sortBy (cmp `on` snd) unsorted
121 f (to, _) (from, _) = if to == from then Nothing else
122 Just (from, to)
123 reverseMapping = Map.fromList $ catMaybes $ zipWith f unsorted sorted
124 g (to, _) (from, _) = if to == from then Nothing else
125 let Just movingTo = Map.lookup from reverseMapping
126 in Just (to, NodeInfo (From_Move from mempty) $ Just movingTo)
128-- | Create a 'PatchMapWithMove' that, if applied to the first 'Map' provided,
129-- will produce a 'Map' with the same values as the second 'Map' but with the
130-- values sorted with the given ordering function.
131patchThatChangesAndSortsMapWith :: forall k p. (Ord k, Ord (PatchTarget p), Monoid p) => (PatchTarget p -> PatchTarget p -> Ordering) -> Map k (PatchTarget p) -> Map k (PatchTarget p) -> PatchMapWithMove k p
132patchThatChangesAndSortsMapWith cmp oldByIndex newByIndexUnsorted = patchThatChangesMap oldByIndex newByIndex
133 where newList = Map.toList newByIndexUnsorted
134 newByIndex = Map.fromList $ zip (fst <$> newList) $ sortBy cmp $ snd <$> newList
136-- | Create a 'PatchMapWithMove' that, if applied to the first 'Map' provided,
137-- will produce the second 'Map'.
138patchThatChangesMap :: (Ord k, Ord (PatchTarget p), Monoid p) => Map k (PatchTarget p) -> Map k (PatchTarget p) -> PatchMapWithMove k p
139patchThatChangesMap oldByIndex newByIndex = patch
140 where oldByValue = Map.fromListWith Set.union $ swap . first Set.singleton <$> Map.toList oldByIndex
141 (insertsAndMoves, unusedValuesByValue) = flip runState oldByValue $ do
142 let f k v = do
143 remainingValues <- get
144 let putRemainingKeys remainingKeys = put $ if Set.null remainingKeys
145 then Map.delete v remainingValues
146 else Map.insert v remainingKeys remainingValues
147 case Map.lookup v remainingValues of
148 Nothing -> return $ NodeInfo (From_Insert v) $ Just undefined -- There's no existing value we can take
149 Just fromKs ->
150 if k `Set.member` fromKs
151 then do
152 putRemainingKeys $ Set.delete k fromKs
153 return $ NodeInfo (From_Move k mempty) $ Just undefined -- There's an existing value, and it's here, so no patch necessary
154 else do
155 (fromK, remainingKeys) <- return . fromJust $ Set.minView fromKs -- There's an existing value, but it's not here; move it here
156 putRemainingKeys remainingKeys
157 return $ NodeInfo (From_Move fromK mempty) $ Just undefined
158 Map.traverseWithKey f newByIndex
159 unusedOldKeys = fold unusedValuesByValue
160 pointlessMove k = \case
161 From_Move k' _ | k == k' -> True
162 _ -> False
163 keyWasMoved k = if k `Map.member` oldByIndex && not (k `Set.member` unusedOldKeys)
164 then Just undefined
165 else Nothing
166 patch = unsafePatchMapWithMove $ Map.filterWithKey (\k -> not . pointlessMove k . _nodeInfo_from) $ Map.mergeWithKey (\k a _ -> Just $ nodeInfoSetTo (keyWasMoved k) a) (Map.mapWithKey $ \k -> nodeInfoSetTo $ keyWasMoved k) (Map.mapWithKey $ \k _ -> NodeInfo From_Delete $ keyWasMoved k) insertsAndMoves oldByIndex
168-- | Change the 'From' value of a 'NodeInfo'
169nodeInfoMapFrom :: (From k v -> From k v) -> NodeInfo k v -> NodeInfo k v
170nodeInfoMapFrom f ni = ni { _nodeInfo_from = f $ _nodeInfo_from ni }
172-- | Change the 'From' value of a 'NodeInfo', using a 'Functor' (or
173-- 'Applicative', 'Monad', etc.) action to get the new value
174nodeInfoMapMFrom :: Functor f => (From k v -> f (From k v)) -> NodeInfo k v -> f (NodeInfo k v)
175nodeInfoMapMFrom f ni = fmap (\result -> ni { _nodeInfo_from = result }) $ f $ _nodeInfo_from ni
177-- | Set the 'To' field of a 'NodeInfo'
178nodeInfoSetTo :: To k -> NodeInfo k v -> NodeInfo k v
179nodeInfoSetTo to ni = ni { _nodeInfo_to = to }
181-- |Helper data structure used for composing patches using the monoid instance.
182data Fixup k v
183 = Fixup_Delete
184 | Fixup_Update (These (From k v) (To k))
186-- |Compose patches having the same effect as applying the patches in turn: @'applyAlways' (p <> q) == 'applyAlways' p . 'applyAlways' q@
187instance (Ord k, Monoid p, Eq p, Patch p) => Semigroup (PatchMapWithMove k p) where
188 PatchMapWithMove ma <> PatchMapWithMove mb = PatchMapWithMove m
189 where
190 connections = Map.toList $ Map.intersectionWithKey (\_ a b -> (_nodeInfo_to a, _nodeInfo_from b)) ma mb
191 h :: (k, (Maybe k, From k p)) -> [(k, Fixup k p)]
192 h (_, (mToAfter, editBefore)) = case (mToAfter, editBefore) of
193 (Just toAfter, From_Move fromBefore p)
194 | fromBefore == toAfter && p == mempty
195 -> [(toAfter, Fixup_Delete)]
196 | otherwise
197 -> [ (toAfter, Fixup_Update (This editBefore))
198 , (fromBefore, Fixup_Update (That mToAfter))
199 ]
200 (Nothing, From_Move fromBefore _) -> [(fromBefore, Fixup_Update (That mToAfter))] -- The item is destroyed in the second patch, so indicate that it is destroyed in the source map
201 (Just toAfter, _) -> [(toAfter, Fixup_Update (This editBefore))]
202 (Nothing, _) -> []
203 mergeFixups _ Fixup_Delete Fixup_Delete = Fixup_Delete
204 mergeFixups _ (Fixup_Update a) (Fixup_Update b)
205 | This x <- a, That y <- b
206 = Fixup_Update $ These x y
207 | That y <- a, This x <- b
208 = Fixup_Update $ These x y
209 mergeFixups _ _ _ = error "PatchMapWithMove: incompatible fixups"
210 fixups = Map.fromListWithKey mergeFixups $ concatMap h connections
211 combineNodeInfos _ nia nib = NodeInfo
212 { _nodeInfo_from = _nodeInfo_from nia
213 , _nodeInfo_to = _nodeInfo_to nib
214 }
215 applyFixup _ ni = \case
216 Fixup_Delete -> Nothing
217 Fixup_Update u -> Just $ NodeInfo
218 { _nodeInfo_from = case _nodeInfo_from ni of
219 f@(From_Move _ p') -> case getHere u of -- The `from` fixup comes from the "old" patch
220 Nothing -> f -- If there's no `from` fixup, just use the "new" `from`
221 Just (From_Insert v) -> From_Insert $ applyAlways p' v
222 Just From_Delete -> From_Delete
223 Just (From_Move oldKey p) -> From_Move oldKey $ p' <> p
224 _ -> error "PatchMapWithMove: fixup for non-move From"
225 , _nodeInfo_to = fromMaybe (_nodeInfo_to ni) $ getThere u
226 }
227 m = Map.differenceWithKey applyFixup (Map.unionWithKey combineNodeInfos ma mb) fixups
228 getHere :: These a b -> Maybe a
229 getHere = \case
230 This a -> Just a
231 These a _ -> Just a
232 That _ -> Nothing
233 getThere :: These a b -> Maybe b
234 getThere = \case
235 This _ -> Nothing
236 These _ b -> Just b
237 That b -> Just b
239--TODO: Figure out how to implement this in terms of PatchDMapWithMove rather than duplicating it here
240-- |Compose patches having the same effect as applying the patches in turn: @'applyAlways' (p <> q) == 'applyAlways' p . 'applyAlways' q@
241instance (Ord k, Monoid p, Eq p, Patch p) => Monoid (PatchMapWithMove k p) where
242 mempty = PatchMapWithMove mempty
243 mappend = (<>)