@@ -1,28 +1,69 @@
11-- | This module defines the 'Patch' class, which is used by Reflex to manage
22-- changes to 'Reflex.Class.Incremental' values.
33{-# LANGUAGE CPP #-}
4+{-# LANGUAGE DeriveFoldable #-}
45{-# LANGUAGE DeriveFunctor #-}
6+{-# LANGUAGE DeriveTraversable #-}
7+{-# LANGUAGE GADTs #-}
8+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
59{-# LANGUAGE LambdaCase #-}
10+{-# LANGUAGE PolyKinds #-}
11+{-# LANGUAGE Rank2Types #-}
12+{-# LANGUAGE ScopedTypeVariables #-}
613{-# LANGUAGE StandaloneDeriving #-}
714{-# LANGUAGE TypeFamilies #-}
8−{-# LANGUAGE GeneralizedNewtypeDeriving #-}
915module Reflex.Patch
1016 ( Patch (..)
1117 , PatchDMap (..)
18+ , mapPatchDMap
19+ , traversePatchDMap
20+ , traversePatchDMapWithKey
21+ , weakenPatchDMapWith
22+ , patchDMapToPatchMapWith
23+ , const2PatchDMapWith
1224 , ComposeMaybe (..)
1325 , PatchMap (..)
26+ , patchMapNewElements
1427 , Group (..)
1528 , Additive
1629 , 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
1752 ) where
1853
1954import Control.Monad.Identity
20−import Data.Dependent.Map (DMap, GCompare (..))
55+import Data.Dependent.Map (DMap, DSum (..), GCompare (..))
2156import qualified Data.Dependent.Map as DMap
57+import Data.Function
2258import Data.Functor.Constant
59+import Data.Functor.Misc
60+import Data.List
2361import Data.Map (Map)
2462import qualified Data.Map as Map
63+import Data.Maybe
2564import Data.Semigroup (Semigroup (..), stimesIdempotentMonoid, (<>))
65+import Data.Some (Some)
66+import qualified Data.Some as Some
2667
2768-- | A 'Patch' type represents a kind of change made to a datastructure.
2869class Patch p where
@@ -59,9 +100,29 @@ instance GCompare k => Patch (PatchDMap k v) where
59100 Nothing -> Just $ Constant ()
60101 Just _ -> Nothing
61102
103+mapPatchDMap :: (forall a. v a -> v' a) -> PatchDMap k v -> PatchDMap k v'
104+mapPatchDMap f (PatchDMap p) = PatchDMap $ DMap.map (ComposeMaybe . fmap f . getComposeMaybe) p
105+
106+traversePatchDMap :: Applicative m => (forall a. v a -> m (v' a)) -> PatchDMap k v -> m (PatchDMap k v')
107+traversePatchDMap f = traversePatchDMapWithKey $ const f
108+
109+traversePatchDMapWithKey :: Applicative m => (forall a. k a -> v a -> m (v' a)) -> PatchDMap k v -> m (PatchDMap k v')
110+traversePatchDMapWithKey f (PatchDMap p) = PatchDMap <$> DMap.traverseWithKey (\k (ComposeMaybe v) -> ComposeMaybe <$> traverse (f k) v) p
111+
112+weakenPatchDMapWith :: (forall a. v a -> v') -> PatchDMap k v -> PatchMap (Some k) v'
113+weakenPatchDMapWith f (PatchDMap p) = PatchMap $ weakenDMapWith (fmap f . getComposeMaybe) p
114+
115+patchDMapToPatchMapWith :: (f v -> v') -> PatchDMap (Const2 k v) f -> PatchMap k v'
116+patchDMapToPatchMapWith f (PatchDMap p) = PatchMap $ dmapToMapWith (fmap f . getComposeMaybe) p
117+
118+const2PatchDMapWith :: forall k v f a. (v -> f a) -> PatchMap k v -> PatchDMap (Const2 k a) f
119+const2PatchDMapWith 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)
122+
62123-- | A set of changes to a 'Map'. Any element may be inserted/updated or
63124-- deleted.
64−newtype PatchMap k v = PatchMap (Map k (Maybe v))
125+newtype PatchMap k v = PatchMap { unPatchMap :: Map k (Maybe v) }
65126
66127instance Ord k => Patch (PatchMap k v) where
67128 type PatchTarget (PatchMap k v) = Map k v
@@ -88,6 +149,13 @@ instance Ord k => Monoid (PatchMap k v) where
88149 mempty = PatchMap mempty
89150 mappend = (<>)
90151
152+instance Functor (PatchMap k) where
153+ fmap f = PatchMap . fmap (fmap f) . unPatchMap
154+
155+-- | Returns all the new elements that will be added to the 'Map'
156+patchMapNewElements :: PatchMap k v -> [v]
157+patchMapNewElements (PatchMap p) = catMaybes $ Map.elems p
158+
91159---- Patches based on commutative groups
92160
93161-- | A 'Group' is a 'Monoid' where every element has an inverse.
@@ -96,7 +164,7 @@ class (Semigroup q, Monoid q) => Group q where
96164 (~~) :: q -> q -> q
97165 r ~~ s = r <> negateG s
98166
99−-- | An 'Additive' 'Semigroup' is one where the multiplication is commutative
167+-- | An 'Additive' 'Semigroup' is one where (<>) is commutative
100168class Semigroup q => Additive q where
101169
102170-- | The elements of an 'Additive' 'Semigroup' can be considered as patches of their own type.
@@ -105,3 +173,171 @@ newtype AdditivePatch p = AdditivePatch { unAdditivePatch :: p }
105173instance Additive p => Patch (AdditivePatch p) where
106174 type PatchTarget (AdditivePatch p) = p
107175 apply (AdditivePatch p) q = Just $ p <> q
176+
177+data 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)
182+
183+mapEditMoved :: MapEdit k v -> Bool
184+mapEditMoved = \case
185+ MapEdit_Insert moved _ -> moved
186+ MapEdit_Delete moved -> moved
187+ MapEdit_Move moved _ -> moved
188+
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)
194+data PatchMapWithMove k v = PatchMapWithMove (Map k (MapEdit k v)) deriving (Functor, Foldable, Traversable)
195+
196+unPatchMapWithMove :: PatchMapWithMove k v -> Map k (MapEdit k v)
197+unPatchMapWithMove (PatchMapWithMove p) = p
198+
199+-- | Warning: when using this function, you must ensure that the invariants of
200+-- 'PatchMapWithMove' are preserved; they will not be checked.
201+unsafePatchMapWithMove :: Map k (MapEdit k v) -> PatchMapWithMove k v
202+unsafePatchMapWithMove = PatchMapWithMove
203+
204+instance 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 ()
214+
215+-- | Returns all the new elements that will be added to the 'Map'
216+patchMapWithMoveNewElements :: PatchMapWithMove k v -> [v]
217+patchMapWithMoveNewElements (PatchMapWithMove p) = catMaybes $ flip fmap (Map.elems p) $ \case
218+ MapEdit_Insert _ v -> Just v
219+ MapEdit_Move _ _ -> Nothing
220+ MapEdit_Delete _ -> Nothing
221+
222+validPatchMapWithMove :: Ord k => PatchMapWithMove k v -> Bool
223+validPatchMapWithMove (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+ ]
233+
234+knownValidPatchMapWithMove :: [PatchMapWithMove Int Int]
235+knownValidPatchMapWithMove =
236+ [ PatchMapWithMove mempty
237+ , PatchMapWithMove $ Map.fromList
238+ [ (1, MapEdit_Move True 2)
239+ , (2, MapEdit_Move True 1)
240+ ]
241+ ]
242+
243+knownInvalidPatchMapWithMove :: [PatchMapWithMove Int Int]
244+knownInvalidPatchMapWithMove =
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+ ]
254+
255+patchThatSortsMapWith :: Ord k => (v -> v -> Ordering) -> Map k v -> PatchMapWithMove k v
256+patchThatSortsMapWith 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)
261+
262+data 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
269+
270+dmapEditMoved :: DMapEdit k v a -> Bool
271+dmapEditMoved = \case
272+ DMapEdit_Insert moved _ -> moved
273+ DMapEdit_Delete moved -> moved
274+ DMapEdit_Move moved _ -> moved
275+
276+-- | Like 'PatchMapWithMove', but for 'DMap'.
277+newtype PatchDMapWithMove k v = PatchDMapWithMove (DMap k (DMapEdit k v))
278+
279+unPatchDMapWithMove :: PatchDMapWithMove k v -> DMap k (DMapEdit k v)
280+unPatchDMapWithMove (PatchDMapWithMove p) = p
281+
282+-- | Warning: when using this function, you must ensure that the invariants of
283+-- 'PatchDMapWithMove' are preserved; they will not be checked.
284+unsafePatchDMapWithMove :: DMap k (DMapEdit k v) -> PatchDMapWithMove k v
285+unsafePatchDMapWithMove = PatchDMapWithMove
286+
287+mapPatchDMapWithMove :: forall k v v'. (forall a. v a -> v' a) -> PatchDMapWithMove k v -> PatchDMapWithMove k v'
288+mapPatchDMapWithMove 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
294+
295+traversePatchDMapWithMove :: forall m k v v'. Applicative m => (forall a. v a -> m (v' a)) -> PatchDMapWithMove k v -> m (PatchDMapWithMove k v')
296+traversePatchDMapWithMove f = traversePatchDMapWithMoveWithKey $ const f
297+
298+traversePatchDMapWithMoveWithKey :: forall m k v v'. Applicative m => (forall a. k a -> v a -> m (v' a)) -> PatchDMapWithMove k v -> m (PatchDMapWithMove k v')
299+traversePatchDMapWithMoveWithKey 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
305+
306+weakenPatchDMapWithMoveWith :: forall k v v'. (forall a. v a -> v') -> PatchDMapWithMove k v -> PatchMapWithMove (Some k) v'
307+weakenPatchDMapWithMoveWith 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
313+
314+patchDMapWithMoveToPatchMapWithMoveWith :: forall k f v v'. (f v -> v') -> PatchDMapWithMove (Const2 k v) f -> PatchMapWithMove k v'
315+patchDMapWithMoveToPatchMapWithMoveWith 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
321+
322+const2PatchDMapWithMoveWith :: forall k v f a. (v -> f a) -> PatchMapWithMove k v -> PatchDMapWithMove (Const2 k a) f
323+const2PatchDMapWithMoveWith 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
329+
330+instance 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 ()