git.iko.soy/patch
on 925dfb2 help sign in
patch/src/Reflex/Patch/MapWithMove.hs
156 lines 7.5 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)
28data 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 (PatchMapWithMove p) = catMaybes $ f <$> Map.elems p
66 where f ni = case _nodeInfo_from ni of
67 From_Insert v -> Just v
68 From_Move _ -> Nothing
69 From_Delete -> Nothing
71validPatchMapWithMove :: Ord k => PatchMapWithMove k v -> Bool
72validPatchMapWithMove (PatchMapWithMove p) =
73 let f ni = case _nodeInfo_from ni of
74 From_Move k -> Just k
75 _ -> Nothing
76 moveSources = catMaybes $ f <$> Map.elems p
77 in and
78 [ -- All Moves must have unique source keys - a single source key can't be moved to two destinations
79 all (==1) $ Map.fromListWith (+) $ fmap (\k -> (k, 1 :: Integer )) moveSources
80 , -- 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)
81 all (isJust . flip Map.lookup p) moveSources
82 ]
84knownValidPatchMapWithMove :: [PatchMapWithMove Int Int]
85knownValidPatchMapWithMove =
86 [ PatchMapWithMove mempty
87 , PatchMapWithMove $ Map.fromList
88 [ (1, NodeInfo (From_Move 2) $ Just 1)
89 , (2, NodeInfo (From_Move 1) $ Just 2)
90 ]
91 ]
93knownInvalidPatchMapWithMove :: [PatchMapWithMove Int Int]
94knownInvalidPatchMapWithMove =
95 [ -- Invalid because we move 2 to 1, but don't specify what to do with 2
96 PatchMapWithMove $ Map.singleton 1 $ NodeInfo (From_Move 2) Nothing
97 , -- Invalid because we have multiple moves from 3
98 PatchMapWithMove $ Map.fromList
99 [ (1, NodeInfo (From_Move 3) Nothing)
100 , (2, NodeInfo (From_Move 3) Nothing)
101 , (3, NodeInfo From_Delete (Just 1))
102 ]
103 ]
105patchThatSortsMapWith :: Ord k => (v -> v -> Ordering) -> Map k v -> PatchMapWithMove k v
106patchThatSortsMapWith cmp m = PatchMapWithMove $ Map.fromList $ catMaybes $ zipWith g unsorted sorted
107 where unsorted = Map.toList m
108 sorted = sortBy (cmp `on` snd) unsorted
109 f (to, _) (from, _) = if to == from then Nothing else
110 Just (from, to)
111 reverseMapping = Map.fromList $ catMaybes $ zipWith f unsorted sorted
112 g (to, _) (from, _) = if to == from then Nothing else
113 let Just movingTo = Map.lookup from reverseMapping
114 in Just (to, NodeInfo (From_Move from) $ Just movingTo)
116patchThatChangesAndSortsMapWith :: forall k v. (Ord k, Ord v) => (v -> v -> Ordering) -> Map k v -> Map k v -> PatchMapWithMove k v
117patchThatChangesAndSortsMapWith cmp oldByIndex newByIndexUnsorted = patch
118 where oldByValue = Map.fromListWith Set.union $ swap . first Set.singleton <$> Map.toList oldByIndex
119 newList = Map.toList newByIndexUnsorted
120 newByIndex = Map.fromList $ zip (fst <$> newList) $ sortBy cmp $ snd <$> newList
121 insertsAndMoves :: Map k (NodeInfo k v)
122 (insertsAndMoves, unusedValuesByValue) = flip runState oldByValue $ do
123 let f k v = do
124 remainingValues <- get
125 let putRemainingKeys remainingKeys = put $ if Set.null remainingKeys
126 then Map.delete v remainingValues
127 else Map.insert v remainingKeys remainingValues
128 case Map.lookup v remainingValues of
129 Nothing -> return $ NodeInfo (From_Insert v) $ Just undefined -- There's no existing value we can take
130 Just fromKs ->
131 if k `Set.member` fromKs
132 then do
133 putRemainingKeys $ Set.delete k fromKs
134 return $ NodeInfo (From_Move k) $ Just undefined -- There's an existing value, and it's here, so no patch necessary
135 else do
136 Just (fromK, remainingKeys) <- return $ Set.minView fromKs -- There's an existing value, but it's not here; move it here
137 putRemainingKeys remainingKeys
138 return $ NodeInfo (From_Move fromK) $ Just undefined
139 Map.traverseWithKey f newByIndex
140 unusedOldKeys = fold unusedValuesByValue
141 pointlessMove k = \case
142 From_Move k' | k == k' -> True
143 _ -> False
144 keyWasMoved k = if k `Map.member` oldByIndex && not (k `Set.member` unusedOldKeys)
145 then Just undefined
146 else Nothing
147 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
149nodeInfoMapFrom :: (From k v -> From k v) -> NodeInfo k v -> NodeInfo k v
150nodeInfoMapFrom f ni = ni { _nodeInfo_from = f $ _nodeInfo_from ni }
152nodeInfoMapMFrom :: Functor f => (From k v -> f (From k v)) -> NodeInfo k v -> f (NodeInfo k v)
153nodeInfoMapMFrom f ni = fmap (\result -> ni { _nodeInfo_from = result }) $ f $ _nodeInfo_from ni
155nodeInfoSetTo :: To k -> NodeInfo k v -> NodeInfo k v
156nodeInfoSetTo to ni = ni { _nodeInfo_to = to }