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