@@ -3,6 +3,7 @@
33{-# LANGUAGE DeriveTraversable #-}
44{-# LANGUAGE FlexibleContexts #-}
55{-# LANGUAGE LambdaCase #-}
6+{-# LANGUAGE PatternGuards #-}
67{-# LANGUAGE ScopedTypeVariables #-}
78{-# LANGUAGE TypeFamilies #-}
89-- | 'Patch'es on 'Map' that can insert, delete, and move values from one key to
@@ -19,7 +20,9 @@ import Data.List
1920import Data.Map (Map)
2021import qualified Data.Map as Map
2122import Data.Maybe
23+import Data.Semigroup
2224import qualified Data.Set as Set
25+import Data.These
2326import Data.Tuple
2427
2528-- | Patch a DMap with additions, deletions, and moves. Invariant: If key @k1@
@@ -161,3 +164,61 @@ nodeInfoMapMFrom f ni = fmap (\result -> ni { _nodeInfo_from = result }) $ f $ _
161164-- | Set the 'To' field of a 'NodeInfo'
162165nodeInfoSetTo :: To k -> NodeInfo k v -> NodeInfo k v
163166nodeInfoSetTo to ni = ni { _nodeInfo_to = to }
167+
168+-- |Helper data structure used for composing patches using the monoid instance.
169+data Fixup k v
170+ = Fixup_Delete
171+ | Fixup_Update (These (From k v) (To k))
172+
173+-- |Compose patches having the same effect as applying the patches in turn: @'applyAlways' (p <> q) == 'applyAlways' p . 'applyAlways' q@
174+instance Ord k => Semigroup (PatchMapWithMove k v) where
175+ PatchMapWithMove ma <> PatchMapWithMove mb = PatchMapWithMove m
176+ where
177+ connections = Map.toList $ Map.intersectionWithKey (\_ a b -> (_nodeInfo_to a, _nodeInfo_from b)) ma mb
178+ h :: (k, (Maybe k, From k v)) -> [(k, Fixup k v)]
179+ h (_, (mToAfter, editBefore)) = case (mToAfter, editBefore) of
180+ (Just toAfter, From_Move fromBefore)
181+ | fromBefore == toAfter
182+ -> [(toAfter, Fixup_Delete)]
183+ | otherwise
184+ -> [ (toAfter, Fixup_Update (This editBefore))
185+ , (fromBefore, Fixup_Update (That mToAfter))
186+ ]
187+ (Nothing, From_Move fromBefore) -> [(fromBefore, Fixup_Update (That mToAfter))] -- The item is destroyed in the second patch, so indicate that it is destroyed in the source map
188+ (Just toAfter, _) -> [(toAfter, Fixup_Update (This editBefore))]
189+ (Nothing, _) -> []
190+ mergeFixups _ Fixup_Delete Fixup_Delete = Fixup_Delete
191+ mergeFixups _ (Fixup_Update a) (Fixup_Update b)
192+ | This x <- a, That y <- b
193+ = Fixup_Update $ These x y
194+ | That y <- a, This x <- b
195+ = Fixup_Update $ These x y
196+ mergeFixups _ _ _ = error "PatchMapWithMove: incompatible fixups"
197+ fixups = Map.fromListWithKey mergeFixups $ concatMap h connections
198+ combineNodeInfos _ nia nib = NodeInfo
199+ { _nodeInfo_from = _nodeInfo_from nia
200+ , _nodeInfo_to = _nodeInfo_to nib
201+ }
202+ applyFixup _ ni = \case
203+ Fixup_Delete -> Nothing
204+ Fixup_Update u -> Just $ NodeInfo
205+ { _nodeInfo_from = fromMaybe (_nodeInfo_from ni) $ getHere u
206+ , _nodeInfo_to = fromMaybe (_nodeInfo_to ni) $ getThere u
207+ }
208+ m = Map.differenceWithKey applyFixup (Map.unionWithKey combineNodeInfos ma mb) fixups
209+ getHere :: These a b -> Maybe a
210+ getHere = \case
211+ This a -> Just a
212+ These a _ -> Just a
213+ That _ -> Nothing
214+ getThere :: These a b -> Maybe b
215+ getThere = \case
216+ This _ -> Nothing
217+ These _ b -> Just b
218+ That b -> Just b
219+
220+--TODO: Figure out how to implement this in terms of PatchDMapWithMove rather than duplicating it here
221+-- |Compose patches having the same effect as applying the patches in turn: @'applyAlways' (p <> q) == 'applyAlways' p . 'applyAlways' q@
222+instance Ord k => Monoid (PatchMapWithMove k v) where
223+ mempty = PatchMapWithMove mempty
224+ mappend = (<>)