git.iko.soy/patch
on 41c56b6 help sign in
patch/src/Reflex/Patch/MapWithMove.hs
159 lines 7.7 kB history raw
1{-# LANGUAGE DeriveFoldable #-}
2{-# LANGUAGE DeriveFunctor #-}
3{-# LANGUAGE DeriveTraversable #-}
4{-# LANGUAGE FlexibleContexts #-}
5{-# LANGUAGE LambdaCase #-}
6{-# LANGUAGE ScopedTypeVariables #-}
7{-# LANGUAGE TypeFamilies #-}
8module Reflex.Patch.MapWithMove where
10import Reflex.Patch.Class
12import Control.Arrow
13import Control.Monad.State
14import Data.Foldable
15import Data.Function
16import Data.List
17import Data.Map (Map)
18import qualified Data.Map as Map
19import Data.Maybe
20import qualified Data.Set as Set
21import Data.Tuple
23-- | Patch a DMap with additions, deletions, and moves.
24-- Invariants:
25-- * The same source key may not be moved to two destination keys.
26-- * Any key that is the source of a Move must also be edited
27-- (otherwise, the Move would duplicate it)
28newtype PatchMapWithMove k v = PatchMapWithMove (Map k (NodeInfo k v)) deriving (Show, Eq, Ord, Functor, Foldable, Traversable)
30data NodeInfo k v = NodeInfo
31 { _nodeInfo_from :: !(From k v)
32 , _nodeInfo_to :: !(To k)
33 }
34 deriving (Show, Read, Eq, Ord, Functor, Foldable, Traversable)
36unPatchMapWithMove :: PatchMapWithMove k v -> Map k (NodeInfo k v)
37unPatchMapWithMove (PatchMapWithMove p) = p
39-- | Warning: when using this function, you must ensure that the invariants of
40-- 'PatchMapWithMove' are preserved; they will not be checked.
41unsafePatchMapWithMove :: Map k (NodeInfo k v) -> PatchMapWithMove k v
42unsafePatchMapWithMove = PatchMapWithMove
44data From k v
45 = From_Insert v -- ^ Insert the given value here
46 | From_Delete -- ^ Delete the existing value, if any, from here
47 | From_Move !k -- ^ Move the value here from the given key
48 deriving (Show, Read, Eq, Ord, Functor, Foldable, Traversable)
50type To = Maybe
52instance Ord k => Patch (PatchMapWithMove k v) where
53 type PatchTarget (PatchMapWithMove k v) = Map k v
54 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?
55 where insertions = flip Map.mapMaybeWithKey p $ \_ ni -> case _nodeInfo_from ni of
56 From_Insert v -> Just v
57 From_Move k -> Map.lookup k old
58 From_Delete -> Nothing
59 deletions = flip Map.mapMaybeWithKey p $ \_ ni -> case _nodeInfo_from ni of
60 From_Delete -> Just ()
61 _ -> Nothing
63-- | Returns all the new elements that will be added to the 'Map'
64patchMapWithMoveNewElements :: PatchMapWithMove k v -> [v]
65patchMapWithMoveNewElements = Map.elems . patchMapWithMoveNewElementsMap
67patchMapWithMoveNewElementsMap :: PatchMapWithMove k v -> Map k v
68patchMapWithMoveNewElementsMap (PatchMapWithMove p) = Map.mapMaybe f p
69 where f ni = case _nodeInfo_from ni of
70 From_Insert v -> Just v
71 From_Move _ -> Nothing
72 From_Delete -> Nothing
74validPatchMapWithMove :: Ord k => PatchMapWithMove k v -> Bool
75validPatchMapWithMove (PatchMapWithMove p) =
76 let f ni = case _nodeInfo_from ni of
77 From_Move k -> Just k
78 _ -> Nothing
79 moveSources = catMaybes $ f <$> Map.elems p
80 in and
81 [ -- All Moves must have unique source keys - a single source key can't be moved to two destinations
82 all (==1) $ Map.fromListWith (+) $ fmap (\k -> (k, 1 :: Integer )) moveSources
83 , -- All Move source keys must also be patched - since the value's being moved elsewhere, the original must either be Deleted or replaced (with Insert or Move)
84 all (isJust . flip Map.lookup p) moveSources
85 ]
87knownValidPatchMapWithMove :: [PatchMapWithMove Int Int]
88knownValidPatchMapWithMove =
89 [ PatchMapWithMove mempty
90 , PatchMapWithMove $ Map.fromList
91 [ (1, NodeInfo (From_Move 2) $ Just 1)
92 , (2, NodeInfo (From_Move 1) $ Just 2)
93 ]
94 ]
96knownInvalidPatchMapWithMove :: [PatchMapWithMove Int Int]
97knownInvalidPatchMapWithMove =
98 [ -- Invalid because we move 2 to 1, but don't specify what to do with 2
99 PatchMapWithMove $ Map.singleton 1 $ NodeInfo (From_Move 2) Nothing
100 , -- Invalid because we have multiple moves from 3
101 PatchMapWithMove $ Map.fromList
102 [ (1, NodeInfo (From_Move 3) Nothing)
103 , (2, NodeInfo (From_Move 3) Nothing)
104 , (3, NodeInfo From_Delete (Just 1))
105 ]
106 ]
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)
119patchThatChangesAndSortsMapWith :: forall k v. (Ord k, Ord v) => (v -> v -> Ordering) -> Map k v -> Map k v -> PatchMapWithMove k v
120patchThatChangesAndSortsMapWith cmp oldByIndex newByIndexUnsorted = patch
121 where oldByValue = Map.fromListWith Set.union $ swap . first Set.singleton <$> Map.toList oldByIndex
122 newList = Map.toList newByIndexUnsorted
123 newByIndex = Map.fromList $ zip (fst <$> newList) $ sortBy cmp $ snd <$> newList
124 insertsAndMoves :: Map k (NodeInfo k v)
125 (insertsAndMoves, unusedValuesByValue) = flip runState oldByValue $ do
126 let f k v = do
127 remainingValues <- get
128 let putRemainingKeys remainingKeys = put $ if Set.null remainingKeys
129 then Map.delete v remainingValues
130 else Map.insert v remainingKeys remainingValues
131 case Map.lookup v remainingValues of
132 Nothing -> return $ NodeInfo (From_Insert v) $ Just undefined -- There's no existing value we can take
133 Just fromKs ->
134 if k `Set.member` fromKs
135 then do
136 putRemainingKeys $ Set.delete k fromKs
137 return $ NodeInfo (From_Move k) $ Just undefined -- There's an existing value, and it's here, so no patch necessary
138 else do
139 Just (fromK, remainingKeys) <- return $ Set.minView fromKs -- There's an existing value, but it's not here; move it here
140 putRemainingKeys remainingKeys
141 return $ NodeInfo (From_Move fromK) $ Just undefined
142 Map.traverseWithKey f newByIndex
143 unusedOldKeys = fold unusedValuesByValue
144 pointlessMove k = \case
145 From_Move k' | k == k' -> True
146 _ -> False
147 keyWasMoved k = if k `Map.member` oldByIndex && not (k `Set.member` unusedOldKeys)
148 then Just undefined
149 else Nothing
150 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
152nodeInfoMapFrom :: (From k v -> From k v) -> NodeInfo k v -> NodeInfo k v
153nodeInfoMapFrom f ni = ni { _nodeInfo_from = f $ _nodeInfo_from ni }
155nodeInfoMapMFrom :: Functor f => (From k v -> f (From k v)) -> NodeInfo k v -> f (NodeInfo k v)
156nodeInfoMapMFrom f ni = fmap (\result -> ni { _nodeInfo_from = result }) $ f $ _nodeInfo_from ni
158nodeInfoSetTo :: To k -> NodeInfo k v -> NodeInfo k v
159nodeInfoSetTo to ni = ni { _nodeInfo_to = to }