git.iko.soy/patch
on e8029ed help sign in
patch/src/Reflex/Patch/MapWithMove.hs
156 lines 8.1 kB history raw
1{-# LANGUAGE DeriveFoldable #-}
2{-# LANGUAGE DeriveFunctor #-}
3{-# LANGUAGE DeriveTraversable #-}
4{-# LANGUAGE FlexibleContexts #-}
5{-# LANGUAGE LambdaCase #-}
6{-# LANGUAGE ScopedTypeVariables #-}
7{-# LANGUAGE TypeFamilies #-}
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 qualified Data.Set as Set
23import Data.Tuple
25-- | Patch a DMap with additions, deletions, and moves. Invariant: If key @k1@
26-- is coming from @From_Move k2@, then key @k2@ should be going to @Just k1@,
27-- and vice versa. There should never be any unpaired From/To keys.
28newtype PatchMapWithMove k v = PatchMapWithMove (Map k (NodeInfo k v)) deriving (Show, Eq, Ord, Functor, Foldable, Traversable)
30-- | Holds the information about each key: where its new value should come from,
31-- and where its old value should go to
32data NodeInfo k v = NodeInfo
33 { _nodeInfo_from :: !(From k v)
34 -- ^ Where do we get the new value for this key?
35 , _nodeInfo_to :: !(To k)
36 -- ^ If the old value is being kept (i.e. moved rather than deleted or
37 -- replaced), where is it going?
38 }
39 deriving (Show, Read, Eq, Ord, Functor, Foldable, Traversable)
41-- | Create a 'PatchMapWithMove', validating it
42patchMapWithMove :: Ord k => Map k (NodeInfo k v) -> Maybe (PatchMapWithMove k v)
43patchMapWithMove m = if valid then Just $ PatchMapWithMove m else Nothing
44 where valid = forwardLinks == backwardLinks
45 forwardLinks = Map.mapMaybe _nodeInfo_to m
46 backwardLinks = Map.fromList $ catMaybes $ flip fmap (Map.toList m) $ \(to, v) ->
47 case _nodeInfo_from v of
48 From_Move from -> Just (from, to)
49 _ -> Nothing
51-- | Extract the internal representation of the 'PatchMapWithMove'
52unPatchMapWithMove :: PatchMapWithMove k v -> Map k (NodeInfo k v)
53unPatchMapWithMove (PatchMapWithMove p) = p
55-- | Warning: when using this function, you must ensure that the invariants of
56-- 'PatchMapWithMove' are preserved; they will not be checked.
57unsafePatchMapWithMove :: Map k (NodeInfo k v) -> PatchMapWithMove k v
58unsafePatchMapWithMove = PatchMapWithMove
60-- | Describe how a key's new value should be produced
61data From k v
62 = From_Insert v -- ^ Insert the given value here
63 | From_Delete -- ^ Delete the existing value, if any, from here
64 | From_Move !k -- ^ Move the value here from the given key
65 deriving (Show, Read, Eq, Ord, Functor, Foldable, Traversable)
67-- | Describe where a key's old value will go. If this is 'Just', that means
68-- the key's old value will be moved to the given other key; if it is 'Nothing',
69-- that means it will be deleted.
70type To = Maybe
72-- | Apply the insertions, deletions, and moves to a given 'Map'
73instance Ord k => Patch (PatchMapWithMove k v) where
74 type PatchTarget (PatchMapWithMove k v) = Map k v
75 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?
76 where insertions = flip Map.mapMaybeWithKey p $ \_ ni -> case _nodeInfo_from ni of
77 From_Insert v -> Just v
78 From_Move k -> Map.lookup k old
79 From_Delete -> Nothing
80 deletions = flip Map.mapMaybeWithKey p $ \_ ni -> case _nodeInfo_from ni of
81 From_Delete -> Just ()
82 _ -> Nothing
84-- | Returns all the new elements that will be added to the 'Map'
85patchMapWithMoveNewElements :: PatchMapWithMove k v -> [v]
86patchMapWithMoveNewElements = Map.elems . patchMapWithMoveNewElementsMap
88patchMapWithMoveNewElementsMap :: PatchMapWithMove k v -> Map k v
89patchMapWithMoveNewElementsMap (PatchMapWithMove p) = Map.mapMaybe f p
90 where f ni = case _nodeInfo_from ni of
91 From_Insert v -> Just v
92 From_Move _ -> Nothing
93 From_Delete -> Nothing
95-- | Create a 'PatchMapWithMove' that, if applied to the given 'Map', will sort
96-- its values using the given ordering function. The set keys of the 'Map' is
97-- not changed.
98patchThatSortsMapWith :: Ord k => (v -> v -> Ordering) -> Map k v -> PatchMapWithMove k v
99patchThatSortsMapWith cmp m = PatchMapWithMove $ Map.fromList $ catMaybes $ zipWith g unsorted sorted
100 where unsorted = Map.toList m
101 sorted = sortBy (cmp `on` snd) unsorted
102 f (to, _) (from, _) = if to == from then Nothing else
103 Just (from, to)
104 reverseMapping = Map.fromList $ catMaybes $ zipWith f unsorted sorted
105 g (to, _) (from, _) = if to == from then Nothing else
106 let Just movingTo = Map.lookup from reverseMapping
107 in Just (to, NodeInfo (From_Move from) $ Just movingTo)
109-- | Create a 'PatchMapWithMove' that, if applied to the first 'Map' provided,
110-- will produce a 'Map' with the same values as the second 'Map' but with the
111-- values sorted with the given ordering function.
112patchThatChangesAndSortsMapWith :: forall k v. (Ord k, Ord v) => (v -> v -> Ordering) -> Map k v -> Map k v -> PatchMapWithMove k v
113patchThatChangesAndSortsMapWith cmp oldByIndex newByIndexUnsorted = patch
114 where oldByValue = Map.fromListWith Set.union $ swap . first Set.singleton <$> Map.toList oldByIndex
115 newList = Map.toList newByIndexUnsorted
116 newByIndex = Map.fromList $ zip (fst <$> newList) $ sortBy cmp $ snd <$> newList
117 insertsAndMoves :: Map k (NodeInfo k v)
118 (insertsAndMoves, unusedValuesByValue) = flip runState oldByValue $ do
119 let f k v = do
120 remainingValues <- get
121 let putRemainingKeys remainingKeys = put $ if Set.null remainingKeys
122 then Map.delete v remainingValues
123 else Map.insert v remainingKeys remainingValues
124 case Map.lookup v remainingValues of
125 Nothing -> return $ NodeInfo (From_Insert v) $ Just undefined -- There's no existing value we can take
126 Just fromKs ->
127 if k `Set.member` fromKs
128 then do
129 putRemainingKeys $ Set.delete k fromKs
130 return $ NodeInfo (From_Move k) $ Just undefined -- There's an existing value, and it's here, so no patch necessary
131 else do
132 Just (fromK, remainingKeys) <- return $ Set.minView fromKs -- There's an existing value, but it's not here; move it here
133 putRemainingKeys remainingKeys
134 return $ NodeInfo (From_Move fromK) $ Just undefined
135 Map.traverseWithKey f newByIndex
136 unusedOldKeys = fold unusedValuesByValue
137 pointlessMove k = \case
138 From_Move k' | k == k' -> True
139 _ -> False
140 keyWasMoved k = if k `Map.member` oldByIndex && not (k `Set.member` unusedOldKeys)
141 then Just undefined
142 else Nothing
143 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
145-- | Change the 'From' value of a 'NodeInfo'
146nodeInfoMapFrom :: (From k v -> From k v) -> NodeInfo k v -> NodeInfo k v
147nodeInfoMapFrom f ni = ni { _nodeInfo_from = f $ _nodeInfo_from ni }
149-- | Change the 'From' value of a 'NodeInfo', using a 'Functor' (or
150-- 'Applicative', 'Monad', etc.) action to get the new value
151nodeInfoMapMFrom :: Functor f => (From k v -> f (From k v)) -> NodeInfo k v -> f (NodeInfo k v)
152nodeInfoMapMFrom f ni = fmap (\result -> ni { _nodeInfo_from = result }) $ f $ _nodeInfo_from ni
154-- | Set the 'To' field of a 'NodeInfo'
155nodeInfoSetTo :: To k -> NodeInfo k v -> NodeInfo k v
156nodeInfoSetTo to ni = ni { _nodeInfo_to = to }