git.iko.soy/reflex
on 02cf9db help sign in
reflex/src/Reflex/Patch.hs
343 lines 15 kB history raw
1-- | This module defines the 'Patch' class, which is used by Reflex to manage
2-- changes to 'Reflex.Class.Incremental' values.
3{-# LANGUAGE CPP #-}
4{-# LANGUAGE DeriveFoldable #-}
5{-# LANGUAGE DeriveFunctor #-}
6{-# LANGUAGE DeriveTraversable #-}
7{-# LANGUAGE GADTs #-}
8{-# LANGUAGE GeneralizedNewtypeDeriving #-}
9{-# LANGUAGE LambdaCase #-}
10{-# LANGUAGE PolyKinds #-}
11{-# LANGUAGE Rank2Types #-}
12{-# LANGUAGE ScopedTypeVariables #-}
13{-# LANGUAGE StandaloneDeriving #-}
14{-# LANGUAGE TypeFamilies #-}
15module Reflex.Patch
16 ( Patch (..)
17 , PatchDMap (..)
18 , mapPatchDMap
19 , traversePatchDMap
20 , traversePatchDMapWithKey
21 , weakenPatchDMapWith
22 , patchDMapToPatchMapWith
23 , const2PatchDMapWith
24 , ComposeMaybe (..)
25 , PatchMap (..)
26 , patchMapNewElements
27 , Group (..)
28 , Additive
29 , AdditivePatch (..)
30 , PatchMapWithMove
31 , unPatchMapWithMove
32 , unsafePatchMapWithMove
33 , patchMapWithMoveNewElements
34 , MapEdit (..)
35 , mapEditMoved
36 , PatchDMapWithMove
37 , unPatchDMapWithMove
38 , unsafePatchDMapWithMove
39 , patchThatSortsMapWith
40 , mapPatchDMapWithMove
41 , traversePatchDMapWithMove
42 , traversePatchDMapWithMoveWithKey
43 , weakenPatchDMapWithMoveWith
44 , patchDMapWithMoveToPatchMapWithMoveWith
45 , const2PatchDMapWithMoveWith
46 , DMapEdit (..)
47 , dmapEditMoved
48 -- * Test functions
49 , validPatchMapWithMove
50 , knownValidPatchMapWithMove
51 , knownInvalidPatchMapWithMove
52 ) where
54import Control.Monad.Identity
55import Data.Dependent.Map (DMap, DSum (..), GCompare (..))
56import qualified Data.Dependent.Map as DMap
57import Data.Function
58import Data.Functor.Constant
59import Data.Functor.Misc
60import Data.List
61import Data.Map (Map)
62import qualified Data.Map as Map
63import Data.Maybe
64import Data.Semigroup (Semigroup (..), stimesIdempotentMonoid, (<>))
65import Data.Some (Some)
66import qualified Data.Some as Some
68-- | A 'Patch' type represents a kind of change made to a datastructure.
69class Patch p where
70 type PatchTarget p :: *
71 -- | Apply the patch @p a@ to the value @a@. If no change is needed, return
72 -- 'Nothing'.
73 apply :: p -> PatchTarget p -> Maybe (PatchTarget p)
75-- | We can't use @Compose Maybe@ instead of 'ComposeMaybe', because that would
76-- make the 'f' parameter have a nominal type role. We need f to be
77-- representational so that we can use safe 'coerce'.
78newtype ComposeMaybe f a = ComposeMaybe { getComposeMaybe :: Maybe (f a) }
80deriving instance Functor f => Functor (ComposeMaybe f)
82instance Patch (Identity a) where
83 type PatchTarget (Identity a) = a
84 apply (Identity a) _ = Just a
86-- | A set of changes to a 'DMap'. Any element may be inserted/updated or
87-- deleted.
88newtype PatchDMap k v = PatchDMap (DMap k (ComposeMaybe v))
90deriving instance GCompare k => Semigroup (PatchDMap k v)
92deriving instance GCompare k => Monoid (PatchDMap k v)
94instance GCompare k => Patch (PatchDMap k v) where
95 type PatchTarget (PatchDMap k v) = DMap k v
96 apply (PatchDMap diff) old = Just $! insertions `DMap.union` (old `DMap.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 = DMap.mapMaybeWithKey (const $ getComposeMaybe) diff
98 deletions = DMap.mapMaybeWithKey (const $ nothingToJust . getComposeMaybe) diff
99 nothingToJust = \case
100 Nothing -> Just $ Constant ()
101 Just _ -> Nothing
103mapPatchDMap :: (forall a. v a -> v' a) -> PatchDMap k v -> PatchDMap k v'
104mapPatchDMap f (PatchDMap p) = PatchDMap $ DMap.map (ComposeMaybe . fmap f . getComposeMaybe) p
106traversePatchDMap :: Applicative m => (forall a. v a -> m (v' a)) -> PatchDMap k v -> m (PatchDMap k v')
107traversePatchDMap f = traversePatchDMapWithKey $ const f
109traversePatchDMapWithKey :: Applicative m => (forall a. k a -> v a -> m (v' a)) -> PatchDMap k v -> m (PatchDMap k v')
110traversePatchDMapWithKey f (PatchDMap p) = PatchDMap <$> DMap.traverseWithKey (\k (ComposeMaybe v) -> ComposeMaybe <$> traverse (f k) v) p
112weakenPatchDMapWith :: (forall a. v a -> v') -> PatchDMap k v -> PatchMap (Some k) v'
113weakenPatchDMapWith f (PatchDMap p) = PatchMap $ weakenDMapWith (fmap f . getComposeMaybe) p
115patchDMapToPatchMapWith :: (f v -> v') -> PatchDMap (Const2 k v) f -> PatchMap k v'
116patchDMapToPatchMapWith f (PatchDMap p) = PatchMap $ dmapToMapWith (fmap f . getComposeMaybe) p
118const2PatchDMapWith :: forall k v f a. (v -> f a) -> PatchMap k v -> PatchDMap (Const2 k a) f
119const2PatchDMapWith f (PatchMap p) = PatchDMap $ DMap.fromDistinctAscList $ g <$> Map.toAscList p
120 where g :: (k, Maybe v) -> DSum (Const2 k a) (ComposeMaybe f)
121 g (k, e) = Const2 k :=> ComposeMaybe (f <$> e)
123-- | A set of changes to a 'Map'. Any element may be inserted/updated or
124-- deleted.
125newtype PatchMap k v = PatchMap { unPatchMap :: Map k (Maybe v) }
127instance Ord k => Patch (PatchMap k v) where
128 type PatchTarget (PatchMap k v) = Map k v
129 apply (PatchMap 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?
130 where insertions = Map.mapMaybeWithKey (const id) p
131 deletions = Map.mapMaybeWithKey (const nothingToJust) p
132 nothingToJust = \case
133 Nothing -> Just ()
134 Just _ -> Nothing
136instance Ord k => Semigroup (PatchMap k v) where
137 PatchMap a <> PatchMap b = PatchMap $ a `mappend` b --TODO: Add a semigroup instance for Map
138 -- PatchMap is idempotent, so stimes n is id for every n
139#if MIN_VERSION_semigroups(0,17,0)
140 stimes = stimesIdempotentMonoid
141#else
142 times1p n x = case compare n 0 of
143 LT -> error "stimesIdempotentMonoid: negative multiplier"
144 EQ -> mempty
145 GT -> x
146#endif
148instance Ord k => Monoid (PatchMap k v) where
149 mempty = PatchMap mempty
150 mappend = (<>)
152instance Functor (PatchMap k) where
153 fmap f = PatchMap . fmap (fmap f) . unPatchMap
155-- | Returns all the new elements that will be added to the 'Map'
156patchMapNewElements :: PatchMap k v -> [v]
157patchMapNewElements (PatchMap p) = catMaybes $ Map.elems p
159---- Patches based on commutative groups
161-- | A 'Group' is a 'Monoid' where every element has an inverse.
162class (Semigroup q, Monoid q) => Group q where
163 negateG :: q -> q
164 (~~) :: q -> q -> q
165 r ~~ s = r <> negateG s
167-- | An 'Additive' 'Semigroup' is one where (<>) is commutative
168class Semigroup q => Additive q where
170-- | The elements of an 'Additive' 'Semigroup' can be considered as patches of their own type.
171newtype AdditivePatch p = AdditivePatch { unAdditivePatch :: p }
173instance Additive p => Patch (AdditivePatch p) where
174 type PatchTarget (AdditivePatch p) = p
175 apply (AdditivePatch p) q = Just $ p <> q
177data MapEdit k v
178 = MapEdit_Insert Bool v -- ^ Insert the given value here
179 | MapEdit_Delete Bool -- ^ Delete the existing value, if any, from here
180 | MapEdit_Move Bool k -- ^ Move the value here from the given key
181 deriving (Functor, Foldable, Traversable)
183mapEditMoved :: MapEdit k v -> Bool
184mapEditMoved = \case
185 MapEdit_Insert moved _ -> moved
186 MapEdit_Delete moved -> moved
187 MapEdit_Move moved _ -> moved
189-- | Patch a DMap with additions, deletions, and moves.
190-- Invariants:
191-- * The same source key may not be moved to two destination keys.
192-- * Any key that is the source of a Move must also be edited
193-- (otherwise, the Move would duplicate it)
194data PatchMapWithMove k v = PatchMapWithMove (Map k (MapEdit k v)) deriving (Functor, Foldable, Traversable)
196unPatchMapWithMove :: PatchMapWithMove k v -> Map k (MapEdit k v)
197unPatchMapWithMove (PatchMapWithMove p) = p
199-- | Warning: when using this function, you must ensure that the invariants of
200-- 'PatchMapWithMove' are preserved; they will not be checked.
201unsafePatchMapWithMove :: Map k (MapEdit k v) -> PatchMapWithMove k v
202unsafePatchMapWithMove = PatchMapWithMove
204instance Ord k => Patch (PatchMapWithMove k v) where
205 type PatchTarget (PatchMapWithMove k v) = Map k v
206 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?
207 where insertions = flip Map.mapMaybeWithKey p $ const $ \case
208 MapEdit_Insert _ v -> Just v
209 MapEdit_Move _ k -> Map.lookup k old
210 MapEdit_Delete _ -> Nothing
211 deletions = flip Map.mapMaybeWithKey p $ const $ \case
212 MapEdit_Delete _ -> Nothing
213 _ -> Just ()
215-- | Returns all the new elements that will be added to the 'Map'
216patchMapWithMoveNewElements :: PatchMapWithMove k v -> [v]
217patchMapWithMoveNewElements (PatchMapWithMove p) = catMaybes $ flip fmap (Map.elems p) $ \case
218 MapEdit_Insert _ v -> Just v
219 MapEdit_Move _ _ -> Nothing
220 MapEdit_Delete _ -> Nothing
222validPatchMapWithMove :: Ord k => PatchMapWithMove k v -> Bool
223validPatchMapWithMove (PatchMapWithMove p) =
224 let moveSources = catMaybes $ flip fmap (Map.elems p) $ \case
225 MapEdit_Move _ k -> Just k
226 _ -> Nothing
227 in and
228 [ -- All Moves must have unique source keys - a single source key can't be moved to two destinations
229 all (==1) $ Map.fromListWith (+) $ fmap (\k -> (k, 1 :: Integer )) moveSources
230 , -- 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)
231 all (isJust . flip Map.lookup p) moveSources
232 ]
234knownValidPatchMapWithMove :: [PatchMapWithMove Int Int]
235knownValidPatchMapWithMove =
236 [ PatchMapWithMove mempty
237 , PatchMapWithMove $ Map.fromList
238 [ (1, MapEdit_Move True 2)
239 , (2, MapEdit_Move True 1)
240 ]
241 ]
243knownInvalidPatchMapWithMove :: [PatchMapWithMove Int Int]
244knownInvalidPatchMapWithMove =
245 [ -- Invalid because we move 2 to 1, but don't specify what to do with 2
246 PatchMapWithMove $ Map.singleton 1 $ MapEdit_Move False 2
247 , -- Invalid because we have multiple moves from 3
248 PatchMapWithMove $ Map.fromList
249 [ (1, MapEdit_Move False 3)
250 , (2, MapEdit_Move False 3)
251 , (3, MapEdit_Delete True)
252 ]
253 ]
255patchThatSortsMapWith :: Ord k => (v -> v -> Ordering) -> Map k v -> PatchMapWithMove k v
256patchThatSortsMapWith cmp m = PatchMapWithMove $ Map.fromList $ catMaybes $ zipWith g l $ sortBy (cmp `on` snd) l
257 where l = Map.toList m
258 g (to, _) (from, _) = if to == from
259 then Nothing
260 else Just (to, MapEdit_Move True from)
262data DMapEdit (k :: a -> *) (v :: a -> *) :: a -> * where
263 -- | Insert the given value here
264 DMapEdit_Insert :: Bool -> v a -> DMapEdit k v a
265 -- | Delete the existing value, if any, from here
266 DMapEdit_Delete :: Bool -> DMapEdit k v a
267 -- | Move the value here from the given key
268 DMapEdit_Move :: Bool -> k a -> DMapEdit k v a
270dmapEditMoved :: DMapEdit k v a -> Bool
271dmapEditMoved = \case
272 DMapEdit_Insert moved _ -> moved
273 DMapEdit_Delete moved -> moved
274 DMapEdit_Move moved _ -> moved
276-- | Like 'PatchMapWithMove', but for 'DMap'.
277newtype PatchDMapWithMove k v = PatchDMapWithMove (DMap k (DMapEdit k v))
279unPatchDMapWithMove :: PatchDMapWithMove k v -> DMap k (DMapEdit k v)
280unPatchDMapWithMove (PatchDMapWithMove p) = p
282-- | Warning: when using this function, you must ensure that the invariants of
283-- 'PatchDMapWithMove' are preserved; they will not be checked.
284unsafePatchDMapWithMove :: DMap k (DMapEdit k v) -> PatchDMapWithMove k v
285unsafePatchDMapWithMove = PatchDMapWithMove
287mapPatchDMapWithMove :: forall k v v'. (forall a. v a -> v' a) -> PatchDMapWithMove k v -> PatchDMapWithMove k v'
288mapPatchDMapWithMove f (PatchDMapWithMove p) = PatchDMapWithMove $ DMap.map g p
289 where g :: forall a. DMapEdit k v a -> DMapEdit k v' a
290 g = \case
291 DMapEdit_Insert moved v -> DMapEdit_Insert moved $ f v
292 DMapEdit_Delete moved -> DMapEdit_Delete moved
293 DMapEdit_Move moved k -> DMapEdit_Move moved k
295traversePatchDMapWithMove :: forall m k v v'. Applicative m => (forall a. v a -> m (v' a)) -> PatchDMapWithMove k v -> m (PatchDMapWithMove k v')
296traversePatchDMapWithMove f = traversePatchDMapWithMoveWithKey $ const f
298traversePatchDMapWithMoveWithKey :: forall m k v v'. Applicative m => (forall a. k a -> v a -> m (v' a)) -> PatchDMapWithMove k v -> m (PatchDMapWithMove k v')
299traversePatchDMapWithMoveWithKey f (PatchDMapWithMove p) = PatchDMapWithMove <$> DMap.traverseWithKey g p
300 where g :: forall a. k a -> DMapEdit k v a -> m (DMapEdit k v' a)
301 g k = \case
302 DMapEdit_Insert moved v -> DMapEdit_Insert moved <$> f k v
303 DMapEdit_Delete moved -> pure $ DMapEdit_Delete moved
304 DMapEdit_Move moved fromKey -> pure $ DMapEdit_Move moved fromKey
306weakenPatchDMapWithMoveWith :: forall k v v'. (forall a. v a -> v') -> PatchDMapWithMove k v -> PatchMapWithMove (Some k) v'
307weakenPatchDMapWithMoveWith f (PatchDMapWithMove p) = PatchMapWithMove $ weakenDMapWith g p
308 where g :: forall a. DMapEdit k v a -> MapEdit (Some k) v'
309 g = \case
310 DMapEdit_Insert moved v -> MapEdit_Insert moved $ f v
311 DMapEdit_Delete moved -> MapEdit_Delete moved
312 DMapEdit_Move moved k -> MapEdit_Move moved $ Some.This k
314patchDMapWithMoveToPatchMapWithMoveWith :: forall k f v v'. (f v -> v') -> PatchDMapWithMove (Const2 k v) f -> PatchMapWithMove k v'
315patchDMapWithMoveToPatchMapWithMoveWith f (PatchDMapWithMove p) = PatchMapWithMove $ dmapToMapWith g p
316 where g :: DMapEdit (Const2 k v) f v -> MapEdit k v'
317 g = \case
318 DMapEdit_Insert moved v -> MapEdit_Insert moved $ f v
319 DMapEdit_Delete moved -> MapEdit_Delete moved
320 DMapEdit_Move moved (Const2 k) -> MapEdit_Move moved k
322const2PatchDMapWithMoveWith :: forall k v f a. (v -> f a) -> PatchMapWithMove k v -> PatchDMapWithMove (Const2 k a) f
323const2PatchDMapWithMoveWith f (PatchMapWithMove p) = PatchDMapWithMove $ DMap.fromDistinctAscList $ g <$> Map.toAscList p
324 where g :: (k, MapEdit k v) -> DSum (Const2 k a) (DMapEdit (Const2 k a) f)
325 g (k, e) = Const2 k :=> case e of
326 MapEdit_Insert moved v -> DMapEdit_Insert moved $ f v
327 MapEdit_Delete moved -> DMapEdit_Delete moved
328 MapEdit_Move moved fromKey -> DMapEdit_Move moved $ Const2 fromKey
330instance GCompare k => Patch (PatchDMapWithMove k v) where
331 type PatchTarget (PatchDMapWithMove k v) = DMap k v
332 apply (PatchDMapWithMove p) old = Just $! insertions `DMap.union` (old `DMap.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?
333 where insertions = DMap.mapMaybeWithKey insertFunc p
334 insertFunc :: forall a. k a -> DMapEdit k v a -> Maybe (v a)
335 insertFunc _ = \case
336 DMapEdit_Insert _ v -> Just v
337 DMapEdit_Move _ k -> DMap.lookup k old
338 DMapEdit_Delete _ -> Nothing
339 deletions = DMap.mapMaybeWithKey deleteFunc p
340 deleteFunc :: forall a. k a -> DMapEdit k v a -> Maybe (Constant () a)
341 deleteFunc _ = \case
342 DMapEdit_Delete _ -> Nothing
343 _ -> Just $ Constant ()