{-# LANGUAGE CPP #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}

{-|
Description: An advanced 'Patch' on 'Map'

Patches of this type can can insert, delete, and move values from one key to
another, and move patches may also additionally patch the value being moved.
-}
module Data.Patch.MapWithPatchingMove
  ( PatchMapWithPatchingMove (..)
  , patchMapWithPatchingMove
  , patchMapWithPatchingMoveInsertAll
  , insertMapKey
  , moveMapKey
  , swapMapKey
  , deleteMapKey
  , unsafePatchMapWithPatchingMove
  , patchMapWithPatchingMoveNewElements
  , patchMapWithPatchingMoveNewElementsMap
  , patchThatSortsMapWith
  , patchThatChangesAndSortsMapWith
  , patchThatChangesMap

  -- * Node Info
  , NodeInfo (..)
  , bitraverseNodeInfo
  , nodeInfoMapFrom
  , nodeInfoMapMFrom
  , nodeInfoSetTo

  -- * From
  , From(..)
  , bitraverseFrom

  -- * To
  , To

  -- TODO internals module
  , Fixup (..)
  ) where

import Data.Patch.Class

import Control.Lens ((<&>))
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 (..))

-- | Patch a Map with additions, deletions, and moves.  Invariant: If key @k1@
-- is coming from @From_Move k2@, then key @k2@ should be going to @Just k1@,
-- and vice versa.  There should never be any unpaired From/To keys.
newtype PatchMapWithPatchingMove k p = PatchMapWithPatchingMove
  { -- | Extract the internal representation of the 'PatchMapWithPatchingMove'
    PatchMapWithPatchingMove k p -> Map k (NodeInfo k p)
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)

-- | Create a 'PatchMapWithPatchingMove', validating it
patchMapWithPatchingMove
  :: Ord k => Map k (NodeInfo k p) -> Maybe (PatchMapWithPatchingMove k p)
patchMapWithPatchingMove :: Map k (NodeInfo k p) -> Maybe (PatchMapWithPatchingMove k p)
patchMapWithPatchingMove Map k (NodeInfo k p)
m = if Bool
valid then PatchMapWithPatchingMove k p
-> Maybe (PatchMapWithPatchingMove k p)
forall a. a -> Maybe a
Just (PatchMapWithPatchingMove k p
 -> Maybe (PatchMapWithPatchingMove k p))
-> PatchMapWithPatchingMove k p
-> Maybe (PatchMapWithPatchingMove k p)
forall a b. (a -> b) -> a -> b
$ Map k (NodeInfo k p) -> PatchMapWithPatchingMove k p
forall k p. Map k (NodeInfo k p) -> PatchMapWithPatchingMove k p
PatchMapWithPatchingMove Map k (NodeInfo k p)
m else Maybe (PatchMapWithPatchingMove k p)
forall a. Maybe a
Nothing
  where valid :: Bool
valid = Map k k
forwardLinks Map k k -> Map k k -> Bool
forall a. Eq a => a -> a -> Bool
== Map k k
backwardLinks
        forwardLinks :: Map k k
forwardLinks = (NodeInfo k p -> Maybe k) -> Map k (NodeInfo k p) -> Map k k
forall a b k. (a -> Maybe b) -> Map k a -> Map k b
Map.mapMaybe NodeInfo k p -> Maybe k
forall k p. NodeInfo k p -> To k
_nodeInfo_to Map k (NodeInfo k p)
m
        backwardLinks :: Map k k
backwardLinks = [(k, k)] -> Map k k
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(k, k)] -> Map k k) -> [(k, k)] -> Map k k
forall a b. (a -> b) -> a -> b
$ [Maybe (k, k)] -> [(k, k)]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe (k, k)] -> [(k, k)]) -> [Maybe (k, k)] -> [(k, k)]
forall a b. (a -> b) -> a -> b
$ (((k, NodeInfo k p) -> Maybe (k, k))
 -> [(k, NodeInfo k p)] -> [Maybe (k, k)])
-> [(k, NodeInfo k p)]
-> ((k, NodeInfo k p) -> Maybe (k, k))
-> [Maybe (k, k)]
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((k, NodeInfo k p) -> Maybe (k, k))
-> [(k, NodeInfo k p)] -> [Maybe (k, k)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Map k (NodeInfo k p) -> [(k, NodeInfo k p)]
forall k a. Map k a -> [(k, a)]
Map.toList Map k (NodeInfo k p)
m) (((k, NodeInfo k p) -> Maybe (k, k)) -> [Maybe (k, k)])
-> ((k, NodeInfo k p) -> Maybe (k, k)) -> [Maybe (k, k)]
forall a b. (a -> b) -> a -> b
$ \(k
to, NodeInfo k p
p) ->
          case NodeInfo k p -> From k p
forall k p. NodeInfo k p -> From k p
_nodeInfo_from NodeInfo k p
p of
            From_Move k
from p
_ -> (k, k) -> Maybe (k, k)
forall a. a -> Maybe a
Just (k
from, k
to)
            From k p
_ -> Maybe (k, k)
forall a. Maybe a
Nothing

-- | Create a 'PatchMapWithPatchingMove' that inserts everything in the given 'Map'
patchMapWithPatchingMoveInsertAll
  :: Map k (PatchTarget p) -> PatchMapWithPatchingMove k p
patchMapWithPatchingMoveInsertAll :: Map k (PatchTarget p) -> PatchMapWithPatchingMove k p
patchMapWithPatchingMoveInsertAll Map k (PatchTarget p)
m = Map k (NodeInfo k p) -> PatchMapWithPatchingMove k p
forall k p. Map k (NodeInfo k p) -> PatchMapWithPatchingMove k p
PatchMapWithPatchingMove (Map k (NodeInfo k p) -> PatchMapWithPatchingMove k p)
-> Map k (NodeInfo k p) -> PatchMapWithPatchingMove k p
forall a b. (a -> b) -> a -> b
$ ((PatchTarget p -> NodeInfo k p)
 -> Map k (PatchTarget p) -> Map k (NodeInfo k p))
-> Map k (PatchTarget p)
-> (PatchTarget p -> NodeInfo k p)
-> Map k (NodeInfo k p)
forall a b c. (a -> b -> c) -> b -> a -> c
flip (PatchTarget p -> NodeInfo k p)
-> Map k (PatchTarget p) -> Map k (NodeInfo k p)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Map k (PatchTarget p)
m ((PatchTarget p -> NodeInfo k p) -> Map k (NodeInfo k p))
-> (PatchTarget p -> NodeInfo k p) -> Map k (NodeInfo k p)
forall a b. (a -> b) -> a -> b
$ \PatchTarget p
v -> NodeInfo :: forall k p. From k p -> To k -> NodeInfo k p
NodeInfo
  { _nodeInfo_from :: From k p
_nodeInfo_from = PatchTarget p -> From k p
forall k p. PatchTarget p -> From k p
From_Insert PatchTarget p
v
  , _nodeInfo_to :: To k
_nodeInfo_to = To k
forall a. Maybe a
Nothing
  }

-- | Make a @'PatchMapWithPatchingMove' k p@ which has the effect of inserting or replacing a value @v@ at the given key @k@, like 'Map.insert'.
insertMapKey
  :: k -> PatchTarget p -> PatchMapWithPatchingMove k p
insertMapKey :: k -> PatchTarget p -> PatchMapWithPatchingMove k p
insertMapKey k
k PatchTarget p
v = Map k (NodeInfo k p) -> PatchMapWithPatchingMove k p
forall k p. Map k (NodeInfo k p) -> PatchMapWithPatchingMove k p
PatchMapWithPatchingMove (Map k (NodeInfo k p) -> PatchMapWithPatchingMove k p)
-> (NodeInfo k p -> Map k (NodeInfo k p))
-> NodeInfo k p
-> PatchMapWithPatchingMove k p
forall b c a. (b -> c) -> (a -> b) -> a -> c
. k -> NodeInfo k p -> Map k (NodeInfo k p)
forall k a. k -> a -> Map k a
Map.singleton k
k (NodeInfo k p -> PatchMapWithPatchingMove k p)
-> NodeInfo k p -> PatchMapWithPatchingMove k p
forall a b. (a -> b) -> a -> b
$ From k p -> To k -> NodeInfo k p
forall k p. From k p -> To k -> NodeInfo k p
NodeInfo (PatchTarget p -> From k p
forall k p. PatchTarget p -> From k p
From_Insert PatchTarget p
v) To k
forall a. Maybe a
Nothing

-- |Make a @'PatchMapWithPatchingMove' k p@ which has the effect of moving the value from the first key @k@ to the second key @k@, equivalent to:
--
-- @
--     'Map.delete' src (maybe map ('Map.insert' dst) (Map.lookup src map))
-- @
moveMapKey
  :: ( DecidablyEmpty p
#if !MIN_VERSION_base(4,11,0)
     , Semigroup p
#endif
     , Patch p
     )
  => Ord k => k -> k -> PatchMapWithPatchingMove k p
moveMapKey :: k -> k -> PatchMapWithPatchingMove k p
moveMapKey k
src k
dst
  | k
src k -> k -> Bool
forall a. Eq a => a -> a -> Bool
== k
dst = PatchMapWithPatchingMove k p
forall a. Monoid a => a
mempty
  | Bool
otherwise =
      Map k (NodeInfo k p) -> PatchMapWithPatchingMove k p
forall k p. Map k (NodeInfo k p) -> PatchMapWithPatchingMove k p
PatchMapWithPatchingMove (Map k (NodeInfo k p) -> PatchMapWithPatchingMove k p)
-> Map k (NodeInfo k p) -> PatchMapWithPatchingMove k p
forall a b. (a -> b) -> a -> b
$ [(k, NodeInfo k p)] -> Map k (NodeInfo k p)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
        [ (k
dst, From k p -> To k -> NodeInfo k p
forall k p. From k p -> To k -> NodeInfo k p
NodeInfo (k -> p -> From k p
forall k p. k -> p -> From k p
From_Move k
src p
forall a. Monoid a => a
mempty) To k
forall a. Maybe a
Nothing)
        , (k
src, From k p -> To k -> NodeInfo k p
forall k p. From k p -> To k -> NodeInfo k p
NodeInfo From k p
forall k p. From k p
From_Delete (k -> To k
forall a. a -> Maybe a
Just k
dst))
        ]

-- |Make a @'PatchMapWithPatchingMove' k p@ which has the effect of swapping two keys in the mapping, equivalent to:
--
-- @
--     let aMay = Map.lookup a map
--         bMay = Map.lookup b map
--     in maybe id (Map.insert a) (bMay <> aMay)
--      . maybe id (Map.insert b) (aMay <> bMay)
--      . Map.delete a . Map.delete b $ map
-- @
swapMapKey
  :: ( DecidablyEmpty p
#if !MIN_VERSION_base(4,11,0)
     , Semigroup p
#endif
     , Patch p
     )
  => Ord k => k -> k -> PatchMapWithPatchingMove k p
swapMapKey :: k -> k -> PatchMapWithPatchingMove k p
swapMapKey k
src k
dst
  | k
src k -> k -> Bool
forall a. Eq a => a -> a -> Bool
== k
dst = PatchMapWithPatchingMove k p
forall a. Monoid a => a
mempty
  | Bool
otherwise =
    Map k (NodeInfo k p) -> PatchMapWithPatchingMove k p
forall k p. Map k (NodeInfo k p) -> PatchMapWithPatchingMove k p
PatchMapWithPatchingMove (Map k (NodeInfo k p) -> PatchMapWithPatchingMove k p)
-> Map k (NodeInfo k p) -> PatchMapWithPatchingMove k p
forall a b. (a -> b) -> a -> b
$ [(k, NodeInfo k p)] -> Map k (NodeInfo k p)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
      [ (k
dst, From k p -> To k -> NodeInfo k p
forall k p. From k p -> To k -> NodeInfo k p
NodeInfo (k -> p -> From k p
forall k p. k -> p -> From k p
From_Move k
src p
forall a. Monoid a => a
mempty) (k -> To k
forall a. a -> Maybe a
Just k
src))
      , (k
src, From k p -> To k -> NodeInfo k p
forall k p. From k p -> To k -> NodeInfo k p
NodeInfo (k -> p -> From k p
forall k p. k -> p -> From k p
From_Move k
dst p
forall a. Monoid a => a
mempty) (k -> To k
forall a. a -> Maybe a
Just k
dst))
      ]

-- | Make a @'PatchMapWithPatchingMove' k v@ which has the effect of deleting a key in
-- the mapping, equivalent to 'Map.delete'.
deleteMapKey
  :: k -> PatchMapWithPatchingMove k v
deleteMapKey :: k -> PatchMapWithPatchingMove k v
deleteMapKey k
k = Map k (NodeInfo k v) -> PatchMapWithPatchingMove k v
forall k p. Map k (NodeInfo k p) -> PatchMapWithPatchingMove k p
PatchMapWithPatchingMove (Map k (NodeInfo k v) -> PatchMapWithPatchingMove k v)
-> (NodeInfo k v -> Map k (NodeInfo k v))
-> NodeInfo k v
-> PatchMapWithPatchingMove k v
forall b c a. (b -> c) -> (a -> b) -> a -> c
. k -> NodeInfo k v -> Map k (NodeInfo k v)
forall k a. k -> a -> Map k a
Map.singleton k
k (NodeInfo k v -> PatchMapWithPatchingMove k v)
-> NodeInfo k v -> PatchMapWithPatchingMove k v
forall a b. (a -> b) -> a -> b
$ From k v -> To k -> NodeInfo k v
forall k p. From k p -> To k -> NodeInfo k p
NodeInfo From k v
forall k p. From k p
From_Delete To k
forall a. Maybe a
Nothing

-- | Wrap a @'Map' k (NodeInfo k v)@ representing patch changes into a @'PatchMapWithPatchingMove' k v@, without checking any invariants.
--
-- __Warning:__ when using this function, you must ensure that the invariants of 'PatchMapWithPatchingMove' are preserved; they will not be checked.
unsafePatchMapWithPatchingMove
  :: Map k (NodeInfo k p) -> PatchMapWithPatchingMove k p
unsafePatchMapWithPatchingMove :: Map k (NodeInfo k p) -> PatchMapWithPatchingMove k p
unsafePatchMapWithPatchingMove = Map k (NodeInfo k p) -> PatchMapWithPatchingMove k p
forall k p. Map k (NodeInfo k p) -> PatchMapWithPatchingMove k p
PatchMapWithPatchingMove

-- | Apply the insertions, deletions, and moves to a given 'Map'
instance (Ord k, Patch p) => Patch (PatchMapWithPatchingMove k p) where
  type PatchTarget (PatchMapWithPatchingMove k p) = Map k (PatchTarget p)
  -- 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?
  apply :: PatchMapWithPatchingMove k p
-> PatchTarget (PatchMapWithPatchingMove k p)
-> Maybe (PatchTarget (PatchMapWithPatchingMove k p))
apply (PatchMapWithPatchingMove Map k (NodeInfo k p)
m) PatchTarget (PatchMapWithPatchingMove k p)
old = Map k (PatchTarget p) -> Maybe (Map k (PatchTarget p))
forall a. a -> Maybe a
Just (Map k (PatchTarget p) -> Maybe (Map k (PatchTarget p)))
-> Map k (PatchTarget p) -> Maybe (Map k (PatchTarget p))
forall a b. (a -> b) -> a -> b
$! Map k (PatchTarget p)
insertions Map k (PatchTarget p)
-> Map k (PatchTarget p) -> Map k (PatchTarget p)
forall k a. Ord k => Map k a -> Map k a -> Map k a
`Map.union` (Map k (PatchTarget p)
PatchTarget (PatchMapWithPatchingMove k p)
old Map k (PatchTarget p) -> Map k () -> Map k (PatchTarget p)
forall k a b. Ord k => Map k a -> Map k b -> Map k a
`Map.difference` Map k ()
deletions)
    where insertions :: Map k (PatchTarget p)
insertions = ((k -> NodeInfo k p -> Maybe (PatchTarget p))
 -> Map k (NodeInfo k p) -> Map k (PatchTarget p))
-> Map k (NodeInfo k p)
-> (k -> NodeInfo k p -> Maybe (PatchTarget p))
-> Map k (PatchTarget p)
forall a b c. (a -> b -> c) -> b -> a -> c
flip (k -> NodeInfo k p -> Maybe (PatchTarget p))
-> Map k (NodeInfo k p) -> Map k (PatchTarget p)
forall k a b. (k -> a -> Maybe b) -> Map k a -> Map k b
Map.mapMaybeWithKey Map k (NodeInfo k p)
m ((k -> NodeInfo k p -> Maybe (PatchTarget p))
 -> Map k (PatchTarget p))
-> (k -> NodeInfo k p -> Maybe (PatchTarget p))
-> Map k (PatchTarget p)
forall a b. (a -> b) -> a -> b
$ \k
_ NodeInfo k p
ni -> case NodeInfo k p -> From k p
forall k p. NodeInfo k p -> From k p
_nodeInfo_from NodeInfo k p
ni of
            From_Insert PatchTarget p
v -> PatchTarget p -> Maybe (PatchTarget p)
forall a. a -> Maybe a
Just PatchTarget p
v
            From_Move k
k p
p -> p -> PatchTarget p -> PatchTarget p
forall p. Patch p => p -> PatchTarget p -> PatchTarget p
applyAlways p
p (PatchTarget p -> PatchTarget p)
-> Maybe (PatchTarget p) -> Maybe (PatchTarget p)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> k -> Map k (PatchTarget p) -> Maybe (PatchTarget p)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup k
k Map k (PatchTarget p)
PatchTarget (PatchMapWithPatchingMove k p)
old
            From k p
From_Delete -> Maybe (PatchTarget p)
forall a. Maybe a
Nothing
          deletions :: Map k ()
deletions = ((k -> NodeInfo k p -> Maybe ())
 -> Map k (NodeInfo k p) -> Map k ())
-> Map k (NodeInfo k p)
-> (k -> NodeInfo k p -> Maybe ())
-> Map k ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip (k -> NodeInfo k p -> Maybe ()) -> Map k (NodeInfo k p) -> Map k ()
forall k a b. (k -> a -> Maybe b) -> Map k a -> Map k b
Map.mapMaybeWithKey Map k (NodeInfo k p)
m ((k -> NodeInfo k p -> Maybe ()) -> Map k ())
-> (k -> NodeInfo k p -> Maybe ()) -> Map k ()
forall a b. (a -> b) -> a -> b
$ \k
_ NodeInfo k p
ni -> case NodeInfo k p -> From k p
forall k p. NodeInfo k p -> From k p
_nodeInfo_from NodeInfo k p
ni of
            From k p
From_Delete -> () -> Maybe ()
forall a. a -> Maybe a
Just ()
            From k p
_ -> Maybe ()
forall a. Maybe a
Nothing

-- | Returns all the new elements that will be added to the 'Map'
patchMapWithPatchingMoveNewElements
  :: PatchMapWithPatchingMove k p -> [PatchTarget p]
patchMapWithPatchingMoveNewElements :: PatchMapWithPatchingMove k p -> [PatchTarget p]
patchMapWithPatchingMoveNewElements = Map k (PatchTarget p) -> [PatchTarget p]
forall k a. Map k a -> [a]
Map.elems (Map k (PatchTarget p) -> [PatchTarget p])
-> (PatchMapWithPatchingMove k p -> Map k (PatchTarget p))
-> PatchMapWithPatchingMove k p
-> [PatchTarget p]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PatchMapWithPatchingMove k p -> Map k (PatchTarget p)
forall k p. PatchMapWithPatchingMove k p -> Map k (PatchTarget p)
patchMapWithPatchingMoveNewElementsMap

-- | Return a @'Map' k v@ with all the inserts/updates from the given @'PatchMapWithPatchingMove' k v@.
patchMapWithPatchingMoveNewElementsMap
  :: PatchMapWithPatchingMove k p -> Map k (PatchTarget p)
patchMapWithPatchingMoveNewElementsMap :: PatchMapWithPatchingMove k p -> Map k (PatchTarget p)
patchMapWithPatchingMoveNewElementsMap (PatchMapWithPatchingMove Map k (NodeInfo k p)
p) = (NodeInfo k p -> Maybe (PatchTarget p))
-> Map k (NodeInfo k p) -> Map k (PatchTarget p)
forall a b k. (a -> Maybe b) -> Map k a -> Map k b
Map.mapMaybe NodeInfo k p -> Maybe (PatchTarget p)
forall k p. NodeInfo k p -> Maybe (PatchTarget p)
f Map k (NodeInfo k p)
p
  where f :: NodeInfo k p -> Maybe (PatchTarget p)
f NodeInfo k p
ni = case NodeInfo k p -> From k p
forall k p. NodeInfo k p -> From k p
_nodeInfo_from NodeInfo k p
ni of
          From_Insert PatchTarget p
v -> PatchTarget p -> Maybe (PatchTarget p)
forall a. a -> Maybe a
Just PatchTarget p
v
          From_Move k
_ p
_ -> Maybe (PatchTarget p)
forall a. Maybe a
Nothing
          From k p
From_Delete -> Maybe (PatchTarget p)
forall a. Maybe a
Nothing

-- | Create a 'PatchMapWithPatchingMove' that, if applied to the given 'Map', will sort
-- its values using the given ordering function.  The set keys of the 'Map' is
-- not changed.
patchThatSortsMapWith
  :: (Ord k, Monoid p)
  => (PatchTarget p -> PatchTarget p -> Ordering)
  -> Map k (PatchTarget p) -> PatchMapWithPatchingMove k p
patchThatSortsMapWith :: (PatchTarget p -> PatchTarget p -> Ordering)
-> Map k (PatchTarget p) -> PatchMapWithPatchingMove k p
patchThatSortsMapWith PatchTarget p -> PatchTarget p -> Ordering
cmp Map k (PatchTarget p)
m = Map k (NodeInfo k p) -> PatchMapWithPatchingMove k p
forall k p. Map k (NodeInfo k p) -> PatchMapWithPatchingMove k p
PatchMapWithPatchingMove (Map k (NodeInfo k p) -> PatchMapWithPatchingMove k p)
-> Map k (NodeInfo k p) -> PatchMapWithPatchingMove k p
forall a b. (a -> b) -> a -> b
$ [(k, NodeInfo k p)] -> Map k (NodeInfo k p)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(k, NodeInfo k p)] -> Map k (NodeInfo k p))
-> [(k, NodeInfo k p)] -> Map k (NodeInfo k p)
forall a b. (a -> b) -> a -> b
$ [Maybe (k, NodeInfo k p)] -> [(k, NodeInfo k p)]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe (k, NodeInfo k p)] -> [(k, NodeInfo k p)])
-> [Maybe (k, NodeInfo k p)] -> [(k, NodeInfo k p)]
forall a b. (a -> b) -> a -> b
$ ((k, PatchTarget p)
 -> (k, PatchTarget p) -> Maybe (k, NodeInfo k p))
-> [(k, PatchTarget p)]
-> [(k, PatchTarget p)]
-> [Maybe (k, NodeInfo k p)]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (k, PatchTarget p) -> (k, PatchTarget p) -> Maybe (k, NodeInfo k p)
g [(k, PatchTarget p)]
unsorted [(k, PatchTarget p)]
sorted
  where unsorted :: [(k, PatchTarget p)]
unsorted = Map k (PatchTarget p) -> [(k, PatchTarget p)]
forall k a. Map k a -> [(k, a)]
Map.toList Map k (PatchTarget p)
m
        sorted :: [(k, PatchTarget p)]
sorted = ((k, PatchTarget p) -> (k, PatchTarget p) -> Ordering)
-> [(k, PatchTarget p)] -> [(k, PatchTarget p)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (PatchTarget p -> PatchTarget p -> Ordering
cmp (PatchTarget p -> PatchTarget p -> Ordering)
-> ((k, PatchTarget p) -> PatchTarget p)
-> (k, PatchTarget p)
-> (k, PatchTarget p)
-> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (k, PatchTarget p) -> PatchTarget p
forall a b. (a, b) -> b
snd) [(k, PatchTarget p)]
unsorted
        f :: (b, b) -> (b, b) -> Maybe (b, b)
f (b
to, b
_) (b
from, b
_) = if b
to b -> b -> Bool
forall a. Eq a => a -> a -> Bool
== b
from then Maybe (b, b)
forall a. Maybe a
Nothing else
          (b, b) -> Maybe (b, b)
forall a. a -> Maybe a
Just (b
from, b
to)
        reverseMapping :: Map k k
reverseMapping = [(k, k)] -> Map k k
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(k, k)] -> Map k k) -> [(k, k)] -> Map k k
forall a b. (a -> b) -> a -> b
$ [Maybe (k, k)] -> [(k, k)]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe (k, k)] -> [(k, k)]) -> [Maybe (k, k)] -> [(k, k)]
forall a b. (a -> b) -> a -> b
$ ((k, PatchTarget p) -> (k, PatchTarget p) -> Maybe (k, k))
-> [(k, PatchTarget p)] -> [(k, PatchTarget p)] -> [Maybe (k, k)]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (k, PatchTarget p) -> (k, PatchTarget p) -> Maybe (k, k)
forall b b b. Eq b => (b, b) -> (b, b) -> Maybe (b, b)
f [(k, PatchTarget p)]
unsorted [(k, PatchTarget p)]
sorted
        g :: (k, PatchTarget p) -> (k, PatchTarget p) -> Maybe (k, NodeInfo k p)
g (k
to, PatchTarget p
_) (k
from, PatchTarget p
_) = if k
to k -> k -> Bool
forall a. Eq a => a -> a -> Bool
== k
from then Maybe (k, NodeInfo k p)
forall a. Maybe a
Nothing else
          let Just k
movingTo = k -> Map k k -> Maybe k
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup k
from Map k k
reverseMapping
          in (k, NodeInfo k p) -> Maybe (k, NodeInfo k p)
forall a. a -> Maybe a
Just (k
to, From k p -> Maybe k -> NodeInfo k p
forall k p. From k p -> To k -> NodeInfo k p
NodeInfo (k -> p -> From k p
forall k p. k -> p -> From k p
From_Move k
from p
forall a. Monoid a => a
mempty) (Maybe k -> NodeInfo k p) -> Maybe k -> NodeInfo k p
forall a b. (a -> b) -> a -> b
$ k -> Maybe k
forall a. a -> Maybe a
Just k
movingTo)

-- | Create a 'PatchMapWithPatchingMove' that, if applied to the first 'Map' provided,
-- will produce a 'Map' with the same values as the second 'Map' but with the
-- values sorted with the given ordering function.
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 :: (PatchTarget p -> PatchTarget p -> Ordering)
-> Map k (PatchTarget p)
-> Map k (PatchTarget p)
-> PatchMapWithPatchingMove k p
patchThatChangesAndSortsMapWith PatchTarget p -> PatchTarget p -> Ordering
cmp Map k (PatchTarget p)
oldByIndex Map k (PatchTarget p)
newByIndexUnsorted = Map k (PatchTarget p)
-> Map k (PatchTarget p) -> PatchMapWithPatchingMove k p
forall k p.
(Ord k, Ord (PatchTarget p), Monoid p) =>
Map k (PatchTarget p)
-> Map k (PatchTarget p) -> PatchMapWithPatchingMove k p
patchThatChangesMap Map k (PatchTarget p)
oldByIndex Map k (PatchTarget p)
newByIndex
  where newList :: [(k, PatchTarget p)]
newList = Map k (PatchTarget p) -> [(k, PatchTarget p)]
forall k a. Map k a -> [(k, a)]
Map.toList Map k (PatchTarget p)
newByIndexUnsorted
        newByIndex :: Map k (PatchTarget p)
newByIndex = [(k, PatchTarget p)] -> Map k (PatchTarget p)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(k, PatchTarget p)] -> Map k (PatchTarget p))
-> [(k, PatchTarget p)] -> Map k (PatchTarget p)
forall a b. (a -> b) -> a -> b
$ [k] -> [PatchTarget p] -> [(k, PatchTarget p)]
forall a b. [a] -> [b] -> [(a, b)]
zip ((k, PatchTarget p) -> k
forall a b. (a, b) -> a
fst ((k, PatchTarget p) -> k) -> [(k, PatchTarget p)] -> [k]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(k, PatchTarget p)]
newList) ([PatchTarget p] -> [(k, PatchTarget p)])
-> [PatchTarget p] -> [(k, PatchTarget p)]
forall a b. (a -> b) -> a -> b
$ (PatchTarget p -> PatchTarget p -> Ordering)
-> [PatchTarget p] -> [PatchTarget p]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy PatchTarget p -> PatchTarget p -> Ordering
cmp ([PatchTarget p] -> [PatchTarget p])
-> [PatchTarget p] -> [PatchTarget p]
forall a b. (a -> b) -> a -> b
$ (k, PatchTarget p) -> PatchTarget p
forall a b. (a, b) -> b
snd ((k, PatchTarget p) -> PatchTarget p)
-> [(k, PatchTarget p)] -> [PatchTarget p]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(k, PatchTarget p)]
newList

-- | Create a 'PatchMapWithPatchingMove' that, if applied to the first 'Map' provided,
-- will produce the second 'Map'.
-- Note: this will never produce a patch on a value.
patchThatChangesMap
  :: forall k p
  .  (Ord k, Ord (PatchTarget p), Monoid p)
  => Map k (PatchTarget p) -> Map k (PatchTarget p) -> PatchMapWithPatchingMove k p
patchThatChangesMap :: Map k (PatchTarget p)
-> Map k (PatchTarget p) -> PatchMapWithPatchingMove k p
patchThatChangesMap Map k (PatchTarget p)
oldByIndex Map k (PatchTarget p)
newByIndex = PatchMapWithPatchingMove k p
patch
  where invert :: Map k (PatchTarget p) -> Map (PatchTarget p) (Set k)
        invert :: Map k (PatchTarget p) -> Map (PatchTarget p) (Set k)
invert = (Set k -> Set k -> Set k)
-> [(PatchTarget p, Set k)] -> Map (PatchTarget p) (Set k)
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith Set k -> Set k -> Set k
forall a. Semigroup a => a -> a -> a
(<>) ([(PatchTarget p, Set k)] -> Map (PatchTarget p) (Set k))
-> (Map k (PatchTarget p) -> [(PatchTarget p, Set k)])
-> Map k (PatchTarget p)
-> Map (PatchTarget p) (Set k)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((k, PatchTarget p) -> (PatchTarget p, Set k))
-> [(k, PatchTarget p)] -> [(PatchTarget p, Set k)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(k
k, PatchTarget p
v) -> (PatchTarget p
v, k -> Set k
forall a. a -> Set a
Set.singleton k
k)) ([(k, PatchTarget p)] -> [(PatchTarget p, Set k)])
-> (Map k (PatchTarget p) -> [(k, PatchTarget p)])
-> Map k (PatchTarget p)
-> [(PatchTarget p, Set k)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map k (PatchTarget p) -> [(k, PatchTarget p)]
forall k a. Map k a -> [(k, a)]
Map.toList
        -- In the places where we use unionDistinct, a non-distinct key indicates a bug in this function
        unionDistinct :: forall k' v'. Ord k' => Map k' v' -> Map k' v' -> Map k' v'
        unionDistinct :: Map k' v' -> Map k' v' -> Map k' v'
unionDistinct = (v' -> v' -> v') -> Map k' v' -> Map k' v' -> Map k' v'
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith (String -> v' -> v' -> v'
forall a. HasCallStack => String -> a
error String
"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 :: (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 (Map k (From k v)
oldFroms, Map k (To k)
oldTos) (Map k (From k v)
newFroms, Map k (To k)
newTos) = (Map k (From k v) -> Map k (From k v) -> Map k (From k v)
forall k a. Ord k => Map k a -> Map k a -> Map k a
unionDistinct Map k (From k v)
oldFroms Map k (From k v)
newFroms, Map k (To k) -> Map k (To k) -> Map k (To k)
forall k a. Ord k => Map k a -> Map k a -> Map k a
unionDistinct Map k (To k)
oldTos Map k (To k)
newTos)
        -- Generate patch info for a single value
        -- Keys that are found in both the old and new sets will not be patched
        -- Keys that are found in only the old set will be moved to a new position if any are available; otherwise they will be deleted
        -- Keys that are found in only the new set will be populated by moving an old key if any are available; otherwise they will be inserted
        patchSingleValue :: PatchTarget p -> Set k -> Set k -> (Map k (From k p), Map k (To k))
        patchSingleValue :: PatchTarget p -> Set k -> Set k -> (Map k (From k p), Map k (To k))
patchSingleValue PatchTarget p
v Set k
oldKeys Set k
newKeys = ((Map k (From k p), Map k (To k))
 -> (Map k (From k p), Map k (To k))
 -> (Map k (From k p), Map k (To k)))
-> (Map k (From k p), Map k (To k))
-> [(Map k (From k p), Map k (To k))]
-> (Map k (From k p), Map k (To k))
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (Map k (From k p), Map k (To k))
-> (Map k (From k p), Map k (To k))
-> (Map k (From k p), Map k (To k))
forall v.
(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 (Map k (From k p), Map k (To k))
forall a. Monoid a => a
mempty ([(Map k (From k p), Map k (To k))]
 -> (Map k (From k p), Map k (To k)))
-> [(Map k (From k p), Map k (To k))]
-> (Map k (From k p), Map k (To k))
forall a b. (a -> b) -> a -> b
$ [k] -> [k] -> [These k k]
forall (f :: * -> *) a b.
Semialign f =>
f a -> f b -> f (These a b)
align (Set k -> [k]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Set k -> [k]) -> Set k -> [k]
forall a b. (a -> b) -> a -> b
$ Set k
oldKeys Set k -> Set k -> Set k
forall a. Ord a => Set a -> Set a -> Set a
`Set.difference` Set k
newKeys) (Set k -> [k]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Set k -> [k]) -> Set k -> [k]
forall a b. (a -> b) -> a -> b
$ Set k
newKeys Set k -> Set k -> Set k
forall a. Ord a => Set a -> Set a -> Set a
`Set.difference` Set k
oldKeys) [These k k]
-> (These k k -> (Map k (From k p), Map k (To k)))
-> [(Map k (From k p), Map k (To k))]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \case
          This k
oldK -> (Map k (From k p)
forall a. Monoid a => a
mempty, k -> To k -> Map k (To k)
forall k a. k -> a -> Map k a
Map.singleton k
oldK To k
forall a. Maybe a
Nothing) -- There's nowhere for this value to go, so we know we are deleting it
          That k
newK -> (k -> From k p -> Map k (From k p)
forall k a. k -> a -> Map k a
Map.singleton k
newK (From k p -> Map k (From k p)) -> From k p -> Map k (From k p)
forall a b. (a -> b) -> a -> b
$ PatchTarget p -> From k p
forall k p. PatchTarget p -> From k p
From_Insert PatchTarget p
v, Map k (To k)
forall a. Monoid a => a
mempty) -- There's nowhere fo this value to come from, so we know we are inserting it
          These k
oldK k
newK -> (k -> From k p -> Map k (From k p)
forall k a. k -> a -> Map k a
Map.singleton k
newK (From k p -> Map k (From k p)) -> From k p -> Map k (From k p)
forall a b. (a -> b) -> a -> b
$ k -> p -> From k p
forall k p. k -> p -> From k p
From_Move k
oldK p
forall a. Monoid a => a
mempty, k -> To k -> Map k (To k)
forall k a. k -> a -> Map k a
Map.singleton k
oldK (To k -> Map k (To k)) -> To k -> Map k (To k)
forall a b. (a -> b) -> a -> b
$ k -> To k
forall a. a -> Maybe a
Just k
newK)
        -- Run patchSingleValue on a These.  Missing old or new sets are considered empty
        patchSingleValueThese :: PatchTarget p -> These (Set k) (Set k) -> (Map k (From k p), Map k (To k))
        patchSingleValueThese :: PatchTarget p
-> These (Set k) (Set k) -> (Map k (From k p), Map k (To k))
patchSingleValueThese PatchTarget p
v = \case
          This Set k
oldKeys -> PatchTarget p -> Set k -> Set k -> (Map k (From k p), Map k (To k))
patchSingleValue PatchTarget p
v Set k
oldKeys Set k
forall a. Monoid a => a
mempty
          That Set k
newKeys -> PatchTarget p -> Set k -> Set k -> (Map k (From k p), Map k (To k))
patchSingleValue PatchTarget p
v Set k
forall a. Monoid a => a
mempty Set k
newKeys
          These Set k
oldKeys Set k
newKeys -> PatchTarget p -> Set k -> Set k -> (Map k (From k p), Map k (To k))
patchSingleValue PatchTarget p
v Set k
oldKeys Set k
newKeys
        -- Generate froms and tos for all values, then merge them together
        (Map k (From k p)
froms, Map k (To k)
tos) = ((Map k (From k p), Map k (To k))
 -> (Map k (From k p), Map k (To k))
 -> (Map k (From k p), Map k (To k)))
-> (Map k (From k p), Map k (To k))
-> Map (PatchTarget p) (Map k (From k p), Map k (To k))
-> (Map k (From k p), Map k (To k))
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (Map k (From k p), Map k (To k))
-> (Map k (From k p), Map k (To k))
-> (Map k (From k p), Map k (To k))
forall v.
(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 (Map k (From k p), Map k (To k))
forall a. Monoid a => a
mempty (Map (PatchTarget p) (Map k (From k p), Map k (To k))
 -> (Map k (From k p), Map k (To k)))
-> Map (PatchTarget p) (Map k (From k p), Map k (To k))
-> (Map k (From k p), Map k (To k))
forall a b. (a -> b) -> a -> b
$ (PatchTarget p
 -> These (Set k) (Set k) -> (Map k (From k p), Map k (To k)))
-> Map (PatchTarget p) (These (Set k) (Set k))
-> Map (PatchTarget p) (Map k (From k p), Map k (To k))
forall k a b. (k -> a -> b) -> Map k a -> Map k b
Map.mapWithKey PatchTarget p
-> These (Set k) (Set k) -> (Map k (From k p), Map k (To k))
patchSingleValueThese (Map (PatchTarget p) (These (Set k) (Set k))
 -> Map (PatchTarget p) (Map k (From k p), Map k (To k)))
-> Map (PatchTarget p) (These (Set k) (Set k))
-> Map (PatchTarget p) (Map k (From k p), Map k (To k))
forall a b. (a -> b) -> a -> b
$ Map (PatchTarget p) (Set k)
-> Map (PatchTarget p) (Set k)
-> Map (PatchTarget p) (These (Set k) (Set k))
forall (f :: * -> *) a b.
Semialign f =>
f a -> f b -> f (These a b)
align (Map k (PatchTarget p) -> Map (PatchTarget p) (Set k)
invert Map k (PatchTarget p)
oldByIndex) (Map k (PatchTarget p) -> Map (PatchTarget p) (Set k)
invert Map k (PatchTarget p)
newByIndex)
        patch :: PatchMapWithPatchingMove k p
patch = Map k (NodeInfo k p) -> PatchMapWithPatchingMove k p
forall k p. Map k (NodeInfo k p) -> PatchMapWithPatchingMove k p
unsafePatchMapWithPatchingMove (Map k (NodeInfo k p) -> PatchMapWithPatchingMove k p)
-> Map k (NodeInfo k p) -> PatchMapWithPatchingMove k p
forall a b. (a -> b) -> a -> b
$ Map k (From k p) -> Map k (To k) -> Map k (These (From k p) (To k))
forall (f :: * -> *) a b.
Semialign f =>
f a -> f b -> f (These a b)
align Map k (From k p)
froms Map k (To k)
tos Map k (These (From k p) (To k))
-> (These (From k p) (To k) -> NodeInfo k p)
-> Map k (NodeInfo k p)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \case
          This From k p
from -> From k p -> To k -> NodeInfo k p
forall k p. From k p -> To k -> NodeInfo k p
NodeInfo From k p
from To k
forall a. Maybe a
Nothing -- Since we don't have a 'to' record for this key, that must mean it isn't being moved anywhere, so it should be deleted.
          That To k
to -> From k p -> To k -> NodeInfo k p
forall k p. From k p -> To k -> NodeInfo k p
NodeInfo From k p
forall k p. From k p
From_Delete To k
to -- Since we don't have a 'from' record for this key, it must be getting deleted
          These From k p
from To k
to -> From k p -> To k -> NodeInfo k p
forall k p. From k p -> To k -> NodeInfo k p
NodeInfo From k p
from To k
to

--
-- NodeInfo
--

-- | Holds the information about each key: where its new value should come from,
-- and where its old value should go to
data NodeInfo k p = NodeInfo
  { NodeInfo k p -> From k p
_nodeInfo_from :: !(From k p)
    -- ^ Where do we get the new value for this key?
  , NodeInfo k p -> To k
_nodeInfo_to :: !(To k)
    -- ^ If the old value is being kept (i.e. moved rather than deleted or
    -- replaced), where is it going?
  }
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)

-- | Traverse the 'NodeInfo' over the key, patch, and patch target. Because of
-- the type families here, this doesn't it any bi- or tri-traversal class.
bitraverseNodeInfo
  :: Applicative f
  => (k0 -> f k1)
  -> (p0 -> f p1)
  -> (PatchTarget p0 -> f (PatchTarget p1))
  -> NodeInfo k0 p0 -> f (NodeInfo k1 p1)
bitraverseNodeInfo :: (k0 -> f k1)
-> (p0 -> f p1)
-> (PatchTarget p0 -> f (PatchTarget p1))
-> NodeInfo k0 p0
-> f (NodeInfo k1 p1)
bitraverseNodeInfo k0 -> f k1
fk p0 -> f p1
fp PatchTarget p0 -> f (PatchTarget p1)
fpt (NodeInfo From k0 p0
from To k0
to) = From k1 p1 -> To k1 -> NodeInfo k1 p1
forall k p. From k p -> To k -> NodeInfo k p
NodeInfo
  (From k1 p1 -> To k1 -> NodeInfo k1 p1)
-> f (From k1 p1) -> f (To k1 -> NodeInfo k1 p1)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (k0 -> f k1)
-> (p0 -> f p1)
-> (PatchTarget p0 -> f (PatchTarget p1))
-> From k0 p0
-> f (From k1 p1)
forall (f :: * -> *) k0 k1 p0 p1.
Applicative f =>
(k0 -> f k1)
-> (p0 -> f p1)
-> (PatchTarget p0 -> f (PatchTarget p1))
-> From k0 p0
-> f (From k1 p1)
bitraverseFrom k0 -> f k1
fk p0 -> f p1
fp PatchTarget p0 -> f (PatchTarget p1)
fpt From k0 p0
from
  f (To k1 -> NodeInfo k1 p1) -> f (To k1) -> f (NodeInfo k1 p1)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (k0 -> f k1) -> To k0 -> f (To k1)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse k0 -> f k1
fk To k0
to

-- | Change the 'From' value of a 'NodeInfo'
nodeInfoMapFrom
  :: (From k v -> From k v) -> NodeInfo k v -> NodeInfo k v
nodeInfoMapFrom :: (From k v -> From k v) -> NodeInfo k v -> NodeInfo k v
nodeInfoMapFrom From k v -> From k v
f NodeInfo k v
ni = NodeInfo k v
ni { _nodeInfo_from :: From k v
_nodeInfo_from = From k v -> From k v
f (From k v -> From k v) -> From k v -> From k v
forall a b. (a -> b) -> a -> b
$ NodeInfo k v -> From k v
forall k p. NodeInfo k p -> From k p
_nodeInfo_from NodeInfo k v
ni }

-- | Change the 'From' value of a 'NodeInfo', using a 'Functor' (or
-- 'Applicative', 'Monad', etc.) action to get the new value
nodeInfoMapMFrom
  :: Functor f => (From k v -> f (From k v)) -> NodeInfo k v -> f (NodeInfo k v)
nodeInfoMapMFrom :: (From k v -> f (From k v)) -> NodeInfo k v -> f (NodeInfo k v)
nodeInfoMapMFrom From k v -> f (From k v)
f NodeInfo k v
ni = (From k v -> NodeInfo k v) -> f (From k v) -> f (NodeInfo k v)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\From k v
result -> NodeInfo k v
ni { _nodeInfo_from :: From k v
_nodeInfo_from = From k v
result }) (f (From k v) -> f (NodeInfo k v))
-> f (From k v) -> f (NodeInfo k v)
forall a b. (a -> b) -> a -> b
$ From k v -> f (From k v)
f (From k v -> f (From k v)) -> From k v -> f (From k v)
forall a b. (a -> b) -> a -> b
$ NodeInfo k v -> From k v
forall k p. NodeInfo k p -> From k p
_nodeInfo_from NodeInfo k v
ni

-- | Set the 'To' field of a 'NodeInfo'
nodeInfoSetTo
  :: To k -> NodeInfo k v -> NodeInfo k v
nodeInfoSetTo :: To k -> NodeInfo k v -> NodeInfo k v
nodeInfoSetTo To k
to NodeInfo k v
ni = NodeInfo k v
ni { _nodeInfo_to :: To k
_nodeInfo_to = To k
to }

--
-- From
--

-- | Describe how a key's new value should be produced
data From k p
   = From_Insert (PatchTarget p) -- ^ Insert the given value here
   | From_Delete -- ^ Delete the existing value, if any, from here
   | From_Move !k !p -- ^ Move the value here from the given key, and apply the given patch

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)

-- | Traverse the 'From' over the key, patch, and patch target. Because of
-- the type families here, this doesn't it any bi- or tri-traversal class.
bitraverseFrom
  :: Applicative f
  => (k0 -> f k1)
  -> (p0 -> f p1)
  -> (PatchTarget p0 -> f (PatchTarget p1))
  -> From k0 p0 -> f (From k1 p1)
bitraverseFrom :: (k0 -> f k1)
-> (p0 -> f p1)
-> (PatchTarget p0 -> f (PatchTarget p1))
-> From k0 p0
-> f (From k1 p1)
bitraverseFrom k0 -> f k1
fk p0 -> f p1
fp PatchTarget p0 -> f (PatchTarget p1)
fpt = \case
  From_Insert PatchTarget p0
pt -> PatchTarget p1 -> From k1 p1
forall k p. PatchTarget p -> From k p
From_Insert (PatchTarget p1 -> From k1 p1)
-> f (PatchTarget p1) -> f (From k1 p1)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PatchTarget p0 -> f (PatchTarget p1)
fpt PatchTarget p0
pt
  From k0 p0
From_Delete -> From k1 p1 -> f (From k1 p1)
forall (f :: * -> *) a. Applicative f => a -> f a
pure From k1 p1
forall k p. From k p
From_Delete
  From_Move k0
k p0
p -> k1 -> p1 -> From k1 p1
forall k p. k -> p -> From k p
From_Move (k1 -> p1 -> From k1 p1) -> f k1 -> f (p1 -> From k1 p1)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> k0 -> f k1
fk k0
k f (p1 -> From k1 p1) -> f p1 -> f (From k1 p1)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> p0 -> f p1
fp p0
p

--
-- To
--

-- | Describe where a key's old value will go.  If this is 'Just', that means
-- the key's old value will be moved to the given other key; if it is 'Nothing',
-- that means it will be deleted.
type To = Maybe

--
-- Fixup
--

-- | Helper data structure used for composing patches using the monoid instance.
data Fixup k v
   = Fixup_Delete
   | Fixup_Update (These (From k v) (To k))

-- | Compose patches having the same effect as applying the patches in turn:
-- @'applyAlways' (p <> q) == 'applyAlways' p . 'applyAlways' q@
instance ( Ord k
#if !MIN_VERSION_base(4,11,0)
         , Semigroup p
#endif
         , DecidablyEmpty p
         , Patch p
         ) => Semigroup (PatchMapWithPatchingMove k p) where
  PatchMapWithPatchingMove Map k (NodeInfo k p)
ma <> :: PatchMapWithPatchingMove k p
-> PatchMapWithPatchingMove k p -> PatchMapWithPatchingMove k p
<> PatchMapWithPatchingMove Map k (NodeInfo k p)
mb = Map k (NodeInfo k p) -> PatchMapWithPatchingMove k p
forall k p. Map k (NodeInfo k p) -> PatchMapWithPatchingMove k p
PatchMapWithPatchingMove Map k (NodeInfo k p)
m
    where
      connections :: [(k, (To k, From k p))]
connections = Map k (To k, From k p) -> [(k, (To k, From k p))]
forall k a. Map k a -> [(k, a)]
Map.toList (Map k (To k, From k p) -> [(k, (To k, From k p))])
-> Map k (To k, From k p) -> [(k, (To k, From k p))]
forall a b. (a -> b) -> a -> b
$ (k -> NodeInfo k p -> NodeInfo k p -> (To k, From k p))
-> Map k (NodeInfo k p)
-> Map k (NodeInfo k p)
-> Map k (To k, From k p)
forall k a b c.
Ord k =>
(k -> a -> b -> c) -> Map k a -> Map k b -> Map k c
Map.intersectionWithKey (\k
_ NodeInfo k p
a NodeInfo k p
b -> (NodeInfo k p -> To k
forall k p. NodeInfo k p -> To k
_nodeInfo_to NodeInfo k p
a, NodeInfo k p -> From k p
forall k p. NodeInfo k p -> From k p
_nodeInfo_from NodeInfo k p
b)) Map k (NodeInfo k p)
ma Map k (NodeInfo k p)
mb
      h :: (k, (Maybe k, From k p)) -> [(k, Fixup k p)]
      h :: (k, (To k, From k p)) -> [(k, Fixup k p)]
h (k
_, (To k
mToAfter, From k p
editBefore)) = case (To k
mToAfter, From k p
editBefore) of
        (Just k
toAfter, From_Move k
fromBefore p
p)
          | k
fromBefore k -> k -> Bool
forall a. Eq a => a -> a -> Bool
== k
toAfter Bool -> Bool -> Bool
&& p -> Bool
forall a. DecidablyEmpty a => a -> Bool
isEmpty p
p
            -> [(k
toAfter, Fixup k p
forall k v. Fixup k v
Fixup_Delete)]
          | Bool
otherwise
            -> [ (k
toAfter, These (From k p) (To k) -> Fixup k p
forall k v. These (From k v) (To k) -> Fixup k v
Fixup_Update (From k p -> These (From k p) (To k)
forall a b. a -> These a b
This From k p
editBefore))
               , (k
fromBefore, These (From k p) (To k) -> Fixup k p
forall k v. These (From k v) (To k) -> Fixup k v
Fixup_Update (To k -> These (From k p) (To k)
forall a b. b -> These a b
That To k
mToAfter))
               ]
        (To k
Nothing, From_Move k
fromBefore p
_) -> [(k
fromBefore, These (From k p) (To k) -> Fixup k p
forall k v. These (From k v) (To k) -> Fixup k v
Fixup_Update (To k -> These (From k p) (To k)
forall a b. b -> These a b
That To k
mToAfter))] -- The item is destroyed in the second patch, so indicate that it is destroyed in the source map
        (Just k
toAfter, From k p
_) -> [(k
toAfter, These (From k p) (To k) -> Fixup k p
forall k v. These (From k v) (To k) -> Fixup k v
Fixup_Update (From k p -> These (From k p) (To k)
forall a b. a -> These a b
This From k p
editBefore))]
        (To k
Nothing, From k p
_) -> []
      mergeFixups :: p -> Fixup k v -> Fixup k v -> Fixup k v
mergeFixups p
_ Fixup k v
Fixup_Delete Fixup k v
Fixup_Delete = Fixup k v
forall k v. Fixup k v
Fixup_Delete
      mergeFixups p
_ (Fixup_Update These (From k v) (To k)
a) (Fixup_Update These (From k v) (To k)
b)
        | This From k v
x <- These (From k v) (To k)
a, That To k
y <- These (From k v) (To k)
b
        = These (From k v) (To k) -> Fixup k v
forall k v. These (From k v) (To k) -> Fixup k v
Fixup_Update (These (From k v) (To k) -> Fixup k v)
-> These (From k v) (To k) -> Fixup k v
forall a b. (a -> b) -> a -> b
$ From k v -> To k -> These (From k v) (To k)
forall a b. a -> b -> These a b
These From k v
x To k
y
        | That To k
y <- These (From k v) (To k)
a, This From k v
x <- These (From k v) (To k)
b
        = These (From k v) (To k) -> Fixup k v
forall k v. These (From k v) (To k) -> Fixup k v
Fixup_Update (These (From k v) (To k) -> Fixup k v)
-> These (From k v) (To k) -> Fixup k v
forall a b. (a -> b) -> a -> b
$ From k v -> To k -> These (From k v) (To k)
forall a b. a -> b -> These a b
These From k v
x To k
y
      mergeFixups p
_ Fixup k v
_ Fixup k v
_ = String -> Fixup k v
forall a. HasCallStack => String -> a
error String
"PatchMapWithPatchingMove: incompatible fixups"
      fixups :: Map k (Fixup k p)
fixups = (k -> Fixup k p -> Fixup k p -> Fixup k p)
-> [(k, Fixup k p)] -> Map k (Fixup k p)
forall k a. Ord k => (k -> a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWithKey k -> Fixup k p -> Fixup k p -> Fixup k p
forall p k v. p -> Fixup k v -> Fixup k v -> Fixup k v
mergeFixups ([(k, Fixup k p)] -> Map k (Fixup k p))
-> [(k, Fixup k p)] -> Map k (Fixup k p)
forall a b. (a -> b) -> a -> b
$ ((k, (To k, From k p)) -> [(k, Fixup k p)])
-> [(k, (To k, From k p))] -> [(k, Fixup k p)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (k, (To k, From k p)) -> [(k, Fixup k p)]
h [(k, (To k, From k p))]
connections
      combineNodeInfos :: p -> NodeInfo k p -> NodeInfo k p -> NodeInfo k p
combineNodeInfos p
_ NodeInfo k p
nia NodeInfo k p
nib = NodeInfo :: forall k p. From k p -> To k -> NodeInfo k p
NodeInfo
        { _nodeInfo_from :: From k p
_nodeInfo_from = NodeInfo k p -> From k p
forall k p. NodeInfo k p -> From k p
_nodeInfo_from NodeInfo k p
nia
        , _nodeInfo_to :: To k
_nodeInfo_to = NodeInfo k p -> To k
forall k p. NodeInfo k p -> To k
_nodeInfo_to NodeInfo k p
nib
        }
      applyFixup :: p -> NodeInfo k p -> Fixup k p -> Maybe (NodeInfo k p)
applyFixup p
_ NodeInfo k p
ni = \case
        Fixup k p
Fixup_Delete -> Maybe (NodeInfo k p)
forall a. Maybe a
Nothing
        Fixup_Update These (From k p) (To k)
u -> NodeInfo k p -> Maybe (NodeInfo k p)
forall a. a -> Maybe a
Just (NodeInfo k p -> Maybe (NodeInfo k p))
-> NodeInfo k p -> Maybe (NodeInfo k p)
forall a b. (a -> b) -> a -> b
$ NodeInfo :: forall k p. From k p -> To k -> NodeInfo k p
NodeInfo
          { _nodeInfo_from :: From k p
_nodeInfo_from = case NodeInfo k p -> From k p
forall k p. NodeInfo k p -> From k p
_nodeInfo_from NodeInfo k p
ni of
              f :: From k p
f@(From_Move k
_ p
p') -> case These (From k p) (To k) -> Maybe (From k p)
forall a b. These a b -> Maybe a
getHere These (From k p) (To k)
u of -- The `from` fixup comes from the "old" patch
                Maybe (From k p)
Nothing -> From k p
f -- If there's no `from` fixup, just use the "new" `from`
                Just (From_Insert PatchTarget p
v) -> PatchTarget p -> From k p
forall k p. PatchTarget p -> From k p
From_Insert (PatchTarget p -> From k p) -> PatchTarget p -> From k p
forall a b. (a -> b) -> a -> b
$ p -> PatchTarget p -> PatchTarget p
forall p. Patch p => p -> PatchTarget p -> PatchTarget p
applyAlways p
p' PatchTarget p
v
                Just From k p
From_Delete -> From k p
forall k p. From k p
From_Delete
                Just (From_Move k
oldKey p
p) -> k -> p -> From k p
forall k p. k -> p -> From k p
From_Move k
oldKey (p -> From k p) -> p -> From k p
forall a b. (a -> b) -> a -> b
$ p
p' p -> p -> p
forall a. Semigroup a => a -> a -> a
<> p
p
              From k p
_ -> String -> From k p
forall a. HasCallStack => String -> a
error String
"PatchMapWithPatchingMove: fixup for non-move From"
          , _nodeInfo_to :: To k
_nodeInfo_to = To k -> Maybe (To k) -> To k
forall a. a -> Maybe a -> a
fromMaybe (NodeInfo k p -> To k
forall k p. NodeInfo k p -> To k
_nodeInfo_to NodeInfo k p
ni) (Maybe (To k) -> To k) -> Maybe (To k) -> To k
forall a b. (a -> b) -> a -> b
$ These (From k p) (To k) -> Maybe (To k)
forall a b. These a b -> Maybe b
getThere These (From k p) (To k)
u
          }
      m :: Map k (NodeInfo k p)
m = (k -> NodeInfo k p -> Fixup k p -> Maybe (NodeInfo k p))
-> Map k (NodeInfo k p)
-> Map k (Fixup k p)
-> Map k (NodeInfo k p)
forall k a b.
Ord k =>
(k -> a -> b -> Maybe a) -> Map k a -> Map k b -> Map k a
Map.differenceWithKey k -> NodeInfo k p -> Fixup k p -> Maybe (NodeInfo k p)
forall p p k.
(Patch p, Semigroup p) =>
p -> NodeInfo k p -> Fixup k p -> Maybe (NodeInfo k p)
applyFixup ((k -> NodeInfo k p -> NodeInfo k p -> NodeInfo k p)
-> Map k (NodeInfo k p)
-> Map k (NodeInfo k p)
-> Map k (NodeInfo k p)
forall k a.
Ord k =>
(k -> a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWithKey k -> NodeInfo k p -> NodeInfo k p -> NodeInfo k p
forall p k p p. p -> NodeInfo k p -> NodeInfo k p -> NodeInfo k p
combineNodeInfos Map k (NodeInfo k p)
ma Map k (NodeInfo k p)
mb) Map k (Fixup k p)
fixups
      getHere :: These a b -> Maybe a
      getHere :: These a b -> Maybe a
getHere = \case
        This a
a -> a -> Maybe a
forall a. a -> Maybe a
Just a
a
        These a
a b
_ -> a -> Maybe a
forall a. a -> Maybe a
Just a
a
        That b
_ -> Maybe a
forall a. Maybe a
Nothing
      getThere :: These a b -> Maybe b
      getThere :: These a b -> Maybe b
getThere = \case
        This a
_ -> Maybe b
forall a. Maybe a
Nothing
        These a
_ b
b -> b -> Maybe b
forall a. a -> Maybe a
Just b
b
        That b
b -> b -> Maybe b
forall a. a -> Maybe a
Just b
b

--TODO: Figure out how to implement this in terms of PatchDMapWithPatchingMove rather than duplicating it here
-- | Compose patches having the same effect as applying the patches in turn:
-- @'applyAlways' (p <> q) == 'applyAlways' p . 'applyAlways' q@
instance ( Ord k
#if !MIN_VERSION_base(4,11,0)
         , Semigroup p
#endif
         , DecidablyEmpty p
         , Patch p
         ) => Monoid (PatchMapWithPatchingMove k p) where
  mempty :: PatchMapWithPatchingMove k p
mempty = Map k (NodeInfo k p) -> PatchMapWithPatchingMove k p
forall k p. Map k (NodeInfo k p) -> PatchMapWithPatchingMove k p
PatchMapWithPatchingMove Map k (NodeInfo k p)
forall a. Monoid a => a
mempty
  mappend :: PatchMapWithPatchingMove k p
-> PatchMapWithPatchingMove k p -> PatchMapWithPatchingMove k p
mappend = PatchMapWithPatchingMove k p
-> PatchMapWithPatchingMove k p -> PatchMapWithPatchingMove k p
forall a. Semigroup a => a -> a -> a
(<>)

makeWrapped ''PatchMapWithPatchingMove