{-# 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
  , patchMapKey
  , 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'
    forall k p. 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 :: forall k p.
Ord k =>
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 a b. (a -> b) -> [a] -> [b]
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 :: forall k p. 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 a b. (a -> b) -> Map k a -> Map k b
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
  { _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 :: forall k p. 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 :: forall p k.
(DecidablyEmpty p, Patch p, Ord k) =>
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))
        ]

patchMapKey
  :: ( DecidablyEmpty p
#if !MIN_VERSION_base(4,11,0)
     , Semigroup p
#endif
     )
  => k -> p -> PatchMapWithPatchingMove k p
patchMapKey :: forall p k.
DecidablyEmpty p =>
k -> p -> PatchMapWithPatchingMove k p
patchMapKey k
k p
p
  | p -> Bool
forall a. DecidablyEmpty a => a -> Bool
isEmpty p
p = 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 k a. Map k a
Map.empty
  | 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. k -> a -> Map k a
Map.singleton k
k (NodeInfo k p -> Map k (NodeInfo k p))
-> NodeInfo k p -> Map k (NodeInfo 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 (k -> p -> From k p
forall k p. k -> p -> From k p
From_Move k
k p
p) (k -> To k
forall a. a -> Maybe a
Just k
k)

-- |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 :: forall p k.
(DecidablyEmpty p, Patch p, Ord k) =>
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 :: forall k v. 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 :: forall k p. 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 :: forall k p. 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 :: forall k p. 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 :: forall k p.
(Ord k, Monoid p) =>
(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 :: 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
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 :: 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 = 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 a b. (a -> b) -> [a] -> [b]
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 :: forall k a. Ord k => Map k a -> Map k a -> Map k a
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 :: 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 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 b a. (b -> a -> b) -> b -> [a] -> b
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 a b. [a] -> [b] -> [These a b]
forall (f :: * -> *) a b.
Semialign f =>
f a -> f b -> f (These a b)
align (Set k -> [k]
forall a. Set a -> [a]
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 a. Set a -> [a]
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 b a. (b -> a -> b) -> b -> Map (PatchTarget p) a -> b
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 a b.
Map (PatchTarget p) a
-> Map (PatchTarget p) b -> Map (PatchTarget p) (These a b)
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 a b. Map k a -> Map k b -> Map k (These a b)
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
  { forall k p. NodeInfo k p -> From k p
_nodeInfo_from :: !(From k p)
    -- ^ Where do we get the new value for this key?
  , forall k p. 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 :: forall (f :: * -> *) k0 k1 p0 p1.
Applicative f =>
(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 a b. f (a -> b) -> f a -> f b
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)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Maybe a -> f (Maybe 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 :: forall k v. (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 = f $ _nodeInfo_from 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 :: forall (f :: * -> *) k v.
Functor f =>
(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 a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\From k v
result -> NodeInfo k v
ni { _nodeInfo_from = 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 :: forall k v. To k -> NodeInfo k v -> NodeInfo k v
nodeInfoSetTo To k
to NodeInfo k v
ni = NodeInfo k v
ni { _nodeInfo_to = 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 :: 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 = \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 a. a -> f a
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 a b. f (a -> b) -> f a -> f b
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)
mNew <> :: PatchMapWithPatchingMove k p
-> PatchMapWithPatchingMove k p -> PatchMapWithPatchingMove k p
<> PatchMapWithPatchingMove Map k (NodeInfo k p)
mOld = 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 :: [(To k, From k p)]
connections = Map k (To k, From k p) -> [(To k, From k p)]
forall k a. Map k a -> [a]
Map.elems (Map k (To k, From k p) -> [(To k, From k p)])
-> Map k (To k, From k p) -> [(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
new NodeInfo k p
old -> (NodeInfo k p -> To k
forall k p. NodeInfo k p -> To k
_nodeInfo_to NodeInfo k p
new, NodeInfo k p -> From k p
forall k p. NodeInfo k p -> From k p
_nodeInfo_from NodeInfo k p
old)) Map k (NodeInfo k p)
mNew Map k (NodeInfo k p)
mOld
      h :: (Maybe k, From k p) -> [(k, Fixup k p)]
      h :: (To k, From k p) -> [(k, Fixup k p)]
h = \case
        (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 (k -> p -> From k p
forall k p. k -> p -> From k p
From_Move k
fromBefore p
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 (k -> To k
forall a. a -> Maybe a
Just k
toAfter)))
               ]
        (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
forall a. Maybe a
Nothing))] -- The item is destroyed in the second patch, so indicate that it is destroyed in the source map
        (Just k
toAfter, From k p
editBefore) -> [(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 :: Fixup k v -> Fixup k v -> Fixup k v
mergeFixups Fixup k v
Fixup_Delete Fixup k v
Fixup_Delete = Fixup k v
forall k v. Fixup k v
Fixup_Delete
      mergeFixups (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 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 {k} {v}. 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
$ ((To k, From k p) -> [(k, Fixup k p)])
-> [(To k, From k p)] -> [(k, Fixup k p)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (To k, From k p) -> [(k, Fixup k p)]
h [(To k, From k p)]
connections
      combineNodeInfos :: NodeInfo k p -> NodeInfo k p -> NodeInfo k p
combineNodeInfos NodeInfo k p
niNew NodeInfo k p
niOld = 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
niNew
        , _nodeInfo_to :: To k
_nodeInfo_to = NodeInfo k p -> To k
forall k p. NodeInfo k p -> To k
_nodeInfo_to NodeInfo k p
niOld
        }
      applyFixup :: NodeInfo k p -> Fixup k p -> Maybe (NodeInfo k p)
applyFixup 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
          { _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
              -- The new patch has a Move, so it could be affected by the
              -- corresponding From in the old patch.  If that From exists, then
              -- it is in the fixup here.
              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
                -- If there's no `From` fixup, just use the "new" `From`
                Maybe (From k p)
Nothing -> From k p
f
                -- If there's a `From` fixup which is an Insert, we can just apply
                -- our patch to that and turn ourselves into an insert.
                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
                -- If there's a `From` fixup which is a Delete, then we can throw
                -- our patch away because there's nothing to apply it to and
                -- become a Delete ourselves.
                Just From k p
From_Delete -> From k p
forall k p. From k p
From_Delete
                -- If there's a `From` fixup which is a Move, we need to apply
                -- both the old patch and the new patch (in that order) to the
                -- value, so we append the patches here.
                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
              -- If the new patch has an Insert, it doesn't care what the fixup
              -- value is, because it will overwrite it anyway.
              f :: From k p
f@(From_Insert PatchTarget p
_) -> From k p
f
              -- If the new patch has an Delete, it doesn't care what the fixup
              -- value is, because it will overwrite it anyway.
              f :: From k p
f@From k p
From_Delete -> From k p
f
          , _nodeInfo_to :: To k
_nodeInfo_to = case NodeInfo k p -> To k
forall k p. NodeInfo k p -> To k
_nodeInfo_to NodeInfo k p
ni of
              -- The old patch deletes this data, so we must delete it as well.
              -- According to the code above, any time we have this situation we
              -- should also have `getThere u == Nothing` because a fixup
              -- shouldn't be generated.
              To k
Nothing -> To k
forall a. Maybe a
Nothing
              -- The old patch sends the value to oldToAfter
              Just k
oldToAfter -> case 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 of
                -- If there is no fixup, that should mean that the new patch
                -- doesn't do anything with the value in oldToAfter, so we still
                -- send it to oldToAfter
                Maybe (To k)
Nothing -> k -> To k
forall a. a -> Maybe a
Just k
oldToAfter
                -- If there is a fixup, it should tell us where the new patch
                -- sends the value at key oldToAfter.  We send our value there.
                Just To k
mNewToAfter -> To k
mNewToAfter
          }
      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} {k}.
(Patch p, Semigroup p) =>
NodeInfo k p -> Fixup k p -> Maybe (NodeInfo k p)
applyFixup) ((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 => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith NodeInfo k p -> NodeInfo k p -> NodeInfo k p
forall {k} {p} {p}. NodeInfo k p -> NodeInfo k p -> NodeInfo k p
combineNodeInfos Map k (NodeInfo k p)
mNew Map k (NodeInfo k p)
mOld) Map k (Fixup k p)
fixups
      getHere :: These a b -> Maybe a
      getHere :: forall a b. 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 :: forall a b. 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