@@ -5,16 +5,19 @@
55{-# LANGUAGE DeriveFunctor #-}
66{-# LANGUAGE DeriveTraversable #-}
77{-# LANGUAGE FlexibleContexts #-}
8+{-# LANGUAGE FlexibleInstances #-}
89{-# LANGUAGE GADTs #-}
910{-# LANGUAGE GeneralizedNewtypeDeriving #-}
1011{-# LANGUAGE LambdaCase #-}
12+{-# LANGUAGE MultiParamTypeClasses #-}
1113{-# LANGUAGE PolyKinds #-}
1214{-# LANGUAGE Rank2Types #-}
1315{-# LANGUAGE ScopedTypeVariables #-}
1416{-# LANGUAGE StandaloneDeriving #-}
1517{-# LANGUAGE TypeFamilies #-}
18+{-# LANGUAGE UndecidableInstances #-}
1619module Reflex.Patch
17− ( Patch (..)
20+{- ( Patch (..)
1821 , PatchDMap (..)
1922 , mapPatchDMap
2023 , traversePatchDMap
@@ -36,7 +39,7 @@ module Reflex.Patch
3639 , mapEditMoved
3740 , mapEditSetMoved
3841 , PatchDMapWithMove
39− , unPatchDMapWithMove
42+-- , unPatchDMapWithMove
4043 , unsafePatchDMapWithMove
4144 , patchThatSortsMapWith
4245 , patchThatChangesAndSortsMapWith
@@ -52,17 +55,20 @@ module Reflex.Patch
5255 , validPatchMapWithMove
5356 , knownValidPatchMapWithMove
5457 , knownInvalidPatchMapWithMove
55− ) where
58+ ) -} where
5659
5760import Control.Arrow
5861import Control.Monad.Identity
5962import Control.Monad.State
6063import Data.Dependent.Map (DMap, DSum (..), GCompare (..))
6164import qualified Data.Dependent.Map as DMap
65+import Data.Dependent.Sum (ShowTag (..), ReadTag (..), EqTag (..), OrdTag (..))
6266import Data.Foldable
6367import Data.Function
6468import Data.Functor.Constant
6569import Data.Functor.Misc
70+import Data.GADT.Compare (GEq (..))
71+import Data.GADT.Show (GShow (..))
6672import Data.List
6773import Data.Map (Map)
6874import qualified Data.Map as Map
@@ -72,6 +78,7 @@ import qualified Data.Set as Set
7278import Data.Some (Some)
7379import qualified Data.Some as Some
7480import Data.Tuple
81+import Data.Typeable (Proxy (..))
7582
7683-- | A 'Patch' type represents a kind of change made to a datastructure.
7784class Patch p where
@@ -80,10 +87,16 @@ class Patch p where
8087 -- 'Nothing'.
8188 apply :: p -> PatchTarget p -> Maybe (PatchTarget p)
8289
90+applyAlways :: Patch p => p -> PatchTarget p -> PatchTarget p
91+applyAlways p t = fromMaybe t $ apply p t
92+
8393-- | We can't use @Compose Maybe@ instead of 'ComposeMaybe', because that would
8494-- make the 'f' parameter have a nominal type role. We need f to be
8595-- representational so that we can use safe 'coerce'.
86−newtype ComposeMaybe f a = ComposeMaybe { getComposeMaybe :: Maybe (f a) }
96+newtype ComposeMaybe f a = ComposeMaybe { getComposeMaybe :: Maybe (f a) } deriving (Show, Eq)
97+
98+instance EqTag f g => EqTag f (ComposeMaybe g) where
99+ eqTagToEq f p r = eqTagToEq f (Proxy :: Proxy g) r
87100
88101deriving instance Functor f => Functor (ComposeMaybe f)
89102
@@ -183,18 +196,18 @@ instance Additive p => Patch (AdditivePatch p) where
183196 apply (AdditivePatch p) q = Just $ p <> q
184197
185198data MapEdit k v
186− = MapEdit_Insert Bool v -- ^ Insert the given value here
187− | MapEdit_Delete Bool -- ^ Delete the existing value, if any, from here
188− | MapEdit_Move Bool k -- ^ Move the value here from the given key
199+ = MapEdit_Insert (Maybe k) v -- ^ Insert the given value here
200+ | MapEdit_Delete (Maybe k) -- ^ Delete the existing value, if any, from here
201+ | MapEdit_Move (Maybe k) k -- ^ Move the value here from the given key
189202 deriving (Show, Read, Eq, Ord, Functor, Foldable, Traversable)
190203
191204mapEditMoved :: MapEdit k v -> Bool
192−mapEditMoved = \case
205+mapEditMoved = isJust . \case
193206 MapEdit_Insert moved _ -> moved
194207 MapEdit_Delete moved -> moved
195208 MapEdit_Move moved _ -> moved
196209
197−mapEditSetMoved :: Bool -> MapEdit k v -> MapEdit k v
210+mapEditSetMoved :: Maybe k -> MapEdit k v -> MapEdit k v
198211mapEditSetMoved moved = \case
199212 MapEdit_Insert _ v -> MapEdit_Insert moved v
200213 MapEdit_Delete _ -> MapEdit_Delete moved
@@ -249,29 +262,33 @@ knownValidPatchMapWithMove :: [PatchMapWithMove Int Int]
249262knownValidPatchMapWithMove =
250263 [ PatchMapWithMove mempty
251264 , PatchMapWithMove $ Map.fromList
252− [ (1, MapEdit_Move True 2)
253− , (2, MapEdit_Move True 1)
265+ [ (1, MapEdit_Move (Just 1) 2)
266+ , (2, MapEdit_Move (Just 2) 1)
254267 ]
255268 ]
256269
257270knownInvalidPatchMapWithMove :: [PatchMapWithMove Int Int]
258271knownInvalidPatchMapWithMove =
259272 [ -- Invalid because we move 2 to 1, but don't specify what to do with 2
260− PatchMapWithMove $ Map.singleton 1 $ MapEdit_Move False 2
273+ PatchMapWithMove $ Map.singleton 1 $ MapEdit_Move Nothing 2
261274 , -- Invalid because we have multiple moves from 3
262275 PatchMapWithMove $ Map.fromList
263− [ (1, MapEdit_Move False 3)
264− , (2, MapEdit_Move False 3)
265− , (3, MapEdit_Delete True)
276+ [ (1, MapEdit_Move Nothing 3)
277+ , (2, MapEdit_Move Nothing 3)
278+ , (3, MapEdit_Delete (Just 1))
266279 ]
267280 ]
268281
269282patchThatSortsMapWith :: Ord k => (v -> v -> Ordering) -> Map k v -> PatchMapWithMove k v
270−patchThatSortsMapWith cmp m = PatchMapWithMove $ Map.fromList $ catMaybes $ zipWith g l $ sortBy (cmp `on` snd) l
271− where l = Map.toList m
272− g (to, _) (from, _) = if to == from
273− then Nothing
274− else Just (to, MapEdit_Move True from)
283+patchThatSortsMapWith cmp m = PatchMapWithMove $ Map.fromList $ catMaybes $ zipWith g unsorted sorted
284+ where unsorted = Map.toList m
285+ sorted = sortBy (cmp `on` snd) unsorted
286+ f (to, _) (from, _) = if to == from then Nothing else
287+ Just (from, to)
288+ reverseMapping = Map.fromList $ catMaybes $ zipWith f unsorted sorted
289+ g (to, _) (from, _) = if to == from then Nothing else
290+ let Just movingTo = Map.lookup from reverseMapping
291+ in Just (to, MapEdit_Move (Just movingTo) from)
275292
276293patchThatChangesAndSortsMapWith :: (Ord k, Ord v) => (v -> v -> Ordering) -> Map k v -> Map k v -> PatchMapWithMove k v
277294patchThatChangesAndSortsMapWith cmp oldByIndex newByIndexUnsorted = patch
@@ -285,41 +302,160 @@ patchThatChangesAndSortsMapWith cmp oldByIndex newByIndexUnsorted = patch
285302 then Map.delete v remainingValues
286303 else Map.insert v remainingKeys remainingValues
287304 case Map.lookup v remainingValues of
288− Nothing -> return $ MapEdit_Insert True v -- There's no existing value we can take
305+ Nothing -> return $ MapEdit_Insert (Just undefined) v -- There's no existing value we can take
289306 Just fromKs ->
290307 if k `Set.member` fromKs
291308 then do
292309 putRemainingKeys $ Set.delete k fromKs
293− return $ MapEdit_Move True k -- There's an existing value, and it's here, so no patch necessary
310+ return $ MapEdit_Move (Just undefined) k -- There's an existing value, and it's here, so no patch necessary
294311 else do
295312 Just (fromK, remainingKeys) <- return $ Set.minView fromKs -- There's an existing value, but it's not here; move it here
296313 putRemainingKeys remainingKeys
297− return $ MapEdit_Move True fromK
314+ return $ MapEdit_Move (Just undefined) fromK
298315 Map.traverseWithKey f newByIndex
299316 unusedOldKeys = fold unusedValuesByValue
300317 pointlessMove k = \case
301318 MapEdit_Move _ k' | k == k' -> True
302319 _ -> False
303− keyWasMoved k = k `Map.member` oldByIndex && not (k `Set.member` unusedOldKeys)
320+ keyWasMoved k = if k `Map.member` oldByIndex && not (k `Set.member` unusedOldKeys)
321+ then Just undefined
322+ else Nothing
304323 patch = unsafePatchMapWithMove $ Map.filterWithKey (\k v -> not $ pointlessMove k v) $ Map.mergeWithKey (\k a _ -> Just $ mapEditSetMoved (keyWasMoved k) a) (Map.mapWithKey $ \k -> mapEditSetMoved $ keyWasMoved k) (Map.mapWithKey $ \k _ -> MapEdit_Delete $ keyWasMoved k) insertsAndMoves oldByIndex
305324
306325data DMapEdit (k :: a -> *) (v :: a -> *) :: a -> * where
307326 -- | Insert the given value here
308− DMapEdit_Insert :: Bool -> v a -> DMapEdit k v a
327+ DMapEdit_Insert :: v a -> DMapEdit k v a
309328 -- | Delete the existing value, if any, from here
310− DMapEdit_Delete :: Bool -> DMapEdit k v a
329+ DMapEdit_Delete :: DMapEdit k v a
311330 -- | Move the value here from the given key
312− DMapEdit_Move :: Bool -> k a -> DMapEdit k v a
331+ DMapEdit_Move :: k a -> DMapEdit k v a
332+ deriving (Show, Read, Eq, Ord)
333+
334+instance {-# INCOHERENT #-} (GShow k, ShowTag k v) => ShowTag k (DMapEdit k v) where
335+ showTagToShow k _ r = gshowToShow k $ showTagToShow k (Proxy :: Proxy v) r
336+
337+instance {-# INCOHERENT #-} GShow k => ShowTag k (ComposeMaybe k) where
338+ showTagToShow k _ r = gshowToShow k (showTagToShow k (Proxy :: Proxy k) r)
313339
340+instance (GEq k, EqTag k v) => EqTag k (DMapEdit k v) where
341+ eqTagToEq k p r = eqTagToEq k (Proxy :: Proxy v) (geqToEq k r)
342+
343+{-
314344dmapEditMoved :: DMapEdit k v a -> Bool
315−dmapEditMoved = \case
345+dmapEditMoved = isJust . dmapEditMovedTo
346+
347+dmapEditMovedTo :: DMapEdit k v a -> Maybe (k a)
348+dmapEditMovedTo = \case
316349 DMapEdit_Insert moved _ -> moved
317350 DMapEdit_Delete moved -> moved
318351 DMapEdit_Move moved _ -> moved
352+-}
319353
320354-- | Like 'PatchMapWithMove', but for 'DMap'.
321−newtype PatchDMapWithMove k v = PatchDMapWithMove (DMap k (DMapEdit k v))
322−
355+data PatchDMapWithMove k v = PatchDMapWithMove (DMap k (DMapEdit k v)) (DMap k (ComposeMaybe k))
356+ deriving (Show)
357+
358+validPatchDMapWithMove :: forall k v. (GCompare k, EqTag k (ComposeMaybe k)) => PatchDMapWithMove k v -> Bool
359+validPatchDMapWithMove (PatchDMapWithMove dst src) = src == srcFromDst
360+ where
361+ srcFromDst :: DMap k (ComposeMaybe k)
362+ srcFromDst = DMap.fromList $ flip fmap (DMap.toList dst) $ \(to :=> edit) -> case edit of
363+ DMapEdit_Move from -> from :=> ComposeMaybe (Just to)
364+ _ -> to :=> ComposeMaybe Nothing
365+
366+instance (Eq k, Eq v) => EqTag (Const2 k v) Identity where
367+ eqTagToEq (Const2 _) _ = id
368+
369+instance (Eq k, Eq v) => EqTag (Const2 k v) (Const2 k v) where
370+ eqTagToEq (Const2 _) _ = id
371+
372+moveDMapKey :: GCompare k => k a -> k a -> PatchDMapWithMove k v
373+moveDMapKey src dst = case src `geq` dst of
374+ Nothing -> PatchDMapWithMove (DMap.fromList [dst :=> DMapEdit_Move src, src :=> DMapEdit_Delete]) (DMap.fromList [src :=> ComposeMaybe (Just dst), dst :=> ComposeMaybe Nothing])
375+ Just _ -> mempty
376+
377+deleteDMapKey :: k a -> PatchDMapWithMove k v
378+deleteDMapKey k = PatchDMapWithMove (DMap.singleton k DMapEdit_Delete) $ DMap.singleton k $ ComposeMaybe Nothing
379+
380+{-
381+k1, k2 :: Const2 Int () ()
382+k1 = Const2 1
383+k2 = Const2 2
384+p1, p2 :: PatchDMapWithMove (Const2 Int ()) Identity
385+p1 = moveDMapKey k1 k2
386+p2 = moveDMapKey k2 k1
387+p12 = p1 <> p2
388+p21 = p2 <> p1
389+p12Slow = p1 `mappendPatchDMapWithMoveSlow` p2
390+p21Slow = p2 `mappendPatchDMapWithMoveSlow` p1
391+
392+testPatchDMapWithMove = do
393+ print p1
394+ print p2
395+ print $ p12 == deleteDMapKey k1
396+ print $ p21 == deleteDMapKey k2
397+ print $ p12Slow == deleteDMapKey k1
398+ print $ p21Slow == deleteDMapKey k2
399+
400+dst (PatchDMapWithMove x _) = x
401+src (PatchDMapWithMove _ x) = x
402+-}
403+
404+instance (EqTag k k, EqTag k v, EqTag k (ComposeMaybe k)) => Eq (PatchDMapWithMove k v) where
405+ PatchDMapWithMove dstA srcA == PatchDMapWithMove dstB srcB = dstA == dstB && srcA == srcB
406+
407+data Pair1 f g a = Pair1 (f a) (g a)
408+
409+instance GCompare k => Semigroup (PatchDMapWithMove k v) where
410+ (<>) = mappend
411+
412+instance GCompare k => Monoid (PatchDMapWithMove k v) where
413+ mempty = PatchDMapWithMove mempty mempty
414+ PatchDMapWithMove dstAfter srcAfter `mappend` PatchDMapWithMove dstBefore srcBefore = PatchDMapWithMove dst src
415+ where
416+ connections = DMap.toList $ DMap.intersectionWithKey (const Pair1) srcAfter dstBefore
417+ f :: DSum k (Pair1 (ComposeMaybe k) (DMapEdit k v)) -> Maybe (DSum k (ComposeMaybe (DMapEdit k v)))
418+ f (k :=> Pair1 (ComposeMaybe mToAfter) editBefore) = case mToAfter of
419+ Nothing -> Nothing -- Since the result of this connection was simply discarded, we don't need to change dst
420+ Just toAfter -> Just $ (toAfter :=>) $ ComposeMaybe $ case editBefore of
421+ DMapEdit_Move fromBefore -> if isJust $ fromBefore `geq` toAfter
422+ then Nothing -- The two moves have canceled out, so eliminate the destination entry
423+ else Just editBefore
424+ nonMove -> Just editBefore
425+ dstPatch = PatchDMap $ DMap.fromList $ catMaybes $ f <$> connections
426+ dst = applyAlways dstPatch $ DMap.union dstAfter dstBefore
427+ g :: DSum k (Pair1 (ComposeMaybe k) (DMapEdit k v)) -> Maybe (DSum k (ComposeMaybe (ComposeMaybe k)))
428+ g (k :=> Pair1 (ComposeMaybe mToAfter) editBefore) = case editBefore of
429+ DMapEdit_Move fromBefore -> Just $ (fromBefore :=>) $ ComposeMaybe $ case mToAfter of
430+ Nothing -> Just $ ComposeMaybe Nothing -- The item is destroyed in the second patch, so indicate that it is destroyed in the source map
431+ Just toAfter -> if isJust $ toAfter `geq` fromBefore
432+ then Nothing -- The two moves have canceled out, so eliminate the source entry
433+ else Just $ ComposeMaybe mToAfter
434+ _ -> Nothing --TODO: Is this right?
435+ srcPatch = PatchDMap $ DMap.fromList $ catMaybes $ g <$> connections
436+ src = applyAlways srcPatch $ DMap.union srcBefore srcAfter
437+
438+mappendPatchDMapWithMoveSlow :: forall k v. (ShowTag k v, GCompare k) => PatchDMapWithMove k v -> PatchDMapWithMove k v -> PatchDMapWithMove k v
439+PatchDMapWithMove dstAfter srcAfter `mappendPatchDMapWithMoveSlow` PatchDMapWithMove dstBefore srcBefore = PatchDMapWithMove dst src
440+ where
441+ getDstAction k m = fromMaybe (DMapEdit_Move k) $ DMap.lookup k m -- Any key that isn't present is treated as that key moving to itself
442+ removeRedundantDst toKey (DMapEdit_Move fromKey) | isJust (toKey `geq` fromKey) = Nothing
443+ removeRedundantDst _ a = Just a
444+ f :: forall a. k a -> DMapEdit k v a -> Maybe (DMapEdit k v a)
445+ f toKey _ = removeRedundantDst toKey $ case getDstAction toKey dstAfter of
446+ DMapEdit_Move fromKey -> getDstAction fromKey dstBefore
447+ nonMove -> nonMove
448+ dst = DMap.mapMaybeWithKey f $ DMap.union dstAfter dstBefore
449+ getSrcAction k m = fromMaybe (ComposeMaybe $ Just k) $ DMap.lookup k m
450+ removeRedundantSrc fromKey (ComposeMaybe (Just toKey)) | isJust (fromKey `geq` toKey) = Nothing
451+ removeRedundantSrc _ a = Just a
452+ g :: forall a. k a -> ComposeMaybe k a -> Maybe (ComposeMaybe k a)
453+ g fromKey _ = removeRedundantSrc fromKey $ case getSrcAction fromKey srcBefore of
454+ ComposeMaybe Nothing -> ComposeMaybe Nothing
455+ ComposeMaybe (Just toKeyBefore) -> getSrcAction toKeyBefore srcAfter
456+ src = DMap.mapMaybeWithKey g $ DMap.union srcAfter srcBefore
457+
458+{-
323459unPatchDMapWithMove :: PatchDMapWithMove k v -> DMap k (DMapEdit k v)
324460unPatchDMapWithMove (PatchDMapWithMove p) = p
325461
@@ -327,6 +463,28 @@ unPatchDMapWithMove (PatchDMapWithMove p) = p
327463-- 'PatchDMapWithMove' are preserved; they will not be checked.
328464unsafePatchDMapWithMove :: DMap k (DMapEdit k v) -> PatchDMapWithMove k v
329465unsafePatchDMapWithMove = PatchDMapWithMove
466+-}
467+
468+{-
469+instance GCompare k => Monoid (PatchDMapWithMove k v) where
470+ mempty = PatchDMapWithMove mempty
471+ PatchDMapWithMove a `mappend` PatchDMapWithMove b = PatchDMapWithMove $ DMap.unionWithKey f a b
472+ where f :: forall a. k a -> DMapEdit k v a -> DMapEdit k v a -> DMapEdit k v a
473+ f _ ea eb = case (ea, eb) of
474+ (DMapEdit_Delete _, DMapEdit_Delete moved) -> DMapEdit_Delete $ do
475+ dst <- moved
476+ case DMap.lookup dst a of
477+ Nothing -> return dst
478+ Just dstChange -> dmapEditMovedTo dstChange
479+ (DMapEdit_Move _ from, DMapEdit_Delete moved) -> DMapEdit_Move moved from
480+ (DMapEdit_Insert _ v, DMapEdit_Delete moved) -> DMapEdit_Insert moved v
481+ (DMapEdit_Delete _, DMapEdit_Insert moved v) -> DMapEdit_Delete moved
482+ (DMapEdit_Move _ from, DMapEdit_Insert moved v) -> DMapEdit_Move moved from
483+ (DMapEdit_Insert _ newV, DMapEdit_Insert moved oldV) -> DMapEdit_Insert moved newV
484+ (DMapEdit_Delete _, DMapEdit_Move moved k) -> DMapEdit_Delete moved
485+-}
486+
487+{-
330488
331489mapPatchDMapWithMove :: forall k v v'. (forall a. v a -> v' a) -> PatchDMapWithMove k v -> PatchDMapWithMove k v'
332490mapPatchDMapWithMove f (PatchDMapWithMove p) = PatchDMapWithMove $ DMap.map g p
@@ -351,25 +509,25 @@ weakenPatchDMapWithMoveWith :: forall k v v'. (forall a. v a -> v') -> PatchDMap
351509weakenPatchDMapWithMoveWith f (PatchDMapWithMove p) = PatchMapWithMove $ weakenDMapWith g p
352510 where g :: forall a. DMapEdit k v a -> MapEdit (Some k) v'
353511 g = \case
354− DMapEdit_Insert moved v -> MapEdit_Insert moved $ f v
355− DMapEdit_Delete moved -> MapEdit_Delete moved
356− DMapEdit_Move moved k -> MapEdit_Move moved $ Some.This k
512+ DMapEdit_Insert moved v -> MapEdit_Insert (Some.This <$> moved) $ f v
513+ DMapEdit_Delete moved -> MapEdit_Delete $ Some.This <$> moved
514+ DMapEdit_Move moved k -> MapEdit_Move (Some.This <$> moved) $ Some.This k
357515
358516patchDMapWithMoveToPatchMapWithMoveWith :: forall k f v v'. (f v -> v') -> PatchDMapWithMove (Const2 k v) f -> PatchMapWithMove k v'
359517patchDMapWithMoveToPatchMapWithMoveWith f (PatchDMapWithMove p) = PatchMapWithMove $ dmapToMapWith g p
360518 where g :: DMapEdit (Const2 k v) f v -> MapEdit k v'
361519 g = \case
362− DMapEdit_Insert moved v -> MapEdit_Insert moved $ f v
363− DMapEdit_Delete moved -> MapEdit_Delete moved
364− DMapEdit_Move moved (Const2 k) -> MapEdit_Move moved k
520+ DMapEdit_Insert moved v -> MapEdit_Insert (unConst2 <$> moved) $ f v
521+ DMapEdit_Delete moved -> MapEdit_Delete $ unConst2 <$> moved
522+ DMapEdit_Move moved (Const2 k) -> MapEdit_Move (unConst2 <$> moved) k
365523
366524const2PatchDMapWithMoveWith :: forall k v f a. (v -> f a) -> PatchMapWithMove k v -> PatchDMapWithMove (Const2 k a) f
367525const2PatchDMapWithMoveWith f (PatchMapWithMove p) = PatchDMapWithMove $ DMap.fromDistinctAscList $ g <$> Map.toAscList p
368526 where g :: (k, MapEdit k v) -> DSum (Const2 k a) (DMapEdit (Const2 k a) f)
369527 g (k, e) = Const2 k :=> case e of
370− MapEdit_Insert moved v -> DMapEdit_Insert moved $ f v
371− MapEdit_Delete moved -> DMapEdit_Delete moved
372− MapEdit_Move moved fromKey -> DMapEdit_Move moved $ Const2 fromKey
528+ MapEdit_Insert moved v -> DMapEdit_Insert (Const2 <$> moved) $ f v
529+ MapEdit_Delete moved -> DMapEdit_Delete $ Const2 <$> moved
530+ MapEdit_Move moved fromKey -> DMapEdit_Move (Const2 <$> moved) $ Const2 fromKey
373531
374532instance GCompare k => Patch (PatchDMapWithMove k v) where
375533 type PatchTarget (PatchDMapWithMove k v) = DMap k v
@@ -385,3 +543,4 @@ instance GCompare k => Patch (PatchDMapWithMove k v) where
385543 deleteFunc _ = \case
386544 DMapEdit_Delete _ -> Just $ Constant ()
387545 _ -> Nothing
546+-}