{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE ViewPatterns #-}

module Unison.Codebase.Branch.Merge
  ( MergeMode (..),
    merge'',
  )
where

import Data.Map qualified as Map
import Data.Map.Merge.Lazy qualified as Map
import U.Codebase.HashTags (PatchHash (..))
import Unison.Codebase.Branch
  ( Branch (..),
    Branch0,
    branch0,
    cons,
    discardHistory0,
    empty0,
    head,
    isEmpty,
    isEmpty0,
  )
import Unison.Codebase.Branch qualified as Branch
import Unison.Codebase.Branch.BranchDiff (BranchDiff (BranchDiff))
import Unison.Codebase.Branch.BranchDiff qualified as BDiff
import Unison.Codebase.Causal qualified as Causal
import Unison.Codebase.Patch (Patch)
import Unison.Codebase.Patch qualified as Patch
import Unison.Hashing.V2.Convert qualified as H
import Unison.Prelude hiding (empty)
import Unison.Util.Map (unionWithM)
import Unison.Util.Relation qualified as R
import Unison.Util.Star2 qualified as Star2
import Prelude hiding (head, read, subtract)

data MergeMode = RegularMerge | SquashMerge deriving (MergeMode -> MergeMode -> Bool
(MergeMode -> MergeMode -> Bool)
-> (MergeMode -> MergeMode -> Bool) -> Eq MergeMode
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: MergeMode -> MergeMode -> Bool
== :: MergeMode -> MergeMode -> Bool
$c/= :: MergeMode -> MergeMode -> Bool
/= :: MergeMode -> MergeMode -> Bool
Eq, Eq MergeMode
Eq MergeMode =>
(MergeMode -> MergeMode -> Ordering)
-> (MergeMode -> MergeMode -> Bool)
-> (MergeMode -> MergeMode -> Bool)
-> (MergeMode -> MergeMode -> Bool)
-> (MergeMode -> MergeMode -> Bool)
-> (MergeMode -> MergeMode -> MergeMode)
-> (MergeMode -> MergeMode -> MergeMode)
-> Ord MergeMode
MergeMode -> MergeMode -> Bool
MergeMode -> MergeMode -> Ordering
MergeMode -> MergeMode -> MergeMode
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
$ccompare :: MergeMode -> MergeMode -> Ordering
compare :: MergeMode -> MergeMode -> Ordering
$c< :: MergeMode -> MergeMode -> Bool
< :: MergeMode -> MergeMode -> Bool
$c<= :: MergeMode -> MergeMode -> Bool
<= :: MergeMode -> MergeMode -> Bool
$c> :: MergeMode -> MergeMode -> Bool
> :: MergeMode -> MergeMode -> Bool
$c>= :: MergeMode -> MergeMode -> Bool
>= :: MergeMode -> MergeMode -> Bool
$cmax :: MergeMode -> MergeMode -> MergeMode
max :: MergeMode -> MergeMode -> MergeMode
$cmin :: MergeMode -> MergeMode -> MergeMode
min :: MergeMode -> MergeMode -> MergeMode
Ord, Int -> MergeMode -> ShowS
[MergeMode] -> ShowS
MergeMode -> String
(Int -> MergeMode -> ShowS)
-> (MergeMode -> String)
-> ([MergeMode] -> ShowS)
-> Show MergeMode
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> MergeMode -> ShowS
showsPrec :: Int -> MergeMode -> ShowS
$cshow :: MergeMode -> String
show :: MergeMode -> String
$cshowList :: [MergeMode] -> ShowS
showList :: [MergeMode] -> ShowS
Show)

merge'' ::
  forall m.
  (Monad m) =>
  (Branch m -> Branch m -> m (Maybe (Branch m))) -> -- lca calculator
  MergeMode ->
  Branch m ->
  Branch m ->
  m (Branch m)
merge'' :: forall (m :: * -> *).
Monad m =>
(Branch m -> Branch m -> m (Maybe (Branch m)))
-> MergeMode -> Branch m -> Branch m -> m (Branch m)
merge'' Branch m -> Branch m -> m (Maybe (Branch m))
_ MergeMode
_ Branch m
b1 Branch m
b2 | Branch m -> Bool
forall (m :: * -> *). Branch m -> Bool
isEmpty Branch m
b1 = Branch m -> m (Branch m)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Branch m
b2
merge'' Branch m -> Branch m -> m (Maybe (Branch m))
_ MergeMode
mode Branch m
b1 Branch m
b2 | Branch m -> Bool
forall (m :: * -> *). Branch m -> Bool
isEmpty Branch m
b2 = case MergeMode
mode of
  MergeMode
RegularMerge -> Branch m -> m (Branch m)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Branch m
b1
  MergeMode
SquashMerge -> Branch m -> m (Branch m)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Branch m -> m (Branch m)) -> Branch m -> m (Branch m)
forall a b. (a -> b) -> a -> b
$ Branch0 m -> Branch m -> Branch m
forall (m :: * -> *).
Applicative m =>
Branch0 m -> Branch m -> Branch m
cons (Branch0 m -> Branch0 m
forall (m :: * -> *). Applicative m => Branch0 m -> Branch0 m
discardHistory0 (Branch m -> Branch0 m
forall (m :: * -> *). Branch m -> Branch0 m
head Branch m
b1)) Branch m
b2
merge'' Branch m -> Branch m -> m (Maybe (Branch m))
lca MergeMode
mode (Branch UnwrappedBranch m
x) (Branch UnwrappedBranch m
y) =
  UnwrappedBranch m -> Branch m
forall (m :: * -> *). UnwrappedBranch m -> Branch m
Branch (UnwrappedBranch m -> Branch m)
-> m (UnwrappedBranch m) -> m (Branch m)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> case MergeMode
mode of
    MergeMode
RegularMerge -> (UnwrappedBranch m
 -> UnwrappedBranch m -> m (Maybe (UnwrappedBranch m)))
-> (Maybe (Branch0 m) -> Branch0 m -> Branch0 m -> m (Branch0 m))
-> UnwrappedBranch m
-> UnwrappedBranch m
-> m (UnwrappedBranch m)
forall (m :: * -> *) e.
(Monad m, ContentAddressable e) =>
(Causal m e -> Causal m e -> m (Maybe (Causal m e)))
-> (Maybe e -> e -> e -> m e)
-> Causal m e
-> Causal m e
-> m (Causal m e)
Causal.threeWayMerge' UnwrappedBranch m
-> UnwrappedBranch m -> m (Maybe (UnwrappedBranch m))
lca' Maybe (Branch0 m) -> Branch0 m -> Branch0 m -> m (Branch0 m)
combine UnwrappedBranch m
x UnwrappedBranch m
y
    MergeMode
SquashMerge -> (UnwrappedBranch m
 -> UnwrappedBranch m -> m (Maybe (UnwrappedBranch m)))
-> (Branch0 m -> m (Branch0 m))
-> (Maybe (Branch0 m) -> Branch0 m -> Branch0 m -> m (Branch0 m))
-> UnwrappedBranch m
-> UnwrappedBranch m
-> m (UnwrappedBranch m)
forall (m :: * -> *) e.
(Monad m, ContentAddressable e, Eq e) =>
(Causal m e -> Causal m e -> m (Maybe (Causal m e)))
-> (e -> m e)
-> (Maybe e -> e -> e -> m e)
-> Causal m e
-> Causal m e
-> m (Causal m e)
Causal.squashMerge' UnwrappedBranch m
-> UnwrappedBranch m -> m (Maybe (UnwrappedBranch m))
lca' (Branch0 m -> m (Branch0 m)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Branch0 m -> m (Branch0 m))
-> (Branch0 m -> Branch0 m) -> Branch0 m -> m (Branch0 m)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Branch0 m -> Branch0 m
forall (m :: * -> *). Applicative m => Branch0 m -> Branch0 m
discardHistory0) Maybe (Branch0 m) -> Branch0 m -> Branch0 m -> m (Branch0 m)
combine UnwrappedBranch m
x UnwrappedBranch m
y
  where
    lca' :: UnwrappedBranch m
-> UnwrappedBranch m -> m (Maybe (UnwrappedBranch m))
lca' UnwrappedBranch m
c1 UnwrappedBranch m
c2 = (Branch m -> UnwrappedBranch m)
-> Maybe (Branch m) -> Maybe (UnwrappedBranch m)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Branch m -> UnwrappedBranch m
forall (m :: * -> *). Branch m -> UnwrappedBranch m
_history (Maybe (Branch m) -> Maybe (UnwrappedBranch m))
-> m (Maybe (Branch m)) -> m (Maybe (UnwrappedBranch m))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Branch m -> Branch m -> m (Maybe (Branch m))
lca (UnwrappedBranch m -> Branch m
forall (m :: * -> *). UnwrappedBranch m -> Branch m
Branch UnwrappedBranch m
c1) (UnwrappedBranch m -> Branch m
forall (m :: * -> *). UnwrappedBranch m -> Branch m
Branch UnwrappedBranch m
c2)
    combine :: Maybe (Branch0 m) -> Branch0 m -> Branch0 m -> m (Branch0 m)
    combine :: Maybe (Branch0 m) -> Branch0 m -> Branch0 m -> m (Branch0 m)
combine Maybe (Branch0 m)
Nothing Branch0 m
l Branch0 m
r = (Branch m -> Branch m -> m (Maybe (Branch m)))
-> MergeMode -> Branch0 m -> Branch0 m -> m (Branch0 m)
forall (m :: * -> *).
Monad m =>
(Branch m -> Branch m -> m (Maybe (Branch m)))
-> MergeMode -> Branch0 m -> Branch0 m -> m (Branch0 m)
merge0 Branch m -> Branch m -> m (Maybe (Branch m))
lca MergeMode
mode Branch0 m
l Branch0 m
r
    combine (Just Branch0 m
ca) Branch0 m
l Branch0 m
r = do
      BranchDiff
dl <- Branch0 m -> Branch0 m -> m BranchDiff
forall (m :: * -> *).
Monad m =>
Branch0 m -> Branch0 m -> m BranchDiff
BDiff.diff0 Branch0 m
ca Branch0 m
l
      BranchDiff
dr <- Branch0 m -> Branch0 m -> m BranchDiff
forall (m :: * -> *).
Monad m =>
Branch0 m -> Branch0 m -> m BranchDiff
BDiff.diff0 Branch0 m
ca Branch0 m
r
      Branch0 m
head0 <- Branch0 m -> BranchDiff -> m (Branch0 m)
apply Branch0 m
ca (BranchDiff
dl BranchDiff -> BranchDiff -> BranchDiff
forall a. Semigroup a => a -> a -> a
<> BranchDiff
dr)
      Map NameSegment (Branch m)
children <-
        WhenMissing m NameSegment (Branch m) (Branch m)
-> WhenMissing m NameSegment (Branch m) (Branch m)
-> WhenMatched m NameSegment (Branch m) (Branch m) (Branch m)
-> Map NameSegment (Branch m)
-> Map NameSegment (Branch m)
-> m (Map NameSegment (Branch m))
forall (f :: * -> *) k a c b.
(Applicative f, Ord k) =>
WhenMissing f k a c
-> WhenMissing f k b c
-> WhenMatched f k a b c
-> Map k a
-> Map k b
-> f (Map k c)
Map.mergeA
          ((NameSegment -> Branch m -> m (Maybe (Branch m)))
-> WhenMissing m NameSegment (Branch m) (Branch m)
forall (f :: * -> *) k x y.
Applicative f =>
(k -> x -> f (Maybe y)) -> WhenMissing f k x y
Map.traverseMaybeMissing ((NameSegment -> Branch m -> m (Maybe (Branch m)))
 -> WhenMissing m NameSegment (Branch m) (Branch m))
-> (NameSegment -> Branch m -> m (Maybe (Branch m)))
-> WhenMissing m NameSegment (Branch m) (Branch m)
forall a b. (a -> b) -> a -> b
$ Branch0 m -> NameSegment -> Branch m -> m (Maybe (Branch m))
combineMissing Branch0 m
ca)
          ((NameSegment -> Branch m -> m (Maybe (Branch m)))
-> WhenMissing m NameSegment (Branch m) (Branch m)
forall (f :: * -> *) k x y.
Applicative f =>
(k -> x -> f (Maybe y)) -> WhenMissing f k x y
Map.traverseMaybeMissing ((NameSegment -> Branch m -> m (Maybe (Branch m)))
 -> WhenMissing m NameSegment (Branch m) (Branch m))
-> (NameSegment -> Branch m -> m (Maybe (Branch m)))
-> WhenMissing m NameSegment (Branch m) (Branch m)
forall a b. (a -> b) -> a -> b
$ Branch0 m -> NameSegment -> Branch m -> m (Maybe (Branch m))
combineMissing Branch0 m
ca)
          ((NameSegment -> Branch m -> Branch m -> m (Branch m))
-> WhenMatched m NameSegment (Branch m) (Branch m) (Branch m)
forall (f :: * -> *) k x y z.
Applicative f =>
(k -> x -> y -> f z) -> WhenMatched f k x y z
Map.zipWithAMatched ((NameSegment -> Branch m -> Branch m -> m (Branch m))
 -> WhenMatched m NameSegment (Branch m) (Branch m) (Branch m))
-> (NameSegment -> Branch m -> Branch m -> m (Branch m))
-> WhenMatched m NameSegment (Branch m) (Branch m) (Branch m)
forall a b. (a -> b) -> a -> b
$ (Branch m -> Branch m -> m (Branch m))
-> NameSegment -> Branch m -> Branch m -> m (Branch m)
forall a b. a -> b -> a
const ((Branch m -> Branch m -> m (Maybe (Branch m)))
-> MergeMode -> Branch m -> Branch m -> m (Branch m)
forall (m :: * -> *).
Monad m =>
(Branch m -> Branch m -> m (Maybe (Branch m)))
-> MergeMode -> Branch m -> Branch m -> m (Branch m)
merge'' Branch m -> Branch m -> m (Maybe (Branch m))
lca MergeMode
mode))
          (Branch0 m
l Branch0 m
-> Getting
     (Map NameSegment (Branch m))
     (Branch0 m)
     (Map NameSegment (Branch m))
-> Map NameSegment (Branch m)
forall s a. s -> Getting a s a -> a
^. Getting
  (Map NameSegment (Branch m))
  (Branch0 m)
  (Map NameSegment (Branch m))
forall (m :: * -> *) (f :: * -> *).
Functor f =>
(Map NameSegment (Branch m) -> f (Map NameSegment (Branch m)))
-> Branch0 m -> f (Branch0 m)
Branch.children)
          (Branch0 m
r Branch0 m
-> Getting
     (Map NameSegment (Branch m))
     (Branch0 m)
     (Map NameSegment (Branch m))
-> Map NameSegment (Branch m)
forall s a. s -> Getting a s a -> a
^. Getting
  (Map NameSegment (Branch m))
  (Branch0 m)
  (Map NameSegment (Branch m))
forall (m :: * -> *) (f :: * -> *).
Functor f =>
(Map NameSegment (Branch m) -> f (Map NameSegment (Branch m)))
-> Branch0 m -> f (Branch0 m)
Branch.children)
      pure $ Star Referent NameSegment
-> Star Value NameSegment
-> Map NameSegment (Branch m)
-> Map NameSegment (PatchHash, m Patch)
-> Branch0 m
forall (m :: * -> *).
Star Referent NameSegment
-> Star Value NameSegment
-> Map NameSegment (Branch m)
-> Map NameSegment (PatchHash, m Patch)
-> Branch0 m
branch0 (Branch0 m
head0 Branch0 m
-> Getting
     (Star Referent NameSegment) (Branch0 m) (Star Referent NameSegment)
-> Star Referent NameSegment
forall s a. s -> Getting a s a -> a
^. Getting
  (Star Referent NameSegment) (Branch0 m) (Star Referent NameSegment)
forall (m :: * -> *) (f :: * -> *).
Functor f =>
(Star Referent NameSegment -> f (Star Referent NameSegment))
-> Branch0 m -> f (Branch0 m)
Branch.terms) (Branch0 m
head0 Branch0 m
-> Getting
     (Star Value NameSegment) (Branch0 m) (Star Value NameSegment)
-> Star Value NameSegment
forall s a. s -> Getting a s a -> a
^. Getting
  (Star Value NameSegment) (Branch0 m) (Star Value NameSegment)
forall (m :: * -> *) (f :: * -> *).
Functor f =>
(Star Value NameSegment -> f (Star Value NameSegment))
-> Branch0 m -> f (Branch0 m)
Branch.types) Map NameSegment (Branch m)
children (Branch0 m
head0 Branch0 m
-> Getting
     (Map NameSegment (PatchHash, m Patch))
     (Branch0 m)
     (Map NameSegment (PatchHash, m Patch))
-> Map NameSegment (PatchHash, m Patch)
forall s a. s -> Getting a s a -> a
^. Getting
  (Map NameSegment (PatchHash, m Patch))
  (Branch0 m)
  (Map NameSegment (PatchHash, m Patch))
forall (m :: * -> *) (f :: * -> *).
Functor f =>
(Map NameSegment (PatchHash, m Patch)
 -> f (Map NameSegment (PatchHash, m Patch)))
-> Branch0 m -> f (Branch0 m)
Branch.edits)

    combineMissing :: Branch0 m -> NameSegment -> Branch m -> m (Maybe (Branch m))
combineMissing Branch0 m
ca NameSegment
k Branch m
cur =
      case NameSegment -> Map NameSegment (Branch m) -> Maybe (Branch m)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup NameSegment
k (Branch0 m
ca Branch0 m
-> Getting
     (Map NameSegment (Branch m))
     (Branch0 m)
     (Map NameSegment (Branch m))
-> Map NameSegment (Branch m)
forall s a. s -> Getting a s a -> a
^. Getting
  (Map NameSegment (Branch m))
  (Branch0 m)
  (Map NameSegment (Branch m))
forall (m :: * -> *) (f :: * -> *).
Functor f =>
(Map NameSegment (Branch m) -> f (Map NameSegment (Branch m)))
-> Branch0 m -> f (Branch0 m)
Branch.children) of
        Maybe (Branch m)
Nothing -> Maybe (Branch m) -> m (Maybe (Branch m))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (Branch m) -> m (Maybe (Branch m)))
-> Maybe (Branch m) -> m (Maybe (Branch m))
forall a b. (a -> b) -> a -> b
$ Branch m -> Maybe (Branch m)
forall a. a -> Maybe a
Just Branch m
cur
        Just Branch m
old -> do
          Branch m
nw <- (Branch m -> Branch m -> m (Maybe (Branch m)))
-> MergeMode -> Branch m -> Branch m -> m (Branch m)
forall (m :: * -> *).
Monad m =>
(Branch m -> Branch m -> m (Maybe (Branch m)))
-> MergeMode -> Branch m -> Branch m -> m (Branch m)
merge'' Branch m -> Branch m -> m (Maybe (Branch m))
lca MergeMode
mode (Branch0 m -> Branch m -> Branch m
forall (m :: * -> *).
Applicative m =>
Branch0 m -> Branch m -> Branch m
cons Branch0 m
forall (m :: * -> *). Branch0 m
empty0 Branch m
old) Branch m
cur
          if Branch0 m -> Bool
forall (m :: * -> *). Branch0 m -> Bool
isEmpty0 (Branch0 m -> Bool) -> Branch0 m -> Bool
forall a b. (a -> b) -> a -> b
$ Branch m -> Branch0 m
forall (m :: * -> *). Branch m -> Branch0 m
head Branch m
nw
            then Maybe (Branch m) -> m (Maybe (Branch m))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Branch m)
forall a. Maybe a
Nothing
            else Maybe (Branch m) -> m (Maybe (Branch m))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (Branch m) -> m (Maybe (Branch m)))
-> Maybe (Branch m) -> m (Maybe (Branch m))
forall a b. (a -> b) -> a -> b
$ Branch m -> Maybe (Branch m)
forall a. a -> Maybe a
Just Branch m
nw

    apply :: Branch0 m -> BranchDiff -> m (Branch0 m)
    apply :: Branch0 m -> BranchDiff -> m (Branch0 m)
apply Branch0 m
b0 (BranchDiff Star Referent NameSegment
addedTerms Star Referent NameSegment
removedTerms Star Value NameSegment
addedTypes Star Value NameSegment
removedTypes Map NameSegment PatchDiff
changedPatches) = do
      Map NameSegment (PatchHash, m Patch)
patches <-
        Map NameSegment (m (PatchHash, m Patch))
-> m (Map NameSegment (PatchHash, m Patch))
forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
forall (f :: * -> *) a.
Applicative f =>
Map NameSegment (f a) -> f (Map NameSegment a)
sequenceA (Map NameSegment (m (PatchHash, m Patch))
 -> m (Map NameSegment (PatchHash, m Patch)))
-> Map NameSegment (m (PatchHash, m Patch))
-> m (Map NameSegment (PatchHash, m Patch))
forall a b. (a -> b) -> a -> b
$
          (m (PatchHash, m Patch)
 -> PatchDiff -> Maybe (m (PatchHash, m Patch)))
-> Map NameSegment (m (PatchHash, m Patch))
-> Map NameSegment PatchDiff
-> Map NameSegment (m (PatchHash, m Patch))
forall k a b.
Ord k =>
(a -> b -> Maybe a) -> Map k a -> Map k b -> Map k a
Map.differenceWith m (PatchHash, m Patch)
-> PatchDiff -> Maybe (m (PatchHash, m Patch))
forall {m :: * -> *} {f :: * -> *} {a}.
(Monad m, Applicative f) =>
m (a, m Patch) -> PatchDiff -> Maybe (m (PatchHash, f Patch))
patchMerge (forall (f :: * -> *) a. Applicative f => a -> f a
pure @m ((PatchHash, m Patch) -> m (PatchHash, m Patch))
-> Map NameSegment (PatchHash, m Patch)
-> Map NameSegment (m (PatchHash, m Patch))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Branch0 m
b0 Branch0 m
-> Getting
     (Map NameSegment (PatchHash, m Patch))
     (Branch0 m)
     (Map NameSegment (PatchHash, m Patch))
-> Map NameSegment (PatchHash, m Patch)
forall s a. s -> Getting a s a -> a
^. Getting
  (Map NameSegment (PatchHash, m Patch))
  (Branch0 m)
  (Map NameSegment (PatchHash, m Patch))
forall (m :: * -> *) (f :: * -> *).
Functor f =>
(Map NameSegment (PatchHash, m Patch)
 -> f (Map NameSegment (PatchHash, m Patch)))
-> Branch0 m -> f (Branch0 m)
Branch.edits) Map NameSegment PatchDiff
changedPatches
      let newPatches :: Map NameSegment (PatchHash, m Patch)
newPatches = PatchDiff -> (PatchHash, m Patch)
forall {f :: * -> *}.
Applicative f =>
PatchDiff -> (PatchHash, f Patch)
makePatch (PatchDiff -> (PatchHash, m Patch))
-> Map NameSegment PatchDiff
-> Map NameSegment (PatchHash, m Patch)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map NameSegment PatchDiff
-> Map NameSegment (PatchHash, m Patch)
-> Map NameSegment PatchDiff
forall k a b. Ord k => Map k a -> Map k b -> Map k a
Map.difference Map NameSegment PatchDiff
changedPatches (Branch0 m
b0 Branch0 m
-> Getting
     (Map NameSegment (PatchHash, m Patch))
     (Branch0 m)
     (Map NameSegment (PatchHash, m Patch))
-> Map NameSegment (PatchHash, m Patch)
forall s a. s -> Getting a s a -> a
^. Getting
  (Map NameSegment (PatchHash, m Patch))
  (Branch0 m)
  (Map NameSegment (PatchHash, m Patch))
forall (m :: * -> *) (f :: * -> *).
Functor f =>
(Map NameSegment (PatchHash, m Patch)
 -> f (Map NameSegment (PatchHash, m Patch)))
-> Branch0 m -> f (Branch0 m)
Branch.edits)
          makePatch :: PatchDiff -> (PatchHash, f Patch)
makePatch Patch.PatchDiff {Relation Value TermEdit
Relation Value TypeEdit
_addedTermEdits :: Relation Value TermEdit
_addedTypeEdits :: Relation Value TypeEdit
_removedTermEdits :: Relation Value TermEdit
_removedTypeEdits :: Relation Value TypeEdit
$sel:_addedTermEdits:PatchDiff :: PatchDiff -> Relation Value TermEdit
$sel:_addedTypeEdits:PatchDiff :: PatchDiff -> Relation Value TypeEdit
$sel:_removedTermEdits:PatchDiff :: PatchDiff -> Relation Value TermEdit
$sel:_removedTypeEdits:PatchDiff :: PatchDiff -> Relation Value TypeEdit
..} =
            let p :: Patch
p = Relation Value TermEdit -> Relation Value TypeEdit -> Patch
Patch.Patch Relation Value TermEdit
_addedTermEdits Relation Value TypeEdit
_addedTypeEdits
             in (Hash -> PatchHash
PatchHash (Patch -> Hash
H.hashPatch Patch
p), Patch -> f Patch
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Patch
p)
      pure $
        Star Referent NameSegment
-> Star Value NameSegment
-> Map NameSegment (Branch m)
-> Map NameSegment (PatchHash, m Patch)
-> Branch0 m
forall (m :: * -> *).
Star Referent NameSegment
-> Star Value NameSegment
-> Map NameSegment (Branch m)
-> Map NameSegment (PatchHash, m Patch)
-> Branch0 m
branch0
          (Star Referent NameSegment
-> Star Referent NameSegment -> Star Referent NameSegment
forall fact d1 d2.
(Ord fact, Ord d1, Ord d2) =>
Star2 fact d1 d2 -> Star2 fact d1 d2 -> Star2 fact d1 d2
Star2.difference (Branch0 m
b0 Branch0 m
-> Getting
     (Star Referent NameSegment) (Branch0 m) (Star Referent NameSegment)
-> Star Referent NameSegment
forall s a. s -> Getting a s a -> a
^. Getting
  (Star Referent NameSegment) (Branch0 m) (Star Referent NameSegment)
forall (m :: * -> *) (f :: * -> *).
Functor f =>
(Star Referent NameSegment -> f (Star Referent NameSegment))
-> Branch0 m -> f (Branch0 m)
Branch.terms) Star Referent NameSegment
removedTerms Star Referent NameSegment
-> Star Referent NameSegment -> Star Referent NameSegment
forall a. Semigroup a => a -> a -> a
<> Star Referent NameSegment
addedTerms)
          (Star Value NameSegment
-> Star Value NameSegment -> Star Value NameSegment
forall fact d1 d2.
(Ord fact, Ord d1, Ord d2) =>
Star2 fact d1 d2 -> Star2 fact d1 d2 -> Star2 fact d1 d2
Star2.difference (Branch0 m
b0 Branch0 m
-> Getting
     (Star Value NameSegment) (Branch0 m) (Star Value NameSegment)
-> Star Value NameSegment
forall s a. s -> Getting a s a -> a
^. Getting
  (Star Value NameSegment) (Branch0 m) (Star Value NameSegment)
forall (m :: * -> *) (f :: * -> *).
Functor f =>
(Star Value NameSegment -> f (Star Value NameSegment))
-> Branch0 m -> f (Branch0 m)
Branch.types) Star Value NameSegment
removedTypes Star Value NameSegment
-> Star Value NameSegment -> Star Value NameSegment
forall a. Semigroup a => a -> a -> a
<> Star Value NameSegment
addedTypes)
          (Branch0 m
b0 Branch0 m
-> Getting
     (Map NameSegment (Branch m))
     (Branch0 m)
     (Map NameSegment (Branch m))
-> Map NameSegment (Branch m)
forall s a. s -> Getting a s a -> a
^. Getting
  (Map NameSegment (Branch m))
  (Branch0 m)
  (Map NameSegment (Branch m))
forall (m :: * -> *) (f :: * -> *).
Functor f =>
(Map NameSegment (Branch m) -> f (Map NameSegment (Branch m)))
-> Branch0 m -> f (Branch0 m)
Branch.children)
          (Map NameSegment (PatchHash, m Patch)
patches Map NameSegment (PatchHash, m Patch)
-> Map NameSegment (PatchHash, m Patch)
-> Map NameSegment (PatchHash, m Patch)
forall a. Semigroup a => a -> a -> a
<> Map NameSegment (PatchHash, m Patch)
newPatches)
    patchMerge :: m (a, m Patch) -> PatchDiff -> Maybe (m (PatchHash, f Patch))
patchMerge m (a, m Patch)
mhp Patch.PatchDiff {Relation Value TermEdit
Relation Value TypeEdit
$sel:_addedTermEdits:PatchDiff :: PatchDiff -> Relation Value TermEdit
$sel:_addedTypeEdits:PatchDiff :: PatchDiff -> Relation Value TypeEdit
$sel:_removedTermEdits:PatchDiff :: PatchDiff -> Relation Value TermEdit
$sel:_removedTypeEdits:PatchDiff :: PatchDiff -> Relation Value TypeEdit
_addedTermEdits :: Relation Value TermEdit
_addedTypeEdits :: Relation Value TypeEdit
_removedTermEdits :: Relation Value TermEdit
_removedTypeEdits :: Relation Value TypeEdit
..} = m (PatchHash, f Patch) -> Maybe (m (PatchHash, f Patch))
forall a. a -> Maybe a
Just (m (PatchHash, f Patch) -> Maybe (m (PatchHash, f Patch)))
-> m (PatchHash, f Patch) -> Maybe (m (PatchHash, f Patch))
forall a b. (a -> b) -> a -> b
$ do
      (a
_, m Patch
mp) <- m (a, m Patch)
mhp
      Patch
p <- m Patch
mp
      let np :: Patch
np =
            Patch.Patch
              { $sel:_termEdits:Patch :: Relation Value TermEdit
_termEdits =
                  Relation Value TermEdit
-> Relation Value TermEdit -> Relation Value TermEdit
forall a b.
(Ord a, Ord b) =>
Relation a b -> Relation a b -> Relation a b
R.difference (Patch -> Relation Value TermEdit
Patch._termEdits Patch
p) Relation Value TermEdit
_removedTermEdits
                    Relation Value TermEdit
-> Relation Value TermEdit -> Relation Value TermEdit
forall a. Semigroup a => a -> a -> a
<> Relation Value TermEdit
_addedTermEdits,
                $sel:_typeEdits:Patch :: Relation Value TypeEdit
_typeEdits =
                  Relation Value TypeEdit
-> Relation Value TypeEdit -> Relation Value TypeEdit
forall a b.
(Ord a, Ord b) =>
Relation a b -> Relation a b -> Relation a b
R.difference (Patch -> Relation Value TypeEdit
Patch._typeEdits Patch
p) Relation Value TypeEdit
_removedTypeEdits
                    Relation Value TypeEdit
-> Relation Value TypeEdit -> Relation Value TypeEdit
forall a. Semigroup a => a -> a -> a
<> Relation Value TypeEdit
_addedTypeEdits
              }
      (PatchHash, f Patch) -> m (PatchHash, f Patch)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Hash -> PatchHash
PatchHash (Patch -> Hash
H.hashPatch Patch
np), Patch -> f Patch
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Patch
np)

merge0 ::
  forall m.
  (Monad m) =>
  (Branch m -> Branch m -> m (Maybe (Branch m))) ->
  MergeMode ->
  Branch0 m ->
  Branch0 m ->
  m (Branch0 m)
merge0 :: forall (m :: * -> *).
Monad m =>
(Branch m -> Branch m -> m (Maybe (Branch m)))
-> MergeMode -> Branch0 m -> Branch0 m -> m (Branch0 m)
merge0 Branch m -> Branch m -> m (Maybe (Branch m))
lca MergeMode
mode Branch0 m
b1 Branch0 m
b2 = do
  Map NameSegment (Branch m)
c3 <- (Branch m -> Branch m -> m (Branch m))
-> Map NameSegment (Branch m)
-> Map NameSegment (Branch m)
-> m (Map NameSegment (Branch m))
forall (m :: * -> *) k a.
(Monad m, Ord k) =>
(a -> a -> m a) -> Map k a -> Map k a -> m (Map k a)
unionWithM ((Branch m -> Branch m -> m (Maybe (Branch m)))
-> MergeMode -> Branch m -> Branch m -> m (Branch m)
forall (m :: * -> *).
Monad m =>
(Branch m -> Branch m -> m (Maybe (Branch m)))
-> MergeMode -> Branch m -> Branch m -> m (Branch m)
merge'' Branch m -> Branch m -> m (Maybe (Branch m))
lca MergeMode
mode) (Branch0 m
b1 Branch0 m
-> Getting
     (Map NameSegment (Branch m))
     (Branch0 m)
     (Map NameSegment (Branch m))
-> Map NameSegment (Branch m)
forall s a. s -> Getting a s a -> a
^. Getting
  (Map NameSegment (Branch m))
  (Branch0 m)
  (Map NameSegment (Branch m))
forall (m :: * -> *) (f :: * -> *).
Functor f =>
(Map NameSegment (Branch m) -> f (Map NameSegment (Branch m)))
-> Branch0 m -> f (Branch0 m)
Branch.children) (Branch0 m
b2 Branch0 m
-> Getting
     (Map NameSegment (Branch m))
     (Branch0 m)
     (Map NameSegment (Branch m))
-> Map NameSegment (Branch m)
forall s a. s -> Getting a s a -> a
^. Getting
  (Map NameSegment (Branch m))
  (Branch0 m)
  (Map NameSegment (Branch m))
forall (m :: * -> *) (f :: * -> *).
Functor f =>
(Map NameSegment (Branch m) -> f (Map NameSegment (Branch m)))
-> Branch0 m -> f (Branch0 m)
Branch.children)
  Map NameSegment (PatchHash, m Patch)
e3 <- ((PatchHash, m Patch)
 -> (PatchHash, m Patch) -> m (PatchHash, m Patch))
-> Map NameSegment (PatchHash, m Patch)
-> Map NameSegment (PatchHash, m Patch)
-> m (Map NameSegment (PatchHash, m Patch))
forall (m :: * -> *) k a.
(Monad m, Ord k) =>
(a -> a -> m a) -> Map k a -> Map k a -> m (Map k a)
unionWithM (PatchHash, m Patch)
-> (PatchHash, m Patch) -> m (PatchHash, m Patch)
g (Branch0 m
b1 Branch0 m
-> Getting
     (Map NameSegment (PatchHash, m Patch))
     (Branch0 m)
     (Map NameSegment (PatchHash, m Patch))
-> Map NameSegment (PatchHash, m Patch)
forall s a. s -> Getting a s a -> a
^. Getting
  (Map NameSegment (PatchHash, m Patch))
  (Branch0 m)
  (Map NameSegment (PatchHash, m Patch))
forall (m :: * -> *) (f :: * -> *).
Functor f =>
(Map NameSegment (PatchHash, m Patch)
 -> f (Map NameSegment (PatchHash, m Patch)))
-> Branch0 m -> f (Branch0 m)
Branch.edits) (Branch0 m
b2 Branch0 m
-> Getting
     (Map NameSegment (PatchHash, m Patch))
     (Branch0 m)
     (Map NameSegment (PatchHash, m Patch))
-> Map NameSegment (PatchHash, m Patch)
forall s a. s -> Getting a s a -> a
^. Getting
  (Map NameSegment (PatchHash, m Patch))
  (Branch0 m)
  (Map NameSegment (PatchHash, m Patch))
forall (m :: * -> *) (f :: * -> *).
Functor f =>
(Map NameSegment (PatchHash, m Patch)
 -> f (Map NameSegment (PatchHash, m Patch)))
-> Branch0 m -> f (Branch0 m)
Branch.edits)
  pure $
    Star Referent NameSegment
-> Star Value NameSegment
-> Map NameSegment (Branch m)
-> Map NameSegment (PatchHash, m Patch)
-> Branch0 m
forall (m :: * -> *).
Star Referent NameSegment
-> Star Value NameSegment
-> Map NameSegment (Branch m)
-> Map NameSegment (PatchHash, m Patch)
-> Branch0 m
branch0
      (Branch0 m
b1 Branch0 m
-> Getting
     (Star Referent NameSegment) (Branch0 m) (Star Referent NameSegment)
-> Star Referent NameSegment
forall s a. s -> Getting a s a -> a
^. Getting
  (Star Referent NameSegment) (Branch0 m) (Star Referent NameSegment)
forall (m :: * -> *) (f :: * -> *).
Functor f =>
(Star Referent NameSegment -> f (Star Referent NameSegment))
-> Branch0 m -> f (Branch0 m)
Branch.terms Star Referent NameSegment
-> Star Referent NameSegment -> Star Referent NameSegment
forall a. Semigroup a => a -> a -> a
<> Branch0 m
b2 Branch0 m
-> Getting
     (Star Referent NameSegment) (Branch0 m) (Star Referent NameSegment)
-> Star Referent NameSegment
forall s a. s -> Getting a s a -> a
^. Getting
  (Star Referent NameSegment) (Branch0 m) (Star Referent NameSegment)
forall (m :: * -> *) (f :: * -> *).
Functor f =>
(Star Referent NameSegment -> f (Star Referent NameSegment))
-> Branch0 m -> f (Branch0 m)
Branch.terms)
      (Branch0 m
b1 Branch0 m
-> Getting
     (Star Value NameSegment) (Branch0 m) (Star Value NameSegment)
-> Star Value NameSegment
forall s a. s -> Getting a s a -> a
^. Getting
  (Star Value NameSegment) (Branch0 m) (Star Value NameSegment)
forall (m :: * -> *) (f :: * -> *).
Functor f =>
(Star Value NameSegment -> f (Star Value NameSegment))
-> Branch0 m -> f (Branch0 m)
Branch.types Star Value NameSegment
-> Star Value NameSegment -> Star Value NameSegment
forall a. Semigroup a => a -> a -> a
<> Branch0 m
b2 Branch0 m
-> Getting
     (Star Value NameSegment) (Branch0 m) (Star Value NameSegment)
-> Star Value NameSegment
forall s a. s -> Getting a s a -> a
^. Getting
  (Star Value NameSegment) (Branch0 m) (Star Value NameSegment)
forall (m :: * -> *) (f :: * -> *).
Functor f =>
(Star Value NameSegment -> f (Star Value NameSegment))
-> Branch0 m -> f (Branch0 m)
Branch.types)
      Map NameSegment (Branch m)
c3
      Map NameSegment (PatchHash, m Patch)
e3
  where
    g :: (PatchHash, m Patch) -> (PatchHash, m Patch) -> m (PatchHash, m Patch)
    g :: (PatchHash, m Patch)
-> (PatchHash, m Patch) -> m (PatchHash, m Patch)
g (PatchHash
h1, m Patch
m1) (PatchHash
h2, m Patch
_) | PatchHash
h1 PatchHash -> PatchHash -> Bool
forall a. Eq a => a -> a -> Bool
== PatchHash
h2 = (PatchHash, m Patch) -> m (PatchHash, m Patch)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PatchHash
h1, m Patch
m1)
    g (PatchHash
_, m Patch
m1) (PatchHash
_, m Patch
m2) = do
      Patch
e1 <- m Patch
m1
      Patch
e2 <- m Patch
m2
      let e3 :: Patch
e3 = Patch
e1 Patch -> Patch -> Patch
forall a. Semigroup a => a -> a -> a
<> Patch
e2
      (PatchHash, m Patch) -> m (PatchHash, m Patch)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Hash -> PatchHash
PatchHash (Patch -> Hash
H.hashPatch Patch
e3), Patch -> m Patch
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Patch
e3)