{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}

-- |Module containing @'PatchDMapWithMove' k v@ and associated functions, which represents a 'Patch' to a @'DMap' k v@ which can insert, update, delete, and
-- move values between keys.
module Data.Patch.DMapWithMove where

import Data.Patch.Class
import Data.Patch.MapWithMove (PatchMapWithMove (..))
import qualified Data.Patch.MapWithMove as MapWithMove

import Data.Constraint.Extras
import Data.Dependent.Map (DMap)
import Data.Dependent.Sum (DSum (..))
import qualified Data.Dependent.Map as DMap
import Data.Functor.Constant
import Data.Functor.Misc
import Data.Functor.Product
import Data.GADT.Compare (GEq (..), GCompare (..))
import Data.GADT.Show (GShow, gshow)
import qualified Data.Map as Map
import Data.Maybe
import Data.Monoid.DecidablyEmpty
#if !MIN_VERSION_base(4,11,0)
import Data.Semigroup (Semigroup (..))
#endif
import Data.Some (Some, mkSome)
import Data.These

-- | Like 'PatchMapWithMove', but for 'DMap'. Each key carries a 'NodeInfo' which describes how it will be changed by the patch and connects move sources and
-- destinations.
--
-- Invariants:
--
--     * A key should not move to itself.
--     * A move should always be represented with both the destination key (as a 'From_Move') and the source key (as a @'ComposeMaybe' ('Just' destination)@)
newtype PatchDMapWithMove k v = PatchDMapWithMove (DMap k (NodeInfo k v))

-- It won't let me derive for some reason
instance GCompare k => DecidablyEmpty (PatchDMapWithMove k v) where
  isEmpty :: PatchDMapWithMove k v -> Bool
isEmpty (PatchDMapWithMove DMap k (NodeInfo k v)
m) = DMap k (NodeInfo k v) -> Bool
forall k1 (k2 :: k1 -> *) (f :: k1 -> *). DMap k2 f -> Bool
DMap.null DMap k (NodeInfo k v)
m

-- |Structure which represents what changes apply to a particular key. @_nodeInfo_from@ specifies what happens to this key, and in particular what other key
-- the current key is moving from, while @_nodeInfo_to@ specifies what key the current key is moving to if involved in a move.
data NodeInfo k v a = NodeInfo
  { NodeInfo k v a -> From k v a
_nodeInfo_from :: !(From k v a)
  -- ^Change applying to the current key, be it an insert, move, or delete.
  , NodeInfo k v a -> To k a
_nodeInfo_to :: !(To k a)
  -- ^Where this key is moving to, if involved in a move. Should only be @ComposeMaybe (Just k)@ when there is a corresponding 'From_Move'.
  }
  deriving (Int -> NodeInfo k v a -> ShowS
[NodeInfo k v a] -> ShowS
NodeInfo k v a -> String
(Int -> NodeInfo k v a -> ShowS)
-> (NodeInfo k v a -> String)
-> ([NodeInfo k v a] -> ShowS)
-> Show (NodeInfo k v a)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall k (k :: k -> *) (v :: k -> *) (a :: k).
(Show (v a), Show (k a)) =>
Int -> NodeInfo k v a -> ShowS
forall k (k :: k -> *) (v :: k -> *) (a :: k).
(Show (v a), Show (k a)) =>
[NodeInfo k v a] -> ShowS
forall k (k :: k -> *) (v :: k -> *) (a :: k).
(Show (v a), Show (k a)) =>
NodeInfo k v a -> String
showList :: [NodeInfo k v a] -> ShowS
$cshowList :: forall k (k :: k -> *) (v :: k -> *) (a :: k).
(Show (v a), Show (k a)) =>
[NodeInfo k v a] -> ShowS
show :: NodeInfo k v a -> String
$cshow :: forall k (k :: k -> *) (v :: k -> *) (a :: k).
(Show (v a), Show (k a)) =>
NodeInfo k v a -> String
showsPrec :: Int -> NodeInfo k v a -> ShowS
$cshowsPrec :: forall k (k :: k -> *) (v :: k -> *) (a :: k).
(Show (v a), Show (k a)) =>
Int -> NodeInfo k v a -> ShowS
Show)

-- |Structure describing a particular change to a key, be it inserting a new key (@From_Insert@), updating an existing key (@From_Insert@ again), deleting a
-- key (@From_Delete@), or moving a key (@From_Move@).
data From (k :: a -> *) (v :: a -> *) :: a -> * where
  -- |Insert a new or update an existing key with the given value @v a@
  From_Insert :: v a -> From k v a
  -- |Delete the existing key
  From_Delete :: From k v a
  -- |Move the value from the given key @k a@ to this key. The source key should also have an entry in the patch giving the current key as @_nodeInfo_to@,
  -- usually but not necessarily with @From_Delete@.
  From_Move :: !(k a) -> From k v a
  deriving (Int -> From k v b -> ShowS
[From k v b] -> ShowS
From k v b -> String
(Int -> From k v b -> ShowS)
-> (From k v b -> String)
-> ([From k v b] -> ShowS)
-> Show (From k v b)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall a (k :: a -> *) (v :: a -> *) (b :: a).
(Show (v b), Show (k b)) =>
Int -> From k v b -> ShowS
forall a (k :: a -> *) (v :: a -> *) (b :: a).
(Show (v b), Show (k b)) =>
[From k v b] -> ShowS
forall a (k :: a -> *) (v :: a -> *) (b :: a).
(Show (v b), Show (k b)) =>
From k v b -> String
showList :: [From k v b] -> ShowS
$cshowList :: forall a (k :: a -> *) (v :: a -> *) (b :: a).
(Show (v b), Show (k b)) =>
[From k v b] -> ShowS
show :: From k v b -> String
$cshow :: forall a (k :: a -> *) (v :: a -> *) (b :: a).
(Show (v b), Show (k b)) =>
From k v b -> String
showsPrec :: Int -> From k v b -> ShowS
$cshowsPrec :: forall a (k :: a -> *) (v :: a -> *) (b :: a).
(Show (v b), Show (k b)) =>
Int -> From k v b -> ShowS
Show, ReadPrec [From k v b]
ReadPrec (From k v b)
Int -> ReadS (From k v b)
ReadS [From k v b]
(Int -> ReadS (From k v b))
-> ReadS [From k v b]
-> ReadPrec (From k v b)
-> ReadPrec [From k v b]
-> Read (From k v b)
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
forall a (k :: a -> *) (v :: a -> *) (b :: a).
(Read (v b), Read (k b)) =>
ReadPrec [From k v b]
forall a (k :: a -> *) (v :: a -> *) (b :: a).
(Read (v b), Read (k b)) =>
ReadPrec (From k v b)
forall a (k :: a -> *) (v :: a -> *) (b :: a).
(Read (v b), Read (k b)) =>
Int -> ReadS (From k v b)
forall a (k :: a -> *) (v :: a -> *) (b :: a).
(Read (v b), Read (k b)) =>
ReadS [From k v b]
readListPrec :: ReadPrec [From k v b]
$creadListPrec :: forall a (k :: a -> *) (v :: a -> *) (b :: a).
(Read (v b), Read (k b)) =>
ReadPrec [From k v b]
readPrec :: ReadPrec (From k v b)
$creadPrec :: forall a (k :: a -> *) (v :: a -> *) (b :: a).
(Read (v b), Read (k b)) =>
ReadPrec (From k v b)
readList :: ReadS [From k v b]
$creadList :: forall a (k :: a -> *) (v :: a -> *) (b :: a).
(Read (v b), Read (k b)) =>
ReadS [From k v b]
readsPrec :: Int -> ReadS (From k v b)
$creadsPrec :: forall a (k :: a -> *) (v :: a -> *) (b :: a).
(Read (v b), Read (k b)) =>
Int -> ReadS (From k v b)
Read, From k v b -> From k v b -> Bool
(From k v b -> From k v b -> Bool)
-> (From k v b -> From k v b -> Bool) -> Eq (From k v b)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall a (k :: a -> *) (v :: a -> *) (b :: a).
(Eq (v b), Eq (k b)) =>
From k v b -> From k v b -> Bool
/= :: From k v b -> From k v b -> Bool
$c/= :: forall a (k :: a -> *) (v :: a -> *) (b :: a).
(Eq (v b), Eq (k b)) =>
From k v b -> From k v b -> Bool
== :: From k v b -> From k v b -> Bool
$c== :: forall a (k :: a -> *) (v :: a -> *) (b :: a).
(Eq (v b), Eq (k b)) =>
From k v b -> From k v b -> Bool
Eq, Eq (From k v b)
Eq (From k v b)
-> (From k v b -> From k v b -> Ordering)
-> (From k v b -> From k v b -> Bool)
-> (From k v b -> From k v b -> Bool)
-> (From k v b -> From k v b -> Bool)
-> (From k v b -> From k v b -> Bool)
-> (From k v b -> From k v b -> From k v b)
-> (From k v b -> From k v b -> From k v b)
-> Ord (From k v b)
From k v b -> From k v b -> Bool
From k v b -> From k v b -> Ordering
From k v b -> From k v b -> From k v b
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall a (k :: a -> *) (v :: a -> *) (b :: a).
(Ord (v b), Ord (k b)) =>
Eq (From k v b)
forall a (k :: a -> *) (v :: a -> *) (b :: a).
(Ord (v b), Ord (k b)) =>
From k v b -> From k v b -> Bool
forall a (k :: a -> *) (v :: a -> *) (b :: a).
(Ord (v b), Ord (k b)) =>
From k v b -> From k v b -> Ordering
forall a (k :: a -> *) (v :: a -> *) (b :: a).
(Ord (v b), Ord (k b)) =>
From k v b -> From k v b -> From k v b
min :: From k v b -> From k v b -> From k v b
$cmin :: forall a (k :: a -> *) (v :: a -> *) (b :: a).
(Ord (v b), Ord (k b)) =>
From k v b -> From k v b -> From k v b
max :: From k v b -> From k v b -> From k v b
$cmax :: forall a (k :: a -> *) (v :: a -> *) (b :: a).
(Ord (v b), Ord (k b)) =>
From k v b -> From k v b -> From k v b
>= :: From k v b -> From k v b -> Bool
$c>= :: forall a (k :: a -> *) (v :: a -> *) (b :: a).
(Ord (v b), Ord (k b)) =>
From k v b -> From k v b -> Bool
> :: From k v b -> From k v b -> Bool
$c> :: forall a (k :: a -> *) (v :: a -> *) (b :: a).
(Ord (v b), Ord (k b)) =>
From k v b -> From k v b -> Bool
<= :: From k v b -> From k v b -> Bool
$c<= :: forall a (k :: a -> *) (v :: a -> *) (b :: a).
(Ord (v b), Ord (k b)) =>
From k v b -> From k v b -> Bool
< :: From k v b -> From k v b -> Bool
$c< :: forall a (k :: a -> *) (v :: a -> *) (b :: a).
(Ord (v b), Ord (k b)) =>
From k v b -> From k v b -> Bool
compare :: From k v b -> From k v b -> Ordering
$ccompare :: forall a (k :: a -> *) (v :: a -> *) (b :: a).
(Ord (v b), Ord (k b)) =>
From k v b -> From k v b -> Ordering
$cp1Ord :: forall a (k :: a -> *) (v :: a -> *) (b :: a).
(Ord (v b), Ord (k b)) =>
Eq (From k v b)
Ord)

-- |Type alias for the "to" part of a 'NodeInfo'. @'ComposeMaybe' ('Just' k)@ means the key is moving to another key, @ComposeMaybe Nothing@ for any other
-- operation.
type To = ComposeMaybe

-- |Test whether a 'PatchDMapWithMove' satisfies its invariants.
validPatchDMapWithMove :: forall k v. (GCompare k, GShow k) => DMap k (NodeInfo k v) -> Bool
validPatchDMapWithMove :: DMap k (NodeInfo k v) -> Bool
validPatchDMapWithMove = Bool -> Bool
not (Bool -> Bool)
-> (DMap k (NodeInfo k v) -> Bool) -> DMap k (NodeInfo k v) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([String] -> Bool)
-> (DMap k (NodeInfo k v) -> [String])
-> DMap k (NodeInfo k v)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DMap k (NodeInfo k v) -> [String]
forall k (k :: k -> *) (v :: k -> *).
(GCompare k, GShow k) =>
DMap k (NodeInfo k v) -> [String]
validationErrorsForPatchDMapWithMove

-- |Enumerate what reasons a 'PatchDMapWithMove' doesn't satisfy its invariants, returning @[]@ if it's valid.
validationErrorsForPatchDMapWithMove :: forall k v. (GCompare k, GShow k) => DMap k (NodeInfo k v) -> [String]
validationErrorsForPatchDMapWithMove :: DMap k (NodeInfo k v) -> [String]
validationErrorsForPatchDMapWithMove DMap k (NodeInfo k v)
m =
  [String]
noSelfMoves [String] -> [String] -> [String]
forall a. Semigroup a => a -> a -> a
<> [String]
movesBalanced
  where
    noSelfMoves :: [String]
noSelfMoves = (DSum k (NodeInfo k v) -> Maybe String)
-> [DSum k (NodeInfo k v)] -> [String]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe DSum k (NodeInfo k v) -> Maybe String
forall k (tag :: k -> *) (v :: k -> *).
(GEq tag, GShow tag) =>
DSum tag (NodeInfo tag v) -> Maybe String
selfMove ([DSum k (NodeInfo k v)] -> [String])
-> (DMap k (NodeInfo k v) -> [DSum k (NodeInfo k v)])
-> DMap k (NodeInfo k v)
-> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DMap k (NodeInfo k v) -> [DSum k (NodeInfo k v)]
forall k1 (k2 :: k1 -> *) (f :: k1 -> *). DMap k2 f -> [DSum k2 f]
DMap.toAscList (DMap k (NodeInfo k v) -> [String])
-> DMap k (NodeInfo k v) -> [String]
forall a b. (a -> b) -> a -> b
$ DMap k (NodeInfo k v)
m
    selfMove :: DSum tag (NodeInfo tag v) -> Maybe String
selfMove (tag a
dst :=> NodeInfo (From_Move src) _)           | Just a :~: a
_ <- tag a
dst tag a -> tag a -> Maybe (a :~: a)
forall k (f :: k -> *) (a :: k) (b :: k).
GEq f =>
f a -> f b -> Maybe (a :~: b)
`geq` tag a
src = String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ String
"self move of key " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> tag a -> String
forall k (t :: k -> *) (a :: k). GShow t => t a -> String
gshow tag a
src String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" at destination side"
    selfMove (tag a
src :=> NodeInfo _ (ComposeMaybe (Just dst))) | Just a :~: a
_ <- tag a
src tag a -> tag a -> Maybe (a :~: a)
forall k (f :: k -> *) (a :: k) (b :: k).
GEq f =>
f a -> f b -> Maybe (a :~: b)
`geq` tag a
dst = String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ String
"self move of key " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> tag a -> String
forall k (t :: k -> *) (a :: k). GShow t => t a -> String
gshow tag a
dst String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" at source side"
    selfMove DSum tag (NodeInfo tag v)
_ = Maybe String
forall a. Maybe a
Nothing
    movesBalanced :: [String]
movesBalanced = (DSum k (NodeInfo k v) -> Maybe String)
-> [DSum k (NodeInfo k v)] -> [String]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe DSum k (NodeInfo k v) -> Maybe String
unbalancedMove ([DSum k (NodeInfo k v)] -> [String])
-> (DMap k (NodeInfo k v) -> [DSum k (NodeInfo k v)])
-> DMap k (NodeInfo k v)
-> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DMap k (NodeInfo k v) -> [DSum k (NodeInfo k v)]
forall k1 (k2 :: k1 -> *) (f :: k1 -> *). DMap k2 f -> [DSum k2 f]
DMap.toAscList (DMap k (NodeInfo k v) -> [String])
-> DMap k (NodeInfo k v) -> [String]
forall a b. (a -> b) -> a -> b
$ DMap k (NodeInfo k v)
m
    unbalancedMove :: DSum k (NodeInfo k v) -> Maybe String
unbalancedMove (k a
dst :=> NodeInfo (From_Move src) _) =
      case k a -> DMap k (NodeInfo k v) -> Maybe (NodeInfo k v a)
forall k1 (k2 :: k1 -> *) (f :: k1 -> *) (v :: k1).
GCompare k2 =>
k2 v -> DMap k2 f -> Maybe (f v)
DMap.lookup k a
src DMap k (NodeInfo k v)
m of
        Maybe (NodeInfo k v a)
Nothing -> String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ String
"unbalanced move at destination key " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> k a -> String
forall k (t :: k -> *) (a :: k). GShow t => t a -> String
gshow k a
dst String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" supposedly from " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> k a -> String
forall k (t :: k -> *) (a :: k). GShow t => t a -> String
gshow k a
src String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" but source key is not in the patch"
        Just (NodeInfo From k v a
_ (ComposeMaybe (Just k a
dst'))) ->
          if Maybe (a :~: a) -> Bool
forall a. Maybe a -> Bool
isNothing (k a
dst' k a -> k a -> Maybe (a :~: a)
forall k (f :: k -> *) (a :: k) (b :: k).
GEq f =>
f a -> f b -> Maybe (a :~: b)
`geq` k a
dst)
            then String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ String
"unbalanced move at destination key " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> k a -> String
forall k (t :: k -> *) (a :: k). GShow t => t a -> String
gshow k a
dst String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" from " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> k a -> String
forall k (t :: k -> *) (a :: k). GShow t => t a -> String
gshow k a
src String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" is going to " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> k a -> String
forall k (t :: k -> *) (a :: k). GShow t => t a -> String
gshow k a
dst' String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" instead"
            else Maybe String
forall a. Maybe a
Nothing
        Maybe (NodeInfo k v a)
_ ->
          String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ String
"unbalanced move at destination key " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> k a -> String
forall k (t :: k -> *) (a :: k). GShow t => t a -> String
gshow k a
dst String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" supposedly from " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> k a -> String
forall k (t :: k -> *) (a :: k). GShow t => t a -> String
gshow k a
src String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" but source key has no move to key"
    unbalancedMove (k a
src :=> NodeInfo _ (ComposeMaybe (Just dst))) =
      case k a -> DMap k (NodeInfo k v) -> Maybe (NodeInfo k v a)
forall k1 (k2 :: k1 -> *) (f :: k1 -> *) (v :: k1).
GCompare k2 =>
k2 v -> DMap k2 f -> Maybe (f v)
DMap.lookup k a
dst DMap k (NodeInfo k v)
m of
        Maybe (NodeInfo k v a)
Nothing -> String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ String
" unbalanced move at source key " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> k a -> String
forall k (t :: k -> *) (a :: k). GShow t => t a -> String
gshow k a
src String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" supposedly going to " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> k a -> String
forall k (t :: k -> *) (a :: k). GShow t => t a -> String
gshow k a
dst String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" but destination key is not in the patch"
        Just (NodeInfo (From_Move k a
src') To k a
_) ->
          if Maybe (a :~: a) -> Bool
forall a. Maybe a -> Bool
isNothing (k a
src' k a -> k a -> Maybe (a :~: a)
forall k (f :: k -> *) (a :: k) (b :: k).
GEq f =>
f a -> f b -> Maybe (a :~: b)
`geq` k a
src)
            then String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ String
"unbalanced move at source key " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> k a -> String
forall k (t :: k -> *) (a :: k). GShow t => t a -> String
gshow k a
src String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" to " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> k a -> String
forall k (t :: k -> *) (a :: k). GShow t => t a -> String
gshow k a
dst String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" is coming from " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> k a -> String
forall k (t :: k -> *) (a :: k). GShow t => t a -> String
gshow k a
src' String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" instead"
            else Maybe String
forall a. Maybe a
Nothing

        Maybe (NodeInfo k v a)
_ ->
          String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ String
"unbalanced move at source key " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> k a -> String
forall k (t :: k -> *) (a :: k). GShow t => t a -> String
gshow k a
src String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" supposedly going to " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> k a -> String
forall k (t :: k -> *) (a :: k). GShow t => t a -> String
gshow k a
dst String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" but destination key is not moving"
    unbalancedMove DSum k (NodeInfo k v)
_ = Maybe String
forall a. Maybe a
Nothing

-- |Test whether two @'PatchDMapWithMove' k v@ contain the same patch operations.
instance (GEq k, Has' Eq k (NodeInfo k v)) => Eq (PatchDMapWithMove k v) where
    PatchDMapWithMove DMap k (NodeInfo k v)
a == :: PatchDMapWithMove k v -> PatchDMapWithMove k v -> Bool
== PatchDMapWithMove DMap k (NodeInfo k v)
b = DMap k (NodeInfo k v)
a DMap k (NodeInfo k v) -> DMap k (NodeInfo k v) -> Bool
forall a. Eq a => a -> a -> Bool
== DMap k (NodeInfo k v)
b

-- |Higher kinded 2-tuple, identical to @Data.Functor.Product@ from base ≥ 4.9
data Pair1 f g a = Pair1 (f a) (g a)

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

-- |Compose patches having the same effect as applying the patches in turn: @'applyAlways' (p <> q) == 'applyAlways' p . 'applyAlways' q@
instance GCompare k => Semigroup (PatchDMapWithMove k v) where
  PatchDMapWithMove DMap k (NodeInfo k v)
ma <> :: PatchDMapWithMove k v
-> PatchDMapWithMove k v -> PatchDMapWithMove k v
<> PatchDMapWithMove DMap k (NodeInfo k v)
mb = DMap k (NodeInfo k v) -> PatchDMapWithMove k v
forall k (k :: k -> *) (v :: k -> *).
DMap k (NodeInfo k v) -> PatchDMapWithMove k v
PatchDMapWithMove DMap k (NodeInfo k v)
m
    where
      connections :: [DSum k (Pair1 (ComposeMaybe k) (From k v))]
connections = DMap k (Pair1 (ComposeMaybe k) (From k v))
-> [DSum k (Pair1 (ComposeMaybe k) (From k v))]
forall k1 (k2 :: k1 -> *) (f :: k1 -> *). DMap k2 f -> [DSum k2 f]
DMap.toList (DMap k (Pair1 (ComposeMaybe k) (From k v))
 -> [DSum k (Pair1 (ComposeMaybe k) (From k v))])
-> DMap k (Pair1 (ComposeMaybe k) (From k v))
-> [DSum k (Pair1 (ComposeMaybe k) (From k v))]
forall a b. (a -> b) -> a -> b
$ (forall (v :: k).
 k v
 -> NodeInfo k v v
 -> NodeInfo k v v
 -> Pair1 (ComposeMaybe k) (From k v) v)
-> DMap k (NodeInfo k v)
-> DMap k (NodeInfo k v)
-> DMap k (Pair1 (ComposeMaybe k) (From k v))
forall k1 (k2 :: k1 -> *) (f :: k1 -> *) (g :: k1 -> *)
       (h :: k1 -> *).
GCompare k2 =>
(forall (v :: k1). k2 v -> f v -> g v -> h v)
-> DMap k2 f -> DMap k2 g -> DMap k2 h
DMap.intersectionWithKey (\k v
_ NodeInfo k v v
a NodeInfo k v v
b -> ComposeMaybe k v
-> From k v v -> Pair1 (ComposeMaybe k) (From k v) v
forall k (f :: k -> *) (g :: k -> *) (a :: k).
f a -> g a -> Pair1 f g a
Pair1 (NodeInfo k v v -> ComposeMaybe k v
forall k (k :: k -> *) (v :: k -> *) (a :: k).
NodeInfo k v a -> To k a
_nodeInfo_to NodeInfo k v v
a) (NodeInfo k v v -> From k v v
forall k (k :: k -> *) (v :: k -> *) (a :: k).
NodeInfo k v a -> From k v a
_nodeInfo_from NodeInfo k v v
b)) DMap k (NodeInfo k v)
ma DMap k (NodeInfo k v)
mb
      h :: DSum k (Pair1 (ComposeMaybe k) (From k v)) -> [DSum k (Fixup k v)]
      h :: DSum k (Pair1 (ComposeMaybe k) (From k v)) -> [DSum k (Fixup k v)]
h (k a
_ :=> Pair1 (ComposeMaybe Maybe (k a)
mToAfter) From k v a
editBefore) = case (Maybe (k a)
mToAfter, From k v a
editBefore) of
        (Just k a
toAfter, From_Move k a
fromBefore)
          | Maybe (a :~: a) -> Bool
forall a. Maybe a -> Bool
isJust (Maybe (a :~: a) -> Bool) -> Maybe (a :~: a) -> Bool
forall a b. (a -> b) -> a -> b
$ k a
fromBefore k a -> k a -> Maybe (a :~: a)
forall k (f :: k -> *) (a :: k) (b :: k).
GEq f =>
f a -> f b -> Maybe (a :~: b)
`geq` k a
toAfter
            -> [k a
toAfter k a -> Fixup k v a -> DSum k (Fixup k v)
forall k (tag :: k -> *) (f :: k -> *) (a :: k).
tag a -> f a -> DSum tag f
:=> Fixup k v a
forall k (k :: k -> *) (v :: k -> *) (a :: k). Fixup k v a
Fixup_Delete]
          | Bool
otherwise
            -> [ k a
toAfter k a -> Fixup k v a -> DSum k (Fixup k v)
forall k (tag :: k -> *) (f :: k -> *) (a :: k).
tag a -> f a -> DSum tag f
:=> These (From k v a) (ComposeMaybe k a) -> Fixup k v a
forall k (k :: k -> *) (v :: k -> *) (a :: k).
These (From k v a) (To k a) -> Fixup k v a
Fixup_Update (From k v a -> These (From k v a) (ComposeMaybe k a)
forall a b. a -> These a b
This From k v a
editBefore)
               , k a
fromBefore k a -> Fixup k v a -> DSum k (Fixup k v)
forall k (tag :: k -> *) (f :: k -> *) (a :: k).
tag a -> f a -> DSum tag f
:=> These (From k v a) (ComposeMaybe k a) -> Fixup k v a
forall k (k :: k -> *) (v :: k -> *) (a :: k).
These (From k v a) (To k a) -> Fixup k v a
Fixup_Update (ComposeMaybe k a -> These (From k v a) (ComposeMaybe k a)
forall a b. b -> These a b
That (Maybe (k a) -> ComposeMaybe k a
forall k (f :: k -> *) (a :: k). Maybe (f a) -> ComposeMaybe f a
ComposeMaybe Maybe (k a)
mToAfter))
               ]
        (Maybe (k a)
Nothing, From_Move k a
fromBefore) -> [k a
fromBefore k a -> Fixup k v a -> DSum k (Fixup k v)
forall k (tag :: k -> *) (f :: k -> *) (a :: k).
tag a -> f a -> DSum tag f
:=> These (From k v a) (ComposeMaybe k a) -> Fixup k v a
forall k (k :: k -> *) (v :: k -> *) (a :: k).
These (From k v a) (To k a) -> Fixup k v a
Fixup_Update (ComposeMaybe k a -> These (From k v a) (ComposeMaybe k a)
forall a b. b -> These a b
That (Maybe (k a) -> ComposeMaybe k a
forall k (f :: k -> *) (a :: k). Maybe (f a) -> ComposeMaybe f a
ComposeMaybe Maybe (k a)
mToAfter))] -- The item is destroyed in the second patch, so indicate that it is destroyed in the source map
        (Just k a
toAfter, From k v a
_) -> [k a
toAfter k a -> Fixup k v a -> DSum k (Fixup k v)
forall k (tag :: k -> *) (f :: k -> *) (a :: k).
tag a -> f a -> DSum tag f
:=> These (From k v a) (ComposeMaybe k a) -> Fixup k v a
forall k (k :: k -> *) (v :: k -> *) (a :: k).
These (From k v a) (To k a) -> Fixup k v a
Fixup_Update (From k v a -> These (From k v a) (ComposeMaybe k a)
forall a b. a -> These a b
This From k v a
editBefore)]
        (Maybe (k a)
Nothing, From k v a
_) -> []
      mergeFixups :: p -> Fixup k v a -> Fixup k v a -> Fixup k v a
mergeFixups p
_ Fixup k v a
Fixup_Delete Fixup k v a
Fixup_Delete = Fixup k v a
forall k (k :: k -> *) (v :: k -> *) (a :: k). Fixup k v a
Fixup_Delete
      mergeFixups p
_ (Fixup_Update These (From k v a) (To k a)
a) (Fixup_Update These (From k v a) (To k a)
b)
        | This From k v a
x <- These (From k v a) (To k a)
a, That To k a
y <- These (From k v a) (To k a)
b
        = These (From k v a) (To k a) -> Fixup k v a
forall k (k :: k -> *) (v :: k -> *) (a :: k).
These (From k v a) (To k a) -> Fixup k v a
Fixup_Update (These (From k v a) (To k a) -> Fixup k v a)
-> These (From k v a) (To k a) -> Fixup k v a
forall a b. (a -> b) -> a -> b
$ From k v a -> To k a -> These (From k v a) (To k a)
forall a b. a -> b -> These a b
These From k v a
x To k a
y
        | That To k a
y <- These (From k v a) (To k a)
a, This From k v a
x <- These (From k v a) (To k a)
b
        = These (From k v a) (To k a) -> Fixup k v a
forall k (k :: k -> *) (v :: k -> *) (a :: k).
These (From k v a) (To k a) -> Fixup k v a
Fixup_Update (These (From k v a) (To k a) -> Fixup k v a)
-> These (From k v a) (To k a) -> Fixup k v a
forall a b. (a -> b) -> a -> b
$ From k v a -> To k a -> These (From k v a) (To k a)
forall a b. a -> b -> These a b
These From k v a
x To k a
y
      mergeFixups p
_ Fixup k v a
_ Fixup k v a
_ = String -> Fixup k v a
forall a. HasCallStack => String -> a
error String
"PatchDMapWithMove: incompatible fixups"
      fixups :: DMap k (Fixup k v)
fixups = (forall (v :: k). k v -> Fixup k v v -> Fixup k v v -> Fixup k v v)
-> [DSum k (Fixup k v)] -> DMap k (Fixup k v)
forall k1 (k2 :: k1 -> *) (f :: k1 -> *).
GCompare k2 =>
(forall (v :: k1). k2 v -> f v -> f v -> f v)
-> [DSum k2 f] -> DMap k2 f
DMap.fromListWithKey forall (v :: k). k v -> Fixup k v v -> Fixup k v v -> Fixup k v v
forall k p (k :: k -> *) (v :: k -> *) (a :: k).
p -> Fixup k v a -> Fixup k v a -> Fixup k v a
mergeFixups ([DSum k (Fixup k v)] -> DMap k (Fixup k v))
-> [DSum k (Fixup k v)] -> DMap k (Fixup k v)
forall a b. (a -> b) -> a -> b
$ (DSum k (Pair1 (ComposeMaybe k) (From k v))
 -> [DSum k (Fixup k v)])
-> [DSum k (Pair1 (ComposeMaybe k) (From k v))]
-> [DSum k (Fixup k v)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap DSum k (Pair1 (ComposeMaybe k) (From k v)) -> [DSum k (Fixup k v)]
h [DSum k (Pair1 (ComposeMaybe k) (From k v))]
connections
      combineNodeInfos :: p -> NodeInfo k v a -> NodeInfo k v a -> NodeInfo k v a
combineNodeInfos p
_ NodeInfo k v a
nia NodeInfo k v a
nib = NodeInfo :: forall k (k :: k -> *) (v :: k -> *) (a :: k).
From k v a -> To k a -> NodeInfo k v a
NodeInfo
        { _nodeInfo_from :: From k v a
_nodeInfo_from = NodeInfo k v a -> From k v a
forall k (k :: k -> *) (v :: k -> *) (a :: k).
NodeInfo k v a -> From k v a
_nodeInfo_from NodeInfo k v a
nia
        , _nodeInfo_to :: To k a
_nodeInfo_to = NodeInfo k v a -> To k a
forall k (k :: k -> *) (v :: k -> *) (a :: k).
NodeInfo k v a -> To k a
_nodeInfo_to NodeInfo k v a
nib
        }
      applyFixup :: p -> NodeInfo k v a -> Fixup k v a -> Maybe (NodeInfo k v a)
applyFixup p
_ NodeInfo k v a
ni = \case
        Fixup k v a
Fixup_Delete -> Maybe (NodeInfo k v a)
forall a. Maybe a
Nothing
        Fixup_Update These (From k v a) (To k a)
u -> NodeInfo k v a -> Maybe (NodeInfo k v a)
forall a. a -> Maybe a
Just (NodeInfo k v a -> Maybe (NodeInfo k v a))
-> NodeInfo k v a -> Maybe (NodeInfo k v a)
forall a b. (a -> b) -> a -> b
$ NodeInfo :: forall k (k :: k -> *) (v :: k -> *) (a :: k).
From k v a -> To k a -> NodeInfo k v a
NodeInfo
          { _nodeInfo_from :: From k v a
_nodeInfo_from = From k v a -> Maybe (From k v a) -> From k v a
forall a. a -> Maybe a -> a
fromMaybe (NodeInfo k v a -> From k v a
forall k (k :: k -> *) (v :: k -> *) (a :: k).
NodeInfo k v a -> From k v a
_nodeInfo_from NodeInfo k v a
ni) (Maybe (From k v a) -> From k v a)
-> Maybe (From k v a) -> From k v a
forall a b. (a -> b) -> a -> b
$ These (From k v a) (To k a) -> Maybe (From k v a)
forall a b. These a b -> Maybe a
getHere These (From k v a) (To k a)
u
          , _nodeInfo_to :: To k a
_nodeInfo_to = To k a -> Maybe (To k a) -> To k a
forall a. a -> Maybe a -> a
fromMaybe (NodeInfo k v a -> To k a
forall k (k :: k -> *) (v :: k -> *) (a :: k).
NodeInfo k v a -> To k a
_nodeInfo_to NodeInfo k v a
ni) (Maybe (To k a) -> To k a) -> Maybe (To k a) -> To k a
forall a b. (a -> b) -> a -> b
$ These (From k v a) (To k a) -> Maybe (To k a)
forall a b. These a b -> Maybe b
getThere These (From k v a) (To k a)
u
          }
      m :: DMap k (NodeInfo k v)
m = (forall (v :: k).
 k v -> NodeInfo k v v -> Fixup k v v -> Maybe (NodeInfo k v v))
-> DMap k (NodeInfo k v)
-> DMap k (Fixup k v)
-> DMap k (NodeInfo k v)
forall k1 (k2 :: k1 -> *) (f :: k1 -> *) (g :: k1 -> *).
GCompare k2 =>
(forall (v :: k1). k2 v -> f v -> g v -> Maybe (f v))
-> DMap k2 f -> DMap k2 g -> DMap k2 f
DMap.differenceWithKey forall (v :: k).
k v -> NodeInfo k v v -> Fixup k v v -> Maybe (NodeInfo k v v)
forall k p (k :: k -> *) (v :: k -> *) (a :: k).
p -> NodeInfo k v a -> Fixup k v a -> Maybe (NodeInfo k v a)
applyFixup ((forall (v :: k).
 k v -> NodeInfo k v v -> NodeInfo k v v -> NodeInfo k v v)
-> DMap k (NodeInfo k v)
-> DMap k (NodeInfo k v)
-> DMap k (NodeInfo k v)
forall k1 (k2 :: k1 -> *) (f :: k1 -> *).
GCompare k2 =>
(forall (v :: k1). k2 v -> f v -> f v -> f v)
-> DMap k2 f -> DMap k2 f -> DMap k2 f
DMap.unionWithKey forall (v :: k).
k v -> NodeInfo k v v -> NodeInfo k v v -> NodeInfo k v v
forall k p (k :: k -> *) (v :: k -> *) (a :: k) (v :: k -> *).
p -> NodeInfo k v a -> NodeInfo k v a -> NodeInfo k v a
combineNodeInfos DMap k (NodeInfo k v)
ma DMap k (NodeInfo k v)
mb) DMap k (Fixup k v)
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

-- |Compose patches having the same effect as applying the patches in turn: @'applyAlways' (p <> q) == 'applyAlways' p . 'applyAlways' q@
instance GCompare k => Monoid (PatchDMapWithMove k v) where
  mempty :: PatchDMapWithMove k v
mempty = DMap k (NodeInfo k v) -> PatchDMapWithMove k v
forall k (k :: k -> *) (v :: k -> *).
DMap k (NodeInfo k v) -> PatchDMapWithMove k v
PatchDMapWithMove DMap k (NodeInfo k v)
forall a. Monoid a => a
mempty
  mappend :: PatchDMapWithMove k v
-> PatchDMapWithMove k v -> PatchDMapWithMove k v
mappend = PatchDMapWithMove k v
-> PatchDMapWithMove k v -> PatchDMapWithMove k v
forall a. Semigroup a => a -> a -> a
(<>)

{-
mappendPatchDMapWithMoveSlow :: forall k v. (ShowTag k v, GCompare k) => PatchDMapWithMove k v -> PatchDMapWithMove k v -> PatchDMapWithMove k v
PatchDMapWithMove dstAfter srcAfter `mappendPatchDMapWithMoveSlow` PatchDMapWithMove dstBefore srcBefore = PatchDMapWithMove dst src
  where
    getDstAction k m = fromMaybe (From_Move k) $ DMap.lookup k m -- Any key that isn't present is treated as that key moving to itself
    removeRedundantDst toKey (From_Move fromKey) | isJust (toKey `geq` fromKey) = Nothing
    removeRedundantDst _ a = Just a
    f :: forall a. k a -> From k v a -> Maybe (From k v a)
    f toKey _ = removeRedundantDst toKey $ case getDstAction toKey dstAfter of
      From_Move fromKey -> getDstAction fromKey dstBefore
      nonMove -> nonMove
    dst = DMap.mapMaybeWithKey f $ DMap.union dstAfter dstBefore
    getSrcAction k m = fromMaybe (ComposeMaybe $ Just k) $ DMap.lookup k m
    removeRedundantSrc fromKey (ComposeMaybe (Just toKey)) | isJust (fromKey `geq` toKey) = Nothing
    removeRedundantSrc _ a = Just a
    g :: forall a. k a -> ComposeMaybe k a -> Maybe (ComposeMaybe k a)
    g fromKey _ = removeRedundantSrc fromKey $ case getSrcAction fromKey srcBefore of
      ComposeMaybe Nothing -> ComposeMaybe Nothing
      ComposeMaybe (Just toKeyBefore) -> getSrcAction toKeyBefore srcAfter
    src = DMap.mapMaybeWithKey g $ DMap.union srcAfter srcBefore
-}

-- |Make a @'PatchDMapWithMove' k v@ which has the effect of inserting or updating a value @v a@ to the given key @k a@, like 'DMap.insert'.
insertDMapKey :: k a -> v a -> PatchDMapWithMove k v
insertDMapKey :: k a -> v a -> PatchDMapWithMove k v
insertDMapKey k a
k v a
v =
  DMap k (NodeInfo k v) -> PatchDMapWithMove k v
forall k (k :: k -> *) (v :: k -> *).
DMap k (NodeInfo k v) -> PatchDMapWithMove k v
PatchDMapWithMove (DMap k (NodeInfo k v) -> PatchDMapWithMove k v)
-> (NodeInfo k v a -> DMap k (NodeInfo k v))
-> NodeInfo k v a
-> PatchDMapWithMove k v
forall b c a. (b -> c) -> (a -> b) -> a -> c
. k a -> NodeInfo k v a -> DMap k (NodeInfo k v)
forall k1 (k2 :: k1 -> *) (v :: k1) (f :: k1 -> *).
k2 v -> f v -> DMap k2 f
DMap.singleton k a
k (NodeInfo k v a -> PatchDMapWithMove k v)
-> NodeInfo k v a -> PatchDMapWithMove k v
forall a b. (a -> b) -> a -> b
$ From k v a -> To k a -> NodeInfo k v a
forall k (k :: k -> *) (v :: k -> *) (a :: k).
From k v a -> To k a -> NodeInfo k v a
NodeInfo (v a -> From k v a
forall a (v :: a -> *) (a :: a) (k :: a -> *). v a -> From k v a
From_Insert v a
v) (Maybe (k a) -> To k a
forall k (f :: k -> *) (a :: k). Maybe (f a) -> ComposeMaybe f a
ComposeMaybe Maybe (k a)
forall a. Maybe a
Nothing)

-- |Make a @'PatchDMapWithMove' k v@ which has the effect of moving the value from the first key @k a@ to the second key @k a@, equivalent to:
--
-- @
--     'DMap.delete' src (maybe dmap ('DMap.insert' dst) (DMap.lookup src dmap))
-- @
moveDMapKey :: GCompare k => k a -> k a -> PatchDMapWithMove k v
moveDMapKey :: k a -> k a -> PatchDMapWithMove k v
moveDMapKey k a
src k a
dst = case k a
src k a -> k a -> Maybe (a :~: a)
forall k (f :: k -> *) (a :: k) (b :: k).
GEq f =>
f a -> f b -> Maybe (a :~: b)
`geq` k a
dst of
  Maybe (a :~: a)
Nothing -> DMap k (NodeInfo k v) -> PatchDMapWithMove k v
forall k (k :: k -> *) (v :: k -> *).
DMap k (NodeInfo k v) -> PatchDMapWithMove k v
PatchDMapWithMove (DMap k (NodeInfo k v) -> PatchDMapWithMove k v)
-> DMap k (NodeInfo k v) -> PatchDMapWithMove k v
forall a b. (a -> b) -> a -> b
$ [DSum k (NodeInfo k v)] -> DMap k (NodeInfo k v)
forall k1 (k2 :: k1 -> *) (f :: k1 -> *).
GCompare k2 =>
[DSum k2 f] -> DMap k2 f
DMap.fromList
    [ k a
dst k a -> NodeInfo k v a -> DSum k (NodeInfo k v)
forall k (tag :: k -> *) (f :: k -> *) (a :: k).
tag a -> f a -> DSum tag f
:=> From k v a -> To k a -> NodeInfo k v a
forall k (k :: k -> *) (v :: k -> *) (a :: k).
From k v a -> To k a -> NodeInfo k v a
NodeInfo (k a -> From k v a
forall a (k :: a -> *) (a :: a) (v :: a -> *). k a -> From k v a
From_Move k a
src) (Maybe (k a) -> To k a
forall k (f :: k -> *) (a :: k). Maybe (f a) -> ComposeMaybe f a
ComposeMaybe Maybe (k a)
forall a. Maybe a
Nothing)
    , k a
src k a -> NodeInfo k v a -> DSum k (NodeInfo k v)
forall k (tag :: k -> *) (f :: k -> *) (a :: k).
tag a -> f a -> DSum tag f
:=> From k v a -> To k a -> NodeInfo k v a
forall k (k :: k -> *) (v :: k -> *) (a :: k).
From k v a -> To k a -> NodeInfo k v a
NodeInfo From k v a
forall a (k :: a -> *) (v :: a -> *) (a :: a). From k v a
From_Delete (Maybe (k a) -> To k a
forall k (f :: k -> *) (a :: k). Maybe (f a) -> ComposeMaybe f a
ComposeMaybe (Maybe (k a) -> To k a) -> Maybe (k a) -> To k a
forall a b. (a -> b) -> a -> b
$ k a -> Maybe (k a)
forall a. a -> Maybe a
Just k a
dst)
    ]
  Just a :~: a
_ -> PatchDMapWithMove k v
forall a. Monoid a => a
mempty

-- |Make a @'PatchDMapWithMove' k v@ which has the effect of swapping two keys in the mapping, equivalent to:
--
-- @
--     let aMay = DMap.lookup a dmap
--         bMay = DMap.lookup b dmap
--     in maybe id (DMap.insert a) (bMay <> aMay)
--      . maybe id (DMap.insert b) (aMay <> bMay)
--      . DMap.delete a . DMap.delete b $ dmap
-- @
swapDMapKey :: GCompare k => k a -> k a -> PatchDMapWithMove k v
swapDMapKey :: k a -> k a -> PatchDMapWithMove k v
swapDMapKey k a
src k a
dst = case k a
src k a -> k a -> Maybe (a :~: a)
forall k (f :: k -> *) (a :: k) (b :: k).
GEq f =>
f a -> f b -> Maybe (a :~: b)
`geq` k a
dst of
  Maybe (a :~: a)
Nothing -> DMap k (NodeInfo k v) -> PatchDMapWithMove k v
forall k (k :: k -> *) (v :: k -> *).
DMap k (NodeInfo k v) -> PatchDMapWithMove k v
PatchDMapWithMove (DMap k (NodeInfo k v) -> PatchDMapWithMove k v)
-> DMap k (NodeInfo k v) -> PatchDMapWithMove k v
forall a b. (a -> b) -> a -> b
$ [DSum k (NodeInfo k v)] -> DMap k (NodeInfo k v)
forall k1 (k2 :: k1 -> *) (f :: k1 -> *).
GCompare k2 =>
[DSum k2 f] -> DMap k2 f
DMap.fromList
    [ k a
dst k a -> NodeInfo k v a -> DSum k (NodeInfo k v)
forall k (tag :: k -> *) (f :: k -> *) (a :: k).
tag a -> f a -> DSum tag f
:=> From k v a -> To k a -> NodeInfo k v a
forall k (k :: k -> *) (v :: k -> *) (a :: k).
From k v a -> To k a -> NodeInfo k v a
NodeInfo (k a -> From k v a
forall a (k :: a -> *) (a :: a) (v :: a -> *). k a -> From k v a
From_Move k a
src) (Maybe (k a) -> To k a
forall k (f :: k -> *) (a :: k). Maybe (f a) -> ComposeMaybe f a
ComposeMaybe (Maybe (k a) -> To k a) -> Maybe (k a) -> To k a
forall a b. (a -> b) -> a -> b
$ k a -> Maybe (k a)
forall a. a -> Maybe a
Just k a
src)
    , k a
src k a -> NodeInfo k v a -> DSum k (NodeInfo k v)
forall k (tag :: k -> *) (f :: k -> *) (a :: k).
tag a -> f a -> DSum tag f
:=> From k v a -> To k a -> NodeInfo k v a
forall k (k :: k -> *) (v :: k -> *) (a :: k).
From k v a -> To k a -> NodeInfo k v a
NodeInfo (k a -> From k v a
forall a (k :: a -> *) (a :: a) (v :: a -> *). k a -> From k v a
From_Move k a
dst) (Maybe (k a) -> To k a
forall k (f :: k -> *) (a :: k). Maybe (f a) -> ComposeMaybe f a
ComposeMaybe (Maybe (k a) -> To k a) -> Maybe (k a) -> To k a
forall a b. (a -> b) -> a -> b
$ k a -> Maybe (k a)
forall a. a -> Maybe a
Just k a
dst)
    ]
  Just a :~: a
_ -> PatchDMapWithMove k v
forall a. Monoid a => a
mempty

-- |Make a @'PatchDMapWithMove' k v@ which has the effect of deleting a key in the mapping, equivalent to 'DMap.delete'.
deleteDMapKey :: k a -> PatchDMapWithMove k v
deleteDMapKey :: k a -> PatchDMapWithMove k v
deleteDMapKey k a
k = DMap k (NodeInfo k v) -> PatchDMapWithMove k v
forall k (k :: k -> *) (v :: k -> *).
DMap k (NodeInfo k v) -> PatchDMapWithMove k v
PatchDMapWithMove (DMap k (NodeInfo k v) -> PatchDMapWithMove k v)
-> DMap k (NodeInfo k v) -> PatchDMapWithMove k v
forall a b. (a -> b) -> a -> b
$ k a -> NodeInfo k v a -> DMap k (NodeInfo k v)
forall k1 (k2 :: k1 -> *) (v :: k1) (f :: k1 -> *).
k2 v -> f v -> DMap k2 f
DMap.singleton k a
k (NodeInfo k v a -> DMap k (NodeInfo k v))
-> NodeInfo k v a -> DMap k (NodeInfo k v)
forall a b. (a -> b) -> a -> b
$ From k v a -> To k a -> NodeInfo k v a
forall k (k :: k -> *) (v :: k -> *) (a :: k).
From k v a -> To k a -> NodeInfo k v a
NodeInfo From k v a
forall a (k :: a -> *) (v :: a -> *) (a :: a). From k v a
From_Delete (To k a -> NodeInfo k v a) -> To k a -> NodeInfo k v a
forall a b. (a -> b) -> a -> b
$ Maybe (k a) -> To k a
forall k (f :: k -> *) (a :: k). Maybe (f a) -> ComposeMaybe f a
ComposeMaybe Maybe (k a)
forall a. Maybe a
Nothing

{-
k1, k2 :: Const2 Int () ()
k1 = Const2 1
k2 = Const2 2
p1, p2 :: PatchDMapWithMove (Const2 Int ()) Identity
p1 = moveDMapKey k1 k2
p2 = moveDMapKey k2 k1
p12 = p1 <> p2
p21 = p2 <> p1
p12Slow = p1 `mappendPatchDMapWithMoveSlow` p2
p21Slow = p2 `mappendPatchDMapWithMoveSlow` p1

testPatchDMapWithMove = do
  print p1
  print p2
  print $ p12 == deleteDMapKey k1
  print $ p21 == deleteDMapKey k2
  print $ p12Slow == deleteDMapKey k1
  print $ p21Slow == deleteDMapKey k2

dst (PatchDMapWithMove x _) = x
src (PatchDMapWithMove _ x) = x
-}

-- |Extract the 'DMap' representing the patch changes from the 'PatchDMapWithMove'.
unPatchDMapWithMove :: PatchDMapWithMove k v -> DMap k (NodeInfo k v)
unPatchDMapWithMove :: PatchDMapWithMove k v -> DMap k (NodeInfo k v)
unPatchDMapWithMove (PatchDMapWithMove DMap k (NodeInfo k v)
p) = DMap k (NodeInfo k v)
p

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

-- |Wrap a 'DMap' representing patch changes into a 'PatchDMapWithMove' while checking invariants. If the invariants are satisfied, @Right p@ is returned
-- otherwise @Left errors@.
patchDMapWithMove :: (GCompare k, GShow k) => DMap k (NodeInfo k v) -> Either [String] (PatchDMapWithMove k v)
patchDMapWithMove :: DMap k (NodeInfo k v) -> Either [String] (PatchDMapWithMove k v)
patchDMapWithMove DMap k (NodeInfo k v)
dm =
  case DMap k (NodeInfo k v) -> [String]
forall k (k :: k -> *) (v :: k -> *).
(GCompare k, GShow k) =>
DMap k (NodeInfo k v) -> [String]
validationErrorsForPatchDMapWithMove DMap k (NodeInfo k v)
dm of
    [] -> PatchDMapWithMove k v -> Either [String] (PatchDMapWithMove k v)
forall a b. b -> Either a b
Right (PatchDMapWithMove k v -> Either [String] (PatchDMapWithMove k v))
-> PatchDMapWithMove k v -> Either [String] (PatchDMapWithMove k v)
forall a b. (a -> b) -> a -> b
$ DMap k (NodeInfo k v) -> PatchDMapWithMove k v
forall k (k :: k -> *) (v :: k -> *).
DMap k (NodeInfo k v) -> PatchDMapWithMove k v
unsafePatchDMapWithMove DMap k (NodeInfo k v)
dm
    [String]
errs -> [String] -> Either [String] (PatchDMapWithMove k v)
forall a b. a -> Either a b
Left [String]
errs

-- |Map a natural transform @v -> v'@ over the given patch, transforming @'PatchDMapWithMove' k v@ into @'PatchDMapWithMove' k v'@.
mapPatchDMapWithMove :: forall k v v'. (forall a. v a -> v' a) -> PatchDMapWithMove k v -> PatchDMapWithMove k v'
mapPatchDMapWithMove :: (forall (a :: k). v a -> v' a)
-> PatchDMapWithMove k v -> PatchDMapWithMove k v'
mapPatchDMapWithMove forall (a :: k). v a -> v' a
f (PatchDMapWithMove DMap k (NodeInfo k v)
p) = DMap k (NodeInfo k v') -> PatchDMapWithMove k v'
forall k (k :: k -> *) (v :: k -> *).
DMap k (NodeInfo k v) -> PatchDMapWithMove k v
PatchDMapWithMove (DMap k (NodeInfo k v') -> PatchDMapWithMove k v')
-> DMap k (NodeInfo k v') -> PatchDMapWithMove k v'
forall a b. (a -> b) -> a -> b
$
  (forall (v :: k). NodeInfo k v v -> NodeInfo k v' v)
-> DMap k (NodeInfo k v) -> DMap k (NodeInfo k v')
forall k1 (f :: k1 -> *) (g :: k1 -> *) (k2 :: k1 -> *).
(forall (v :: k1). f v -> g v) -> DMap k2 f -> DMap k2 g
DMap.map (\NodeInfo k v v
ni -> NodeInfo k v v
ni { _nodeInfo_from :: From k v' v
_nodeInfo_from = From k v v -> From k v' v
forall (a :: k). From k v a -> From k v' a
g (From k v v -> From k v' v) -> From k v v -> From k v' v
forall a b. (a -> b) -> a -> b
$ NodeInfo k v v -> From k v v
forall k (k :: k -> *) (v :: k -> *) (a :: k).
NodeInfo k v a -> From k v a
_nodeInfo_from NodeInfo k v v
ni }) DMap k (NodeInfo k v)
p
  where g :: forall a. From k v a -> From k v' a
        g :: From k v a -> From k v' a
g = \case
          From_Insert v a
v -> v' a -> From k v' a
forall a (v :: a -> *) (a :: a) (k :: a -> *). v a -> From k v a
From_Insert (v' a -> From k v' a) -> v' a -> From k v' a
forall a b. (a -> b) -> a -> b
$ v a -> v' a
forall (a :: k). v a -> v' a
f v a
v
          From k v a
From_Delete -> From k v' a
forall a (k :: a -> *) (v :: a -> *) (a :: a). From k v a
From_Delete
          From_Move k a
k -> k a -> From k v' a
forall a (k :: a -> *) (a :: a) (v :: a -> *). k a -> From k v a
From_Move k a
k

-- |Traverse an effectful function @forall a. v a -> m (v ' a)@ over the given patch, transforming @'PatchDMapWithMove' k v@ into @m ('PatchDMapWithMove' k v')@.
traversePatchDMapWithMove :: forall m k v v'. Applicative m => (forall a. v a -> m (v' a)) -> PatchDMapWithMove k v -> m (PatchDMapWithMove k v')
traversePatchDMapWithMove :: (forall (a :: k). v a -> m (v' a))
-> PatchDMapWithMove k v -> m (PatchDMapWithMove k v')
traversePatchDMapWithMove forall (a :: k). v a -> m (v' a)
f = (forall (a :: k). k a -> v a -> m (v' a))
-> PatchDMapWithMove k v -> m (PatchDMapWithMove k v')
forall k (m :: * -> *) (k :: k -> *) (v :: k -> *) (v' :: k -> *).
Applicative m =>
(forall (a :: k). k a -> v a -> m (v' a))
-> PatchDMapWithMove k v -> m (PatchDMapWithMove k v')
traversePatchDMapWithMoveWithKey ((forall (a :: k). k a -> v a -> m (v' a))
 -> PatchDMapWithMove k v -> m (PatchDMapWithMove k v'))
-> (forall (a :: k). k a -> v a -> m (v' a))
-> PatchDMapWithMove k v
-> m (PatchDMapWithMove k v')
forall a b. (a -> b) -> a -> b
$ (v a -> m (v' a)) -> k a -> v a -> m (v' a)
forall a b. a -> b -> a
const v a -> m (v' a)
forall (a :: k). v a -> m (v' a)
f

-- |Map an effectful function @forall a. k a -> v a -> m (v ' a)@ over the given patch, transforming @'PatchDMapWithMove' k v@ into @m ('PatchDMapWithMove' k v')@.
traversePatchDMapWithMoveWithKey :: forall m k v v'. Applicative m => (forall a. k a -> v a -> m (v' a)) -> PatchDMapWithMove k v -> m (PatchDMapWithMove k v')
traversePatchDMapWithMoveWithKey :: (forall (a :: k). k a -> v a -> m (v' a))
-> PatchDMapWithMove k v -> m (PatchDMapWithMove k v')
traversePatchDMapWithMoveWithKey forall (a :: k). k a -> v a -> m (v' a)
f (PatchDMapWithMove DMap k (NodeInfo k v)
p) = DMap k (NodeInfo k v') -> PatchDMapWithMove k v'
forall k (k :: k -> *) (v :: k -> *).
DMap k (NodeInfo k v) -> PatchDMapWithMove k v
PatchDMapWithMove (DMap k (NodeInfo k v') -> PatchDMapWithMove k v')
-> m (DMap k (NodeInfo k v')) -> m (PatchDMapWithMove k v')
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall (v :: k). k v -> NodeInfo k v v -> m (NodeInfo k v' v))
-> DMap k (NodeInfo k v) -> m (DMap k (NodeInfo k v'))
forall k1 (t :: * -> *) (k2 :: k1 -> *) (f :: k1 -> *)
       (g :: k1 -> *).
Applicative t =>
(forall (v :: k1). k2 v -> f v -> t (g v))
-> DMap k2 f -> t (DMap k2 g)
DMap.traverseWithKey ((From k v v -> m (From k v' v))
-> NodeInfo k v v -> m (NodeInfo k v' v)
forall k (f :: * -> *) (k :: k -> *) (v :: k -> *) (a :: k)
       (v' :: k -> *).
Functor f =>
(From k v a -> f (From k v' a))
-> NodeInfo k v a -> f (NodeInfo k v' a)
nodeInfoMapFromM ((From k v v -> m (From k v' v))
 -> NodeInfo k v v -> m (NodeInfo k v' v))
-> (k v -> From k v v -> m (From k v' v))
-> k v
-> NodeInfo k v v
-> m (NodeInfo k v' v)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. k v -> From k v v -> m (From k v' v)
forall (a :: k). k a -> From k v a -> m (From k v' a)
g) DMap k (NodeInfo k v)
p
  where g :: forall a. k a -> From k v a -> m (From k v' a)
        g :: k a -> From k v a -> m (From k v' a)
g k a
k = \case
          From_Insert v a
v -> v' a -> From k v' a
forall a (v :: a -> *) (a :: a) (k :: a -> *). v a -> From k v a
From_Insert (v' a -> From k v' a) -> m (v' a) -> m (From k v' a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> k a -> v a -> m (v' a)
forall (a :: k). k a -> v a -> m (v' a)
f k a
k v a
v
          From k v a
From_Delete -> From k v' a -> m (From k v' a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure From k v' a
forall a (k :: a -> *) (v :: a -> *) (a :: a). From k v a
From_Delete
          From_Move k a
fromKey -> From k v' a -> m (From k v' a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (From k v' a -> m (From k v' a)) -> From k v' a -> m (From k v' a)
forall a b. (a -> b) -> a -> b
$ k a -> From k v' a
forall a (k :: a -> *) (a :: a) (v :: a -> *). k a -> From k v a
From_Move k a
fromKey

-- |Map a function which transforms @'From' k v a@ into a @'From' k v' a@ over a @'NodeInfo' k v a@.
nodeInfoMapFrom :: (From k v a -> From k v' a) -> NodeInfo k v a -> NodeInfo k v' a
nodeInfoMapFrom :: (From k v a -> From k v' a) -> NodeInfo k v a -> NodeInfo k v' a
nodeInfoMapFrom From k v a -> From k v' a
f NodeInfo k v a
ni = NodeInfo k v a
ni { _nodeInfo_from :: From k v' a
_nodeInfo_from = From k v a -> From k v' a
f (From k v a -> From k v' a) -> From k v a -> From k v' a
forall a b. (a -> b) -> a -> b
$ NodeInfo k v a -> From k v a
forall k (k :: k -> *) (v :: k -> *) (a :: k).
NodeInfo k v a -> From k v a
_nodeInfo_from NodeInfo k v a
ni }

-- |Map an effectful function which transforms @'From' k v a@ into a @f ('From' k v' a)@ over a @'NodeInfo' k v a@.
nodeInfoMapFromM :: Functor f => (From k v a -> f (From k v' a)) -> NodeInfo k v a -> f (NodeInfo k v' a)
nodeInfoMapFromM :: (From k v a -> f (From k v' a))
-> NodeInfo k v a -> f (NodeInfo k v' a)
nodeInfoMapFromM From k v a -> f (From k v' a)
f NodeInfo k v a
ni = (From k v' a -> NodeInfo k v' a)
-> f (From k v' a) -> f (NodeInfo k v' a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\From k v' a
result -> NodeInfo k v a
ni { _nodeInfo_from :: From k v' a
_nodeInfo_from = From k v' a
result }) (f (From k v' a) -> f (NodeInfo k v' a))
-> f (From k v' a) -> f (NodeInfo k v' a)
forall a b. (a -> b) -> a -> b
$ From k v a -> f (From k v' a)
f (From k v a -> f (From k v' a)) -> From k v a -> f (From k v' a)
forall a b. (a -> b) -> a -> b
$ NodeInfo k v a -> From k v a
forall k (k :: k -> *) (v :: k -> *) (a :: k).
NodeInfo k v a -> From k v a
_nodeInfo_from NodeInfo k v a
ni

-- |Weaken a 'PatchDMapWithMove' to a 'PatchMapWithMove' by weakening the keys from @k a@ to @'Some' k@ and applying a given weakening function @v a -> v'@ to
-- values.
weakenPatchDMapWithMoveWith :: forall k v v'. (forall a. v a -> v') -> PatchDMapWithMove k v -> PatchMapWithMove (Some k) v'
weakenPatchDMapWithMoveWith :: (forall (a :: k). v a -> v')
-> PatchDMapWithMove k v -> PatchMapWithMove (Some k) v'
weakenPatchDMapWithMoveWith forall (a :: k). v a -> v'
f (PatchDMapWithMove DMap k (NodeInfo k v)
p) = Map (Some k) (NodeInfo (Some k) v') -> PatchMapWithMove (Some k) v'
forall k v. Map k (NodeInfo k v) -> PatchMapWithMove k v
PatchMapWithMove (Map (Some k) (NodeInfo (Some k) v')
 -> PatchMapWithMove (Some k) v')
-> Map (Some k) (NodeInfo (Some k) v')
-> PatchMapWithMove (Some k) v'
forall a b. (a -> b) -> a -> b
$ (forall (a :: k). NodeInfo k v a -> NodeInfo (Some k) v')
-> DMap k (NodeInfo k v) -> Map (Some k) (NodeInfo (Some k) v')
forall k1 (v :: k1 -> *) v' (k2 :: k1 -> *).
(forall (a :: k1). v a -> v') -> DMap k2 v -> Map (Some k2) v'
weakenDMapWith forall (a :: k). NodeInfo k v a -> NodeInfo (Some k) v'
g DMap k (NodeInfo k v)
p
  where g :: forall a. NodeInfo k v a -> MapWithMove.NodeInfo (Some k) v'
        g :: NodeInfo k v a -> NodeInfo (Some k) v'
g NodeInfo k v a
ni = NodeInfo :: forall k v. To k -> From k v -> NodeInfo k v
MapWithMove.NodeInfo
          { _nodeInfo_from :: From (Some k) v'
MapWithMove._nodeInfo_from = case NodeInfo k v a -> From k v a
forall k (k :: k -> *) (v :: k -> *) (a :: k).
NodeInfo k v a -> From k v a
_nodeInfo_from NodeInfo k v a
ni of
              From_Insert v a
v -> v' -> From (Some k) v'
forall v k. v -> From k v
MapWithMove.From_Insert (v' -> From (Some k) v') -> v' -> From (Some k) v'
forall a b. (a -> b) -> a -> b
$ v a -> v'
forall (a :: k). v a -> v'
f v a
v
              From k v a
From_Delete -> From (Some k) v'
forall k v. From k v
MapWithMove.From_Delete
              From_Move k a
k -> Some k -> From (Some k) v'
forall k v. k -> From k v
MapWithMove.From_Move (Some k -> From (Some k) v') -> Some k -> From (Some k) v'
forall a b. (a -> b) -> a -> b
$ k a -> Some k
forall k (tag :: k -> *) (a :: k). tag a -> Some tag
mkSome k a
k
          , _nodeInfo_to :: To (Some k)
MapWithMove._nodeInfo_to = k a -> Some k
forall k (tag :: k -> *) (a :: k). tag a -> Some tag
mkSome (k a -> Some k) -> Maybe (k a) -> To (Some k)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ComposeMaybe k a -> Maybe (k a)
forall k (f :: k -> *) (a :: k). ComposeMaybe f a -> Maybe (f a)
getComposeMaybe (NodeInfo k v a -> ComposeMaybe k a
forall k (k :: k -> *) (v :: k -> *) (a :: k).
NodeInfo k v a -> To k a
_nodeInfo_to NodeInfo k v a
ni)
          }

-- |"Weaken" a @'PatchDMapWithMove' (Const2 k a) v@ to a @'PatchMapWithMove' k v'@. Weaken is in scare quotes because the 'Const2' has already disabled any
-- dependency in the typing and all points are already @a@, hence the function to map each value to @v'@ is not higher rank.
patchDMapWithMoveToPatchMapWithMoveWith :: forall k v v' a. (v a -> v') -> PatchDMapWithMove (Const2 k a) v -> PatchMapWithMove k v'
patchDMapWithMoveToPatchMapWithMoveWith :: (v a -> v')
-> PatchDMapWithMove (Const2 k a) v -> PatchMapWithMove k v'
patchDMapWithMoveToPatchMapWithMoveWith v a -> v'
f (PatchDMapWithMove DMap (Const2 k a) (NodeInfo (Const2 k a) v)
p) = Map k (NodeInfo k v') -> PatchMapWithMove k v'
forall k v. Map k (NodeInfo k v) -> PatchMapWithMove k v
PatchMapWithMove (Map k (NodeInfo k v') -> PatchMapWithMove k v')
-> Map k (NodeInfo k v') -> PatchMapWithMove k v'
forall a b. (a -> b) -> a -> b
$ (NodeInfo (Const2 k a) v a -> NodeInfo k v')
-> DMap (Const2 k a) (NodeInfo (Const2 k a) v)
-> Map k (NodeInfo k v')
forall k1 (f :: k1 -> *) (v :: k1) v' k2.
(f v -> v') -> DMap (Const2 k2 v) f -> Map k2 v'
dmapToMapWith NodeInfo (Const2 k a) v a -> NodeInfo k v'
g DMap (Const2 k a) (NodeInfo (Const2 k a) v)
p
  where g :: NodeInfo (Const2 k a) v a -> MapWithMove.NodeInfo k v'
        g :: NodeInfo (Const2 k a) v a -> NodeInfo k v'
g NodeInfo (Const2 k a) v a
ni = NodeInfo :: forall k v. To k -> From k v -> NodeInfo k v
MapWithMove.NodeInfo
          { _nodeInfo_from :: From k v'
MapWithMove._nodeInfo_from = case NodeInfo (Const2 k a) v a -> From (Const2 k a) v a
forall k (k :: k -> *) (v :: k -> *) (a :: k).
NodeInfo k v a -> From k v a
_nodeInfo_from NodeInfo (Const2 k a) v a
ni of
              From_Insert v a
v -> v' -> From k v'
forall v k. v -> From k v
MapWithMove.From_Insert (v' -> From k v') -> v' -> From k v'
forall a b. (a -> b) -> a -> b
$ v a -> v'
f v a
v
              From (Const2 k a) v a
From_Delete -> From k v'
forall k v. From k v
MapWithMove.From_Delete
              From_Move (Const2 k
k) -> k -> From k v'
forall k v. k -> From k v
MapWithMove.From_Move k
k
          , _nodeInfo_to :: To k
MapWithMove._nodeInfo_to = Const2 k a a -> k
forall x k (v :: x) (v' :: x). Const2 k v v' -> k
unConst2 (Const2 k a a -> k) -> Maybe (Const2 k a a) -> To k
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ComposeMaybe (Const2 k a) a -> Maybe (Const2 k a a)
forall k (f :: k -> *) (a :: k). ComposeMaybe f a -> Maybe (f a)
getComposeMaybe (NodeInfo (Const2 k a) v a -> ComposeMaybe (Const2 k a) a
forall k (k :: k -> *) (v :: k -> *) (a :: k).
NodeInfo k v a -> To k a
_nodeInfo_to NodeInfo (Const2 k a) v a
ni)
          }

-- |"Strengthen" a @'PatchMapWithMove' k v@ into a @'PatchDMapWithMove ('Const2' k a)@; that is, turn a non-dependently-typed patch into a dependently typed
-- one but which always has a constant key type represented by 'Const2'. Apply the given function to each @v@ to produce a @v' a@.
-- Completemented by 'patchDMapWithMoveToPatchMapWithMoveWith'
const2PatchDMapWithMoveWith :: forall k v v' a. (v -> v' a) -> PatchMapWithMove k v -> PatchDMapWithMove (Const2 k a) v'
const2PatchDMapWithMoveWith :: (v -> v' a)
-> PatchMapWithMove k v -> PatchDMapWithMove (Const2 k a) v'
const2PatchDMapWithMoveWith v -> v' a
f (PatchMapWithMove Map k (NodeInfo k v)
p) = DMap (Const2 k a) (NodeInfo (Const2 k a) v')
-> PatchDMapWithMove (Const2 k a) v'
forall k (k :: k -> *) (v :: k -> *).
DMap k (NodeInfo k v) -> PatchDMapWithMove k v
PatchDMapWithMove (DMap (Const2 k a) (NodeInfo (Const2 k a) v')
 -> PatchDMapWithMove (Const2 k a) v')
-> DMap (Const2 k a) (NodeInfo (Const2 k a) v')
-> PatchDMapWithMove (Const2 k a) v'
forall a b. (a -> b) -> a -> b
$ [DSum (Const2 k a) (NodeInfo (Const2 k a) v')]
-> DMap (Const2 k a) (NodeInfo (Const2 k a) v')
forall k1 (k2 :: k1 -> *) (f :: k1 -> *). [DSum k2 f] -> DMap k2 f
DMap.fromDistinctAscList ([DSum (Const2 k a) (NodeInfo (Const2 k a) v')]
 -> DMap (Const2 k a) (NodeInfo (Const2 k a) v'))
-> [DSum (Const2 k a) (NodeInfo (Const2 k a) v')]
-> DMap (Const2 k a) (NodeInfo (Const2 k a) v')
forall a b. (a -> b) -> a -> b
$ (k, NodeInfo k v) -> DSum (Const2 k a) (NodeInfo (Const2 k a) v')
g ((k, NodeInfo k v) -> DSum (Const2 k a) (NodeInfo (Const2 k a) v'))
-> [(k, NodeInfo k v)]
-> [DSum (Const2 k a) (NodeInfo (Const2 k a) v')]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map k (NodeInfo k v) -> [(k, NodeInfo k v)]
forall k a. Map k a -> [(k, a)]
Map.toAscList Map k (NodeInfo k v)
p
  where g :: (k, MapWithMove.NodeInfo k v) -> DSum (Const2 k a) (NodeInfo (Const2 k a) v')
        g :: (k, NodeInfo k v) -> DSum (Const2 k a) (NodeInfo (Const2 k a) v')
g (k
k, NodeInfo k v
ni) = k -> Const2 k a a
forall x k (v :: x). k -> Const2 k v v
Const2 k
k Const2 k a a
-> NodeInfo (Const2 k a) v' a
-> DSum (Const2 k a) (NodeInfo (Const2 k a) v')
forall k (tag :: k -> *) (f :: k -> *) (a :: k).
tag a -> f a -> DSum tag f
:=> NodeInfo :: forall k (k :: k -> *) (v :: k -> *) (a :: k).
From k v a -> To k a -> NodeInfo k v a
NodeInfo
          { _nodeInfo_from :: From (Const2 k a) v' a
_nodeInfo_from = case NodeInfo k v -> From k v
forall k v. NodeInfo k v -> From k v
MapWithMove._nodeInfo_from NodeInfo k v
ni of
              MapWithMove.From_Insert v
v -> v' a -> From (Const2 k a) v' a
forall a (v :: a -> *) (a :: a) (k :: a -> *). v a -> From k v a
From_Insert (v' a -> From (Const2 k a) v' a) -> v' a -> From (Const2 k a) v' a
forall a b. (a -> b) -> a -> b
$ v -> v' a
f v
v
              From k v
MapWithMove.From_Delete -> From (Const2 k a) v' a
forall a (k :: a -> *) (v :: a -> *) (a :: a). From k v a
From_Delete
              MapWithMove.From_Move k
fromKey -> Const2 k a a -> From (Const2 k a) v' a
forall a (k :: a -> *) (a :: a) (v :: a -> *). k a -> From k v a
From_Move (Const2 k a a -> From (Const2 k a) v' a)
-> Const2 k a a -> From (Const2 k a) v' a
forall a b. (a -> b) -> a -> b
$ k -> Const2 k a a
forall x k (v :: x). k -> Const2 k v v
Const2 k
fromKey
          , _nodeInfo_to :: To (Const2 k a) a
_nodeInfo_to = Maybe (Const2 k a a) -> To (Const2 k a) a
forall k (f :: k -> *) (a :: k). Maybe (f a) -> ComposeMaybe f a
ComposeMaybe (Maybe (Const2 k a a) -> To (Const2 k a) a)
-> Maybe (Const2 k a a) -> To (Const2 k a) a
forall a b. (a -> b) -> a -> b
$ k -> Const2 k a a
forall x k (v :: x). k -> Const2 k v v
Const2 (k -> Const2 k a a) -> Maybe k -> Maybe (Const2 k a a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NodeInfo k v -> Maybe k
forall k v. NodeInfo k v -> To k
MapWithMove._nodeInfo_to NodeInfo k v
ni
          }

-- | Apply the insertions, deletions, and moves to a given 'DMap'.
instance GCompare k => Patch (PatchDMapWithMove k v) where
  type PatchTarget (PatchDMapWithMove k v) = DMap k v
  apply :: PatchDMapWithMove k v
-> PatchTarget (PatchDMapWithMove k v)
-> Maybe (PatchTarget (PatchDMapWithMove k v))
apply (PatchDMapWithMove DMap k (NodeInfo k v)
p) PatchTarget (PatchDMapWithMove k v)
old = DMap k v -> Maybe (DMap k v)
forall a. a -> Maybe a
Just (DMap k v -> Maybe (DMap k v)) -> DMap k v -> Maybe (DMap k v)
forall a b. (a -> b) -> a -> b
$! DMap k v
insertions DMap k v -> DMap k v -> DMap k v
forall k1 (k2 :: k1 -> *) (f :: k1 -> *).
GCompare k2 =>
DMap k2 f -> DMap k2 f -> DMap k2 f
`DMap.union` (DMap k v
PatchTarget (PatchDMapWithMove k v)
old DMap k v -> DMap k (Constant ()) -> DMap k v
forall k1 (k2 :: k1 -> *) (f :: k1 -> *) (g :: k1 -> *).
GCompare k2 =>
DMap k2 f -> DMap k2 g -> DMap k2 f
`DMap.difference` DMap k (Constant ())
deletions) --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?
    where insertions :: DMap k v
insertions = (forall (v :: k). k v -> NodeInfo k v v -> Maybe (v v))
-> DMap k (NodeInfo k v) -> DMap k v
forall k1 (k2 :: k1 -> *) (f :: k1 -> *) (g :: k1 -> *).
GCompare k2 =>
(forall (v :: k1). k2 v -> f v -> Maybe (g v))
-> DMap k2 f -> DMap k2 g
DMap.mapMaybeWithKey forall (v :: k). k v -> NodeInfo k v v -> Maybe (v v)
insertFunc DMap k (NodeInfo k v)
p
          insertFunc :: forall a. k a -> NodeInfo k v a -> Maybe (v a)
          insertFunc :: k a -> NodeInfo k v a -> Maybe (v a)
insertFunc k a
_ NodeInfo k v a
ni = case NodeInfo k v a -> From k v a
forall k (k :: k -> *) (v :: k -> *) (a :: k).
NodeInfo k v a -> From k v a
_nodeInfo_from NodeInfo k v a
ni of
            From_Insert v a
v -> v a -> Maybe (v a)
forall a. a -> Maybe a
Just v a
v
            From_Move k a
k -> k a -> DMap k v -> Maybe (v a)
forall k1 (k2 :: k1 -> *) (f :: k1 -> *) (v :: k1).
GCompare k2 =>
k2 v -> DMap k2 f -> Maybe (f v)
DMap.lookup k a
k DMap k v
PatchTarget (PatchDMapWithMove k v)
old
            From k v a
From_Delete -> Maybe (v a)
forall a. Maybe a
Nothing
          deletions :: DMap k (Constant ())
deletions = (forall (v :: k). k v -> NodeInfo k v v -> Maybe (Constant () v))
-> DMap k (NodeInfo k v) -> DMap k (Constant ())
forall k1 (k2 :: k1 -> *) (f :: k1 -> *) (g :: k1 -> *).
GCompare k2 =>
(forall (v :: k1). k2 v -> f v -> Maybe (g v))
-> DMap k2 f -> DMap k2 g
DMap.mapMaybeWithKey forall (v :: k). k v -> NodeInfo k v v -> Maybe (Constant () v)
deleteFunc DMap k (NodeInfo k v)
p
          deleteFunc :: forall a. k a -> NodeInfo k v a -> Maybe (Constant () a)
          deleteFunc :: k a -> NodeInfo k v a -> Maybe (Constant () a)
deleteFunc k a
_ NodeInfo k v a
ni = case NodeInfo k v a -> From k v a
forall k (k :: k -> *) (v :: k -> *) (a :: k).
NodeInfo k v a -> From k v a
_nodeInfo_from NodeInfo k v a
ni of
            From k v a
From_Delete -> Constant () a -> Maybe (Constant () a)
forall a. a -> Maybe a
Just (Constant () a -> Maybe (Constant () a))
-> Constant () a -> Maybe (Constant () a)
forall a b. (a -> b) -> a -> b
$ () -> Constant () a
forall k a (b :: k). a -> Constant a b
Constant ()
            From k v a
_ -> Maybe (Constant () a)
forall a. Maybe a
Nothing

-- | Get the values that will be replaced, deleted, or moved if the given patch is applied to the given 'DMap'.
getDeletionsAndMoves :: GCompare k => PatchDMapWithMove k v -> DMap k v' -> DMap k (Product v' (ComposeMaybe k))
getDeletionsAndMoves :: PatchDMapWithMove k v
-> DMap k v' -> DMap k (Product v' (ComposeMaybe k))
getDeletionsAndMoves (PatchDMapWithMove DMap k (NodeInfo k v)
p) DMap k v'
m = (forall (v :: k).
 k v -> v' v -> NodeInfo k v v -> Product v' (ComposeMaybe k) v)
-> DMap k v'
-> DMap k (NodeInfo k v)
-> DMap k (Product v' (ComposeMaybe k))
forall k1 (k2 :: k1 -> *) (f :: k1 -> *) (g :: k1 -> *)
       (h :: k1 -> *).
GCompare k2 =>
(forall (v :: k1). k2 v -> f v -> g v -> h v)
-> DMap k2 f -> DMap k2 g -> DMap k2 h
DMap.intersectionWithKey forall (v :: k).
k v -> v' v -> NodeInfo k v v -> Product v' (ComposeMaybe k) v
forall k p (f :: k -> *) (a :: k) (k :: k -> *) (v :: k -> *).
p -> f a -> NodeInfo k v a -> Product f (ComposeMaybe k) a
f DMap k v'
m DMap k (NodeInfo k v)
p
  where f :: p -> f a -> NodeInfo k v a -> Product f (ComposeMaybe k) a
f p
_ f a
v NodeInfo k v a
ni = f a -> ComposeMaybe k a -> Product f (ComposeMaybe k) a
forall k (f :: k -> *) (g :: k -> *) (a :: k).
f a -> g a -> Product f g a
Pair f a
v (ComposeMaybe k a -> Product f (ComposeMaybe k) a)
-> ComposeMaybe k a -> Product f (ComposeMaybe k) a
forall a b. (a -> b) -> a -> b
$ NodeInfo k v a -> ComposeMaybe k a
forall k (k :: k -> *) (v :: k -> *) (a :: k).
NodeInfo k v a -> To k a
_nodeInfo_to NodeInfo k v a
ni