{-# LANGUAGE CPP #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
module Data.Patch.MapWithPatchingMove
( PatchMapWithPatchingMove (..)
, patchMapWithPatchingMove
, patchMapWithPatchingMoveInsertAll
, insertMapKey
, moveMapKey
, swapMapKey
, deleteMapKey
, unsafePatchMapWithPatchingMove
, patchMapWithPatchingMoveNewElements
, patchMapWithPatchingMoveNewElementsMap
, patchThatSortsMapWith
, patchThatChangesAndSortsMapWith
, patchThatChangesMap
, NodeInfo (..)
, bitraverseNodeInfo
, nodeInfoMapFrom
, nodeInfoMapMFrom
, nodeInfoSetTo
, From(..)
, bitraverseFrom
, To
, Fixup (..)
) where
import Data.Patch.Class
import Control.Lens hiding (from, to)
import Control.Lens.TH (makeWrapped)
import Data.Align (align)
import Data.Foldable (toList)
import Data.Function
import Data.List
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Maybe
#if !MIN_VERSION_base(4,11,0)
import Data.Semigroup (Semigroup (..))
#endif
import Data.Monoid.DecidablyEmpty
import Data.Set (Set)
import qualified Data.Set as Set
import Data.These (These (..))
newtype PatchMapWithPatchingMove k p = PatchMapWithPatchingMove
{
unPatchMapWithPatchingMove :: Map k (NodeInfo k p)
}
deriving instance (Show k, Show p, Show (PatchTarget p)) => Show (PatchMapWithPatchingMove k p)
deriving instance (Ord k, Read k, Read p, Read (PatchTarget p)) => Read (PatchMapWithPatchingMove k p)
deriving instance (Eq k, Eq p, Eq (PatchTarget p)) => Eq (PatchMapWithPatchingMove k p)
deriving instance (Ord k, Ord p, Ord (PatchTarget p)) => Ord (PatchMapWithPatchingMove k p)
deriving instance ( Ord k
#if !MIN_VERSION_base(4,11,0)
, Semigroup p
#endif
, DecidablyEmpty p
, Patch p
) => DecidablyEmpty (PatchMapWithPatchingMove k p)
patchMapWithPatchingMove
:: Ord k => Map k (NodeInfo k p) -> Maybe (PatchMapWithPatchingMove k p)
patchMapWithPatchingMove m = if valid then Just $ PatchMapWithPatchingMove m else Nothing
where valid = forwardLinks == backwardLinks
forwardLinks = Map.mapMaybe _nodeInfo_to m
backwardLinks = Map.fromList $ catMaybes $ flip fmap (Map.toList m) $ \(to, p) ->
case _nodeInfo_from p of
From_Move from _ -> Just (from, to)
_ -> Nothing
patchMapWithPatchingMoveInsertAll
:: Map k (PatchTarget p) -> PatchMapWithPatchingMove k p
patchMapWithPatchingMoveInsertAll m = PatchMapWithPatchingMove $ flip fmap m $ \v -> NodeInfo
{ _nodeInfo_from = From_Insert v
, _nodeInfo_to = Nothing
}
insertMapKey
:: k -> PatchTarget p -> PatchMapWithPatchingMove k p
insertMapKey k v = PatchMapWithPatchingMove . Map.singleton k $ NodeInfo (From_Insert v) Nothing
moveMapKey
:: ( DecidablyEmpty p
#if !MIN_VERSION_base(4,11,0)
, Semigroup p
#endif
, Patch p
)
=> Ord k => k -> k -> PatchMapWithPatchingMove k p
moveMapKey src dst
| src == dst = mempty
| otherwise =
PatchMapWithPatchingMove $ Map.fromList
[ (dst, NodeInfo (From_Move src mempty) Nothing)
, (src, NodeInfo From_Delete (Just dst))
]
swapMapKey
:: ( DecidablyEmpty p
#if !MIN_VERSION_base(4,11,0)
, Semigroup p
#endif
, Patch p
)
=> Ord k => k -> k -> PatchMapWithPatchingMove k p
swapMapKey src dst
| src == dst = mempty
| otherwise =
PatchMapWithPatchingMove $ Map.fromList
[ (dst, NodeInfo (From_Move src mempty) (Just src))
, (src, NodeInfo (From_Move dst mempty) (Just dst))
]
deleteMapKey
:: k -> PatchMapWithPatchingMove k v
deleteMapKey k = PatchMapWithPatchingMove . Map.singleton k $ NodeInfo From_Delete Nothing
unsafePatchMapWithPatchingMove
:: Map k (NodeInfo k p) -> PatchMapWithPatchingMove k p
unsafePatchMapWithPatchingMove = PatchMapWithPatchingMove
instance (Ord k, Patch p) => Patch (PatchMapWithPatchingMove k p) where
type PatchTarget (PatchMapWithPatchingMove k p) = Map k (PatchTarget p)
apply (PatchMapWithPatchingMove m) old = Just $! insertions `Map.union` (old `Map.difference` deletions)
where insertions = flip Map.mapMaybeWithKey m $ \_ ni -> case _nodeInfo_from ni of
From_Insert v -> Just v
From_Move k p -> applyAlways p <$> Map.lookup k old
From_Delete -> Nothing
deletions = flip Map.mapMaybeWithKey m $ \_ ni -> case _nodeInfo_from ni of
From_Delete -> Just ()
_ -> Nothing
patchMapWithPatchingMoveNewElements
:: PatchMapWithPatchingMove k p -> [PatchTarget p]
patchMapWithPatchingMoveNewElements = Map.elems . patchMapWithPatchingMoveNewElementsMap
patchMapWithPatchingMoveNewElementsMap
:: PatchMapWithPatchingMove k p -> Map k (PatchTarget p)
patchMapWithPatchingMoveNewElementsMap (PatchMapWithPatchingMove p) = Map.mapMaybe f p
where f ni = case _nodeInfo_from ni of
From_Insert v -> Just v
From_Move _ _ -> Nothing
From_Delete -> Nothing
patchThatSortsMapWith
:: (Ord k, Monoid p)
=> (PatchTarget p -> PatchTarget p -> Ordering)
-> Map k (PatchTarget p) -> PatchMapWithPatchingMove k p
patchThatSortsMapWith cmp m = PatchMapWithPatchingMove $ Map.fromList $ catMaybes $ zipWith g unsorted sorted
where unsorted = Map.toList m
sorted = sortBy (cmp `on` snd) unsorted
f (to, _) (from, _) = if to == from then Nothing else
Just (from, to)
reverseMapping = Map.fromList $ catMaybes $ zipWith f unsorted sorted
g (to, _) (from, _) = if to == from then Nothing else
let Just movingTo = Map.lookup from reverseMapping
in Just (to, NodeInfo (From_Move from mempty) $ Just movingTo)
patchThatChangesAndSortsMapWith
:: forall k p. (Ord k, Ord (PatchTarget p), Monoid p)
=> (PatchTarget p -> PatchTarget p -> Ordering)
-> Map k (PatchTarget p) -> Map k (PatchTarget p) -> PatchMapWithPatchingMove k p
patchThatChangesAndSortsMapWith cmp oldByIndex newByIndexUnsorted = patchThatChangesMap oldByIndex newByIndex
where newList = Map.toList newByIndexUnsorted
newByIndex = Map.fromList $ zip (fst <$> newList) $ sortBy cmp $ snd <$> newList
patchThatChangesMap
:: forall k p
. (Ord k, Ord (PatchTarget p), Monoid p)
=> Map k (PatchTarget p) -> Map k (PatchTarget p) -> PatchMapWithPatchingMove k p
patchThatChangesMap oldByIndex newByIndex = patch
where invert :: Map k (PatchTarget p) -> Map (PatchTarget p) (Set k)
invert = Map.fromListWith (<>) . fmap (\(k, v) -> (v, Set.singleton k)) . Map.toList
unionDistinct :: forall k' v'. Ord k' => Map k' v' -> Map k' v' -> Map k' v'
unionDistinct = Map.unionWith (error "patchThatChangesMap: non-distinct keys")
unionPairDistinct :: (Map k (From k v), Map k (To k)) -> (Map k (From k v), Map k (To k)) -> (Map k (From k v), Map k (To k))
unionPairDistinct (oldFroms, oldTos) (newFroms, newTos) = (unionDistinct oldFroms newFroms, unionDistinct oldTos newTos)
patchSingleValue :: PatchTarget p -> Set k -> Set k -> (Map k (From k p), Map k (To k))
patchSingleValue v oldKeys newKeys = foldl' unionPairDistinct mempty $ align (toList $ oldKeys `Set.difference` newKeys) (toList $ newKeys `Set.difference` oldKeys) <&> \case
This oldK -> (mempty, Map.singleton oldK Nothing)
That newK -> (Map.singleton newK $ From_Insert v, mempty)
These oldK newK -> (Map.singleton newK $ From_Move oldK mempty, Map.singleton oldK $ Just newK)
patchSingleValueThese :: PatchTarget p -> These (Set k) (Set k) -> (Map k (From k p), Map k (To k))
patchSingleValueThese v = \case
This oldKeys -> patchSingleValue v oldKeys mempty
That newKeys -> patchSingleValue v mempty newKeys
These oldKeys newKeys -> patchSingleValue v oldKeys newKeys
(froms, tos) = foldl' unionPairDistinct mempty $ Map.mapWithKey patchSingleValueThese $ align (invert oldByIndex) (invert newByIndex)
patch = unsafePatchMapWithPatchingMove $ align froms tos <&> \case
This from -> NodeInfo from Nothing
That to -> NodeInfo From_Delete to
These from to -> NodeInfo from to
data NodeInfo k p = NodeInfo
{ _nodeInfo_from :: !(From k p)
, _nodeInfo_to :: !(To k)
}
deriving instance (Show k, Show p, Show (PatchTarget p)) => Show (NodeInfo k p)
deriving instance (Read k, Read p, Read (PatchTarget p)) => Read (NodeInfo k p)
deriving instance (Eq k, Eq p, Eq (PatchTarget p)) => Eq (NodeInfo k p)
deriving instance (Ord k, Ord p, Ord (PatchTarget p)) => Ord (NodeInfo k p)
bitraverseNodeInfo
:: Applicative f
=> (k0 -> f k1)
-> (p0 -> f p1)
-> (PatchTarget p0 -> f (PatchTarget p1))
-> NodeInfo k0 p0 -> f (NodeInfo k1 p1)
bitraverseNodeInfo fk fp fpt (NodeInfo from to) = NodeInfo
<$> bitraverseFrom fk fp fpt from
<*> traverse fk to
nodeInfoMapFrom
:: (From k v -> From k v) -> NodeInfo k v -> NodeInfo k v
nodeInfoMapFrom f ni = ni { _nodeInfo_from = f $ _nodeInfo_from ni }
nodeInfoMapMFrom
:: Functor f => (From k v -> f (From k v)) -> NodeInfo k v -> f (NodeInfo k v)
nodeInfoMapMFrom f ni = fmap (\result -> ni { _nodeInfo_from = result }) $ f $ _nodeInfo_from ni
nodeInfoSetTo
:: To k -> NodeInfo k v -> NodeInfo k v
nodeInfoSetTo to ni = ni { _nodeInfo_to = to }
data From k p
= From_Insert (PatchTarget p)
| From_Delete
| From_Move !k !p
deriving instance (Show k, Show p, Show (PatchTarget p)) => Show (From k p)
deriving instance (Read k, Read p, Read (PatchTarget p)) => Read (From k p)
deriving instance (Eq k, Eq p, Eq (PatchTarget p)) => Eq (From k p)
deriving instance (Ord k, Ord p, Ord (PatchTarget p)) => Ord (From k p)
bitraverseFrom
:: Applicative f
=> (k0 -> f k1)
-> (p0 -> f p1)
-> (PatchTarget p0 -> f (PatchTarget p1))
-> From k0 p0 -> f (From k1 p1)
bitraverseFrom fk fp fpt = \case
From_Insert pt -> From_Insert <$> fpt pt
From_Delete -> pure From_Delete
From_Move k p -> From_Move <$> fk k <*> fp p
type To = Maybe
data Fixup k v
= Fixup_Delete
| Fixup_Update (These (From k v) (To k))
instance ( Ord k
#if !MIN_VERSION_base(4,11,0)
, Semigroup p
#endif
, DecidablyEmpty p
, Patch p
) => Semigroup (PatchMapWithPatchingMove k p) where
PatchMapWithPatchingMove ma <> PatchMapWithPatchingMove mb = PatchMapWithPatchingMove m
where
connections = Map.toList $ Map.intersectionWithKey (\_ a b -> (_nodeInfo_to a, _nodeInfo_from b)) ma mb
h :: (k, (Maybe k, From k p)) -> [(k, Fixup k p)]
h (_, (mToAfter, editBefore)) = case (mToAfter, editBefore) of
(Just toAfter, From_Move fromBefore p)
| fromBefore == toAfter && isEmpty p
-> [(toAfter, Fixup_Delete)]
| otherwise
-> [ (toAfter, Fixup_Update (This editBefore))
, (fromBefore, Fixup_Update (That mToAfter))
]
(Nothing, From_Move fromBefore _) -> [(fromBefore, Fixup_Update (That mToAfter))]
(Just toAfter, _) -> [(toAfter, Fixup_Update (This editBefore))]
(Nothing, _) -> []
mergeFixups _ Fixup_Delete Fixup_Delete = Fixup_Delete
mergeFixups _ (Fixup_Update a) (Fixup_Update b)
| This x <- a, That y <- b
= Fixup_Update $ These x y
| That y <- a, This x <- b
= Fixup_Update $ These x y
mergeFixups _ _ _ = error "PatchMapWithPatchingMove: incompatible fixups"
fixups = Map.fromListWithKey mergeFixups $ concatMap h connections
combineNodeInfos _ nia nib = NodeInfo
{ _nodeInfo_from = _nodeInfo_from nia
, _nodeInfo_to = _nodeInfo_to nib
}
applyFixup _ ni = \case
Fixup_Delete -> Nothing
Fixup_Update u -> Just $ NodeInfo
{ _nodeInfo_from = case _nodeInfo_from ni of
f@(From_Move _ p') -> case getHere u of
Nothing -> f
Just (From_Insert v) -> From_Insert $ applyAlways p' v
Just From_Delete -> From_Delete
Just (From_Move oldKey p) -> From_Move oldKey $ p' <> p
_ -> error "PatchMapWithPatchingMove: fixup for non-move From"
, _nodeInfo_to = fromMaybe (_nodeInfo_to ni) $ getThere u
}
m = Map.differenceWithKey applyFixup (Map.unionWithKey combineNodeInfos ma mb) fixups
getHere :: These a b -> Maybe a
getHere = \case
This a -> Just a
These a _ -> Just a
That _ -> Nothing
getThere :: These a b -> Maybe b
getThere = \case
This _ -> Nothing
These _ b -> Just b
That b -> Just b
instance ( Ord k
#if !MIN_VERSION_base(4,11,0)
, Semigroup p
#endif
, DecidablyEmpty p
, Patch p
) => Monoid (PatchMapWithPatchingMove k p) where
mempty = PatchMapWithPatchingMove mempty
mappend = (<>)
makeWrapped ''PatchMapWithPatchingMove