@@ -1,153 +1,120 @@
1−{-# LANGUAGE DeriveFoldable #-}
2−{-# LANGUAGE DeriveFunctor #-}
3−{-# LANGUAGE DeriveTraversable #-}
41{-# LANGUAGE FlexibleContexts #-}
52{-# LANGUAGE LambdaCase #-}
63{-# LANGUAGE PatternGuards #-}
74{-# LANGUAGE ScopedTypeVariables #-}
5+{-# LANGUAGE StandaloneDeriving #-}
86{-# LANGUAGE TypeFamilies #-}
7+{-# LANGUAGE UndecidableInstances #-}
98-- | 'Patch'es on 'Map' that can insert, delete, and move values from one key to
109-- another
11−module Data.Patch.MapWithMove where
10+module Reflex.Patch.MapWithMove where
1211
13−import Data.Patch.Class
12+import Reflex.Patch.Class
1413
1514import Control.Arrow
16−import Control.Monad.Trans.State
15+import Control.Monad.State
1716import Data.Foldable
1817import Data.Function
1918import Data.List
2019import Data.Map (Map)
2120import qualified Data.Map as Map
2221import Data.Maybe
23−import Data.Semigroup (Semigroup (..), (<>))
22+import Data.Semigroup
2423import qualified Data.Set as Set
25−import Data.These (These(..))
24+import Data.These
2625import Data.Tuple
2726
2827-- | 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@,
28+-- is coming from @From_Move k@, then key @k2@ should be going to @Just k1@,
3029-- and vice versa. There should never be any unpaired From/To keys.
31−newtype PatchMapWithMove k v = PatchMapWithMove (Map k (NodeInfo k v)) deriving (Show, Eq, Ord, Functor, Foldable, Traversable)
30+newtype PatchMapWithMove k p = PatchMapWithMove (Map k (NodeInfo k p))
31+deriving instance (Show k, Show p, Show (PatchTarget p)) => Show (PatchMapWithMove k p)
32+deriving instance (Eq k, Eq p, Eq (PatchTarget p)) => Eq (PatchMapWithMove k p)
33+deriving instance (Ord k, Ord p, Ord (PatchTarget p)) => Ord (PatchMapWithMove k p)
3234
3335-- | Holds the information about each key: where its new value should come from,
3436-- and where its old value should go to
35−data NodeInfo k v = NodeInfo
36− { _nodeInfo_from :: !(From k v)
37+data NodeInfo k p = NodeInfo
38+ { _nodeInfo_from :: !(From k p)
3739 -- ^ Where do we get the new value for this key?
3840 , _nodeInfo_to :: !(To k)
3941 -- ^ If the old value is being kept (i.e. moved rather than deleted or
4042 -- replaced), where is it going?
4143 }
42− deriving (Show, Read, Eq, Ord, Functor, Foldable, Traversable)
43−
44−-- | Describe how a key's new value should be produced
45−data From k v
46− = From_Insert v -- ^ Insert the given value here
47− | From_Delete -- ^ Delete the existing value, if any, from here
48− | From_Move !k -- ^ Move the value here from the given key
49− deriving (Show, Read, Eq, Ord, Functor, Foldable, Traversable)
50−
51−-- | Describe where a key's old value will go. If this is 'Just', that means
52−-- the key's old value will be moved to the given other key; if it is 'Nothing',
53−-- that means it will be deleted.
54−type To = Maybe
44+deriving instance (Show k, Show p, Show (PatchTarget p)) => Show (NodeInfo k p)
45+deriving instance (Read k, Read p, Read (PatchTarget p)) => Read (NodeInfo k p)
46+deriving instance (Eq k, Eq p, Eq (PatchTarget p)) => Eq (NodeInfo k p)
47+deriving instance (Ord k, Ord p, Ord (PatchTarget p)) => Ord (NodeInfo k p)
5548
5649-- | Create a 'PatchMapWithMove', validating it
57−patchMapWithMove :: Ord k => Map k (NodeInfo k v) -> Maybe (PatchMapWithMove k v)
50+patchMapWithMove :: Ord k => Map k (NodeInfo k p) -> Maybe (PatchMapWithMove k p)
5851patchMapWithMove m = if valid then Just $ PatchMapWithMove m else Nothing
5952 where valid = forwardLinks == backwardLinks
6053 forwardLinks = Map.mapMaybe _nodeInfo_to m
61− backwardLinks = Map.fromList $ catMaybes $ flip fmap (Map.toList m) $ \(to, v) ->
62− case _nodeInfo_from v of
63− From_Move from -> Just (from, to)
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)
6457 _ -> Nothing
6558
6659-- | Create a 'PatchMapWithMove' that inserts everything in the given 'Map'
67−patchMapWithMoveInsertAll :: Map k v -> PatchMapWithMove k v
60+patchMapWithMoveInsertAll :: Map k (PatchTarget p) -> PatchMapWithMove k p
6861patchMapWithMoveInsertAll m = PatchMapWithMove $ flip fmap m $ \v -> NodeInfo
6962 { _nodeInfo_from = From_Insert v
7063 , _nodeInfo_to = Nothing
7164 }
7265
7366-- | Extract the internal representation of the 'PatchMapWithMove'
74−unPatchMapWithMove :: PatchMapWithMove k v -> Map k (NodeInfo k v)
67+unPatchMapWithMove :: PatchMapWithMove k p -> Map k (NodeInfo k p)
7568unPatchMapWithMove (PatchMapWithMove p) = p
7669
77−-- | Make a @'PatchMapWithMove' k v@ which has the effect of inserting or updating a value @v@ to the given key @k@, like 'Map.insert'.
78−insertMapKey :: k -> v -> PatchMapWithMove k v
79−insertMapKey k v = PatchMapWithMove . Map.singleton k $ NodeInfo (From_Insert v) Nothing
80−
81−-- |Make a @'PatchMapWithMove' k v@ which has the effect of moving the value from the first key @k@ to the second key @k@, equivalent to:
82−--
83−-- @
84−-- 'Map.delete' src (maybe map ('Map.insert' dst) (Map.lookup src map))
85−-- @
86−moveMapKey :: Ord k => k -> k -> PatchMapWithMove k v
87−moveMapKey src dst
88− | src == dst = mempty
89− | otherwise =
90− PatchMapWithMove $ Map.fromList
91− [ (dst, NodeInfo (From_Move src) Nothing)
92− , (src, NodeInfo From_Delete (Just dst))
93− ]
70+-- | Warning: when using this function, you must ensure that the invariants of
71+-- 'PatchMapWithMove' are preserved; they will not be checked.
72+unsafePatchMapWithMove :: Map k (NodeInfo k p) -> PatchMapWithMove k p
73+unsafePatchMapWithMove = PatchMapWithMove
9474
95−-- |Make a @'PatchMapWithMove' k v@ which has the effect of swapping two keys in the mapping, equivalent to:
96−--
97−-- @
98−-- let aMay = Map.lookup a map
99−-- bMay = Map.lookup b map
100−-- in maybe id (Map.insert a) (bMay `mplus` aMay)
101−-- . maybe id (Map.insert b) (aMay `mplus` bMay)
102−-- . Map.delete a . Map.delete b $ map
103−-- @
104−swapMapKey :: Ord k => k -> k -> PatchMapWithMove k v
105−swapMapKey src dst
106− | src == dst = mempty
107− | otherwise =
108− PatchMapWithMove $ Map.fromList
109− [ (dst, NodeInfo (From_Move src) (Just src))
110− , (src, NodeInfo (From_Move dst) (Just dst))
111− ]
75+-- | Describe how a key's new value should be produced
76+data 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
11280
113−-- |Make a @'PatchMapWithMove' k v@ which has the effect of deleting a key in the mapping, equivalent to 'Map.delete'.
114−deleteMapKey :: k -> PatchMapWithMove k v
115−deleteMapKey k = PatchMapWithMove . Map.singleton k $ NodeInfo From_Delete Nothing
81+deriving instance (Show k, Show p, Show (PatchTarget p)) => Show (From k p)
82+deriving instance (Read k, Read p, Read (PatchTarget p)) => Read (From k p)
83+deriving instance (Eq k, Eq p, Eq (PatchTarget p)) => Eq (From k p)
84+deriving instance (Ord k, Ord p, Ord (PatchTarget p)) => Ord (From k p)
11685
117−-- | Wrap a @'Map' k (NodeInfo k v)@ representing patch changes into a @'PatchMapWithMove' k v@, without checking any invariants.
118−--
119−-- __Warning:__ when using this function, you must ensure that the invariants of 'PatchMapWithMove' are preserved; they will not be checked.
120−unsafePatchMapWithMove :: Map k (NodeInfo k v) -> PatchMapWithMove k v
121−unsafePatchMapWithMove = PatchMapWithMove
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.
89+type To = Maybe
12290
12391-- | Apply the insertions, deletions, and moves to a given 'Map'
124−instance Ord k => Patch (PatchMapWithMove k v) where
125− type PatchTarget (PatchMapWithMove k v) = Map k v
126− 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?
127− where insertions = flip Map.mapMaybeWithKey p $ \_ ni -> case _nodeInfo_from ni of
92+instance (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
12896 From_Insert v -> Just v
129− From_Move k -> Map.lookup k old
97+ From_Move k p -> applyAlways p <$> Map.lookup k old
13098 From_Delete -> Nothing
131− deletions = flip Map.mapMaybeWithKey p $ \_ ni -> case _nodeInfo_from ni of
99+ deletions = flip Map.mapMaybeWithKey m $ \_ ni -> case _nodeInfo_from ni of
132100 From_Delete -> Just ()
133101 _ -> Nothing
134102
135−-- | Returns all the new elements that will be added to the 'Map'.
136−patchMapWithMoveNewElements :: PatchMapWithMove k v -> [v]
103+-- | Returns all the new elements that will be added to the 'Map'
104+patchMapWithMoveNewElements :: PatchMapWithMove k p -> [PatchTarget p]
137105patchMapWithMoveNewElements = Map.elems . patchMapWithMoveNewElementsMap
138106
139−-- | Return a @'Map' k v@ with all the inserts/updates from the given @'PatchMapWithMove' k v@.
140−patchMapWithMoveNewElementsMap :: PatchMapWithMove k v -> Map k v
107+patchMapWithMoveNewElementsMap :: PatchMapWithMove k p -> Map k (PatchTarget p)
141108patchMapWithMoveNewElementsMap (PatchMapWithMove p) = Map.mapMaybe f p
142109 where f ni = case _nodeInfo_from ni of
143110 From_Insert v -> Just v
144− From_Move _ -> Nothing
111+ From_Move _ _ -> Nothing
145112 From_Delete -> Nothing
146113
147114-- | Create a 'PatchMapWithMove' that, if applied to the given 'Map', will sort
148115-- its values using the given ordering function. The set keys of the 'Map' is
149116-- not changed.
150−patchThatSortsMapWith :: Ord k => (v -> v -> Ordering) -> Map k v -> PatchMapWithMove k v
117+patchThatSortsMapWith :: (Ord k, Monoid p) => (PatchTarget p -> PatchTarget p -> Ordering) -> Map k (PatchTarget p) -> PatchMapWithMove k p
151118patchThatSortsMapWith cmp m = PatchMapWithMove $ Map.fromList $ catMaybes $ zipWith g unsorted sorted
152119 where unsorted = Map.toList m
153120 sorted = sortBy (cmp `on` snd) unsorted
@@ -155,20 +122,20 @@ patchThatSortsMapWith cmp m = PatchMapWithMove $ Map.fromList $ catMaybes $ zipW
155122 Just (from, to)
156123 reverseMapping = Map.fromList $ catMaybes $ zipWith f unsorted sorted
157124 g (to, _) (from, _) = if to == from then Nothing else
158− let Just movingTo = Map.lookup to reverseMapping
159− in Just (to, NodeInfo (From_Move from) $ Just movingTo)
125+ let Just movingTo = Map.lookup from reverseMapping
126+ in Just (to, NodeInfo (From_Move from mempty) $ Just movingTo)
160127
161128-- | Create a 'PatchMapWithMove' that, if applied to the first 'Map' provided,
162129-- will produce a 'Map' with the same values as the second 'Map' but with the
163130-- values sorted with the given ordering function.
164−patchThatChangesAndSortsMapWith :: forall k v. (Ord k, Ord v) => (v -> v -> Ordering) -> Map k v -> Map k v -> PatchMapWithMove k v
131+patchThatChangesAndSortsMapWith :: 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
165132patchThatChangesAndSortsMapWith cmp oldByIndex newByIndexUnsorted = patchThatChangesMap oldByIndex newByIndex
166133 where newList = Map.toList newByIndexUnsorted
167134 newByIndex = Map.fromList $ zip (fst <$> newList) $ sortBy cmp $ snd <$> newList
168135
169136-- | Create a 'PatchMapWithMove' that, if applied to the first 'Map' provided,
170137-- will produce the second 'Map'.
171−patchThatChangesMap :: (Ord k, Ord v) => Map k v -> Map k v -> PatchMapWithMove k v
138+patchThatChangesMap :: (Ord k, Ord (PatchTarget p), Monoid p) => Map k (PatchTarget p) -> Map k (PatchTarget p) -> PatchMapWithMove k p
172139patchThatChangesMap oldByIndex newByIndex = patch
173140 where oldByValue = Map.fromListWith Set.union $ swap . first Set.singleton <$> Map.toList oldByIndex
174141 (insertsAndMoves, unusedValuesByValue) = flip runState oldByValue $ do
@@ -183,15 +150,15 @@ patchThatChangesMap oldByIndex newByIndex = patch
183150 if k `Set.member` fromKs
184151 then do
185152 putRemainingKeys $ Set.delete k fromKs
186− return $ NodeInfo (From_Move k) $ Just undefined -- There's an existing value, and it's here, so no patch necessary
153+ return $ NodeInfo (From_Move k mempty) $ Just undefined -- There's an existing value, and it's here, so no patch necessary
187154 else do
188155 (fromK, remainingKeys) <- return . fromJust $ Set.minView fromKs -- There's an existing value, but it's not here; move it here
189156 putRemainingKeys remainingKeys
190− return $ NodeInfo (From_Move fromK) $ Just undefined
157+ return $ NodeInfo (From_Move fromK mempty) $ Just undefined
191158 Map.traverseWithKey f newByIndex
192159 unusedOldKeys = fold unusedValuesByValue
193160 pointlessMove k = \case
194− From_Move k' | k == k' -> True
161+ From_Move k' _ | k == k' -> True
195162 _ -> False
196163 keyWasMoved k = if k `Map.member` oldByIndex && not (k `Set.member` unusedOldKeys)
197164 then Just undefined
@@ -217,20 +184,20 @@ data Fixup k v
217184 | Fixup_Update (These (From k v) (To k))
218185
219186-- |Compose patches having the same effect as applying the patches in turn: @'applyAlways' (p <> q) == 'applyAlways' p . 'applyAlways' q@
220−instance Ord k => Semigroup (PatchMapWithMove k v) where
187+instance (Ord k, Monoid p, Eq p, Patch p) => Semigroup (PatchMapWithMove k p) where
221188 PatchMapWithMove ma <> PatchMapWithMove mb = PatchMapWithMove m
222189 where
223190 connections = Map.toList $ Map.intersectionWithKey (\_ a b -> (_nodeInfo_to a, _nodeInfo_from b)) ma mb
224− h :: (k, (Maybe k, From k v)) -> [(k, Fixup k v)]
191+ h :: (k, (Maybe k, From k p)) -> [(k, Fixup k p)]
225192 h (_, (mToAfter, editBefore)) = case (mToAfter, editBefore) of
226− (Just toAfter, From_Move fromBefore)
227− | fromBefore == toAfter
193+ (Just toAfter, From_Move fromBefore p)
194+ | fromBefore == toAfter && p == mempty
228195 -> [(toAfter, Fixup_Delete)]
229196 | otherwise
230197 -> [ (toAfter, Fixup_Update (This editBefore))
231198 , (fromBefore, Fixup_Update (That mToAfter))
232199 ]
233− (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
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
234201 (Just toAfter, _) -> [(toAfter, Fixup_Update (This editBefore))]
235202 (Nothing, _) -> []
236203 mergeFixups _ Fixup_Delete Fixup_Delete = Fixup_Delete
@@ -248,7 +215,13 @@ instance Ord k => Semigroup (PatchMapWithMove k v) where
248215 applyFixup _ ni = \case
249216 Fixup_Delete -> Nothing
250217 Fixup_Update u -> Just $ NodeInfo
251− { _nodeInfo_from = fromMaybe (_nodeInfo_from ni) $ getHere u
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"
252225 , _nodeInfo_to = fromMaybe (_nodeInfo_to ni) $ getThere u
253226 }
254227 m = Map.differenceWithKey applyFixup (Map.unionWithKey combineNodeInfos ma mb) fixups
@@ -265,6 +238,6 @@ instance Ord k => Semigroup (PatchMapWithMove k v) where
265238
266239--TODO: Figure out how to implement this in terms of PatchDMapWithMove rather than duplicating it here
267240-- |Compose patches having the same effect as applying the patches in turn: @'applyAlways' (p <> q) == 'applyAlways' p . 'applyAlways' q@
268−instance Ord k => Monoid (PatchMapWithMove k v) where
241+instance (Ord k, Monoid p, Eq p, Patch p) => Monoid (PatchMapWithMove k p) where
269242 mempty = PatchMapWithMove mempty
270243 mappend = (<>)