git.iko.soy/reflex
on develop help sign in
WIP: Monoid instance for PatchDMapWithMove is basically working
4defc95Ryan Trinkle
src/Data/Functor/Misc.hs+37−19
compare with develop
unifiedsplit
@@ -19,6 +19,7 @@
19module Data.Functor.Misc
19module Data.Functor.Misc
20 ( -- * Const2
20 ( -- * Const2
21 Const2 (..)
21 Const2 (..)
22+ , unConst2
22 , dmapToMap
23 , dmapToMap
23 , dmapToMapWith
24 , dmapToMapWith
24 , mapToDMap
25 , mapToDMap
@@ -66,25 +67,27 @@ data Const2 :: * -> x -> x -> * where
66 Const2 :: k -> Const2 k v v
67 Const2 :: k -> Const2 k v v
67 deriving (Typeable)
68 deriving (Typeable)
68
69
70+unConst2 :: Const2 k v v' -> k
71+unConst2 (Const2 k) = k
72+
73+deriving instance Eq k => Eq (Const2 k v v')
74+deriving instance Ord k => Ord (Const2 k v v')
69−deriving instance Show k => Show (Const2 k v v)
75+deriving instance Show k => Show (Const2 k v v')
76+deriving instance Read k => Read (Const2 k v v)
70
77
71instance Show k => GShow (Const2 k v) where
78instance Show k => GShow (Const2 k v) where
72− gshowsPrec n x@(Const2 _) = showsPrec n x
79+ gshowToShow (Const2 _) = id
73
80
74instance (Show k, Show (f v)) => ShowTag (Const2 k v) f where
81instance (Show k, Show (f v)) => ShowTag (Const2 k v) f where
75− showTaggedPrec (Const2 _) = showsPrec
82+ showTagToShow (Const2 _) _ = id
76
83
77instance Eq k => GEq (Const2 k v) where
84instance Eq k => GEq (Const2 k v) where
85+ geqToEq _ = id
78− geq (Const2 a) (Const2 b) =
86+ geqUnify (Const2 _) (Const2 _) _ = id
79− if a == b
80− then Just Refl
81− else Nothing
82
87
83instance Ord k => GCompare (Const2 k v) where
88instance Ord k => GCompare (Const2 k v) where
89+ gcompareToOrd (Const2 _) = id
84− gcompare (Const2 a) (Const2 b) = case compare a b of
90+ gcompare (Const2 a) (Const2 b) = strengthenOrdering $ compare a b
85− LT -> GLT
86− EQ -> GEQ
87− GT -> GGT
88
91
89-- | Convert a 'DMap' to a regular 'Map'
92-- | Convert a 'DMap' to a regular 'Map'
90dmapToMap :: DMap (Const2 k v) Identity -> Map k v
93dmapToMap :: DMap (Const2 k v) Identity -> Map k v
@@ -115,10 +118,17 @@ weakenDMapWith f = Map.fromDistinctAscList . map (\(k :=> v) -> (Some.This k, f
115data WrapArg :: (k -> *) -> (k -> *) -> * -> * where
118data WrapArg :: (k -> *) -> (k -> *) -> * -> * where
116 WrapArg :: f a -> WrapArg g f (g a)
119 WrapArg :: f a -> WrapArg g f (g a)
117
120
121+deriving instance Eq (f a) => Eq (WrapArg g f (g' a))
122+deriving instance Ord (f a) => Ord (WrapArg g f (g' a))
123+deriving instance Show (f a) => Show (WrapArg g f (g' a))
124+deriving instance Read (f a) => Read (WrapArg g f (g a))
125+
118instance GEq f => GEq (WrapArg g f) where
126instance GEq f => GEq (WrapArg g f) where
119− geq (WrapArg a) (WrapArg b) = (\Refl -> Refl) <$> geq a b
127+ geqToEq (WrapArg f) r = geqToEq f r
128+ geqUnify (WrapArg a) (WrapArg b) = geqUnify a b
120
129
121instance GCompare f => GCompare (WrapArg g f) where
130instance GCompare f => GCompare (WrapArg g f) where
131+ gcompareToOrd (WrapArg f) = gcompareToOrd f
122 gcompare (WrapArg a) (WrapArg b) = case gcompare a b of
132 gcompare (WrapArg a) (WrapArg b) = case gcompare a b of
123 GLT -> GLT
133 GLT -> GLT
124 GEQ -> GEQ
134 GEQ -> GEQ
@@ -164,29 +174,37 @@ dmapToThese m = case (DMap.lookup LeftTag m, DMap.lookup RightTag m) of
164data EitherTag l r a where
174data EitherTag l r a where
165 LeftTag :: EitherTag l r l
175 LeftTag :: EitherTag l r l
166 RightTag :: EitherTag l r r
176 RightTag :: EitherTag l r r
177+ deriving (Typeable)
178+
179+deriving instance Show (EitherTag l r a)
180+deriving instance Eq (EitherTag l r a)
181+deriving instance Ord (EitherTag l r a)
167
182
168instance GEq (EitherTag l r) where
183instance GEq (EitherTag l r) where
184+ geqToEq _ = id
185+ geqUnify LeftTag LeftTag _ same = same
186+ geqUnify RightTag RightTag _ same = same
187+ geqUnify _ _ unknown _ = unknown
169 geq a b = case (a, b) of
188 geq a b = case (a, b) of
170 (LeftTag, LeftTag) -> Just Refl
189 (LeftTag, LeftTag) -> Just Refl
171 (RightTag, RightTag) -> Just Refl
190 (RightTag, RightTag) -> Just Refl
172 _ -> Nothing
191 _ -> Nothing
173
192
174instance GCompare (EitherTag l r) where
193instance GCompare (EitherTag l r) where
194+ gcompareToOrd _ = id
175 gcompare a b = case (a, b) of
195 gcompare a b = case (a, b) of
176 (LeftTag, LeftTag) -> GEQ
196 (LeftTag, LeftTag) -> GEQ
177 (LeftTag, RightTag) -> GLT
197 (LeftTag, RightTag) -> GLT
178 (RightTag, LeftTag) -> GGT
198 (RightTag, LeftTag) -> GGT
179 (RightTag, RightTag) -> GEQ
199 (RightTag, RightTag) -> GEQ
180
200
181−instance GShow (EitherTag l r) where
201+instance {-# INCOHERENT #-} GShow (EitherTag l r) where
182− gshowsPrec _ a = case a of
202+ gshowToShow _ = id
183− LeftTag -> showString "LeftTag"
184− RightTag -> showString "RightTag"
185
203
186instance (Show l, Show r) => ShowTag (EitherTag l r) Identity where
204instance (Show l, Show r) => ShowTag (EitherTag l r) Identity where
187− showTaggedPrec t n (Identity a) = case t of
205+ showTagToShow t _ = case t of
188− LeftTag -> showsPrec n a
206+ LeftTag -> id
189− RightTag -> showsPrec n a
207+ RightTag -> id
190
208
191-- | Convert 'Either' to a 'DSum'. Inverse of 'dsumToEither'.
209-- | Convert 'Either' to a 'DSum'. Inverse of 'dsumToEither'.
192eitherToDSum :: Either a b -> DSum (EitherTag a b) Identity
210eitherToDSum :: Either a b -> DSum (EitherTag a b) Identity
src/Reflex/Patch.hs+198−39
@@ -5,16 +5,19 @@
5{-# LANGUAGE DeriveFunctor #-}
5{-# LANGUAGE DeriveFunctor #-}
6{-# LANGUAGE DeriveTraversable #-}
6{-# LANGUAGE DeriveTraversable #-}
7{-# LANGUAGE FlexibleContexts #-}
7{-# LANGUAGE FlexibleContexts #-}
8+{-# LANGUAGE FlexibleInstances #-}
8{-# LANGUAGE GADTs #-}
9{-# LANGUAGE GADTs #-}
9{-# LANGUAGE GeneralizedNewtypeDeriving #-}
10{-# LANGUAGE GeneralizedNewtypeDeriving #-}
10{-# LANGUAGE LambdaCase #-}
11{-# LANGUAGE LambdaCase #-}
12+{-# LANGUAGE MultiParamTypeClasses #-}
11{-# LANGUAGE PolyKinds #-}
13{-# LANGUAGE PolyKinds #-}
12{-# LANGUAGE Rank2Types #-}
14{-# LANGUAGE Rank2Types #-}
13{-# LANGUAGE ScopedTypeVariables #-}
15{-# LANGUAGE ScopedTypeVariables #-}
14{-# LANGUAGE StandaloneDeriving #-}
16{-# LANGUAGE StandaloneDeriving #-}
15{-# LANGUAGE TypeFamilies #-}
17{-# LANGUAGE TypeFamilies #-}
18+{-# LANGUAGE UndecidableInstances #-}
16module Reflex.Patch
19module Reflex.Patch
17− ( Patch (..)
20+{- ( Patch (..)
18 , PatchDMap (..)
21 , PatchDMap (..)
19 , mapPatchDMap
22 , mapPatchDMap
20 , traversePatchDMap
23 , traversePatchDMap
@@ -36,7 +39,7 @@ module Reflex.Patch
36 , mapEditMoved
39 , mapEditMoved
37 , mapEditSetMoved
40 , mapEditSetMoved
38 , PatchDMapWithMove
41 , PatchDMapWithMove
39− , unPatchDMapWithMove
42+-- , unPatchDMapWithMove
40 , unsafePatchDMapWithMove
43 , unsafePatchDMapWithMove
41 , patchThatSortsMapWith
44 , patchThatSortsMapWith
42 , patchThatChangesAndSortsMapWith
45 , patchThatChangesAndSortsMapWith
@@ -52,17 +55,20 @@ module Reflex.Patch
52 , validPatchMapWithMove
55 , validPatchMapWithMove
53 , knownValidPatchMapWithMove
56 , knownValidPatchMapWithMove
54 , knownInvalidPatchMapWithMove
57 , knownInvalidPatchMapWithMove
55− ) where
58+ ) -} where
56
59
57import Control.Arrow
60import Control.Arrow
58import Control.Monad.Identity
61import Control.Monad.Identity
59import Control.Monad.State
62import Control.Monad.State
60import Data.Dependent.Map (DMap, DSum (..), GCompare (..))
63import Data.Dependent.Map (DMap, DSum (..), GCompare (..))
61import qualified Data.Dependent.Map as DMap
64import qualified Data.Dependent.Map as DMap
65+import Data.Dependent.Sum (ShowTag (..), ReadTag (..), EqTag (..), OrdTag (..))
62import Data.Foldable
66import Data.Foldable
63import Data.Function
67import Data.Function
64import Data.Functor.Constant
68import Data.Functor.Constant
65import Data.Functor.Misc
69import Data.Functor.Misc
70+import Data.GADT.Compare (GEq (..))
71+import Data.GADT.Show (GShow (..))
66import Data.List
72import Data.List
67import Data.Map (Map)
73import Data.Map (Map)
68import qualified Data.Map as Map
74import qualified Data.Map as Map
@@ -72,6 +78,7 @@ import qualified Data.Set as Set
72import Data.Some (Some)
78import Data.Some (Some)
73import qualified Data.Some as Some
79import qualified Data.Some as Some
74import Data.Tuple
80import Data.Tuple
81+import Data.Typeable (Proxy (..))
75
82
76-- | A 'Patch' type represents a kind of change made to a datastructure.
83-- | A 'Patch' type represents a kind of change made to a datastructure.
77class Patch p where
84class Patch p where
@@ -80,10 +87,16 @@ class Patch p where
80 -- 'Nothing'.
87 -- 'Nothing'.
81 apply :: p -> PatchTarget p -> Maybe (PatchTarget p)
88 apply :: p -> PatchTarget p -> Maybe (PatchTarget p)
82
89
90+applyAlways :: Patch p => p -> PatchTarget p -> PatchTarget p
91+applyAlways p t = fromMaybe t $ apply p t
92+
83-- | We can't use @Compose Maybe@ instead of 'ComposeMaybe', because that would
93-- | We can't use @Compose Maybe@ instead of 'ComposeMaybe', because that would
84-- make the 'f' parameter have a nominal type role. We need f to be
94-- make the 'f' parameter have a nominal type role. We need f to be
85-- representational so that we can use safe 'coerce'.
95-- 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
87
100
88deriving instance Functor f => Functor (ComposeMaybe f)
101deriving instance Functor f => Functor (ComposeMaybe f)
89
102
@@ -183,18 +196,18 @@ instance Additive p => Patch (AdditivePatch p) where
183 apply (AdditivePatch p) q = Just $ p <> q
196 apply (AdditivePatch p) q = Just $ p <> q
184
197
185data MapEdit k v
198data MapEdit k v
186− = MapEdit_Insert Bool v -- ^ Insert the given value here
199+ = MapEdit_Insert (Maybe k) v -- ^ Insert the given value here
187− | MapEdit_Delete Bool -- ^ Delete the existing value, if any, from here
200+ | MapEdit_Delete (Maybe k) -- ^ Delete the existing value, if any, from here
188− | MapEdit_Move Bool k -- ^ Move the value here from the given key
201+ | MapEdit_Move (Maybe k) k -- ^ Move the value here from the given key
189 deriving (Show, Read, Eq, Ord, Functor, Foldable, Traversable)
202 deriving (Show, Read, Eq, Ord, Functor, Foldable, Traversable)
190
203
191mapEditMoved :: MapEdit k v -> Bool
204mapEditMoved :: MapEdit k v -> Bool
192−mapEditMoved = \case
205+mapEditMoved = isJust . \case
193 MapEdit_Insert moved _ -> moved
206 MapEdit_Insert moved _ -> moved
194 MapEdit_Delete moved -> moved
207 MapEdit_Delete moved -> moved
195 MapEdit_Move moved _ -> moved
208 MapEdit_Move moved _ -> moved
196
209
197−mapEditSetMoved :: Bool -> MapEdit k v -> MapEdit k v
210+mapEditSetMoved :: Maybe k -> MapEdit k v -> MapEdit k v
198mapEditSetMoved moved = \case
211mapEditSetMoved moved = \case
199 MapEdit_Insert _ v -> MapEdit_Insert moved v
212 MapEdit_Insert _ v -> MapEdit_Insert moved v
200 MapEdit_Delete _ -> MapEdit_Delete moved
213 MapEdit_Delete _ -> MapEdit_Delete moved
@@ -249,29 +262,33 @@ knownValidPatchMapWithMove :: [PatchMapWithMove Int Int]
249knownValidPatchMapWithMove =
262knownValidPatchMapWithMove =
250 [ PatchMapWithMove mempty
263 [ PatchMapWithMove mempty
251 , PatchMapWithMove $ Map.fromList
264 , PatchMapWithMove $ Map.fromList
252− [ (1, MapEdit_Move True 2)
265+ [ (1, MapEdit_Move (Just 1) 2)
253− , (2, MapEdit_Move True 1)
266+ , (2, MapEdit_Move (Just 2) 1)
254 ]
267 ]
255 ]
268 ]
256
269
257knownInvalidPatchMapWithMove :: [PatchMapWithMove Int Int]
270knownInvalidPatchMapWithMove :: [PatchMapWithMove Int Int]
258knownInvalidPatchMapWithMove =
271knownInvalidPatchMapWithMove =
259 [ -- Invalid because we move 2 to 1, but don't specify what to do with 2
272 [ -- 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
261 , -- Invalid because we have multiple moves from 3
274 , -- Invalid because we have multiple moves from 3
262 PatchMapWithMove $ Map.fromList
275 PatchMapWithMove $ Map.fromList
263− [ (1, MapEdit_Move False 3)
276+ [ (1, MapEdit_Move Nothing 3)
264− , (2, MapEdit_Move False 3)
277+ , (2, MapEdit_Move Nothing 3)
265− , (3, MapEdit_Delete True)
278+ , (3, MapEdit_Delete (Just 1))
266 ]
279 ]
267 ]
280 ]
268
281
269patchThatSortsMapWith :: Ord k => (v -> v -> Ordering) -> Map k v -> PatchMapWithMove k v
282patchThatSortsMapWith :: 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
283+patchThatSortsMapWith cmp m = PatchMapWithMove $ Map.fromList $ catMaybes $ zipWith g unsorted sorted
271− where l = Map.toList m
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
272− g (to, _) (from, _) = if to == from
289+ g (to, _) (from, _) = if to == from then Nothing else
273− then Nothing
290+ let Just movingTo = Map.lookup from reverseMapping
274− else Just (to, MapEdit_Move True from)
291+ in Just (to, MapEdit_Move (Just movingTo) from)
275
292
276patchThatChangesAndSortsMapWith :: (Ord k, Ord v) => (v -> v -> Ordering) -> Map k v -> Map k v -> PatchMapWithMove k v
293patchThatChangesAndSortsMapWith :: (Ord k, Ord v) => (v -> v -> Ordering) -> Map k v -> Map k v -> PatchMapWithMove k v
277patchThatChangesAndSortsMapWith cmp oldByIndex newByIndexUnsorted = patch
294patchThatChangesAndSortsMapWith cmp oldByIndex newByIndexUnsorted = patch
@@ -285,41 +302,160 @@ patchThatChangesAndSortsMapWith cmp oldByIndex newByIndexUnsorted = patch
285 then Map.delete v remainingValues
302 then Map.delete v remainingValues
286 else Map.insert v remainingKeys remainingValues
303 else Map.insert v remainingKeys remainingValues
287 case Map.lookup v remainingValues of
304 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
289 Just fromKs ->
306 Just fromKs ->
290 if k `Set.member` fromKs
307 if k `Set.member` fromKs
291 then do
308 then do
292 putRemainingKeys $ Set.delete k fromKs
309 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
294 else do
311 else do
295 Just (fromK, remainingKeys) <- return $ Set.minView fromKs -- There's an existing value, but it's not here; move it here
312 Just (fromK, remainingKeys) <- return $ Set.minView fromKs -- There's an existing value, but it's not here; move it here
296 putRemainingKeys remainingKeys
313 putRemainingKeys remainingKeys
297− return $ MapEdit_Move True fromK
314+ return $ MapEdit_Move (Just undefined) fromK
298 Map.traverseWithKey f newByIndex
315 Map.traverseWithKey f newByIndex
299 unusedOldKeys = fold unusedValuesByValue
316 unusedOldKeys = fold unusedValuesByValue
300 pointlessMove k = \case
317 pointlessMove k = \case
301 MapEdit_Move _ k' | k == k' -> True
318 MapEdit_Move _ k' | k == k' -> True
302 _ -> False
319 _ -> 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
304 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
323 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
305
324
306data DMapEdit (k :: a -> *) (v :: a -> *) :: a -> * where
325data DMapEdit (k :: a -> *) (v :: a -> *) :: a -> * where
307 -- | Insert the given value here
326 -- | Insert the given value here
308− DMapEdit_Insert :: Bool -> v a -> DMapEdit k v a
327+ DMapEdit_Insert :: v a -> DMapEdit k v a
309 -- | Delete the existing value, if any, from here
328 -- | Delete the existing value, if any, from here
310− DMapEdit_Delete :: Bool -> DMapEdit k v a
329+ DMapEdit_Delete :: DMapEdit k v a
311 -- | Move the value here from the given key
330 -- | 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)
313
339
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+{-
314dmapEditMoved :: DMapEdit k v a -> Bool
344dmapEditMoved :: 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
316 DMapEdit_Insert moved _ -> moved
349 DMapEdit_Insert moved _ -> moved
317 DMapEdit_Delete moved -> moved
350 DMapEdit_Delete moved -> moved
318 DMapEdit_Move moved _ -> moved
351 DMapEdit_Move moved _ -> moved
352+-}
319
353
320-- | Like 'PatchMapWithMove', but for 'DMap'.
354-- | Like 'PatchMapWithMove', but for 'DMap'.
321−newtype PatchDMapWithMove k v = PatchDMapWithMove (DMap k (DMapEdit k v))
355+data PatchDMapWithMove k v = PatchDMapWithMove (DMap k (DMapEdit k v)) (DMap k (ComposeMaybe k))
322−
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+{-
323unPatchDMapWithMove :: PatchDMapWithMove k v -> DMap k (DMapEdit k v)
459unPatchDMapWithMove :: PatchDMapWithMove k v -> DMap k (DMapEdit k v)
324unPatchDMapWithMove (PatchDMapWithMove p) = p
460unPatchDMapWithMove (PatchDMapWithMove p) = p
325
461
@@ -327,6 +463,28 @@ unPatchDMapWithMove (PatchDMapWithMove p) = p
327-- 'PatchDMapWithMove' are preserved; they will not be checked.
463-- 'PatchDMapWithMove' are preserved; they will not be checked.
328unsafePatchDMapWithMove :: DMap k (DMapEdit k v) -> PatchDMapWithMove k v
464unsafePatchDMapWithMove :: DMap k (DMapEdit k v) -> PatchDMapWithMove k v
329unsafePatchDMapWithMove = PatchDMapWithMove
465unsafePatchDMapWithMove = 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+{-
330
488
331mapPatchDMapWithMove :: forall k v v'. (forall a. v a -> v' a) -> PatchDMapWithMove k v -> PatchDMapWithMove k v'
489mapPatchDMapWithMove :: forall k v v'. (forall a. v a -> v' a) -> PatchDMapWithMove k v -> PatchDMapWithMove k v'
332mapPatchDMapWithMove f (PatchDMapWithMove p) = PatchDMapWithMove $ DMap.map g p
490mapPatchDMapWithMove f (PatchDMapWithMove p) = PatchDMapWithMove $ DMap.map g p
@@ -351,25 +509,25 @@ weakenPatchDMapWithMoveWith :: forall k v v'. (forall a. v a -> v') -> PatchDMap
351weakenPatchDMapWithMoveWith f (PatchDMapWithMove p) = PatchMapWithMove $ weakenDMapWith g p
509weakenPatchDMapWithMoveWith f (PatchDMapWithMove p) = PatchMapWithMove $ weakenDMapWith g p
352 where g :: forall a. DMapEdit k v a -> MapEdit (Some k) v'
510 where g :: forall a. DMapEdit k v a -> MapEdit (Some k) v'
353 g = \case
511 g = \case
354− DMapEdit_Insert moved v -> MapEdit_Insert moved $ f v
512+ DMapEdit_Insert moved v -> MapEdit_Insert (Some.This <$> moved) $ f v
355− DMapEdit_Delete moved -> MapEdit_Delete moved
513+ DMapEdit_Delete moved -> MapEdit_Delete $ Some.This <$> moved
356− DMapEdit_Move moved k -> MapEdit_Move moved $ Some.This k
514+ DMapEdit_Move moved k -> MapEdit_Move (Some.This <$> moved) $ Some.This k
357
515
358patchDMapWithMoveToPatchMapWithMoveWith :: forall k f v v'. (f v -> v') -> PatchDMapWithMove (Const2 k v) f -> PatchMapWithMove k v'
516patchDMapWithMoveToPatchMapWithMoveWith :: forall k f v v'. (f v -> v') -> PatchDMapWithMove (Const2 k v) f -> PatchMapWithMove k v'
359patchDMapWithMoveToPatchMapWithMoveWith f (PatchDMapWithMove p) = PatchMapWithMove $ dmapToMapWith g p
517patchDMapWithMoveToPatchMapWithMoveWith f (PatchDMapWithMove p) = PatchMapWithMove $ dmapToMapWith g p
360 where g :: DMapEdit (Const2 k v) f v -> MapEdit k v'
518 where g :: DMapEdit (Const2 k v) f v -> MapEdit k v'
361 g = \case
519 g = \case
362− DMapEdit_Insert moved v -> MapEdit_Insert moved $ f v
520+ DMapEdit_Insert moved v -> MapEdit_Insert (unConst2 <$> moved) $ f v
363− DMapEdit_Delete moved -> MapEdit_Delete moved
521+ DMapEdit_Delete moved -> MapEdit_Delete $ unConst2 <$> moved
364− DMapEdit_Move moved (Const2 k) -> MapEdit_Move moved k
522+ DMapEdit_Move moved (Const2 k) -> MapEdit_Move (unConst2 <$> moved) k
365
523
366const2PatchDMapWithMoveWith :: forall k v f a. (v -> f a) -> PatchMapWithMove k v -> PatchDMapWithMove (Const2 k a) f
524const2PatchDMapWithMoveWith :: forall k v f a. (v -> f a) -> PatchMapWithMove k v -> PatchDMapWithMove (Const2 k a) f
367const2PatchDMapWithMoveWith f (PatchMapWithMove p) = PatchDMapWithMove $ DMap.fromDistinctAscList $ g <$> Map.toAscList p
525const2PatchDMapWithMoveWith f (PatchMapWithMove p) = PatchDMapWithMove $ DMap.fromDistinctAscList $ g <$> Map.toAscList p
368 where g :: (k, MapEdit k v) -> DSum (Const2 k a) (DMapEdit (Const2 k a) f)
526 where g :: (k, MapEdit k v) -> DSum (Const2 k a) (DMapEdit (Const2 k a) f)
369 g (k, e) = Const2 k :=> case e of
527 g (k, e) = Const2 k :=> case e of
370− MapEdit_Insert moved v -> DMapEdit_Insert moved $ f v
528+ MapEdit_Insert moved v -> DMapEdit_Insert (Const2 <$> moved) $ f v
371− MapEdit_Delete moved -> DMapEdit_Delete moved
529+ MapEdit_Delete moved -> DMapEdit_Delete $ Const2 <$> moved
372− MapEdit_Move moved fromKey -> DMapEdit_Move moved $ Const2 fromKey
530+ MapEdit_Move moved fromKey -> DMapEdit_Move (Const2 <$> moved) $ Const2 fromKey
373
531
374instance GCompare k => Patch (PatchDMapWithMove k v) where
532instance GCompare k => Patch (PatchDMapWithMove k v) where
375 type PatchTarget (PatchDMapWithMove k v) = DMap k v
533 type PatchTarget (PatchDMapWithMove k v) = DMap k v
@@ -385,3 +543,4 @@ instance GCompare k => Patch (PatchDMapWithMove k v) where
385 deleteFunc _ = \case
543 deleteFunc _ = \case
386 DMapEdit_Delete _ -> Just $ Constant ()
544 DMapEdit_Delete _ -> Just $ Constant ()
387 _ -> Nothing
545 _ -> Nothing
546+-}