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