-- | @merge@ input handler.
module Unison.Codebase.Editor.HandleInput.Merge2
  ( handleMerge,

    -- * API exported for @pull@
    MergeInfo (..),
    AliceMergeInfo (..),
    BobMergeInfo (..),
    LcaMergeInfo (..),
    doMerge,
    doMergeLocalBranch,

    -- * API exported for @todo@
    hasDefnsInLib,
  )
where

import Control.Lens (mapped, _1)
import Control.Monad.Reader (ask)
import Data.Algorithm.Diff qualified as Diff
import Data.List qualified as List
import Data.Map.Strict qualified as Map
import Data.Semialign (zipWith)
import Data.Set qualified as Set
import Data.Text qualified as Text
import Data.Text.IO qualified as Text
import System.Directory (canonicalizePath, getTemporaryDirectory, removeFile)
import System.Environment (lookupEnv)
import System.FilePath ((</>))
import System.IO.Temp qualified as Temporary
import System.Process qualified as Process
import Text.ANSI qualified as Text
import Text.Builder qualified
import Text.Builder qualified as Text (Builder)
import U.Codebase.Branch qualified as V2 (Branch (..), CausalBranch)
import U.Codebase.Branch qualified as V2.Branch
import U.Codebase.Causal qualified as V2.Causal
import U.Codebase.HashTags (CausalHash, unCausalHash)
import U.Codebase.Reference (TermReferenceId, TypeReference, TypeReferenceId)
import U.Codebase.Sqlite.DbId (ProjectId)
import U.Codebase.Sqlite.Operations qualified as Operations
import U.Codebase.Sqlite.Project (Project (..))
import U.Codebase.Sqlite.ProjectBranch (ProjectBranch (..))
import U.Codebase.Sqlite.Queries qualified as Queries
import Unison.Cli.MergeTypes (MergeSource (..), MergeSourceAndTarget (..), MergeSourceOrTarget (..))
import Unison.Cli.Monad (Cli)
import Unison.Cli.Monad qualified as Cli
import Unison.Cli.MonadUtils qualified as Cli
import Unison.Cli.ProjectUtils qualified as ProjectUtils
import Unison.Cli.Share.Projects qualified as Share
import Unison.Cli.UpdateUtils (hydrateRefs)
import Unison.Codebase qualified as Codebase
import Unison.Codebase.Branch (Branch, Branch0)
import Unison.Codebase.Branch qualified as Branch
import Unison.Codebase.Branch.Names qualified as Branch
import Unison.Codebase.BranchUtil qualified as BranchUtil
import Unison.Codebase.Editor.HandleInput.Branch qualified as HandleInput.Branch
import Unison.Codebase.Editor.Output (Output)
import Unison.Codebase.Editor.Output qualified as Output
import Unison.Codebase.Editor.RemoteRepo (ReadShareLooseCode (..))
import Unison.Codebase.Path (Path)
import Unison.Codebase.Path qualified as Path
import Unison.Codebase.ProjectPath (ProjectPathG (..))
import Unison.Codebase.ProjectPath qualified as PP
import Unison.Codebase.SqliteCodebase.Operations qualified as Operations
import Unison.DataDeclaration (Decl)
import Unison.DataDeclaration qualified as DataDeclaration
import Unison.Debug qualified as Debug
import Unison.DeclCoherencyCheck (asOneRandomIncoherentDeclReason)
import Unison.Hash qualified as Hash
import Unison.LabeledDependency (LabeledDependency)
import Unison.Merge qualified as Merge
import Unison.Merge.EitherWayI qualified as EitherWayI
import Unison.Merge.Synhashed qualified as Synhashed
import Unison.Merge.ThreeWay qualified as ThreeWay
import Unison.Merge.TwoOrThreeWay qualified as TwoOrThreeWay
import Unison.Merge.Updated qualified as Updated
import Unison.Name (Name)
import Unison.NameSegment qualified as NameSegment
import Unison.Names (Names)
import Unison.Names qualified as Names
import Unison.Parser.Ann (Ann)
import Unison.PartialDeclNameLookup qualified as PartialDeclNameLookup
import Unison.Prelude
import Unison.Project
  ( ProjectAndBranch (..),
    ProjectBranchName,
    ProjectName,
    projectBranchNameToValidProjectBranchNameText,
  )
import Unison.Reference (TermReference)
import Unison.Reference qualified as Reference
import Unison.Referent (Referent)
import Unison.Referent qualified as Referent
import Unison.ReferentPrime qualified as Referent'
import Unison.Sqlite (Transaction)
import Unison.Sqlite qualified as Sqlite
import Unison.Symbol (Symbol)
import Unison.Syntax.Name qualified as Name
import Unison.Term (Term)
import Unison.Type (Type)
import Unison.UnconflictedLocalDefnsView qualified as UnconflictedLocalDefnsView
import Unison.UnisonFile (TypecheckedUnisonFile)
import Unison.UnisonFile qualified as UnisonFile
import Unison.Util.Alphabetical (sortAlphabeticallyOn)
import Unison.Util.BiMultimap (BiMultimap)
import Unison.Util.BiMultimap qualified as BiMultimap
import Unison.Util.Defns (Defns (..), DefnsF, DefnsF2, DefnsF3, defnsAreEmpty)
import Unison.Util.Monoid qualified as Monoid
import Unison.Util.Pretty (ColorText, Pretty)
import Unison.Util.Pretty qualified as Pretty
import Unison.WatchKind qualified as WatchKind
import Witch (unsafeFrom)
import Prelude hiding (unzip, zip, zipWith)

handleMerge :: ProjectAndBranch (Maybe ProjectName) ProjectBranchName -> Cli ()
handleMerge :: ProjectAndBranch (Maybe ProjectName) ProjectBranchName -> Cli ()
handleMerge (ProjectAndBranch Maybe ProjectName
maybeBobProjectName ProjectBranchName
bobBranchName) = do
  -- Assert that Alice (us) is on a project branch, and grab the causal hash.
  ProjectPath Project
aliceProject ProjectBranch
aliceProjectBranch Absolute
_path <- Cli (ProjectPathG Project ProjectBranch)
Cli.getCurrentProjectPath
  let aliceProjectAndBranch :: ProjectAndBranch Project ProjectBranch
aliceProjectAndBranch = Project -> ProjectBranch -> ProjectAndBranch Project ProjectBranch
forall a b. a -> b -> ProjectAndBranch a b
ProjectAndBranch Project
aliceProject ProjectBranch
aliceProjectBranch

  -- Resolve Bob's maybe-project-name + branch-name to the info the merge algorithm needs: the project name, branch
  -- name, and causal hash.
  Project
bobProject <-
    case Maybe ProjectName
maybeBobProjectName of
      Maybe ProjectName
Nothing -> Project -> Cli Project
forall a. a -> Cli a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ProjectAndBranch Project ProjectBranch
aliceProjectAndBranch.project
      Just ProjectName
bobProjectName
        | ProjectName
bobProjectName ProjectName -> ProjectName -> Bool
forall a. Eq a => a -> a -> Bool
== ProjectAndBranch Project ProjectBranch
aliceProjectAndBranch.project.name -> Project -> Cli Project
forall a. a -> Cli a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ProjectAndBranch Project ProjectBranch
aliceProjectAndBranch.project
        | Bool
otherwise -> do
            Transaction (Maybe Project) -> Cli (Maybe Project)
forall a. Transaction a -> Cli a
Cli.runTransaction (ProjectName -> Transaction (Maybe Project)
Queries.loadProjectByName ProjectName
bobProjectName)
              Cli (Maybe Project)
-> (Cli (Maybe Project) -> Cli Project) -> Cli Project
forall a b. a -> (a -> b) -> b
& Cli Project -> Cli (Maybe Project) -> Cli Project
forall (m :: * -> *) a. Monad m => m a -> m (Maybe a) -> m a
onNothingM (Output -> Cli Project
forall a. Output -> Cli a
Cli.returnEarly (ProjectName -> Output
Output.LocalProjectDoesntExist ProjectName
bobProjectName))
  ProjectBranch
bobProjectBranch <- Project -> ProjectBranchName -> Cli ProjectBranch
ProjectUtils.expectProjectBranchByName Project
bobProject ProjectBranchName
bobBranchName
  let bobProjectAndBranch :: ProjectAndBranch Project ProjectBranch
bobProjectAndBranch = Project -> ProjectBranch -> ProjectAndBranch Project ProjectBranch
forall a b. a -> b -> ProjectAndBranch a b
ProjectAndBranch Project
bobProject ProjectBranch
bobProjectBranch

  TwoWay (ProjectAndBranch Project ProjectBranch) -> Cli ()
doMergeLocalBranch
    Merge.TwoWay
      { $sel:alice:TwoWay :: ProjectAndBranch Project ProjectBranch
alice = ProjectAndBranch Project ProjectBranch
aliceProjectAndBranch,
        $sel:bob:TwoWay :: ProjectAndBranch Project ProjectBranch
bob = ProjectAndBranch Project ProjectBranch
bobProjectAndBranch
      }

data MergeInfo = MergeInfo
  { MergeInfo -> AliceMergeInfo
alice :: !AliceMergeInfo,
    MergeInfo -> BobMergeInfo
bob :: !BobMergeInfo,
    MergeInfo -> LcaMergeInfo
lca :: !LcaMergeInfo,
    -- | How should we describe this merge in the reflog?
    MergeInfo -> Text
description :: !Text
  }

data AliceMergeInfo = AliceMergeInfo
  { AliceMergeInfo -> CausalHash
causalHash :: !CausalHash,
    AliceMergeInfo -> ProjectAndBranch Project ProjectBranch
projectAndBranch :: !(ProjectAndBranch Project ProjectBranch)
  }

data BobMergeInfo = BobMergeInfo
  { BobMergeInfo -> CausalHash
causalHash :: !CausalHash,
    BobMergeInfo -> MergeSource
source :: !MergeSource
  }

newtype LcaMergeInfo = LcaMergeInfo
  { LcaMergeInfo -> Maybe CausalHash
causalHash :: Maybe CausalHash
  }

doMerge :: MergeInfo -> Cli ()
doMerge :: MergeInfo -> Cli ()
doMerge MergeInfo
info = do
  let debugFunctions :: DebugFunctions
debugFunctions =
        if DebugFlag -> Bool
Debug.shouldDebug DebugFlag
Debug.Merge
          then DebugFunctions
realDebugFunctions
          else DebugFunctions
fakeDebugFunctions

  -- When debugging, don't bother with progress messages, so debug output is cleaner and doesn't disappear
  let withRespondRegion :: ((Output -> IO ()) -> Cli a) -> Cli a
      withRespondRegion :: forall a. ((Output -> IO ()) -> Cli a) -> Cli a
withRespondRegion =
        if DebugFlag -> Bool
Debug.shouldDebug DebugFlag
Debug.Merge
          then \(Output -> IO ()) -> Cli a
f -> (Output -> IO ()) -> Cli a
f \Output
_output -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
          else ((Output -> IO ()) -> Cli a) -> Cli a
forall a. ((Output -> IO ()) -> Cli a) -> Cli a
Cli.withRespondRegionIO

  let aliceBranchNames :: MergeTarget
aliceBranchNames = ProjectAndBranch Project ProjectBranch -> MergeTarget
ProjectUtils.justTheNames MergeInfo
info.alice.projectAndBranch
  let mergeSource :: MergeSourceOrTarget
mergeSource = MergeSource -> MergeSourceOrTarget
MergeSourceOrTarget'Source MergeInfo
info.bob.source
  let mergeTarget :: MergeSourceOrTarget
mergeTarget = MergeTarget -> MergeSourceOrTarget
MergeSourceOrTarget'Target MergeTarget
aliceBranchNames
  let mergeSourceAndTarget :: MergeSourceAndTarget
mergeSourceAndTarget = MergeSourceAndTarget {$sel:alice:MergeSourceAndTarget :: MergeTarget
alice = MergeTarget
aliceBranchNames, $sel:bob:MergeSourceAndTarget :: MergeSource
bob = MergeInfo
info.bob.source}

  Env
env <- Cli Env
forall r (m :: * -> *). MonadReader r m => m r
ask

  Output
finalOutput <-
    ((forall a. Output -> Cli a) -> Cli Output) -> Cli Output
forall a. ((forall void. a -> Cli void) -> Cli a) -> Cli a
Cli.label \forall a. Output -> Cli a
done -> do
      -- If alice == bob, or LCA == bob (so alice is ahead of bob), then we are done.
      Bool -> Cli () -> Cli ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (MergeInfo
info.alice.causalHash CausalHash -> CausalHash -> Bool
forall a. Eq a => a -> a -> Bool
== MergeInfo
info.bob.causalHash Bool -> Bool -> Bool
|| MergeInfo
info.lca.causalHash Maybe CausalHash -> Maybe CausalHash -> Bool
forall a. Eq a => a -> a -> Bool
== CausalHash -> Maybe CausalHash
forall a. a -> Maybe a
Just MergeInfo
info.bob.causalHash) do
        Output -> Cli ()
forall a. Output -> Cli a
done (MergeSourceAndTarget -> Output
Output.MergeAlreadyUpToDate2 MergeSourceAndTarget
mergeSourceAndTarget)

      -- Otherwise, if LCA == alice (so alice is behind bob), then we could fast forward to bob, so we're done.
      Bool -> Cli () -> Cli ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (MergeInfo
info.lca.causalHash Maybe CausalHash -> Maybe CausalHash -> Bool
forall a. Eq a => a -> a -> Bool
== CausalHash -> Maybe CausalHash
forall a. a -> Maybe a
Just MergeInfo
info.alice.causalHash) do
        Branch IO
bobBranch <- IO (Branch IO) -> Cli (Branch IO)
forall a. IO a -> Cli a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Codebase IO Symbol Ann -> CausalHash -> IO (Branch IO)
forall (m :: * -> *) v a.
Monad m =>
Codebase m v a -> CausalHash -> m (Branch m)
Codebase.expectBranchForHash Env
env.codebase MergeInfo
info.bob.causalHash)
        Bool
_ <- Text
-> ProjectPathG Project ProjectBranch
-> (Branch IO -> Branch IO)
-> Cli Bool
Cli.updateAt MergeInfo
info.description (ProjectAndBranch Project ProjectBranch
-> ProjectPathG Project ProjectBranch
PP.projectBranchRoot MergeInfo
info.alice.projectAndBranch) (\Branch IO
_aliceBranch -> Branch IO
bobBranch)
        Output -> Cli ()
forall a. Output -> Cli a
done (MergeSourceAndTarget -> Output
Output.MergeSuccessFastForward MergeSourceAndTarget
mergeSourceAndTarget)

      ((Output -> IO ()) -> Cli Output) -> Cli Output
forall a. ((Output -> IO ()) -> Cli a) -> Cli a
withRespondRegion \Output -> IO ()
respondRegion -> do
        IO () -> Cli ()
forall a. IO a -> Cli a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Output -> IO ()
respondRegion (Pretty ColorText -> Output
Output.Literal Pretty ColorText
"Loading namespaces..."))

        -- Load Alice/Bob/LCA branches
        TwoOrThreeWay (Branch Transaction)
branches <-
          Transaction (TwoOrThreeWay (Branch Transaction))
-> Cli (TwoOrThreeWay (Branch Transaction))
forall a. Transaction a -> Cli a
Cli.runTransaction do
            (CausalHash -> Transaction (Branch Transaction))
-> TwoOrThreeWay CausalHash
-> Transaction (TwoOrThreeWay (Branch Transaction))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> TwoOrThreeWay a -> f (TwoOrThreeWay b)
traverse
              (Codebase IO Symbol Ann
-> CausalHash -> Transaction (Branch Transaction)
forall (m :: * -> *) v a.
Codebase m v a -> CausalHash -> Transaction (Branch Transaction)
Codebase.expectBranchForHashTx Env
env.codebase)
              Merge.TwoOrThreeWay
                { $sel:alice:TwoOrThreeWay :: CausalHash
alice = MergeInfo
info.alice.causalHash,
                  $sel:bob:TwoOrThreeWay :: CausalHash
bob = MergeInfo
info.bob.causalHash,
                  $sel:lca:TwoOrThreeWay :: Maybe CausalHash
lca = MergeInfo
info.lca.causalHash
                }

        -- Assert that neither Alice nor Bob have defns in lib
        [(MergeSourceOrTarget, Branch0 Transaction)]
-> ((MergeSourceOrTarget, Branch0 Transaction) -> Cli ()) -> Cli ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [(MergeSourceOrTarget
mergeTarget, Branch Transaction -> Branch0 Transaction
forall (m :: * -> *). Branch m -> Branch0 m
Branch.head TwoOrThreeWay (Branch Transaction)
branches.alice), (MergeSourceOrTarget
mergeSource, Branch Transaction -> Branch0 Transaction
forall (m :: * -> *). Branch m -> Branch0 m
Branch.head TwoOrThreeWay (Branch Transaction)
branches.bob)] \(MergeSourceOrTarget
who, Branch0 Transaction
branch) -> do
          Bool -> Cli () -> Cli ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Branch0 Transaction -> Bool
forall (m :: * -> *). Branch0 m -> Bool
Branch.hasDefnsInLib Branch0 Transaction
branch) do
            Output -> Cli ()
forall a. Output -> Cli a
done (MergeSourceOrTarget -> Output
Output.MergeDefnsInLib MergeSourceOrTarget
who)

        -- Derive unconflicted defns views
        --
        -- FIXME: Oops, if this fails due to a conflicted name, we don't actually say where the conflicted name came from.
        -- We should have a better error message (even though you can't do anything about conflicted names in the LCA).
        ThreeWay UnconflictedLocalDefnsView
defns <- do
          let asUnconflicted :: Branch0 Transaction -> Cli UnconflictedLocalDefnsView
asUnconflicted Branch0 Transaction
branch = Branch0 Transaction
-> Either
     (Defn (Conflicted Name Referent) (Conflicted Name TypeReference))
     UnconflictedLocalDefnsView
forall (m :: * -> *).
Branch0 m
-> Either
     (Defn (Conflicted Name Referent) (Conflicted Name TypeReference))
     UnconflictedLocalDefnsView
Branch.asUnconflicted Branch0 Transaction
branch Either
  (Defn (Conflicted Name Referent) (Conflicted Name TypeReference))
  UnconflictedLocalDefnsView
-> (Either
      (Defn (Conflicted Name Referent) (Conflicted Name TypeReference))
      UnconflictedLocalDefnsView
    -> Cli UnconflictedLocalDefnsView)
-> Cli UnconflictedLocalDefnsView
forall a b. a -> (a -> b) -> b
& (Defn (Conflicted Name Referent) (Conflicted Name TypeReference)
 -> Cli UnconflictedLocalDefnsView)
-> Either
     (Defn (Conflicted Name Referent) (Conflicted Name TypeReference))
     UnconflictedLocalDefnsView
-> Cli UnconflictedLocalDefnsView
forall (m :: * -> *) a b.
Applicative m =>
(a -> m b) -> Either a b -> m b
onLeft (Output -> Cli UnconflictedLocalDefnsView
forall a. Output -> Cli a
done (Output -> Cli UnconflictedLocalDefnsView)
-> (Defn (Conflicted Name Referent) (Conflicted Name TypeReference)
    -> Output)
-> Defn (Conflicted Name Referent) (Conflicted Name TypeReference)
-> Cli UnconflictedLocalDefnsView
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text
-> Defn (Conflicted Name Referent) (Conflicted Name TypeReference)
-> Output
Output.ConflictedDefn Text
"merge")
          UnconflictedLocalDefnsView
lca <- Cli UnconflictedLocalDefnsView
-> (Branch Transaction -> Cli UnconflictedLocalDefnsView)
-> Maybe (Branch Transaction)
-> Cli UnconflictedLocalDefnsView
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (UnconflictedLocalDefnsView -> Cli UnconflictedLocalDefnsView
forall a. a -> Cli a
forall (f :: * -> *) a. Applicative f => a -> f a
pure UnconflictedLocalDefnsView
UnconflictedLocalDefnsView.empty) (Branch0 Transaction -> Cli UnconflictedLocalDefnsView
asUnconflicted (Branch0 Transaction -> Cli UnconflictedLocalDefnsView)
-> (Branch Transaction -> Branch0 Transaction)
-> Branch Transaction
-> Cli UnconflictedLocalDefnsView
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Branch Transaction -> Branch0 Transaction
forall (m :: * -> *). Branch m -> Branch0 m
Branch.head) TwoOrThreeWay (Branch Transaction)
branches.lca
          UnconflictedLocalDefnsView
alice <- Branch0 Transaction -> Cli UnconflictedLocalDefnsView
asUnconflicted (Branch Transaction -> Branch0 Transaction
forall (m :: * -> *). Branch m -> Branch0 m
Branch.head TwoOrThreeWay (Branch Transaction)
branches.alice)
          UnconflictedLocalDefnsView
bob <- Branch0 Transaction -> Cli UnconflictedLocalDefnsView
asUnconflicted (Branch Transaction -> Branch0 Transaction
forall (m :: * -> *). Branch m -> Branch0 m
Branch.head TwoOrThreeWay (Branch Transaction)
branches.bob)
          ThreeWay UnconflictedLocalDefnsView
-> Cli (ThreeWay UnconflictedLocalDefnsView)
forall a. a -> Cli a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Merge.ThreeWay {UnconflictedLocalDefnsView
lca :: UnconflictedLocalDefnsView
$sel:lca:ThreeWay :: UnconflictedLocalDefnsView
lca, UnconflictedLocalDefnsView
alice :: UnconflictedLocalDefnsView
$sel:alice:ThreeWay :: UnconflictedLocalDefnsView
alice, UnconflictedLocalDefnsView
bob :: UnconflictedLocalDefnsView
$sel:bob:ThreeWay :: UnconflictedLocalDefnsView
bob}

        -- Load decl name lookups
        GThreeWay PartialDeclNameLookup DeclNameLookup
declNameLookups <- do
          (Output -> Cli (GThreeWay PartialDeclNameLookup DeclNameLookup))
-> Cli
     (Either Output (GThreeWay PartialDeclNameLookup DeclNameLookup))
-> Cli (GThreeWay PartialDeclNameLookup DeclNameLookup)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> m (Either a b) -> m b
onLeftM Output -> Cli (GThreeWay PartialDeclNameLookup DeclNameLookup)
forall a. Output -> Cli a
done do
            ((forall void. Output -> Transaction void)
 -> Transaction (GThreeWay PartialDeclNameLookup DeclNameLookup))
-> Cli
     (Either Output (GThreeWay PartialDeclNameLookup DeclNameLookup))
forall a b.
((forall void. a -> Transaction void) -> Transaction b)
-> Cli (Either a b)
Cli.runTransactionWithRollbackE \forall void. Output -> Transaction void
rollback -> do
              PartialDeclNameLookup
lca <-
                case TwoOrThreeWay (Branch Transaction)
branches.lca of
                  Just Branch Transaction
lca -> Codebase IO Symbol Ann
-> BranchHash
-> UnconflictedLocalDefnsView
-> Transaction PartialDeclNameLookup
forall (m :: * -> *) v a.
Codebase m v a
-> BranchHash
-> UnconflictedLocalDefnsView
-> Transaction PartialDeclNameLookup
Codebase.getBranchPartialDeclNameLookup Env
env.codebase (Branch Transaction -> BranchHash
forall (m :: * -> *). Branch m -> BranchHash
Branch.namespaceHash Branch Transaction
lca) ThreeWay UnconflictedLocalDefnsView
defns.lca
                  Maybe (Branch Transaction)
Nothing -> PartialDeclNameLookup -> Transaction PartialDeclNameLookup
forall a. a -> Transaction a
forall (f :: * -> *) a. Applicative f => a -> f a
pure PartialDeclNameLookup
PartialDeclNameLookup.empty
              TwoWay DeclNameLookup
aliceAndBob <-
                TwoWay (Transaction DeclNameLookup)
-> Transaction (TwoWay DeclNameLookup)
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => TwoWay (m a) -> m (TwoWay a)
sequence (TwoWay (Transaction DeclNameLookup)
 -> Transaction (TwoWay DeclNameLookup))
-> TwoWay (Transaction DeclNameLookup)
-> Transaction (TwoWay DeclNameLookup)
forall a b. (a -> b) -> a -> b
$
                  ( \Branch Transaction
x UnconflictedLocalDefnsView
y MergeSourceOrTarget
z ->
                      Codebase IO Symbol Ann
-> BranchHash
-> UnconflictedLocalDefnsView
-> Transaction (Either IncoherentDeclReasons DeclNameLookup)
forall (m :: * -> *) v a.
Codebase m v a
-> BranchHash
-> UnconflictedLocalDefnsView
-> Transaction (Either IncoherentDeclReasons DeclNameLookup)
Codebase.getBranchDeclNameLookup Env
env.codebase (Branch Transaction -> BranchHash
forall (m :: * -> *). Branch m -> BranchHash
Branch.namespaceHash Branch Transaction
x) UnconflictedLocalDefnsView
y
                        Transaction (Either IncoherentDeclReasons DeclNameLookup)
-> (Transaction (Either IncoherentDeclReasons DeclNameLookup)
    -> Transaction DeclNameLookup)
-> Transaction DeclNameLookup
forall a b. a -> (a -> b) -> b
& (IncoherentDeclReasons -> Transaction DeclNameLookup)
-> Transaction (Either IncoherentDeclReasons DeclNameLookup)
-> Transaction DeclNameLookup
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> m (Either a b) -> m b
onLeftM \IncoherentDeclReasons
reasons ->
                          Output -> Transaction DeclNameLookup
forall void. Output -> Transaction void
rollback (MergeSourceOrTarget -> IncoherentDeclReason -> Output
Output.IncoherentDeclDuringMerge MergeSourceOrTarget
z (IncoherentDeclReasons -> IncoherentDeclReason
asOneRandomIncoherentDeclReason IncoherentDeclReasons
reasons))
                  )
                    (Branch Transaction
 -> UnconflictedLocalDefnsView
 -> MergeSourceOrTarget
 -> Transaction DeclNameLookup)
-> TwoWay (Branch Transaction)
-> TwoWay
     (UnconflictedLocalDefnsView
      -> MergeSourceOrTarget -> Transaction DeclNameLookup)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TwoOrThreeWay (Branch Transaction) -> TwoWay (Branch Transaction)
forall a. TwoOrThreeWay a -> TwoWay a
TwoOrThreeWay.forgetLca TwoOrThreeWay (Branch Transaction)
branches
                    TwoWay
  (UnconflictedLocalDefnsView
   -> MergeSourceOrTarget -> Transaction DeclNameLookup)
-> TwoWay UnconflictedLocalDefnsView
-> TwoWay (MergeSourceOrTarget -> Transaction DeclNameLookup)
forall a b. TwoWay (a -> b) -> TwoWay a -> TwoWay b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ThreeWay UnconflictedLocalDefnsView
-> TwoWay UnconflictedLocalDefnsView
forall a. ThreeWay a -> TwoWay a
ThreeWay.forgetLca ThreeWay UnconflictedLocalDefnsView
defns
                    TwoWay (MergeSourceOrTarget -> Transaction DeclNameLookup)
-> TwoWay MergeSourceOrTarget
-> TwoWay (Transaction DeclNameLookup)
forall a b. TwoWay (a -> b) -> TwoWay a -> TwoWay b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Merge.TwoWay {$sel:alice:TwoWay :: MergeSourceOrTarget
alice = MergeSourceOrTarget
mergeTarget, $sel:bob:TwoWay :: MergeSourceOrTarget
bob = MergeSourceOrTarget
mergeSource}
              GThreeWay PartialDeclNameLookup DeclNameLookup
-> Transaction (GThreeWay PartialDeclNameLookup DeclNameLookup)
forall a. a -> Transaction a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PartialDeclNameLookup
-> TwoWay DeclNameLookup
-> GThreeWay PartialDeclNameLookup DeclNameLookup
forall a b. a -> TwoWay b -> GThreeWay a b
ThreeWay.gfromTwoWay PartialDeclNameLookup
lca TwoWay DeclNameLookup
aliceAndBob)

        (Mergeblob (Branch Transaction)
mergeblob, Updated (Branch0 Transaction)
libdepsBranches) <- do
          let -- Hydrate definitions. Since we don't have to get them from separate codebases like Share does, we
              -- combine the three-way sets together.
              hydrate ::
                Pretty ColorText ->
                Merge.ThreeWay (DefnsF Set TermReferenceId TypeReferenceId) ->
                Transaction
                  ( Defns
                      (Map TermReferenceId (Term Symbol Ann, Type Symbol Ann))
                      (Map TypeReferenceId (Decl Symbol Ann))
                  )
              hydrate :: Pretty ColorText
-> ThreeWay (DefnsF Set Id Id)
-> Transaction
     (Defns
        (Map Id (Term Symbol Ann, Type Symbol Ann))
        (Map Id (Decl Symbol Ann)))
hydrate Pretty ColorText
message ThreeWay (DefnsF Set Id Id)
refs0
                | DefnsF Set Id Id -> Bool
forall (f :: * -> *) (g :: * -> *) a b.
(Foldable f, Foldable g) =>
Defns (f a) (g b) -> Bool
defnsAreEmpty DefnsF Set Id Id
refs = Defns
  (Map Id (Term Symbol Ann, Type Symbol Ann))
  (Map Id (Decl Symbol Ann))
-> Transaction
     (Defns
        (Map Id (Term Symbol Ann, Type Symbol Ann))
        (Map Id (Decl Symbol Ann)))
forall a. a -> Transaction a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Map Id (Term Symbol Ann, Type Symbol Ann)
-> Map Id (Decl Symbol Ann)
-> Defns
     (Map Id (Term Symbol Ann, Type Symbol Ann))
     (Map Id (Decl Symbol Ann))
forall terms types. terms -> types -> Defns terms types
Defns Map Id (Term Symbol Ann, Type Symbol Ann)
forall k a. Map k a
Map.empty Map Id (Decl Symbol Ann)
forall k a. Map k a
Map.empty)
                | Bool
otherwise = do
                    IO () -> Transaction ()
forall a. HasCallStack => IO a -> Transaction a
Sqlite.unsafeIO (Output -> IO ()
respondRegion (Pretty ColorText -> Output
Output.Literal Pretty ColorText
message))
                    (Hash -> Transaction [(Term Symbol Ann, Type Symbol Ann)])
-> (Hash -> Transaction [Decl Symbol Ann])
-> DefnsF Set Id Id
-> Transaction
     (Defns
        (Map Id (Term Symbol Ann, Type Symbol Ann))
        (Map Id (Decl Symbol Ann)))
forall (m :: * -> *) term typ.
Monad m =>
(Hash -> m [term])
-> (Hash -> m [typ])
-> DefnsF Set Id Id
-> m (Defns (Map Id term) (Map Id typ))
hydrateRefs
                      (Codebase IO Symbol Ann
-> Hash -> Transaction [(Term Symbol Ann, Type Symbol Ann)]
forall (m :: * -> *) v a.
HasCallStack =>
Codebase m v a -> Hash -> Transaction [(Term v a, Type v a)]
Codebase.unsafeGetTermComponent Env
env.codebase)
                      HasCallStack => Hash -> Transaction [Decl Symbol Ann]
Hash -> Transaction [Decl Symbol Ann]
Operations.expectDeclComponent
                      DefnsF Set Id Id
refs
                where
                  refs :: DefnsF Set Id Id
refs = ThreeWay (DefnsF Set Id Id) -> DefnsF Set Id Id
forall m. Monoid m => ThreeWay m -> m
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold ThreeWay (DefnsF Set Id Id)
refs0

              -- Ignore the input (dependencies whose names we need), because we already have all names in memory
              -- in the Branch object. That isn't true on Share, for example, where we load these names from the
              -- database in a separate follow-up query.
              loadNames :: Merge.ThreeWay (Set LabeledDependency) -> Transaction (Merge.ThreeWay Names)
              loadNames :: ThreeWay (Set LabeledDependency) -> Transaction (ThreeWay Names)
loadNames ThreeWay (Set LabeledDependency)
_ =
                ThreeWay Names -> Transaction (ThreeWay Names)
forall a. a -> Transaction a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Names -> TwoOrThreeWay Names -> ThreeWay Names
forall a. a -> TwoOrThreeWay a -> ThreeWay a
TwoOrThreeWay.toThreeWay Names
Names.empty (Branch0 Transaction -> Names
forall (m :: * -> *). Branch0 m -> Names
Branch.toNames (Branch0 Transaction -> Names)
-> (Branch Transaction -> Branch0 Transaction)
-> Branch Transaction
-> Names
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting
  (Branch0 Transaction) (Branch Transaction) (Branch0 Transaction)
-> Branch Transaction -> Branch0 Transaction
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting
  (Branch0 Transaction) (Branch Transaction) (Branch0 Transaction)
forall (m :: * -> *) (f :: * -> *).
Functor f =>
(Branch0 m -> f (Branch0 m)) -> Branch m -> f (Branch m)
Branch.head_ (Branch Transaction -> Names)
-> TwoOrThreeWay (Branch Transaction) -> TwoOrThreeWay Names
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TwoOrThreeWay (Branch Transaction)
branches))

          (Output
 -> Cli
      (Mergeblob (Branch Transaction), Updated (Branch0 Transaction)))
-> Cli
     (Either
        Output
        (Mergeblob (Branch Transaction), Updated (Branch0 Transaction)))
-> Cli
     (Mergeblob (Branch Transaction), Updated (Branch0 Transaction))
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> m (Either a b) -> m b
onLeftM Output
-> Cli
     (Mergeblob (Branch Transaction), Updated (Branch0 Transaction))
forall a. Output -> Cli a
done do
            ((forall void. Output -> Transaction void)
 -> Transaction
      (Mergeblob (Branch Transaction), Updated (Branch0 Transaction)))
-> Cli
     (Either
        Output
        (Mergeblob (Branch Transaction), Updated (Branch0 Transaction)))
forall a b.
((forall void. a -> Transaction void) -> Transaction b)
-> Cli (Either a b)
Cli.runTransactionWithRollbackE \forall void. Output -> Transaction void
rollback -> do
              IO () -> Transaction ()
forall a. HasCallStack => IO a -> Transaction a
Sqlite.unsafeIO (Output -> IO ()
respondRegion (Pretty ColorText -> Output
Output.Literal Pretty ColorText
"Computing diff..."))

              Diffblob (Branch Transaction)
diffblob <-
                DiffblobLog Transaction
-> (ThreeWay (DefnsF Set Id Id)
    -> Transaction
         (Defns
            (Map Id (Term Symbol Ann, Type Symbol Ann))
            (Map Id (Decl Symbol Ann))))
-> (ThreeWay (Set LabeledDependency)
    -> Transaction (ThreeWay Names))
-> ThreeWay UnconflictedLocalDefnsView
-> ThreeWay (Map NameSegment (Branch Transaction))
-> GThreeWay PartialDeclNameLookup DeclNameLookup
-> Transaction (Diffblob (Branch Transaction))
forall libdep (m :: * -> *).
(Eq libdep, Monad m) =>
DiffblobLog m
-> (ThreeWay (DefnsF Set Id Id)
    -> m (Defns
            (Map Id (Term Symbol Ann, Type Symbol Ann))
            (Map Id (Decl Symbol Ann))))
-> (ThreeWay (Set LabeledDependency) -> m (ThreeWay Names))
-> ThreeWay UnconflictedLocalDefnsView
-> ThreeWay (Map NameSegment libdep)
-> GThreeWay PartialDeclNameLookup DeclNameLookup
-> m (Diffblob libdep)
Merge.makeDiffblob
                  Merge.DiffblobLog
                    { $sel:logDefns:DiffblobLog :: ThreeWay (DefnsF (Map Name) Referent TypeReference)
-> Transaction ()
logDefns =
                        -- Sqlite.unsafeIO . debugFunctions.debugDefns
                        ThreeWay (DefnsF (Map Name) Referent TypeReference)
-> Transaction ()
forall a. Monoid a => a
mempty,
                      $sel:logNarrowedDefns:DiffblobLog :: TwoWay (Updated (DefnsF (Map Name) Referent TypeReference))
-> Transaction ()
logNarrowedDefns = IO () -> Transaction ()
forall a. HasCallStack => IO a -> Transaction a
Sqlite.unsafeIO (IO () -> Transaction ())
-> (TwoWay (Updated (DefnsF (Map Name) Referent TypeReference))
    -> IO ())
-> TwoWay (Updated (DefnsF (Map Name) Referent TypeReference))
-> Transaction ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DebugFunctions
debugFunctions.debugNarrowedDefns,
                      $sel:logSynhashedNarrowedDefns:DiffblobLog :: TwoWay
  (Updated (DefnsF2 (Map Name) Synhashed Referent TypeReference))
-> Transaction ()
logSynhashedNarrowedDefns = IO () -> Transaction ()
forall a. HasCallStack => IO a -> Transaction a
Sqlite.unsafeIO (IO () -> Transaction ())
-> (TwoWay
      (Updated (DefnsF2 (Map Name) Synhashed Referent TypeReference))
    -> IO ())
-> TwoWay
     (Updated (DefnsF2 (Map Name) Synhashed Referent TypeReference))
-> Transaction ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DebugFunctions
debugFunctions.debugSynhashedNarrowedDefns,
                      $sel:logDiffsFromLCA:DiffblobLog :: TwoWay (DefnsF3 (Map Name) DiffOp Synhashed Referent TypeReference)
-> Transaction ()
logDiffsFromLCA = IO () -> Transaction ()
forall a. HasCallStack => IO a -> Transaction a
Sqlite.unsafeIO (IO () -> Transaction ())
-> (TwoWay
      (DefnsF3 (Map Name) DiffOp Synhashed Referent TypeReference)
    -> IO ())
-> TwoWay
     (DefnsF3 (Map Name) DiffOp Synhashed Referent TypeReference)
-> Transaction ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DebugFunctions
debugFunctions.debugDiffs,
                      $sel:logDiff:DiffblobLog :: DefnsF2 (Map Name) CombinedDiffOp Referent TypeReference
-> Transaction ()
logDiff = IO () -> Transaction ()
forall a. HasCallStack => IO a -> Transaction a
Sqlite.unsafeIO (IO () -> Transaction ())
-> (DefnsF2 (Map Name) CombinedDiffOp Referent TypeReference
    -> IO ())
-> DefnsF2 (Map Name) CombinedDiffOp Referent TypeReference
-> Transaction ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DebugFunctions
debugFunctions.debugCombinedDiff
                    }
                  (Pretty ColorText
-> ThreeWay (DefnsF Set Id Id)
-> Transaction
     (Defns
        (Map Id (Term Symbol Ann, Type Symbol Ann))
        (Map Id (Decl Symbol Ann)))
hydrate Pretty ColorText
"Loading definitions...")
                  ThreeWay (Set LabeledDependency) -> Transaction (ThreeWay Names)
loadNames
                  ThreeWay UnconflictedLocalDefnsView
defns
                  ( let f :: Branch Transaction -> Map NameSegment (Branch Transaction)
f = Getting
  (Map NameSegment (Branch Transaction))
  (Branch Transaction)
  (Map NameSegment (Branch Transaction))
-> Branch Transaction -> Map NameSegment (Branch Transaction)
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view ((Branch0 Transaction
 -> Const
      (Map NameSegment (Branch Transaction)) (Branch0 Transaction))
-> Branch Transaction
-> Const
     (Map NameSegment (Branch Transaction)) (Branch Transaction)
forall (m :: * -> *) (f :: * -> *).
Functor f =>
(Branch0 m -> f (Branch0 m)) -> Branch m -> f (Branch m)
Branch.head_ ((Branch0 Transaction
  -> Const
       (Map NameSegment (Branch Transaction)) (Branch0 Transaction))
 -> Branch Transaction
 -> Const
      (Map NameSegment (Branch Transaction)) (Branch Transaction))
-> ((Map NameSegment (Branch Transaction)
     -> Const
          (Map NameSegment (Branch Transaction))
          (Map NameSegment (Branch Transaction)))
    -> Branch0 Transaction
    -> Const
         (Map NameSegment (Branch Transaction)) (Branch0 Transaction))
-> Getting
     (Map NameSegment (Branch Transaction))
     (Branch Transaction)
     (Map NameSegment (Branch Transaction))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map NameSegment (Branch Transaction)
 -> Const
      (Map NameSegment (Branch Transaction))
      (Map NameSegment (Branch Transaction)))
-> Branch0 Transaction
-> Const
     (Map NameSegment (Branch Transaction)) (Branch0 Transaction)
forall (m :: * -> *) (f :: * -> *).
Applicative f =>
(Map NameSegment (Branch m) -> f (Map NameSegment (Branch m)))
-> Branch0 m -> f (Branch0 m)
Branch.libdeps_)
                     in Merge.ThreeWay
                          { $sel:lca:ThreeWay :: Map NameSegment (Branch Transaction)
lca = Map NameSegment (Branch Transaction)
-> (Branch Transaction -> Map NameSegment (Branch Transaction))
-> Maybe (Branch Transaction)
-> Map NameSegment (Branch Transaction)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Map NameSegment (Branch Transaction)
forall k a. Map k a
Map.empty Branch Transaction -> Map NameSegment (Branch Transaction)
f TwoOrThreeWay (Branch Transaction)
branches.lca,
                            $sel:alice:ThreeWay :: Map NameSegment (Branch Transaction)
alice = Branch Transaction -> Map NameSegment (Branch Transaction)
f TwoOrThreeWay (Branch Transaction)
branches.alice,
                            $sel:bob:ThreeWay :: Map NameSegment (Branch Transaction)
bob = Branch Transaction -> Map NameSegment (Branch Transaction)
f TwoOrThreeWay (Branch Transaction)
branches.bob
                          }
                  )
                  GThreeWay PartialDeclNameLookup DeclNameLookup
declNameLookups

              let libdepsBranches :: Updated (Branch0 Transaction)
libdepsBranches =
                    Diffblob (Branch Transaction)
diffblob.libdeps Updated (Map NameSegment (Branch Transaction))
-> (Updated (Map NameSegment (Branch Transaction))
    -> Updated (Branch0 Transaction))
-> Updated (Branch0 Transaction)
forall a b. a -> (a -> b) -> b
& (Map NameSegment (Branch Transaction) -> Branch0 Transaction)
-> Updated (Map NameSegment (Branch Transaction))
-> Updated (Branch0 Transaction)
forall a b. (a -> b) -> Updated a -> Updated b
Updated.map \Map NameSegment (Branch Transaction)
libdeps ->
                      Branch0 Transaction
forall (m :: * -> *). Branch0 m
Branch.empty0 Branch0 Transaction
-> (Branch0 Transaction -> Branch0 Transaction)
-> Branch0 Transaction
forall a b. a -> (a -> b) -> b
& (Map NameSegment (Branch Transaction)
 -> Identity (Map NameSegment (Branch Transaction)))
-> Branch0 Transaction -> Identity (Branch0 Transaction)
forall (m :: * -> *) (f :: * -> *).
Functor f =>
(Map NameSegment (Branch m) -> f (Map NameSegment (Branch m)))
-> Branch0 m -> f (Branch0 m)
Branch.children_ ((Map NameSegment (Branch Transaction)
  -> Identity (Map NameSegment (Branch Transaction)))
 -> Branch0 Transaction -> Identity (Branch0 Transaction))
-> Map NameSegment (Branch Transaction)
-> Branch0 Transaction
-> Branch0 Transaction
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Map NameSegment (Branch Transaction)
libdeps

              IO () -> Transaction ()
forall a. HasCallStack => IO a -> Transaction a
Sqlite.unsafeIO (Output -> IO ()
respondRegion (Pretty ColorText -> Output
Output.Literal Pretty ColorText
"Computing merge..."))

              Mergeblob (Branch Transaction)
mergeblob <- do
                let handleMergeblobError :: MergeblobError -> Transaction (Mergeblob (Branch Transaction))
handleMergeblobError MergeblobError
err =
                      Output -> Transaction (Mergeblob (Branch Transaction))
forall void. Output -> Transaction void
rollback case MergeblobError
err of
                        Merge.MergeblobError'ConflictedAlias EitherWay (Defn (Name, Name) (Name, Name))
defn0 ->
                          case EitherWay (Defn (Name, Name) (Name, Name))
defn0 of
                            Merge.Alice Defn (Name, Name) (Name, Name)
defn -> MergeSourceOrTarget -> Defn (Name, Name) (Name, Name) -> Output
Output.MergeConflictedAliases MergeSourceOrTarget
mergeTarget Defn (Name, Name) (Name, Name)
defn
                            Merge.Bob Defn (Name, Name) (Name, Name)
defn -> MergeSourceOrTarget -> Defn (Name, Name) (Name, Name) -> Output
Output.MergeConflictedAliases MergeSourceOrTarget
mergeSource Defn (Name, Name) (Name, Name)
defn
                        Merge.MergeblobError'ConflictedBuiltin Defn Name Name
defn -> Defn Name Name -> Output
Output.MergeConflictInvolvingBuiltin Defn Name Name
defn
                (MergeblobError -> Transaction (Mergeblob (Branch Transaction)))
-> Transaction
     (Either MergeblobError (Mergeblob (Branch Transaction)))
-> Transaction (Mergeblob (Branch Transaction))
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> m (Either a b) -> m b
onLeftM MergeblobError -> Transaction (Mergeblob (Branch Transaction))
handleMergeblobError do
                  (ThreeWay (DefnsF Set Id Id)
 -> Transaction
      (Defns
         (Map Id (Term Symbol Ann, Type Symbol Ann))
         (Map Id (Decl Symbol Ann))))
-> (DefnsF Set Id Id
    -> Set TypeReference -> Transaction (DefnsF Set Id Id))
-> Transaction (Updated Names)
-> (DefnsF Set TypeReference TypeReference
    -> Transaction (TypeLookup Symbol Ann))
-> Diffblob (Branch Transaction)
-> TwoWay Text
-> Transaction
     (Either MergeblobError (Mergeblob (Branch Transaction)))
forall (m :: * -> *) libdep.
Monad m =>
(ThreeWay (DefnsF Set Id Id)
 -> m (Defns
         (Map Id (Term Symbol Ann, Type Symbol Ann))
         (Map Id (Decl Symbol Ann))))
-> (DefnsF Set Id Id -> Set TypeReference -> m (DefnsF Set Id Id))
-> m (Updated Names)
-> (DefnsF Set TypeReference TypeReference
    -> m (TypeLookup Symbol Ann))
-> Diffblob libdep
-> TwoWay Text
-> m (Either MergeblobError (Mergeblob libdep))
Merge.makeMergeblob
                    (Pretty ColorText
-> ThreeWay (DefnsF Set Id Id)
-> Transaction
     (Defns
        (Map Id (Term Symbol Ann, Type Symbol Ann))
        (Map Id (Decl Symbol Ann)))
hydrate Pretty ColorText
"Loading more definitions...")
                    DefnsF Set Id Id
-> Set TypeReference -> Transaction (DefnsF Set Id Id)
Operations.transitiveDependentsWithinScope
                    (Updated Names -> Transaction (Updated Names)
forall a. a -> Transaction a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Branch0 Transaction -> Names)
-> Updated (Branch0 Transaction) -> Updated Names
forall a b. (a -> b) -> Updated a -> Updated b
Updated.map Branch0 Transaction -> Names
forall (m :: * -> *). Branch0 m -> Names
Branch.toNames Updated (Branch0 Transaction)
libdepsBranches))
                    (Codebase IO Symbol Ann
-> DefnsF Set TypeReference TypeReference
-> Transaction (TypeLookup Symbol Ann)
Codebase.typeLookupForDependencies Env
env.codebase)
                    Diffblob (Branch Transaction)
diffblob
                    Merge.TwoWay
                      { $sel:alice:TwoWay :: Text
alice = forall target source. From source target => source -> target
into @Text MergeTarget
aliceBranchNames,
                        $sel:bob:TwoWay :: Text
bob =
                          case MergeInfo
info.bob.source of
                            MergeSource'LocalProjectBranch ProjectAndBranch Project ProjectBranch
bobBranch -> forall target source. From source target => source -> target
into @Text (ProjectAndBranch Project ProjectBranch -> MergeTarget
ProjectUtils.justTheNames ProjectAndBranch Project ProjectBranch
bobBranch)
                            MergeSource'RemoteProjectBranch RemoteProjectBranch
bobBranch
                              | MergeTarget
aliceBranchNames MergeTarget -> MergeTarget -> Bool
forall a. Eq a => a -> a -> Bool
== MergeTarget
bobBranchNames -> Text
"remote " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> forall target source. From source target => source -> target
into @Text MergeTarget
bobBranchNames
                              | Bool
otherwise -> forall target source. From source target => source -> target
into @Text MergeTarget
bobBranchNames
                              where
                                bobBranchNames :: MergeTarget
bobBranchNames =
                                  ProjectName -> ProjectBranchName -> MergeTarget
forall a b. a -> b -> ProjectAndBranch a b
ProjectAndBranch RemoteProjectBranch
bobBranch.projectName RemoteProjectBranch
bobBranch.branchName
                            MergeSource'RemoteLooseCode ReadShareLooseCode
info ->
                              case Path -> Maybe Name
forall path. Namey path => path -> Maybe Name
Path.toName ReadShareLooseCode
info.path of
                                Maybe Name
Nothing -> Text
"<root>"
                                Just Name
name -> Name -> Text
Name.toText Name
name
                      }

              (Mergeblob (Branch Transaction), Updated (Branch0 Transaction))
-> Transaction
     (Mergeblob (Branch Transaction), Updated (Branch0 Transaction))
forall a. a -> Transaction a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Mergeblob (Branch Transaction)
mergeblob, Updated (Branch0 Transaction)
libdepsBranches)

        let makeMergeNode :: (Branch0 Transaction -> Branch0 Transaction) -> Branch Transaction
            makeMergeNode :: (Branch0 Transaction -> Branch0 Transaction) -> Branch Transaction
makeMergeNode =
              let unconflictedBranch :: Branch0 Transaction
unconflictedBranch =
                    DefnsF (Map Name) Referent TypeReference -> Branch0 Transaction
forall (m :: * -> *).
DefnsF (Map Name) Referent TypeReference -> Branch0 m
Branch.fromUnconflictedDefns Mergeblob (Branch Transaction)
mergeblob.unconflictedDefns
                      Branch0 Transaction
-> (Branch0 Transaction -> Branch0 Transaction)
-> Branch0 Transaction
forall a b. a -> (a -> b) -> b
& Branch0 Transaction -> Branch0 Transaction -> Branch0 Transaction
forall (m :: * -> *). Branch0 m -> Branch0 m -> Branch0 m
Branch.setLibdeps Updated (Branch0 Transaction)
libdepsBranches.new
               in \Branch0 Transaction -> Branch0 Transaction
f ->
                    Branch0 Transaction
-> (CausalHash, Transaction (Branch Transaction))
-> (CausalHash, Transaction (Branch Transaction))
-> Branch Transaction
forall (m :: * -> *).
Applicative m =>
Branch0 m
-> (CausalHash, m (Branch m))
-> (CausalHash, m (Branch m))
-> Branch m
Branch.mergeNode
                      (Branch0 Transaction -> Branch0 Transaction
f Branch0 Transaction
unconflictedBranch)
                      (Branch Transaction -> CausalHash
forall (m :: * -> *). Branch m -> CausalHash
Branch.headHash TwoOrThreeWay (Branch Transaction)
branches.alice, Branch Transaction -> Transaction (Branch Transaction)
forall a. a -> Transaction a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TwoOrThreeWay (Branch Transaction)
branches.alice)
                      (Branch Transaction -> CausalHash
forall (m :: * -> *). Branch m -> CausalHash
Branch.headHash TwoOrThreeWay (Branch Transaction)
branches.bob, Branch Transaction -> Transaction (Branch Transaction)
forall a. a -> Transaction a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TwoOrThreeWay (Branch Transaction)
branches.bob)

        TypecheckedUnisonFile Symbol Ann
typecheckedFile <-
          Mergeblob (Branch Transaction)
mergeblob.typecheckedFile Maybe (TypecheckedUnisonFile Symbol Ann)
-> (Maybe (TypecheckedUnisonFile Symbol Ann)
    -> Cli (TypecheckedUnisonFile Symbol Ann))
-> Cli (TypecheckedUnisonFile Symbol Ann)
forall a b. a -> (a -> b) -> b
& Cli (TypecheckedUnisonFile Symbol Ann)
-> Maybe (TypecheckedUnisonFile Symbol Ann)
-> Cli (TypecheckedUnisonFile Symbol Ann)
forall (m :: * -> *) a. Applicative m => m a -> Maybe a -> m a
onNothing do
            Env
env <- Cli Env
forall r (m :: * -> *). MonadReader r m => m r
ask
            (ProjectAndBranch ProjectId ProjectBranchId
_temporaryBranchId, ProjectBranchName
temporaryBranchName) <-
              Text
-> CreateFrom
-> Project
-> Transaction ProjectBranchName
-> Cli
     (ProjectAndBranch ProjectId ProjectBranchId, ProjectBranchName)
HandleInput.Branch.createBranch
                MergeInfo
info.description
                ( let sourceStuff :: (CreateFromMergeSource, CausalHash, Map Name Text)
sourceStuff =
                        ( case MergeInfo
info.bob.source of
                            MergeSource'LocalProjectBranch ProjectAndBranch Project ProjectBranch
bobBranch ->
                              ProjectBranch -> CreateFromMergeSource
HandleInput.Branch.CreateFromMergeSource'Local ProjectAndBranch Project ProjectBranch
bobBranch.branch
                            MergeSource'RemoteProjectBranch RemoteProjectBranch
bobBranch ->
                              RemoteProjectBranch -> URI -> CreateFromMergeSource
HandleInput.Branch.CreateFromMergeSource'Remote RemoteProjectBranch
bobBranch URI
Share.hardCodedUri
                            MergeSource'RemoteLooseCode ReadShareLooseCode
_ -> CreateFromMergeSource
HandleInput.Branch.CreateFromMergeSource'LooseCode,
                          MergeInfo
info.bob.causalHash,
                          Mergeblob (Branch Transaction)
mergeblob.uniqueTypeGuids.bob
                        )
                      targetStuff :: (ProjectBranch, CausalHash, Map Name Text)
targetStuff =
                        ( MergeInfo
info.alice.projectAndBranch.branch,
                          MergeInfo
info.alice.causalHash,
                          Mergeblob (Branch Transaction)
mergeblob.uniqueTypeGuids.alice
                        )
                      mergeStuff :: Branch Transaction
mergeStuff = (Branch0 Transaction -> Branch0 Transaction) -> Branch Transaction
makeMergeNode Branch0 Transaction -> Branch0 Transaction
forall a. a -> a
id
                   in (CreateFromMergeSource, CausalHash, Map Name Text)
-> (ProjectBranch, CausalHash, Map Name Text)
-> Branch Transaction
-> CreateFrom
HandleInput.Branch.CreateFrom'MergeParents (CreateFromMergeSource, CausalHash, Map Name Text)
sourceStuff (ProjectBranch, CausalHash, Map Name Text)
targetStuff Branch Transaction
mergeStuff
                )
                MergeInfo
info.alice.projectAndBranch.project
                (ProjectId -> MergeSourceAndTarget -> Transaction ProjectBranchName
findTemporaryBranchName MergeInfo
info.alice.projectAndBranch.project.projectId MergeSourceAndTarget
mergeSourceAndTarget)

            --   Merge conflicts?    Have UCM_MERGETOOL?    Result
            --   ----------------    -------------------    ------------------------------------------------------------
            --                 No                     No           Put code that doesn't parse or typecheck in scratch.u
            --                 No                    Yes           Put code that doesn't parse or typecheck in scratch.u
            --                Yes                     No    Put code that doesn't parse (because conflicts) in scratch.u
            --                Yes                    Yes                                              Run that cool tool

            Maybe FilePath
maybeMergetool <-
              if Bool -> Bool
not (DefnsF (Map Name) Id Id -> Bool
forall (f :: * -> *) (g :: * -> *) a b.
(Foldable f, Foldable g) =>
Defns (f a) (g b) -> Bool
defnsAreEmpty Mergeblob (Branch Transaction)
mergeblob.conflicts.alice)
                then IO (Maybe FilePath) -> Cli (Maybe FilePath)
forall a. IO a -> Cli a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (FilePath -> IO (Maybe FilePath)
lookupEnv FilePath
"UCM_MERGETOOL")
                else Maybe FilePath -> Cli (Maybe FilePath)
forall a. a -> Cli a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe FilePath
forall a. Maybe a
Nothing

            case Maybe FilePath
maybeMergetool of
              Maybe FilePath
Nothing -> do
                FilePath
scratchFilePath <-
                  Cli (Maybe (FilePath, Bool))
Cli.getLatestFile Cli (Maybe (FilePath, Bool))
-> (Maybe (FilePath, Bool) -> FilePath) -> Cli FilePath
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \case
                    Maybe (FilePath, Bool)
Nothing -> FilePath
"scratch.u"
                    Just (FilePath
file, Bool
_) -> FilePath
file
                IO () -> Cli ()
forall a. IO a -> Cli a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Cli ()) -> IO () -> Cli ()
forall a b. (a -> b) -> a -> b
$
                  Env
env.writeSource
                    (FilePath -> Text
Text.pack FilePath
scratchFilePath)
                    (FilePath -> Text
Text.pack (FilePath -> Text) -> FilePath -> Text
forall a b. (a -> b) -> a -> b
$ Width -> Pretty ColorText -> FilePath
Pretty.toPlain Width
80 Mergeblob (Branch Transaction)
mergeblob.unparsedFile)
                    Bool
True
                Output -> Cli (TypecheckedUnisonFile Symbol Ann)
forall a. Output -> Cli a
done (FilePath -> MergeSourceAndTarget -> ProjectBranchName -> Output
Output.MergeFailure FilePath
scratchFilePath MergeSourceAndTarget
mergeSourceAndTarget ProjectBranchName
temporaryBranchName)
              Just FilePath
mergetool0 -> do
                let aliceFilenameSlug :: Builder
aliceFilenameSlug = ProjectBranchName -> Builder
projectBranchNameToValidProjectBranchNameText MergeSourceAndTarget
mergeSourceAndTarget.alice.branch
                let bobFilenameSlug :: Builder
bobFilenameSlug = MergeSource -> Builder
mangleMergeSource MergeSourceAndTarget
mergeSourceAndTarget.bob
                Builder -> Text
makeTempFilename <-
                  IO (Builder -> Text) -> Cli (Builder -> Text)
forall a. IO a -> Cli a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO do
                    FilePath
tmpdir0 <- IO FilePath
getTemporaryDirectory
                    FilePath
tmpdir1 <- FilePath -> IO FilePath
canonicalizePath FilePath
tmpdir0
                    FilePath
tmpdir2 <- FilePath -> FilePath -> IO FilePath
Temporary.createTempDirectory FilePath
tmpdir1 FilePath
"unison-merge"
                    (Builder -> Text) -> IO (Builder -> Text)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure \Builder
filename -> FilePath -> Text
Text.pack (FilePath
tmpdir2 FilePath -> FilePath -> FilePath
</> Text -> FilePath
Text.unpack (Builder -> Text
Text.Builder.run Builder
filename))
                let filenames :: ThreeWay Text
filenames =
                      (Builder -> Text) -> ThreeWay Builder -> ThreeWay Text
forall a b. (a -> b) -> ThreeWay a -> ThreeWay b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
                        Builder -> Text
makeTempFilename
                        Merge.ThreeWay
                          { $sel:lca:ThreeWay :: Builder
lca = Builder
aliceFilenameSlug Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
"-" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
bobFilenameSlug Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
"-base.u",
                            $sel:alice:ThreeWay :: Builder
alice = Builder
aliceFilenameSlug Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
".u",
                            $sel:bob:ThreeWay :: Builder
bob = Builder
bobFilenameSlug Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
".u"
                          }
                let mergedFilename :: Text
mergedFilename = Builder -> Text
Text.Builder.run (Builder
aliceFilenameSlug Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
"-" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
bobFilenameSlug Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
"-merged.u")
                let mergetool :: Text
mergetool =
                      FilePath
mergetool0
                        FilePath -> (FilePath -> Text) -> Text
forall a b. a -> (a -> b) -> b
& FilePath -> Text
Text.pack
                        Text -> (Text -> Text) -> Text
forall a b. a -> (a -> b) -> b
& HasCallStack => Text -> Text -> Text -> Text
Text -> Text -> Text -> Text
Text.replace Text
"$BASE" ThreeWay Text
filenames.lca
                        Text -> (Text -> Text) -> Text
forall a b. a -> (a -> b) -> b
& HasCallStack => Text -> Text -> Text -> Text
Text -> Text -> Text -> Text
Text.replace Text
"$LOCAL" ThreeWay Text
filenames.alice
                        Text -> (Text -> Text) -> Text
forall a b. a -> (a -> b) -> b
& HasCallStack => Text -> Text -> Text -> Text
Text -> Text -> Text -> Text
Text.replace Text
"$MERGED" Text
mergedFilename
                        Text -> (Text -> Text) -> Text
forall a b. a -> (a -> b) -> b
& HasCallStack => Text -> Text -> Text -> Text
Text -> Text -> Text -> Text
Text.replace Text
"$REMOTE" ThreeWay Text
filenames.bob
                ExitCode
exitCode <-
                  IO ExitCode -> Cli ExitCode
forall a. IO a -> Cli a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO do
                    let fileContents :: ThreeWay Text
fileContents = FilePath -> Text
Text.pack (FilePath -> Text)
-> (Pretty ColorText -> FilePath) -> Pretty ColorText -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Width -> Pretty ColorText -> FilePath
Pretty.toPlain Width
80 (Pretty ColorText -> Text)
-> ThreeWay (Pretty ColorText) -> ThreeWay Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Mergeblob (Branch Transaction)
mergeblob.unparsedSoloFiles
                    FilePath -> IO ()
removeFile (Text -> FilePath
Text.unpack Text
mergedFilename) IO () -> IO () -> IO ()
forall a. IO a -> IO a -> IO a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
                    ThreeWay (Text, Text) -> ((Text, Text) -> IO ()) -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ ((,) (Text -> Text -> (Text, Text))
-> ThreeWay Text -> ThreeWay (Text -> (Text, Text))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ThreeWay Text
filenames ThreeWay (Text -> (Text, Text))
-> ThreeWay Text -> ThreeWay (Text, Text)
forall a b. ThreeWay (a -> b) -> ThreeWay a -> ThreeWay b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ThreeWay Text
fileContents) \(Text
name, Text
contents) ->
                      Env
env.writeSource Text
name Text
contents Bool
True
                    Env
env.writeSource
                      Text
mergedFilename
                      ( MergeSourceAndTarget -> Text -> Text -> Text
makeMergedFileContents
                          MergeSourceAndTarget
mergeSourceAndTarget
                          ThreeWay Text
fileContents.alice
                          ThreeWay Text
fileContents.bob
                      )
                      Bool
True
                    let createProcess :: CreateProcess
createProcess = (FilePath -> CreateProcess
Process.shell (Text -> FilePath
Text.unpack Text
mergetool)) {Process.delegate_ctlc = True}
                    CreateProcess
-> (Maybe Handle
    -> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO ExitCode)
-> IO ExitCode
forall a.
CreateProcess
-> (Maybe Handle
    -> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO a)
-> IO a
Process.withCreateProcess CreateProcess
createProcess \Maybe Handle
_ Maybe Handle
_ Maybe Handle
_ -> ProcessHandle -> IO ExitCode
Process.waitForProcess
                Output -> Cli (TypecheckedUnisonFile Symbol Ann)
forall a. Output -> Cli a
done (MergeSourceAndTarget
-> ProjectBranchName -> Text -> ExitCode -> Output
Output.MergeFailureWithMergetool MergeSourceAndTarget
mergeSourceAndTarget ProjectBranchName
temporaryBranchName Text
mergetool ExitCode
exitCode)

        Transaction () -> Cli ()
forall a. Transaction a -> Cli a
Cli.runTransaction (Codebase IO Symbol Ann
-> TypecheckedUnisonFile Symbol Ann -> Transaction ()
forall (m :: * -> *) v a.
(Var v, Show a) =>
Codebase m v a -> TypecheckedUnisonFile v a -> Transaction ()
Codebase.addDefsToCodebase Env
env.codebase TypecheckedUnisonFile Symbol Ann
typecheckedFile)
        ProjectBranch -> Text -> (Branch IO -> Branch IO) -> Cli ()
Cli.updateProjectBranchRoot_
          MergeInfo
info.alice.projectAndBranch.branch
          MergeInfo
info.description
          \Branch IO
_aliceBranch ->
            TypecheckedUnisonFile Symbol Ann
typecheckedFile
              TypecheckedUnisonFile Symbol Ann
-> (TypecheckedUnisonFile Symbol Ann
    -> [(Path, Branch0 Transaction -> Branch0 Transaction)])
-> [(Path, Branch0 Transaction -> Branch0 Transaction)]
forall a b. a -> (a -> b) -> b
& TypecheckedUnisonFile Symbol Ann
-> [(Path, Branch0 Transaction -> Branch0 Transaction)]
forall (m :: * -> *).
TypecheckedUnisonFile Symbol Ann
-> [(Path, Branch0 m -> Branch0 m)]
typecheckedUnisonFileToBranchAdds
              [(Path, Branch0 Transaction -> Branch0 Transaction)]
-> ([(Path, Branch0 Transaction -> Branch0 Transaction)]
    -> Branch0 Transaction -> Branch0 Transaction)
-> Branch0 Transaction
-> Branch0 Transaction
forall a b. a -> (a -> b) -> b
& [(Path, Branch0 Transaction -> Branch0 Transaction)]
-> Branch0 Transaction -> Branch0 Transaction
forall (f :: * -> *) (m :: * -> *).
(Monad m, Foldable f) =>
f (Path, Branch0 m -> Branch0 m) -> Branch0 m -> Branch0 m
Branch.batchUpdates
              (Branch0 Transaction -> Branch0 Transaction)
-> ((Branch0 Transaction -> Branch0 Transaction)
    -> Branch Transaction)
-> Branch Transaction
forall a b. a -> (a -> b) -> b
& (Branch0 Transaction -> Branch0 Transaction) -> Branch Transaction
makeMergeNode
              -- Awkward: we have a Branch Transaction but we need a Branch IO (because reasons)
              Branch Transaction
-> (Branch Transaction -> Branch IO) -> Branch IO
forall a b. a -> (a -> b) -> b
& (forall a. Transaction a -> IO a)
-> Branch Transaction -> Branch IO
forall (m :: * -> *) (n :: * -> *).
Functor m =>
(forall a. m a -> n a) -> Branch m -> Branch n
Branch.transform (Codebase IO Symbol Ann -> Transaction a -> IO a
forall (m :: * -> *) v a b.
MonadIO m =>
Codebase m v a -> Transaction b -> m b
Codebase.runTransaction Env
env.codebase)
        Output -> Cli Output
forall a. a -> Cli a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (MergeSourceAndTarget -> Output
Output.MergeSuccess MergeSourceAndTarget
mergeSourceAndTarget)

  Output -> Cli ()
Cli.respond Output
finalOutput

doMergeLocalBranch :: Merge.TwoWay (ProjectAndBranch Project ProjectBranch) -> Cli ()
doMergeLocalBranch :: TwoWay (ProjectAndBranch Project ProjectBranch) -> Cli ()
doMergeLocalBranch TwoWay (ProjectAndBranch Project ProjectBranch)
branches = do
  (CausalHash
aliceCausalHash, CausalHash
bobCausalHash, Maybe CausalHash
lcaCausalHash) <-
    Transaction (CausalHash, CausalHash, Maybe CausalHash)
-> Cli (CausalHash, CausalHash, Maybe CausalHash)
forall a. Transaction a -> Cli a
Cli.runTransaction do
      CausalHash
aliceCausalHash <- ProjectBranch -> Transaction CausalHash
ProjectUtils.getProjectBranchCausalHash (TwoWay (ProjectAndBranch Project ProjectBranch)
branches.alice ProjectAndBranch Project ProjectBranch
-> Getting
     ProjectBranch
     (ProjectAndBranch Project ProjectBranch)
     ProjectBranch
-> ProjectBranch
forall s a. s -> Getting a s a -> a
^. Getting
  ProjectBranch
  (ProjectAndBranch Project ProjectBranch)
  ProjectBranch
#branch)
      CausalHash
bobCausalHash <- ProjectBranch -> Transaction CausalHash
ProjectUtils.getProjectBranchCausalHash (TwoWay (ProjectAndBranch Project ProjectBranch)
branches.bob ProjectAndBranch Project ProjectBranch
-> Getting
     ProjectBranch
     (ProjectAndBranch Project ProjectBranch)
     ProjectBranch
-> ProjectBranch
forall s a. s -> Getting a s a -> a
^. Getting
  ProjectBranch
  (ProjectAndBranch Project ProjectBranch)
  ProjectBranch
#branch)
      -- Using Alice and Bob's causal hashes, find the LCA (if it exists)
      Maybe CausalHash
lcaCausalHash <- CausalHash -> CausalHash -> Transaction (Maybe CausalHash)
Operations.lca CausalHash
aliceCausalHash CausalHash
bobCausalHash
      (CausalHash, CausalHash, Maybe CausalHash)
-> Transaction (CausalHash, CausalHash, Maybe CausalHash)
forall a. a -> Transaction a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CausalHash
aliceCausalHash, CausalHash
bobCausalHash, Maybe CausalHash
lcaCausalHash)

  -- Do the merge!
  MergeInfo -> Cli ()
doMerge
    MergeInfo
      { $sel:alice:MergeInfo :: AliceMergeInfo
alice =
          AliceMergeInfo
            { $sel:causalHash:AliceMergeInfo :: CausalHash
causalHash = CausalHash
aliceCausalHash,
              $sel:projectAndBranch:AliceMergeInfo :: ProjectAndBranch Project ProjectBranch
projectAndBranch = TwoWay (ProjectAndBranch Project ProjectBranch)
branches.alice
            },
        $sel:bob:MergeInfo :: BobMergeInfo
bob =
          BobMergeInfo
            { $sel:causalHash:BobMergeInfo :: CausalHash
causalHash = CausalHash
bobCausalHash,
              $sel:source:BobMergeInfo :: MergeSource
source = ProjectAndBranch Project ProjectBranch -> MergeSource
MergeSource'LocalProjectBranch TwoWay (ProjectAndBranch Project ProjectBranch)
branches.bob
            },
        $sel:lca:MergeInfo :: LcaMergeInfo
lca =
          LcaMergeInfo
            { $sel:causalHash:LcaMergeInfo :: Maybe CausalHash
causalHash = Maybe CausalHash
lcaCausalHash
            },
        $sel:description:MergeInfo :: Text
description = Text
"merge " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> forall target source. From source target => source -> target
into @Text (ProjectAndBranch Project ProjectBranch -> MergeTarget
ProjectUtils.justTheNames TwoWay (ProjectAndBranch Project ProjectBranch)
branches.bob)
      }

------------------------------------------------------------------------------------------------------------------------
-- Merge precondition violation checks

hasDefnsInLib :: (Applicative m) => V2.Branch m -> m Bool
hasDefnsInLib :: forall (m :: * -> *). Applicative m => Branch m -> m Bool
hasDefnsInLib Branch m
branch = do
  ( case NameSegment
-> Map NameSegment (CausalBranch m) -> Maybe (CausalBranch m)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup NameSegment
NameSegment.libSegment Branch m
branch.children of
      Maybe (CausalBranch m)
Nothing -> Branch m -> m (Branch m)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Branch m
forall (m :: * -> *). Branch m
V2.Branch.empty
      Just CausalBranch m
libdeps -> CausalBranch m
libdeps.value
    )
    m (Branch m) -> (Branch m -> Bool) -> m Bool
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \Branch m
libdeps -> Bool -> Bool
not (Map NameSegment (Map Referent (m MdValues)) -> Bool
forall k a. Map k a -> Bool
Map.null Branch m
libdeps.terms) Bool -> Bool -> Bool
|| Bool -> Bool
not (Map NameSegment (Map TypeReference (m MdValues)) -> Bool
forall k a. Map k a -> Bool
Map.null Branch m
libdeps.types)

------------------------------------------------------------------------------------------------------------------------
--

findTemporaryBranchName :: ProjectId -> MergeSourceAndTarget -> Transaction ProjectBranchName
findTemporaryBranchName :: ProjectId -> MergeSourceAndTarget -> Transaction ProjectBranchName
findTemporaryBranchName ProjectId
projectId MergeSourceAndTarget
mergeSourceAndTarget = do
  ProjectId -> ProjectBranchName -> Transaction ProjectBranchName
ProjectUtils.findTemporaryBranchName ProjectId
projectId ProjectBranchName
preferred
  where
    preferred :: ProjectBranchName
    preferred :: ProjectBranchName
preferred =
      forall source target.
(HasCallStack, TryFrom source target, Show source, Typeable source,
 Typeable target) =>
source -> target
unsafeFrom @Text (Text -> ProjectBranchName) -> Text -> ProjectBranchName
forall a b. (a -> b) -> a -> b
$
        Builder -> Text
Text.Builder.run (Builder -> Text) -> Builder -> Text
forall a b. (a -> b) -> a -> b
$
          Builder
"merge-"
            Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> MergeSource -> Builder
mangleMergeSource MergeSourceAndTarget
mergeSourceAndTarget.bob
            Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
"-into-"
            Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ProjectBranchName -> Builder
projectBranchNameToValidProjectBranchNameText MergeSourceAndTarget
mergeSourceAndTarget.alice.branch

mangleMergeSource :: MergeSource -> Text.Builder
mangleMergeSource :: MergeSource -> Builder
mangleMergeSource = \case
  MergeSource'LocalProjectBranch (ProjectAndBranch Project
_project ProjectBranch
branch) -> ProjectBranchName -> Builder
projectBranchNameToValidProjectBranchNameText ProjectBranch
branch.name
  MergeSource'RemoteProjectBranch RemoteProjectBranch
remoteBranch -> Builder
"remote-" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ProjectBranchName -> Builder
projectBranchNameToValidProjectBranchNameText RemoteProjectBranch
remoteBranch.branchName
  MergeSource'RemoteLooseCode ReadShareLooseCode
info -> Path -> Builder
manglePath ReadShareLooseCode
info.path
  where
    manglePath :: Path -> Text.Builder
    manglePath :: Path -> Builder
manglePath =
      Builder -> (NameSegment -> Builder) -> [NameSegment] -> Builder
forall (t :: * -> *) a b.
(Foldable t, Monoid a) =>
a -> (b -> a) -> t b -> a
Monoid.intercalateMap Builder
"-" (Text -> Builder
Text.Builder.text (Text -> Builder)
-> (NameSegment -> Text) -> NameSegment -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NameSegment -> Text
NameSegment.toUnescapedText) ([NameSegment] -> Builder)
-> (Path -> [NameSegment]) -> Path -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path -> [NameSegment]
Path.toList

typecheckedUnisonFileToBranchAdds :: TypecheckedUnisonFile Symbol Ann -> [(Path, Branch0 m -> Branch0 m)]
typecheckedUnisonFileToBranchAdds :: forall (m :: * -> *).
TypecheckedUnisonFile Symbol Ann
-> [(Path, Branch0 m -> Branch0 m)]
typecheckedUnisonFileToBranchAdds TypecheckedUnisonFile Symbol Ann
tuf = do
  [(Path, Branch0 m -> Branch0 m)]
forall (m :: * -> *). [(Path, Branch0 m -> Branch0 m)]
declAdds [(Path, Branch0 m -> Branch0 m)]
-> [(Path, Branch0 m -> Branch0 m)]
-> [(Path, Branch0 m -> Branch0 m)]
forall a. [a] -> [a] -> [a]
++ [(Path, Branch0 m -> Branch0 m)]
forall (m :: * -> *). [(Path, Branch0 m -> Branch0 m)]
termAdds
  where
    declAdds :: [(Path, Branch0 m -> Branch0 m)]
    declAdds :: forall (m :: * -> *). [(Path, Branch0 m -> Branch0 m)]
declAdds = do
      ((Symbol, (Id, DataDeclaration Symbol Ann))
 -> [(Path, Branch0 m -> Branch0 m)])
-> [(Symbol, (Id, DataDeclaration Symbol Ann))]
-> [(Path, Branch0 m -> Branch0 m)]
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (Symbol, (Id, DataDeclaration Symbol Ann))
-> [(Path, Branch0 m -> Branch0 m)]
forall {m :: * -> *}.
(Symbol, (Id, DataDeclaration Symbol Ann))
-> [(Path, Branch0 m -> Branch0 m)]
makeDataDeclAdds (Map Symbol (Id, DataDeclaration Symbol Ann)
-> [(Symbol, (Id, DataDeclaration Symbol Ann))]
forall k a. Map k a -> [(k, a)]
Map.toList (TypecheckedUnisonFile Symbol Ann
-> Map Symbol (Id, DataDeclaration Symbol Ann)
forall v a.
TypecheckedUnisonFile v a -> Map v (Id, DataDeclaration v a)
UnisonFile.dataDeclarationsId' TypecheckedUnisonFile Symbol Ann
tuf))
        [(Path, Branch0 m -> Branch0 m)]
-> [(Path, Branch0 m -> Branch0 m)]
-> [(Path, Branch0 m -> Branch0 m)]
forall a. [a] -> [a] -> [a]
++ ((Symbol, (Id, EffectDeclaration Symbol Ann))
 -> [(Path, Branch0 m -> Branch0 m)])
-> [(Symbol, (Id, EffectDeclaration Symbol Ann))]
-> [(Path, Branch0 m -> Branch0 m)]
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (Symbol, (Id, EffectDeclaration Symbol Ann))
-> [(Path, Branch0 m -> Branch0 m)]
forall {m :: * -> *}.
(Symbol, (Id, EffectDeclaration Symbol Ann))
-> [(Path, Branch0 m -> Branch0 m)]
makeEffectDeclUpdates (Map Symbol (Id, EffectDeclaration Symbol Ann)
-> [(Symbol, (Id, EffectDeclaration Symbol Ann))]
forall k a. Map k a -> [(k, a)]
Map.toList (TypecheckedUnisonFile Symbol Ann
-> Map Symbol (Id, EffectDeclaration Symbol Ann)
forall v a.
TypecheckedUnisonFile v a -> Map v (Id, EffectDeclaration v a)
UnisonFile.effectDeclarationsId' TypecheckedUnisonFile Symbol Ann
tuf))
      where
        makeDataDeclAdds :: (Symbol, (Id, DataDeclaration Symbol Ann))
-> [(Path, Branch0 m -> Branch0 m)]
makeDataDeclAdds (Symbol
symbol, (Id
typeRefId, DataDeclaration Symbol Ann
dataDecl)) = (Symbol, (Id, Decl Symbol Ann)) -> [(Path, Branch0 m -> Branch0 m)]
forall (m :: * -> *).
(Symbol, (Id, Decl Symbol Ann)) -> [(Path, Branch0 m -> Branch0 m)]
makeDeclAdds (Symbol
symbol, (Id
typeRefId, DataDeclaration Symbol Ann -> Decl Symbol Ann
forall a b. b -> Either a b
Right DataDeclaration Symbol Ann
dataDecl))
        makeEffectDeclUpdates :: (Symbol, (Id, EffectDeclaration Symbol Ann))
-> [(Path, Branch0 m -> Branch0 m)]
makeEffectDeclUpdates (Symbol
symbol, (Id
typeRefId, EffectDeclaration Symbol Ann
effectDecl)) = (Symbol, (Id, Decl Symbol Ann)) -> [(Path, Branch0 m -> Branch0 m)]
forall (m :: * -> *).
(Symbol, (Id, Decl Symbol Ann)) -> [(Path, Branch0 m -> Branch0 m)]
makeDeclAdds (Symbol
symbol, (Id
typeRefId, EffectDeclaration Symbol Ann -> Decl Symbol Ann
forall a b. a -> Either a b
Left EffectDeclaration Symbol Ann
effectDecl))

        makeDeclAdds :: (Symbol, (TypeReferenceId, Decl Symbol Ann)) -> [(Path, Branch0 m -> Branch0 m)]
        makeDeclAdds :: forall (m :: * -> *).
(Symbol, (Id, Decl Symbol Ann)) -> [(Path, Branch0 m -> Branch0 m)]
makeDeclAdds (Symbol
symbol, (Id
typeRefId, Decl Symbol Ann
decl)) =
          let insertTypeAction :: (Path, Branch0 m -> Branch0 m)
insertTypeAction = Split Path -> TypeReference -> (Path, Branch0 m -> Branch0 m)
forall p (m :: * -> *).
Split p -> TypeReference -> (p, Branch0 m -> Branch0 m)
BranchUtil.makeAddTypeName (Symbol -> Split Path
splitVar Symbol
symbol) (Id -> TypeReference
Reference.fromId Id
typeRefId)
              insertTypeConstructorActions :: [(Path, Branch0 m -> Branch0 m)]
insertTypeConstructorActions =
                (Symbol -> Referent' Id -> (Path, Branch0 m -> Branch0 m))
-> [Symbol] -> [Referent' Id] -> [(Path, Branch0 m -> Branch0 m)]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
forall (f :: * -> *) a b c.
Zip f =>
(a -> b -> c) -> f a -> f b -> f c
zipWith
                  (\Symbol
sym Referent' Id
rid -> Split Path -> Referent -> (Path, Branch0 m -> Branch0 m)
forall p (m :: * -> *).
Split p -> Referent -> (p, Branch0 m -> Branch0 m)
BranchUtil.makeAddTermName (Symbol -> Split Path
splitVar Symbol
sym) (Id -> TypeReference
Reference.fromId (Id -> TypeReference) -> Referent' Id -> Referent
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Referent' Id
rid))
                  (DataDeclaration Symbol Ann -> [Symbol]
forall v a. DataDeclaration v a -> [v]
DataDeclaration.constructorVars (Decl Symbol Ann -> DataDeclaration Symbol Ann
forall v a. Decl v a -> DataDeclaration v a
DataDeclaration.asDataDecl Decl Symbol Ann
decl))
                  (Id -> Decl Symbol Ann -> [Referent' Id]
forall v a. Id -> Decl v a -> [Referent' Id]
DataDeclaration.declConstructorReferents Id
typeRefId Decl Symbol Ann
decl)
           in (Path, Branch0 m -> Branch0 m)
insertTypeAction (Path, Branch0 m -> Branch0 m)
-> [(Path, Branch0 m -> Branch0 m)]
-> [(Path, Branch0 m -> Branch0 m)]
forall a. a -> [a] -> [a]
: [(Path, Branch0 m -> Branch0 m)]
insertTypeConstructorActions

    termAdds :: [(Path, Branch0 m -> Branch0 m)]
    termAdds :: forall (m :: * -> *). [(Path, Branch0 m -> Branch0 m)]
termAdds =
      TypecheckedUnisonFile Symbol Ann
tuf
        TypecheckedUnisonFile Symbol Ann
-> (TypecheckedUnisonFile Symbol Ann
    -> Map
         Symbol (Ann, Id, Maybe FilePath, Term Symbol Ann, Type Symbol Ann))
-> Map
     Symbol (Ann, Id, Maybe FilePath, Term Symbol Ann, Type Symbol Ann)
forall a b. a -> (a -> b) -> b
& TypecheckedUnisonFile Symbol Ann
-> Map
     Symbol (Ann, Id, Maybe FilePath, Term Symbol Ann, Type Symbol Ann)
forall v a.
TypecheckedUnisonFile v a
-> Map v (a, Id, Maybe FilePath, Term v a, Type v a)
UnisonFile.hashTermsId
        Map
  Symbol (Ann, Id, Maybe FilePath, Term Symbol Ann, Type Symbol Ann)
-> (Map
      Symbol (Ann, Id, Maybe FilePath, Term Symbol Ann, Type Symbol Ann)
    -> [(Symbol,
         (Ann, Id, Maybe FilePath, Term Symbol Ann, Type Symbol Ann))])
-> [(Symbol,
     (Ann, Id, Maybe FilePath, Term Symbol Ann, Type Symbol Ann))]
forall a b. a -> (a -> b) -> b
& Map
  Symbol (Ann, Id, Maybe FilePath, Term Symbol Ann, Type Symbol Ann)
-> [(Symbol,
     (Ann, Id, Maybe FilePath, Term Symbol Ann, Type Symbol Ann))]
forall k a. Map k a -> [(k, a)]
Map.toList
        [(Symbol,
  (Ann, Id, Maybe FilePath, Term Symbol Ann, Type Symbol Ann))]
-> ([(Symbol,
      (Ann, Id, Maybe FilePath, Term Symbol Ann, Type Symbol Ann))]
    -> [(Path, Branch0 m -> Branch0 m)])
-> [(Path, Branch0 m -> Branch0 m)]
forall a b. a -> (a -> b) -> b
& ((Symbol,
  (Ann, Id, Maybe FilePath, Term Symbol Ann, Type Symbol Ann))
 -> Maybe (Path, Branch0 m -> Branch0 m))
-> [(Symbol,
     (Ann, Id, Maybe FilePath, Term Symbol Ann, Type Symbol Ann))]
-> [(Path, Branch0 m -> Branch0 m)]
forall a b. (a -> Maybe b) -> [a] -> [b]
forall (f :: * -> *) a b.
Filterable f =>
(a -> Maybe b) -> f a -> f b
mapMaybe \(Symbol
var, (Ann
_, Id
ref, Maybe FilePath
wk, Term Symbol Ann
_, Type Symbol Ann
_)) -> do
          Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Maybe FilePath -> Bool
WatchKind.watchKindShouldBeStoredInDatabase Maybe FilePath
wk)
          (Path, Branch0 m -> Branch0 m)
-> Maybe (Path, Branch0 m -> Branch0 m)
forall a. a -> Maybe a
Just (Split Path -> Referent -> (Path, Branch0 m -> Branch0 m)
forall p (m :: * -> *).
Split p -> Referent -> (p, Branch0 m -> Branch0 m)
BranchUtil.makeAddTermName (Symbol -> Split Path
splitVar Symbol
var) (Id -> Referent
Referent.fromTermReferenceId Id
ref))

    splitVar :: Symbol -> Path.Split Path
    splitVar :: Symbol -> Split Path
splitVar = Name -> Split Path
Path.splitFromName (Name -> Split Path) -> (Symbol -> Name) -> Symbol -> Split Path
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Symbol -> Name
forall v. Var v => v -> Name
Name.unsafeParseVar

------------------------------------------------------------------------------------------------------------------------
-- Making file with conflict markers

makeMergedFileContents :: MergeSourceAndTarget -> Text -> Text -> Text
makeMergedFileContents :: MergeSourceAndTarget -> Text -> Text -> Text
makeMergedFileContents MergeSourceAndTarget
sourceAndTarget Text
aliceContents Text
bobContents =
  let f :: (Text.Builder, Diff.Diff Text) -> Diff.Diff Text -> (Text.Builder, Diff.Diff Text)
      f :: (Builder, Diff Text) -> Diff Text -> (Builder, Diff Text)
f (Builder
acc, Diff Text
previous) Diff Text
line =
        case (Diff Text
previous, Diff Text
line) of
          (Diff.Both {}, Diff.Both Text
bothLine Text
_) -> Builder -> (Builder, Diff Text)
go (Text -> Builder
Text.Builder.text Text
bothLine)
          (Diff.Both {}, Diff.First Text
aliceLine) -> Builder -> (Builder, Diff Text)
go (Builder
aliceSlug Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Builder
Text.Builder.text Text
aliceLine)
          (Diff.Both {}, Diff.Second Text
bobLine) -> Builder -> (Builder, Diff Text)
go (Builder
aliceSlug Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
middleSlug Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Builder
Text.Builder.text Text
bobLine)
          (Diff.First {}, Diff.Both Text
bothLine Text
_) -> Builder -> (Builder, Diff Text)
go (Builder
middleSlug Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
bobSlug Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Builder
Text.Builder.text Text
bothLine)
          (Diff.First {}, Diff.First Text
aliceLine) -> Builder -> (Builder, Diff Text)
go (Text -> Builder
Text.Builder.text Text
aliceLine)
          (Diff.First {}, Diff.Second Text
bobLine) -> Builder -> (Builder, Diff Text)
go (Builder
middleSlug Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Builder
Text.Builder.text Text
bobLine)
          (Diff.Second {}, Diff.Both Text
bothLine Text
_) -> Builder -> (Builder, Diff Text)
go (Builder
bobSlug Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Builder
Text.Builder.text Text
bothLine)
          (Diff.Second {}, Diff.First Text
aliceLine) -> Builder -> (Builder, Diff Text)
go (Builder
bobSlug Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
aliceSlug Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Builder
Text.Builder.text Text
aliceLine)
          (Diff.Second {}, Diff.Second Text
bobLine) -> Builder -> (Builder, Diff Text)
go (Text -> Builder
Text.Builder.text Text
bobLine)
        where
          go :: Builder -> (Builder, Diff Text)
go Builder
content =
            let !acc1 :: Builder
acc1 = Builder
acc Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
content Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
newline
             in (Builder
acc1, Diff Text
line)
   in [Text] -> [Text] -> [Diff Text]
forall a. Eq a => [a] -> [a] -> [Diff a]
Diff.getDiff (Text -> [Text]
Text.lines Text
aliceContents) (Text -> [Text]
Text.lines Text
bobContents)
        [Diff Text]
-> ([Diff Text] -> (Builder, Diff Text)) -> (Builder, Diff Text)
forall a b. a -> (a -> b) -> b
& ((Builder, Diff Text) -> Diff Text -> (Builder, Diff Text))
-> (Builder, Diff Text) -> [Diff Text] -> (Builder, Diff Text)
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
List.foldl' (Builder, Diff Text) -> Diff Text -> (Builder, Diff Text)
f (forall a. Monoid a => a
mempty @Text.Builder, Text -> Text -> Diff Text
forall a b. a -> b -> PolyDiff a b
Diff.Both Text
Text.empty Text
Text.empty)
        (Builder, Diff Text)
-> ((Builder, Diff Text) -> Builder) -> Builder
forall a b. a -> (a -> b) -> b
& (Builder, Diff Text) -> Builder
forall a b. (a, b) -> a
fst
        Builder -> (Builder -> Text) -> Text
forall a b. a -> (a -> b) -> b
& Builder -> Text
Text.Builder.run
  where
    aliceSlug :: Text.Builder
    aliceSlug :: Builder
aliceSlug =
      Builder
"<<<<<<< " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Builder
Text.Builder.text (forall target source. From source target => source -> target
into @Text MergeSourceAndTarget
sourceAndTarget.alice.branch) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
newline

    middleSlug :: Text.Builder
    middleSlug :: Builder
middleSlug = Builder
"=======\n"

    bobSlug :: Text.Builder
    bobSlug :: Builder
bobSlug =
      Builder
">>>>>>> "
        Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ( case MergeSourceAndTarget
sourceAndTarget.bob of
               MergeSource'LocalProjectBranch ProjectAndBranch Project ProjectBranch
bobProjectAndBranch ->
                 Text -> Builder
Text.Builder.text (forall target source. From source target => source -> target
into @Text ProjectAndBranch Project ProjectBranch
bobProjectAndBranch.branch.name)
               MergeSource'RemoteProjectBranch RemoteProjectBranch
bobRemoteBranch ->
                 Builder
"remote " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Builder
Text.Builder.text (forall target source. From source target => source -> target
into @Text RemoteProjectBranch
bobRemoteBranch.branchName)
               MergeSource'RemoteLooseCode ReadShareLooseCode
info ->
                 case Path -> Maybe Name
forall path. Namey path => path -> Maybe Name
Path.toName ReadShareLooseCode
info.path of
                   Maybe Name
Nothing -> Builder
"<root>"
                   Just Name
name -> Text -> Builder
Text.Builder.text (Name -> Text
Name.toText Name
name)
           )
        Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
newline

    newline :: Text.Builder
    newline :: Builder
newline = Builder
"\n"

------------------------------------------------------------------------------------------------------------------------
-- Debugging by printing a bunch of stuff out

data DebugFunctions = DebugFunctions
  { DebugFunctions -> TwoOrThreeWay (CausalBranch Transaction) -> IO ()
debugCausals :: Merge.TwoOrThreeWay (V2.CausalBranch Transaction) -> IO (),
    DebugFunctions
-> TwoWay
     (Defns (BiMultimap Referent Name) (BiMultimap TypeReference Name))
-> TwoWay (DefnsF Set TypeReference TypeReference)
-> IO ()
debugCoreDependencies ::
      Merge.TwoWay (Defns (BiMultimap Referent Name) (BiMultimap TypeReference Name)) ->
      Merge.TwoWay (DefnsF Set TermReference TypeReference) ->
      IO (),
    DebugFunctions
-> ThreeWay (DefnsF (Map Name) Referent TypeReference) -> IO ()
debugDefns :: Merge.ThreeWay (DefnsF (Map Name) Referent TypeReference) -> IO (),
    DebugFunctions
-> TwoWay
     (DefnsF3 (Map Name) DiffOp Synhashed Referent TypeReference)
-> IO ()
debugDiffs :: Merge.TwoWay (DefnsF3 (Map Name) Merge.DiffOp Merge.Synhashed Referent TypeReference) -> IO (),
    DebugFunctions
-> DefnsF2 (Map Name) CombinedDiffOp Referent TypeReference
-> IO ()
debugCombinedDiff :: DefnsF2 (Map Name) Merge.CombinedDiffOp Referent TypeReference -> IO (),
    DebugFunctions
-> TwoWay
     (Defns (BiMultimap Referent Name) (BiMultimap TypeReference Name))
-> TwoWay (DefnsF Set Id Id)
-> IO ()
debugInitialDependents ::
      Merge.TwoWay (Defns (BiMultimap Referent Name) (BiMultimap TypeReference Name)) ->
      Merge.TwoWay (DefnsF Set TermReferenceId TypeReferenceId) ->
      IO (),
    DebugFunctions
-> TwoWay (Updated (DefnsF (Map Name) Referent TypeReference))
-> IO ()
debugNarrowedDefns :: Merge.TwoWay (Merge.Updated (DefnsF (Map Name) Referent TypeReference)) -> IO (),
    DebugFunctions
-> TwoWay (DefnsF (Map Name) Id Id)
-> DefnsF Unconflicts Referent TypeReference
-> IO ()
debugPartitionedDiff ::
      Merge.TwoWay (DefnsF (Map Name) TermReferenceId TypeReferenceId) ->
      DefnsF Merge.Unconflicts Referent TypeReference ->
      IO (),
    DebugFunctions -> TwoWay (DefnsF [] Rename Rename) -> IO ()
debugRenames :: Merge.TwoWay (DefnsF [] Merge.Rename Merge.Rename) -> IO (),
    DebugFunctions
-> TwoWay (Defns SimpleRenames SimpleRenames) -> IO ()
debugSimpleRenames :: Merge.TwoWay (Defns Merge.SimpleRenames Merge.SimpleRenames) -> IO (),
    DebugFunctions
-> TwoWay
     (Updated (DefnsF2 (Map Name) Synhashed Referent TypeReference))
-> IO ()
debugSynhashedNarrowedDefns ::
      Merge.TwoWay (Merge.Updated (DefnsF2 (Map Name) Merge.Synhashed Referent TypeReference)) ->
      IO ()
  }

realDebugFunctions :: DebugFunctions
realDebugFunctions :: DebugFunctions
realDebugFunctions =
  DebugFunctions
    { $sel:debugCausals:DebugFunctions :: TwoOrThreeWay (CausalBranch Transaction) -> IO ()
debugCausals = TwoOrThreeWay (CausalBranch Transaction) -> IO ()
realDebugCausals,
      $sel:debugCoreDependencies:DebugFunctions :: TwoWay
  (Defns (BiMultimap Referent Name) (BiMultimap TypeReference Name))
-> TwoWay (DefnsF Set TypeReference TypeReference) -> IO ()
debugCoreDependencies = TwoWay
  (Defns (BiMultimap Referent Name) (BiMultimap TypeReference Name))
-> TwoWay (DefnsF Set TypeReference TypeReference) -> IO ()
realDebugCoreDependencies,
      $sel:debugDefns:DebugFunctions :: ThreeWay (DefnsF (Map Name) Referent TypeReference) -> IO ()
debugDefns = ThreeWay (DefnsF (Map Name) Referent TypeReference) -> IO ()
realDebugDefns,
      $sel:debugDiffs:DebugFunctions :: TwoWay (DefnsF3 (Map Name) DiffOp Synhashed Referent TypeReference)
-> IO ()
debugDiffs = TwoWay (DefnsF3 (Map Name) DiffOp Synhashed Referent TypeReference)
-> IO ()
realDebugDiffs,
      $sel:debugCombinedDiff:DebugFunctions :: DefnsF2 (Map Name) CombinedDiffOp Referent TypeReference -> IO ()
debugCombinedDiff = DefnsF2 (Map Name) CombinedDiffOp Referent TypeReference -> IO ()
realDebugCombinedDiff,
      $sel:debugInitialDependents:DebugFunctions :: TwoWay
  (Defns (BiMultimap Referent Name) (BiMultimap TypeReference Name))
-> TwoWay (DefnsF Set Id Id) -> IO ()
debugInitialDependents = TwoWay
  (Defns (BiMultimap Referent Name) (BiMultimap TypeReference Name))
-> TwoWay (DefnsF Set Id Id) -> IO ()
realDebugInitialDependents,
      $sel:debugNarrowedDefns:DebugFunctions :: TwoWay (Updated (DefnsF (Map Name) Referent TypeReference))
-> IO ()
debugNarrowedDefns = TwoWay (Updated (DefnsF (Map Name) Referent TypeReference))
-> IO ()
realDebugNarrowedDefns,
      $sel:debugPartitionedDiff:DebugFunctions :: TwoWay (DefnsF (Map Name) Id Id)
-> DefnsF Unconflicts Referent TypeReference -> IO ()
debugPartitionedDiff = TwoWay (DefnsF (Map Name) Id Id)
-> DefnsF Unconflicts Referent TypeReference -> IO ()
realDebugPartitionedDiff,
      $sel:debugRenames:DebugFunctions :: TwoWay (DefnsF [] Rename Rename) -> IO ()
debugRenames = TwoWay (DefnsF [] Rename Rename) -> IO ()
realDebugRenames,
      $sel:debugSimpleRenames:DebugFunctions :: TwoWay (Defns SimpleRenames SimpleRenames) -> IO ()
debugSimpleRenames = TwoWay (Defns SimpleRenames SimpleRenames) -> IO ()
realDebugSimpleRenames,
      $sel:debugSynhashedNarrowedDefns:DebugFunctions :: TwoWay
  (Updated (DefnsF2 (Map Name) Synhashed Referent TypeReference))
-> IO ()
debugSynhashedNarrowedDefns = TwoWay
  (Updated (DefnsF2 (Map Name) Synhashed Referent TypeReference))
-> IO ()
realDebugSynhashedNarrowedDefns
    }

fakeDebugFunctions :: DebugFunctions
fakeDebugFunctions :: DebugFunctions
fakeDebugFunctions =
  (TwoOrThreeWay (CausalBranch Transaction) -> IO ())
-> (TwoWay
      (Defns (BiMultimap Referent Name) (BiMultimap TypeReference Name))
    -> TwoWay (DefnsF Set TypeReference TypeReference) -> IO ())
-> (ThreeWay (DefnsF (Map Name) Referent TypeReference) -> IO ())
-> (TwoWay
      (DefnsF3 (Map Name) DiffOp Synhashed Referent TypeReference)
    -> IO ())
-> (DefnsF2 (Map Name) CombinedDiffOp Referent TypeReference
    -> IO ())
-> (TwoWay
      (Defns (BiMultimap Referent Name) (BiMultimap TypeReference Name))
    -> TwoWay (DefnsF Set Id Id) -> IO ())
-> (TwoWay (Updated (DefnsF (Map Name) Referent TypeReference))
    -> IO ())
-> (TwoWay (DefnsF (Map Name) Id Id)
    -> DefnsF Unconflicts Referent TypeReference -> IO ())
-> (TwoWay (DefnsF [] Rename Rename) -> IO ())
-> (TwoWay (Defns SimpleRenames SimpleRenames) -> IO ())
-> (TwoWay
      (Updated (DefnsF2 (Map Name) Synhashed Referent TypeReference))
    -> IO ())
-> DebugFunctions
DebugFunctions
    TwoOrThreeWay (CausalBranch Transaction) -> IO ()
forall a. Monoid a => a
mempty
    TwoWay
  (Defns (BiMultimap Referent Name) (BiMultimap TypeReference Name))
-> TwoWay (DefnsF Set TypeReference TypeReference) -> IO ()
forall a. Monoid a => a
mempty
    ThreeWay (DefnsF (Map Name) Referent TypeReference) -> IO ()
forall a. Monoid a => a
mempty
    TwoWay (DefnsF3 (Map Name) DiffOp Synhashed Referent TypeReference)
-> IO ()
forall a. Monoid a => a
mempty
    DefnsF2 (Map Name) CombinedDiffOp Referent TypeReference -> IO ()
forall a. Monoid a => a
mempty
    TwoWay
  (Defns (BiMultimap Referent Name) (BiMultimap TypeReference Name))
-> TwoWay (DefnsF Set Id Id) -> IO ()
forall a. Monoid a => a
mempty
    TwoWay (Updated (DefnsF (Map Name) Referent TypeReference))
-> IO ()
forall a. Monoid a => a
mempty
    TwoWay (DefnsF (Map Name) Id Id)
-> DefnsF Unconflicts Referent TypeReference -> IO ()
forall a. Monoid a => a
mempty
    TwoWay (DefnsF [] Rename Rename) -> IO ()
forall a. Monoid a => a
mempty
    TwoWay (Defns SimpleRenames SimpleRenames) -> IO ()
forall a. Monoid a => a
mempty
    TwoWay
  (Updated (DefnsF2 (Map Name) Synhashed Referent TypeReference))
-> IO ()
forall a. Monoid a => a
mempty

realDebugCausals :: Merge.TwoOrThreeWay (V2.CausalBranch Transaction) -> IO ()
realDebugCausals :: TwoOrThreeWay (CausalBranch Transaction) -> IO ()
realDebugCausals TwoOrThreeWay (CausalBranch Transaction)
causals = do
  Text -> IO ()
Text.putStrLn (Text -> Text
Text.bold Text
"\n=== Alice causal hash ===")
  Text -> IO ()
Text.putStrLn (Hash -> Text
Hash.toBase32HexText (CausalHash -> Hash
unCausalHash TwoOrThreeWay (CausalBranch Transaction)
causals.alice.causalHash))
  Text -> IO ()
Text.putStrLn (Text -> Text
Text.bold Text
"\n=== Bob causal hash ===")
  Text -> IO ()
Text.putStrLn (Hash -> Text
Hash.toBase32HexText (CausalHash -> Hash
unCausalHash TwoOrThreeWay (CausalBranch Transaction)
causals.bob.causalHash))
  Text -> IO ()
Text.putStrLn (Text -> Text
Text.bold Text
"\n=== LCA causal hash ===")
  Text -> IO ()
Text.putStrLn case TwoOrThreeWay (CausalBranch Transaction)
causals.lca of
    Maybe (CausalBranch Transaction)
Nothing -> Text
"Nothing"
    Just CausalBranch Transaction
causal -> Text
"Just " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Hash -> Text
Hash.toBase32HexText (CausalHash -> Hash
unCausalHash CausalBranch Transaction
causal.causalHash)

realDebugDefns :: Merge.ThreeWay (DefnsF (Map Name) Referent TypeReference) -> IO ()
realDebugDefns :: ThreeWay (DefnsF (Map Name) Referent TypeReference) -> IO ()
realDebugDefns ThreeWay (DefnsF (Map Name) Referent TypeReference)
defns = do
  Text -> IO ()
Text.putStrLn (Text -> Text
Text.bold Text
"\n=== LCA defns ===")
  DefnsF (Map Name) Referent TypeReference -> IO ()
renderDefns ThreeWay (DefnsF (Map Name) Referent TypeReference)
defns.lca
  Text -> IO ()
Text.putStrLn (Text -> Text
Text.bold Text
"\n=== Alice defns ===")
  DefnsF (Map Name) Referent TypeReference -> IO ()
renderDefns ThreeWay (DefnsF (Map Name) Referent TypeReference)
defns.alice
  Text -> IO ()
Text.putStrLn (Text -> Text
Text.bold Text
"\n=== Bob defns ===")
  DefnsF (Map Name) Referent TypeReference -> IO ()
renderDefns ThreeWay (DefnsF (Map Name) Referent TypeReference)
defns.bob
  where
    renderDefns :: DefnsF (Map Name) Referent TypeReference -> IO ()
    renderDefns :: DefnsF (Map Name) Referent TypeReference -> IO ()
renderDefns DefnsF (Map Name) Referent TypeReference
defns = do
      (Referent -> Text)
-> (Referent -> Text) -> Map Name Referent -> IO ()
forall ref. (ref -> Text) -> (ref -> Text) -> Map Name ref -> IO ()
renderThings Referent -> Text
referentLabel Referent -> Text
Referent.toText DefnsF (Map Name) Referent TypeReference
defns.terms
      (TypeReference -> Text)
-> (TypeReference -> Text) -> Map Name TypeReference -> IO ()
forall ref. (ref -> Text) -> (ref -> Text) -> Map Name ref -> IO ()
renderThings (Text -> TypeReference -> Text
forall a b. a -> b -> a
const Text
"type") TypeReference -> Text
Reference.toText DefnsF (Map Name) Referent TypeReference
defns.types

    renderThings :: (ref -> Text) -> (ref -> Text) -> Map Name ref -> IO ()
    renderThings :: forall ref. (ref -> Text) -> (ref -> Text) -> Map Name ref -> IO ()
renderThings ref -> Text
label ref -> Text
render =
      Map Name ref -> [(Name, ref)]
forall k a. Map k a -> [(k, a)]
Map.toList
        (Map Name ref -> [(Name, ref)])
-> ([(Name, ref)] -> IO ()) -> Map Name ref -> IO ()
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> ASetter [(Name, ref)] [(Text, ref)] Name Text
-> (Name -> Text) -> [(Name, ref)] -> [(Text, ref)]
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over (((Name, ref) -> Identity (Text, ref))
-> [(Name, ref)] -> Identity [(Text, ref)]
Setter [(Name, ref)] [(Text, ref)] (Name, ref) (Text, ref)
forall (f :: * -> *) a b. Functor f => Setter (f a) (f b) a b
mapped (((Name, ref) -> Identity (Text, ref))
 -> [(Name, ref)] -> Identity [(Text, ref)])
-> ((Name -> Identity Text) -> (Name, ref) -> Identity (Text, ref))
-> ASetter [(Name, ref)] [(Text, ref)] Name Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name -> Identity Text) -> (Name, ref) -> Identity (Text, ref)
forall s t a b. Field1 s t a b => Lens s t a b
Lens (Name, ref) (Text, ref) Name Text
_1) Name -> Text
Name.toText
        ([(Name, ref)] -> [(Text, ref)])
-> ([(Text, ref)] -> IO ()) -> [(Name, ref)] -> IO ()
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> ((Text, ref) -> Text) -> [(Text, ref)] -> [(Text, ref)]
forall a b. Alphabetical a => (b -> a) -> [b] -> [b]
sortAlphabeticallyOn (Text, ref) -> Text
forall a b. (a, b) -> a
fst
        ([(Text, ref)] -> [(Text, ref)])
-> ([(Text, ref)] -> IO ()) -> [(Text, ref)] -> IO ()
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> ((Text, ref) -> IO ()) -> [(Text, ref)] -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ \(Text
name, ref
ref) ->
          Text -> IO ()
Text.putStrLn (Text -> Text
Text.italic (ref -> Text
label ref
ref) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ref -> Text
render ref
ref)

realDebugDiffs :: Merge.TwoWay (DefnsF3 (Map Name) Merge.DiffOp Merge.Synhashed Referent TypeReference) -> IO ()
realDebugDiffs :: TwoWay (DefnsF3 (Map Name) DiffOp Synhashed Referent TypeReference)
-> IO ()
realDebugDiffs TwoWay (DefnsF3 (Map Name) DiffOp Synhashed Referent TypeReference)
diffs = do
  Text -> IO ()
Text.putStrLn (Text -> Text
Text.bold Text
"\n=== LCA→Alice diff ===")
  DefnsF3 (Map Name) DiffOp Synhashed Referent TypeReference -> IO ()
renderDiff TwoWay (DefnsF3 (Map Name) DiffOp Synhashed Referent TypeReference)
diffs.alice
  Text -> IO ()
Text.putStrLn (Text -> Text
Text.bold Text
"\n=== LCA→Bob diff ===")
  DefnsF3 (Map Name) DiffOp Synhashed Referent TypeReference -> IO ()
renderDiff TwoWay (DefnsF3 (Map Name) DiffOp Synhashed Referent TypeReference)
diffs.bob
  where
    renderDiff :: DefnsF3 (Map Name) Merge.DiffOp Merge.Synhashed Referent TypeReference -> IO ()
    renderDiff :: DefnsF3 (Map Name) DiffOp Synhashed Referent TypeReference -> IO ()
renderDiff DefnsF3 (Map Name) DiffOp Synhashed Referent TypeReference
diff = do
      (Referent -> Text)
-> Map Name (DiffOp (Synhashed Referent)) -> IO ()
forall ref.
(ref -> Text) -> Map Name (DiffOp (Synhashed ref)) -> IO ()
renderThings Referent -> Text
referentLabel DefnsF3 (Map Name) DiffOp Synhashed Referent TypeReference
diff.terms
      (TypeReference -> Text)
-> Map Name (DiffOp (Synhashed TypeReference)) -> IO ()
forall ref.
(ref -> Text) -> Map Name (DiffOp (Synhashed ref)) -> IO ()
renderThings (Text -> TypeReference -> Text
forall a b. a -> b -> a
const Text
"type") DefnsF3 (Map Name) DiffOp Synhashed Referent TypeReference
diff.types

    renderThings :: (ref -> Text) -> Map Name (Merge.DiffOp (Merge.Synhashed ref)) -> IO ()
    renderThings :: forall ref.
(ref -> Text) -> Map Name (DiffOp (Synhashed ref)) -> IO ()
renderThings ref -> Text
label =
      Map Name (DiffOp (Synhashed ref))
-> [(Name, DiffOp (Synhashed ref))]
forall k a. Map k a -> [(k, a)]
Map.toList
        (Map Name (DiffOp (Synhashed ref))
 -> [(Name, DiffOp (Synhashed ref))])
-> ([(Name, DiffOp (Synhashed ref))] -> IO ())
-> Map Name (DiffOp (Synhashed ref))
-> IO ()
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> ASetter
  [(Name, DiffOp (Synhashed ref))]
  [(Text, DiffOp (Synhashed ref))]
  Name
  Text
-> (Name -> Text)
-> [(Name, DiffOp (Synhashed ref))]
-> [(Text, DiffOp (Synhashed ref))]
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over (((Name, DiffOp (Synhashed ref))
 -> Identity (Text, DiffOp (Synhashed ref)))
-> [(Name, DiffOp (Synhashed ref))]
-> Identity [(Text, DiffOp (Synhashed ref))]
Setter
  [(Name, DiffOp (Synhashed ref))]
  [(Text, DiffOp (Synhashed ref))]
  (Name, DiffOp (Synhashed ref))
  (Text, DiffOp (Synhashed ref))
forall (f :: * -> *) a b. Functor f => Setter (f a) (f b) a b
mapped (((Name, DiffOp (Synhashed ref))
  -> Identity (Text, DiffOp (Synhashed ref)))
 -> [(Name, DiffOp (Synhashed ref))]
 -> Identity [(Text, DiffOp (Synhashed ref))])
-> ((Name -> Identity Text)
    -> (Name, DiffOp (Synhashed ref))
    -> Identity (Text, DiffOp (Synhashed ref)))
-> ASetter
     [(Name, DiffOp (Synhashed ref))]
     [(Text, DiffOp (Synhashed ref))]
     Name
     Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name -> Identity Text)
-> (Name, DiffOp (Synhashed ref))
-> Identity (Text, DiffOp (Synhashed ref))
forall s t a b. Field1 s t a b => Lens s t a b
Lens
  (Name, DiffOp (Synhashed ref))
  (Text, DiffOp (Synhashed ref))
  Name
  Text
_1) Name -> Text
Name.toText
        ([(Name, DiffOp (Synhashed ref))]
 -> [(Text, DiffOp (Synhashed ref))])
-> ([(Text, DiffOp (Synhashed ref))] -> IO ())
-> [(Name, DiffOp (Synhashed ref))]
-> IO ()
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> ((Text, DiffOp (Synhashed ref)) -> Text)
-> [(Text, DiffOp (Synhashed ref))]
-> [(Text, DiffOp (Synhashed ref))]
forall a b. Alphabetical a => (b -> a) -> [b] -> [b]
sortAlphabeticallyOn (Text, DiffOp (Synhashed ref)) -> Text
forall a b. (a, b) -> a
fst
        ([(Text, DiffOp (Synhashed ref))]
 -> [(Text, DiffOp (Synhashed ref))])
-> ([(Text, DiffOp (Synhashed ref))] -> IO ())
-> [(Text, DiffOp (Synhashed ref))]
-> IO ()
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> ((Text, DiffOp (Synhashed ref)) -> IO ())
-> [(Text, DiffOp (Synhashed ref))] -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ \(Text
name, DiffOp (Synhashed ref)
op) ->
          let go :: (Text -> Text) -> Text -> Synhashed ref -> Text
go Text -> Text
color Text
action Synhashed ref
x =
                Text -> Text
color (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$
                  Text
action
                    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" "
                    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
Text.italic (ref -> Text
label (Synhashed ref -> ref
forall a. Synhashed a -> a
Synhashed.value Synhashed ref
x))
                    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" "
                    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name
                    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" #"
                    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Hash -> Text
Hash.toBase32HexText (Synhashed ref -> Hash
forall a. Synhashed a -> Hash
Synhashed.hash Synhashed ref
x)
           in Text -> IO ()
Text.putStrLn case DiffOp (Synhashed ref)
op of
                Merge.DiffOp'Add Synhashed ref
x -> (Text -> Text) -> Text -> Synhashed ref -> Text
go Text -> Text
Text.green Text
"+" Synhashed ref
x
                Merge.DiffOp'Delete Synhashed ref
x -> (Text -> Text) -> Text -> Synhashed ref -> Text
go Text -> Text
Text.red Text
"-" Synhashed ref
x
                Merge.DiffOp'Update Updated (Synhashed ref)
x -> (Text -> Text) -> Text -> Synhashed ref -> Text
go Text -> Text
Text.yellow Text
"%" Updated (Synhashed ref)
x.new

realDebugCombinedDiff :: DefnsF2 (Map Name) Merge.CombinedDiffOp Referent TypeReference -> IO ()
realDebugCombinedDiff :: DefnsF2 (Map Name) CombinedDiffOp Referent TypeReference -> IO ()
realDebugCombinedDiff DefnsF2 (Map Name) CombinedDiffOp Referent TypeReference
diff = do
  Text -> IO ()
Text.putStrLn (Text -> Text
Text.bold Text
"\n=== Combined diff ===")
  (Referent -> Text)
-> (Referent -> Text)
-> Map Name (CombinedDiffOp Referent)
-> IO ()
forall ref.
(ref -> Text)
-> (ref -> Text) -> Map Name (CombinedDiffOp ref) -> IO ()
renderThings Referent -> Text
referentLabel Referent -> Text
Referent.toText DefnsF2 (Map Name) CombinedDiffOp Referent TypeReference
diff.terms
  (TypeReference -> Text)
-> (TypeReference -> Text)
-> Map Name (CombinedDiffOp TypeReference)
-> IO ()
forall ref.
(ref -> Text)
-> (ref -> Text) -> Map Name (CombinedDiffOp ref) -> IO ()
renderThings (Text -> TypeReference -> Text
forall a b. a -> b -> a
const Text
"type") TypeReference -> Text
Reference.toText DefnsF2 (Map Name) CombinedDiffOp Referent TypeReference
diff.types
  where
    renderThings :: (ref -> Text) -> (ref -> Text) -> Map Name (Merge.CombinedDiffOp ref) -> IO ()
    renderThings :: forall ref.
(ref -> Text)
-> (ref -> Text) -> Map Name (CombinedDiffOp ref) -> IO ()
renderThings ref -> Text
label ref -> Text
renderRef Map Name (CombinedDiffOp ref)
things =
      Map Name (CombinedDiffOp ref)
things
        Map Name (CombinedDiffOp ref)
-> (Map Name (CombinedDiffOp ref) -> [(Name, CombinedDiffOp ref)])
-> [(Name, CombinedDiffOp ref)]
forall a b. a -> (a -> b) -> b
& Map Name (CombinedDiffOp ref) -> [(Name, CombinedDiffOp ref)]
forall k a. Map k a -> [(k, a)]
Map.toList
        [(Name, CombinedDiffOp ref)]
-> ([(Name, CombinedDiffOp ref)] -> [(Text, CombinedDiffOp ref)])
-> [(Text, CombinedDiffOp ref)]
forall a b. a -> (a -> b) -> b
& ASetter
  [(Name, CombinedDiffOp ref)] [(Text, CombinedDiffOp ref)] Name Text
-> (Name -> Text)
-> [(Name, CombinedDiffOp ref)]
-> [(Text, CombinedDiffOp ref)]
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over (((Name, CombinedDiffOp ref) -> Identity (Text, CombinedDiffOp ref))
-> [(Name, CombinedDiffOp ref)]
-> Identity [(Text, CombinedDiffOp ref)]
Setter
  [(Name, CombinedDiffOp ref)]
  [(Text, CombinedDiffOp ref)]
  (Name, CombinedDiffOp ref)
  (Text, CombinedDiffOp ref)
forall (f :: * -> *) a b. Functor f => Setter (f a) (f b) a b
mapped (((Name, CombinedDiffOp ref)
  -> Identity (Text, CombinedDiffOp ref))
 -> [(Name, CombinedDiffOp ref)]
 -> Identity [(Text, CombinedDiffOp ref)])
-> ((Name -> Identity Text)
    -> (Name, CombinedDiffOp ref)
    -> Identity (Text, CombinedDiffOp ref))
-> ASetter
     [(Name, CombinedDiffOp ref)] [(Text, CombinedDiffOp ref)] Name Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name -> Identity Text)
-> (Name, CombinedDiffOp ref)
-> Identity (Text, CombinedDiffOp ref)
forall s t a b. Field1 s t a b => Lens s t a b
Lens
  (Name, CombinedDiffOp ref) (Text, CombinedDiffOp ref) Name Text
_1) Name -> Text
Name.toText
        [(Text, CombinedDiffOp ref)]
-> ([(Text, CombinedDiffOp ref)] -> [(Text, CombinedDiffOp ref)])
-> [(Text, CombinedDiffOp ref)]
forall a b. a -> (a -> b) -> b
& ((Text, CombinedDiffOp ref) -> Text)
-> [(Text, CombinedDiffOp ref)] -> [(Text, CombinedDiffOp ref)]
forall a b. Alphabetical a => (b -> a) -> [b] -> [b]
sortAlphabeticallyOn (Text, CombinedDiffOp ref) -> Text
forall a b. (a, b) -> a
fst
        [(Text, CombinedDiffOp ref)]
-> ([(Text, CombinedDiffOp ref)] -> IO ()) -> IO ()
forall a b. a -> (a -> b) -> b
& ((Text, CombinedDiffOp ref) -> IO ())
-> [(Text, CombinedDiffOp ref)] -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ \(Text
name, CombinedDiffOp ref
op) ->
          Text -> IO ()
Text.putStrLn case CombinedDiffOp ref
op of
            Merge.CombinedDiffOp'Add EitherWayI ref
who ->
              Text -> Text
Text.green (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$
                Text
"+ "
                  Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
Text.italic (ref -> Text
label (EitherWayI ref -> ref
forall a. EitherWayI a -> a
EitherWayI.value EitherWayI ref
who))
                  Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" "
                  Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name
                  Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" "
                  Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ref -> Text
renderRef (EitherWayI ref -> ref
forall a. EitherWayI a -> a
EitherWayI.value EitherWayI ref
who)
                  Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" ("
                  Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> EitherWayI ref -> Text
forall v. EitherWayI v -> Text
renderWho EitherWayI ref
who
                  Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")"
            Merge.CombinedDiffOp'Delete EitherWayI ref
who ->
              Text -> Text
Text.red (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$
                Text
"- "
                  Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
Text.italic (ref -> Text
label (EitherWayI ref -> ref
forall a. EitherWayI a -> a
EitherWayI.value EitherWayI ref
who))
                  Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" "
                  Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name
                  Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" "
                  Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ref -> Text
renderRef (EitherWayI ref -> ref
forall a. EitherWayI a -> a
EitherWayI.value EitherWayI ref
who)
                  Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" ("
                  Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> EitherWayI ref -> Text
forall v. EitherWayI v -> Text
renderWho EitherWayI ref
who
                  Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")"
            Merge.CombinedDiffOp'Update EitherWayI (Updated ref)
who ->
              Text -> Text
Text.yellow (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$
                Text
"% "
                  Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
Text.italic (ref -> Text
label (EitherWayI (Updated ref) -> Updated ref
forall a. EitherWayI a -> a
EitherWayI.value EitherWayI (Updated ref)
who).new)
                  Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" "
                  Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name
                  Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" "
                  Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ref -> Text
renderRef (EitherWayI (Updated ref) -> Updated ref
forall a. EitherWayI a -> a
EitherWayI.value EitherWayI (Updated ref)
who).new
                  Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" ("
                  Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> EitherWayI (Updated ref) -> Text
forall v. EitherWayI v -> Text
renderWho EitherWayI (Updated ref)
who
                  Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")"
            Merge.CombinedDiffOp'Conflict TwoWay ref
ref ->
              Text -> Text
Text.magenta (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$
                Text
"! "
                  Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
Text.italic (ref -> Text
label TwoWay ref
ref.alice)
                  Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"/"
                  Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
Text.italic (ref -> Text
label TwoWay ref
ref.bob)
                  Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" "
                  Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name
                  Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" "
                  Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ref -> Text
renderRef TwoWay ref
ref.alice
                  Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"/"
                  Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ref -> Text
renderRef TwoWay ref
ref.bob

    renderWho :: Merge.EitherWayI v -> Text
    renderWho :: forall v. EitherWayI v -> Text
renderWho = \case
      Merge.OnlyAlice v
_ -> Text
"Alice"
      Merge.OnlyBob v
_ -> Text
"Bob"
      Merge.AliceAndBob v
_ -> Text
"Alice and Bob"

realDebugCoreDependencies ::
  Merge.TwoWay (Defns (BiMultimap Referent Name) (BiMultimap TypeReference Name)) ->
  Merge.TwoWay (DefnsF Set TermReference TypeReference) ->
  IO ()
realDebugCoreDependencies :: TwoWay
  (Defns (BiMultimap Referent Name) (BiMultimap TypeReference Name))
-> TwoWay (DefnsF Set TypeReference TypeReference) -> IO ()
realDebugCoreDependencies TwoWay
  (Defns (BiMultimap Referent Name) (BiMultimap TypeReference Name))
defns TwoWay (DefnsF Set TypeReference TypeReference)
dependencies = do
  Text -> IO ()
Text.putStrLn (Text -> Text
Text.bold Text
"\n=== Alice core dependencies ===")
  Defns (BiMultimap Referent Name) (BiMultimap TypeReference Name)
-> DefnsF Set TypeReference TypeReference -> IO ()
renderDependencies TwoWay
  (Defns (BiMultimap Referent Name) (BiMultimap TypeReference Name))
defns.alice TwoWay (DefnsF Set TypeReference TypeReference)
dependencies.alice

  Text -> IO ()
Text.putStrLn (Text -> Text
Text.bold Text
"\n=== Bob core dependencies ===")
  Defns (BiMultimap Referent Name) (BiMultimap TypeReference Name)
-> DefnsF Set TypeReference TypeReference -> IO ()
renderDependencies TwoWay
  (Defns (BiMultimap Referent Name) (BiMultimap TypeReference Name))
defns.bob TwoWay (DefnsF Set TypeReference TypeReference)
dependencies.bob
  where
    renderDependencies ::
      Defns (BiMultimap Referent Name) (BiMultimap TypeReference Name) ->
      DefnsF Set TermReference TypeReference ->
      IO ()
    renderDependencies :: Defns (BiMultimap Referent Name) (BiMultimap TypeReference Name)
-> DefnsF Set TypeReference TypeReference -> IO ()
renderDependencies Defns (BiMultimap Referent Name) (BiMultimap TypeReference Name)
defns DefnsF Set TypeReference TypeReference
dependencies = do
      DefnsF Set TypeReference TypeReference
dependencies.terms
        Set TypeReference
-> (Set TypeReference -> [TypeReference]) -> [TypeReference]
forall a b. a -> (a -> b) -> b
& Set TypeReference -> [TypeReference]
forall a. Set a -> [a]
Set.toList
        [TypeReference]
-> ([TypeReference] -> [(TypeReference, Text)])
-> [(TypeReference, Text)]
forall a b. a -> (a -> b) -> b
& (TypeReference -> (TypeReference, Text))
-> [TypeReference] -> [(TypeReference, Text)]
forall a b. (a -> b) -> [a] -> [b]
map (\TypeReference
dep -> (TypeReference
dep, TypeReference -> Text
termNames TypeReference
dep))
        [(TypeReference, Text)]
-> ([(TypeReference, Text)] -> [(TypeReference, Text)])
-> [(TypeReference, Text)]
forall a b. a -> (a -> b) -> b
& ((TypeReference, Text) -> Text)
-> [(TypeReference, Text)] -> [(TypeReference, Text)]
forall a b. Alphabetical a => (b -> a) -> [b] -> [b]
sortAlphabeticallyOn (TypeReference, Text) -> Text
forall a b. (a, b) -> b
snd
        [(TypeReference, Text)]
-> ([(TypeReference, Text)] -> IO ()) -> IO ()
forall a b. a -> (a -> b) -> b
& ((TypeReference, Text) -> IO ())
-> [(TypeReference, Text)] -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ \(TypeReference
dep, Text
names) ->
          Text -> IO ()
Text.putStrLn (Text -> Text
Text.italic Text
"term" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
names Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> TypeReference -> Text
Reference.toText TypeReference
dep)
      DefnsF Set TypeReference TypeReference
dependencies.types
        Set TypeReference
-> (Set TypeReference -> [TypeReference]) -> [TypeReference]
forall a b. a -> (a -> b) -> b
& Set TypeReference -> [TypeReference]
forall a. Set a -> [a]
Set.toList
        [TypeReference]
-> ([TypeReference] -> [(TypeReference, Text)])
-> [(TypeReference, Text)]
forall a b. a -> (a -> b) -> b
& (TypeReference -> (TypeReference, Text))
-> [TypeReference] -> [(TypeReference, Text)]
forall a b. (a -> b) -> [a] -> [b]
map (\TypeReference
dep -> (TypeReference
dep, TypeReference -> Text
typeNames TypeReference
dep))
        [(TypeReference, Text)]
-> ([(TypeReference, Text)] -> [(TypeReference, Text)])
-> [(TypeReference, Text)]
forall a b. a -> (a -> b) -> b
& ((TypeReference, Text) -> Text)
-> [(TypeReference, Text)] -> [(TypeReference, Text)]
forall a b. Alphabetical a => (b -> a) -> [b] -> [b]
sortAlphabeticallyOn (TypeReference, Text) -> Text
forall a b. (a, b) -> b
snd
        [(TypeReference, Text)]
-> ([(TypeReference, Text)] -> IO ()) -> IO ()
forall a b. a -> (a -> b) -> b
& ((TypeReference, Text) -> IO ())
-> [(TypeReference, Text)] -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ \(TypeReference
dep, Text
names) ->
          Text -> IO ()
Text.putStrLn (Text -> Text
Text.italic Text
"type" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
names Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> TypeReference -> Text
Reference.toText TypeReference
dep)
      where
        termNames :: TermReference -> Text
        termNames :: TypeReference -> Text
termNames TypeReference
ref =
          (Name -> Text) -> Set Name -> Text
forall m a. Monoid m => (a -> m) -> Set a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap
            (\Name
name -> Name -> Text
Name.toText Name
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" ")
            (Referent -> BiMultimap Referent Name -> Set Name
forall a b. Ord a => a -> BiMultimap a b -> Set b
BiMultimap.lookupDom (TypeReference -> Referent
Referent.fromTermReference TypeReference
ref) Defns (BiMultimap Referent Name) (BiMultimap TypeReference Name)
defns.terms)

        typeNames :: TypeReference -> Text
        typeNames :: TypeReference -> Text
typeNames TypeReference
ref =
          (Name -> Text) -> Set Name -> Text
forall m a. Monoid m => (a -> m) -> Set a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap
            (\Name
name -> Name -> Text
Name.toText Name
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" ")
            (TypeReference -> BiMultimap TypeReference Name -> Set Name
forall a b. Ord a => a -> BiMultimap a b -> Set b
BiMultimap.lookupDom TypeReference
ref Defns (BiMultimap Referent Name) (BiMultimap TypeReference Name)
defns.types)

realDebugInitialDependents ::
  Merge.TwoWay (Defns (BiMultimap Referent Name) (BiMultimap TypeReference Name)) ->
  Merge.TwoWay (DefnsF Set TermReferenceId TypeReferenceId) ->
  IO ()
realDebugInitialDependents :: TwoWay
  (Defns (BiMultimap Referent Name) (BiMultimap TypeReference Name))
-> TwoWay (DefnsF Set Id Id) -> IO ()
realDebugInitialDependents TwoWay
  (Defns (BiMultimap Referent Name) (BiMultimap TypeReference Name))
defns TwoWay (DefnsF Set Id Id)
dependents = do
  Text -> IO ()
Text.putStrLn (Text -> Text
Text.bold Text
"\n=== Alice initial dependents ===")
  Defns (BiMultimap Referent Name) (BiMultimap TypeReference Name)
-> DefnsF Set Id Id -> IO ()
renderDependents TwoWay
  (Defns (BiMultimap Referent Name) (BiMultimap TypeReference Name))
defns.alice TwoWay (DefnsF Set Id Id)
dependents.alice

  Text -> IO ()
Text.putStrLn (Text -> Text
Text.bold Text
"\n=== Bob initial dependents ===")
  Defns (BiMultimap Referent Name) (BiMultimap TypeReference Name)
-> DefnsF Set Id Id -> IO ()
renderDependents TwoWay
  (Defns (BiMultimap Referent Name) (BiMultimap TypeReference Name))
defns.bob TwoWay (DefnsF Set Id Id)
dependents.bob
  where
    renderDependents ::
      Defns (BiMultimap Referent Name) (BiMultimap TypeReference Name) ->
      DefnsF Set TermReferenceId TypeReferenceId ->
      IO ()
    renderDependents :: Defns (BiMultimap Referent Name) (BiMultimap TypeReference Name)
-> DefnsF Set Id Id -> IO ()
renderDependents Defns (BiMultimap Referent Name) (BiMultimap TypeReference Name)
defns DefnsF Set Id Id
dependents = do
      DefnsF Set Id Id
dependents.terms
        Set Id -> (Set Id -> [Id]) -> [Id]
forall a b. a -> (a -> b) -> b
& Set Id -> [Id]
forall a. Set a -> [a]
Set.toList
        [Id] -> ([Id] -> [(Id, Text)]) -> [(Id, Text)]
forall a b. a -> (a -> b) -> b
& (Id -> (Id, Text)) -> [Id] -> [(Id, Text)]
forall a b. (a -> b) -> [a] -> [b]
map (\Id
dep -> (Id
dep, Id -> Text
termNames Id
dep))
        [(Id, Text)] -> ([(Id, Text)] -> [(Id, Text)]) -> [(Id, Text)]
forall a b. a -> (a -> b) -> b
& ((Id, Text) -> Text) -> [(Id, Text)] -> [(Id, Text)]
forall a b. Alphabetical a => (b -> a) -> [b] -> [b]
sortAlphabeticallyOn (Id, Text) -> Text
forall a b. (a, b) -> b
snd
        [(Id, Text)] -> ([(Id, Text)] -> IO ()) -> IO ()
forall a b. a -> (a -> b) -> b
& ((Id, Text) -> IO ()) -> [(Id, Text)] -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ \(Id
dep, Text
names) ->
          Text -> IO ()
Text.putStrLn (Text -> Text
Text.italic Text
"term" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
names Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Id -> Text
Reference.idToText Id
dep)
      DefnsF Set Id Id
dependents.types
        Set Id -> (Set Id -> [Id]) -> [Id]
forall a b. a -> (a -> b) -> b
& Set Id -> [Id]
forall a. Set a -> [a]
Set.toList
        [Id] -> ([Id] -> [(Id, Text)]) -> [(Id, Text)]
forall a b. a -> (a -> b) -> b
& (Id -> (Id, Text)) -> [Id] -> [(Id, Text)]
forall a b. (a -> b) -> [a] -> [b]
map (\Id
dep -> (Id
dep, Id -> Text
typeNames Id
dep))
        [(Id, Text)] -> ([(Id, Text)] -> [(Id, Text)]) -> [(Id, Text)]
forall a b. a -> (a -> b) -> b
& ((Id, Text) -> Text) -> [(Id, Text)] -> [(Id, Text)]
forall a b. Alphabetical a => (b -> a) -> [b] -> [b]
sortAlphabeticallyOn (Id, Text) -> Text
forall a b. (a, b) -> b
snd
        [(Id, Text)] -> ([(Id, Text)] -> IO ()) -> IO ()
forall a b. a -> (a -> b) -> b
& ((Id, Text) -> IO ()) -> [(Id, Text)] -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ \(Id
dep, Text
names) ->
          Text -> IO ()
Text.putStrLn (Text -> Text
Text.italic Text
"type" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
names Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Id -> Text
Reference.idToText Id
dep)
      where
        termNames :: TermReferenceId -> Text
        termNames :: Id -> Text
termNames Id
ref =
          (Name -> Text) -> Set Name -> Text
forall m a. Monoid m => (a -> m) -> Set a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap
            (\Name
name -> Name -> Text
Name.toText Name
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" ")
            (Referent -> BiMultimap Referent Name -> Set Name
forall a b. Ord a => a -> BiMultimap a b -> Set b
BiMultimap.lookupDom (Id -> Referent
Referent.fromTermReferenceId Id
ref) Defns (BiMultimap Referent Name) (BiMultimap TypeReference Name)
defns.terms)

        typeNames :: TypeReferenceId -> Text
        typeNames :: Id -> Text
typeNames Id
ref =
          (Name -> Text) -> Set Name -> Text
forall m a. Monoid m => (a -> m) -> Set a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap
            (\Name
name -> Name -> Text
Name.toText Name
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" ")
            (TypeReference -> BiMultimap TypeReference Name -> Set Name
forall a b. Ord a => a -> BiMultimap a b -> Set b
BiMultimap.lookupDom (Id -> TypeReference
Reference.fromId Id
ref) Defns (BiMultimap Referent Name) (BiMultimap TypeReference Name)
defns.types)

realDebugNarrowedDefns :: Merge.TwoWay (Merge.Updated (DefnsF (Map Name) Referent TypeReference)) -> IO ()
realDebugNarrowedDefns :: TwoWay (Updated (DefnsF (Map Name) Referent TypeReference))
-> IO ()
realDebugNarrowedDefns TwoWay (Updated (DefnsF (Map Name) Referent TypeReference))
defns = do
  Text -> IO ()
Text.putStrLn (Text -> Text
Text.bold Text
"\n=== Narrowed LCA→Alice defns (LCA) ===")
  DefnsF (Map Name) Referent TypeReference -> IO ()
renderDefns TwoWay (Updated (DefnsF (Map Name) Referent TypeReference))
defns.alice.old
  Text -> IO ()
Text.putStrLn (Text -> Text
Text.bold Text
"\n=== Narrowed LCA→Alice defns (Alice) ===")
  DefnsF (Map Name) Referent TypeReference -> IO ()
renderDefns TwoWay (Updated (DefnsF (Map Name) Referent TypeReference))
defns.alice.new
  Text -> IO ()
Text.putStrLn (Text -> Text
Text.bold Text
"\n=== Narrowed LCA→Bob defns (LCA) ===")
  DefnsF (Map Name) Referent TypeReference -> IO ()
renderDefns TwoWay (Updated (DefnsF (Map Name) Referent TypeReference))
defns.bob.old
  Text -> IO ()
Text.putStrLn (Text -> Text
Text.bold Text
"\n=== Narrowed LCA→Bob defns (Bob) ===")
  DefnsF (Map Name) Referent TypeReference -> IO ()
renderDefns TwoWay (Updated (DefnsF (Map Name) Referent TypeReference))
defns.bob.new
  where
    renderDefns :: DefnsF (Map Name) Referent TypeReference -> IO ()
    renderDefns :: DefnsF (Map Name) Referent TypeReference -> IO ()
renderDefns DefnsF (Map Name) Referent TypeReference
defns = do
      (Referent -> Text)
-> (Referent -> Text) -> Map Name Referent -> IO ()
forall ref. (ref -> Text) -> (ref -> Text) -> Map Name ref -> IO ()
renderThings Referent -> Text
referentLabel Referent -> Text
Referent.toText DefnsF (Map Name) Referent TypeReference
defns.terms
      (TypeReference -> Text)
-> (TypeReference -> Text) -> Map Name TypeReference -> IO ()
forall ref. (ref -> Text) -> (ref -> Text) -> Map Name ref -> IO ()
renderThings (Text -> TypeReference -> Text
forall a b. a -> b -> a
const Text
"type") TypeReference -> Text
Reference.toText DefnsF (Map Name) Referent TypeReference
defns.types

    renderThings :: (ref -> Text) -> (ref -> Text) -> Map Name ref -> IO ()
    renderThings :: forall ref. (ref -> Text) -> (ref -> Text) -> Map Name ref -> IO ()
renderThings ref -> Text
label ref -> Text
render =
      Map Name ref -> [(Name, ref)]
forall k a. Map k a -> [(k, a)]
Map.toList
        (Map Name ref -> [(Name, ref)])
-> ([(Name, ref)] -> IO ()) -> Map Name ref -> IO ()
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> ASetter [(Name, ref)] [(Text, ref)] Name Text
-> (Name -> Text) -> [(Name, ref)] -> [(Text, ref)]
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over (((Name, ref) -> Identity (Text, ref))
-> [(Name, ref)] -> Identity [(Text, ref)]
Setter [(Name, ref)] [(Text, ref)] (Name, ref) (Text, ref)
forall (f :: * -> *) a b. Functor f => Setter (f a) (f b) a b
mapped (((Name, ref) -> Identity (Text, ref))
 -> [(Name, ref)] -> Identity [(Text, ref)])
-> ((Name -> Identity Text) -> (Name, ref) -> Identity (Text, ref))
-> ASetter [(Name, ref)] [(Text, ref)] Name Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name -> Identity Text) -> (Name, ref) -> Identity (Text, ref)
forall s t a b. Field1 s t a b => Lens s t a b
Lens (Name, ref) (Text, ref) Name Text
_1) Name -> Text
Name.toText
        ([(Name, ref)] -> [(Text, ref)])
-> ([(Text, ref)] -> IO ()) -> [(Name, ref)] -> IO ()
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> ((Text, ref) -> Text) -> [(Text, ref)] -> [(Text, ref)]
forall a b. Alphabetical a => (b -> a) -> [b] -> [b]
sortAlphabeticallyOn (Text, ref) -> Text
forall a b. (a, b) -> a
fst
        ([(Text, ref)] -> [(Text, ref)])
-> ([(Text, ref)] -> IO ()) -> [(Text, ref)] -> IO ()
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> ((Text, ref) -> IO ()) -> [(Text, ref)] -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ \(Text
name, ref
ref) ->
          Text -> IO ()
Text.putStrLn (Text -> Text
Text.italic (ref -> Text
label ref
ref) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ref -> Text
render ref
ref)

realDebugPartitionedDiff ::
  Merge.TwoWay (DefnsF (Map Name) TermReferenceId TypeReferenceId) ->
  DefnsF Merge.Unconflicts Referent TypeReference ->
  IO ()
realDebugPartitionedDiff :: TwoWay (DefnsF (Map Name) Id Id)
-> DefnsF Unconflicts Referent TypeReference -> IO ()
realDebugPartitionedDiff TwoWay (DefnsF (Map Name) Id Id)
conflicts DefnsF Unconflicts Referent TypeReference
unconflicts = do
  Text -> IO ()
Text.putStrLn (Text -> Text
Text.bold Text
"\n=== Alice conflicts ===")
  Text -> Map Name Id -> EitherWay () -> IO ()
renderConflicts Text
"termid" TwoWay (DefnsF (Map Name) Id Id)
conflicts.alice.terms (() -> EitherWay ()
forall a. a -> EitherWay a
Merge.Alice ())
  Text -> Map Name Id -> EitherWay () -> IO ()
renderConflicts Text
"typeid" TwoWay (DefnsF (Map Name) Id Id)
conflicts.alice.types (() -> EitherWay ()
forall a. a -> EitherWay a
Merge.Alice ())

  Text -> IO ()
Text.putStrLn (Text -> Text
Text.bold Text
"\n=== Bob conflicts ===")
  Text -> Map Name Id -> EitherWay () -> IO ()
renderConflicts Text
"termid" TwoWay (DefnsF (Map Name) Id Id)
conflicts.bob.terms (() -> EitherWay ()
forall a. a -> EitherWay a
Merge.Bob ())
  Text -> Map Name Id -> EitherWay () -> IO ()
renderConflicts Text
"typeid" TwoWay (DefnsF (Map Name) Id Id)
conflicts.bob.types (() -> EitherWay ()
forall a. a -> EitherWay a
Merge.Bob ())

  Text -> IO ()
Text.putStrLn (Text -> Text
Text.bold Text
"\n=== Alice unconflicts ===")
  (Text -> Text)
-> Text
-> (Referent -> Text)
-> (Referent -> Text)
-> Map Name Referent
-> IO ()
forall ref.
(Text -> Text)
-> Text -> (ref -> Text) -> (ref -> Text) -> Map Name ref -> IO ()
renderUnconflicts Text -> Text
Text.green Text
"+" Referent -> Text
referentLabel Referent -> Text
Referent.toText DefnsF Unconflicts Referent TypeReference
unconflicts.terms.adds.alice
  (Text -> Text)
-> Text
-> (TypeReference -> Text)
-> (TypeReference -> Text)
-> Map Name TypeReference
-> IO ()
forall ref.
(Text -> Text)
-> Text -> (ref -> Text) -> (ref -> Text) -> Map Name ref -> IO ()
renderUnconflicts Text -> Text
Text.green Text
"+" (Text -> TypeReference -> Text
forall a b. a -> b -> a
const Text
"type") TypeReference -> Text
Reference.toText DefnsF Unconflicts Referent TypeReference
unconflicts.types.adds.alice
  (Text -> Text)
-> Text
-> (Referent -> Text)
-> (Referent -> Text)
-> Map Name Referent
-> IO ()
forall ref.
(Text -> Text)
-> Text -> (ref -> Text) -> (ref -> Text) -> Map Name ref -> IO ()
renderUnconflicts Text -> Text
Text.red Text
"-" Referent -> Text
referentLabel Referent -> Text
Referent.toText DefnsF Unconflicts Referent TypeReference
unconflicts.terms.deletes.alice
  (Text -> Text)
-> Text
-> (TypeReference -> Text)
-> (TypeReference -> Text)
-> Map Name TypeReference
-> IO ()
forall ref.
(Text -> Text)
-> Text -> (ref -> Text) -> (ref -> Text) -> Map Name ref -> IO ()
renderUnconflicts Text -> Text
Text.red Text
"-" (Text -> TypeReference -> Text
forall a b. a -> b -> a
const Text
"type") TypeReference -> Text
Reference.toText DefnsF Unconflicts Referent TypeReference
unconflicts.types.deletes.alice
  (Text -> Text)
-> Text
-> (Referent -> Text)
-> (Referent -> Text)
-> Map Name Referent
-> IO ()
forall ref.
(Text -> Text)
-> Text -> (ref -> Text) -> (ref -> Text) -> Map Name ref -> IO ()
renderUnconflicts Text -> Text
Text.yellow Text
"%" Referent -> Text
referentLabel Referent -> Text
Referent.toText DefnsF Unconflicts Referent TypeReference
unconflicts.terms.updates.alice
  (Text -> Text)
-> Text
-> (TypeReference -> Text)
-> (TypeReference -> Text)
-> Map Name TypeReference
-> IO ()
forall ref.
(Text -> Text)
-> Text -> (ref -> Text) -> (ref -> Text) -> Map Name ref -> IO ()
renderUnconflicts Text -> Text
Text.yellow Text
"%" (Text -> TypeReference -> Text
forall a b. a -> b -> a
const Text
"type") TypeReference -> Text
Reference.toText DefnsF Unconflicts Referent TypeReference
unconflicts.types.updates.alice

  Text -> IO ()
Text.putStrLn (Text -> Text
Text.bold Text
"\n=== Bob unconflicts ===")
  (Text -> Text)
-> Text
-> (Referent -> Text)
-> (Referent -> Text)
-> Map Name Referent
-> IO ()
forall ref.
(Text -> Text)
-> Text -> (ref -> Text) -> (ref -> Text) -> Map Name ref -> IO ()
renderUnconflicts Text -> Text
Text.green Text
"+" Referent -> Text
referentLabel Referent -> Text
Referent.toText DefnsF Unconflicts Referent TypeReference
unconflicts.terms.adds.bob
  (Text -> Text)
-> Text
-> (TypeReference -> Text)
-> (TypeReference -> Text)
-> Map Name TypeReference
-> IO ()
forall ref.
(Text -> Text)
-> Text -> (ref -> Text) -> (ref -> Text) -> Map Name ref -> IO ()
renderUnconflicts Text -> Text
Text.green Text
"+" (Text -> TypeReference -> Text
forall a b. a -> b -> a
const Text
"type") TypeReference -> Text
Reference.toText DefnsF Unconflicts Referent TypeReference
unconflicts.types.adds.bob
  (Text -> Text)
-> Text
-> (Referent -> Text)
-> (Referent -> Text)
-> Map Name Referent
-> IO ()
forall ref.
(Text -> Text)
-> Text -> (ref -> Text) -> (ref -> Text) -> Map Name ref -> IO ()
renderUnconflicts Text -> Text
Text.red Text
"-" Referent -> Text
referentLabel Referent -> Text
Referent.toText DefnsF Unconflicts Referent TypeReference
unconflicts.terms.deletes.bob
  (Text -> Text)
-> Text
-> (TypeReference -> Text)
-> (TypeReference -> Text)
-> Map Name TypeReference
-> IO ()
forall ref.
(Text -> Text)
-> Text -> (ref -> Text) -> (ref -> Text) -> Map Name ref -> IO ()
renderUnconflicts Text -> Text
Text.red Text
"-" (Text -> TypeReference -> Text
forall a b. a -> b -> a
const Text
"type") TypeReference -> Text
Reference.toText DefnsF Unconflicts Referent TypeReference
unconflicts.types.deletes.bob
  (Text -> Text)
-> Text
-> (Referent -> Text)
-> (Referent -> Text)
-> Map Name Referent
-> IO ()
forall ref.
(Text -> Text)
-> Text -> (ref -> Text) -> (ref -> Text) -> Map Name ref -> IO ()
renderUnconflicts Text -> Text
Text.yellow Text
"%" Referent -> Text
referentLabel Referent -> Text
Referent.toText DefnsF Unconflicts Referent TypeReference
unconflicts.terms.updates.bob
  (Text -> Text)
-> Text
-> (TypeReference -> Text)
-> (TypeReference -> Text)
-> Map Name TypeReference
-> IO ()
forall ref.
(Text -> Text)
-> Text -> (ref -> Text) -> (ref -> Text) -> Map Name ref -> IO ()
renderUnconflicts Text -> Text
Text.yellow Text
"%" (Text -> TypeReference -> Text
forall a b. a -> b -> a
const Text
"type") TypeReference -> Text
Reference.toText DefnsF Unconflicts Referent TypeReference
unconflicts.types.updates.bob

  Text -> IO ()
Text.putStrLn (Text -> Text
Text.bold Text
"\n=== Alice-and-Bob unconflicts ===")
  (Text -> Text)
-> Text
-> (Referent -> Text)
-> (Referent -> Text)
-> Map Name Referent
-> IO ()
forall ref.
(Text -> Text)
-> Text -> (ref -> Text) -> (ref -> Text) -> Map Name ref -> IO ()
renderUnconflicts Text -> Text
Text.green Text
"+" Referent -> Text
referentLabel Referent -> Text
Referent.toText DefnsF Unconflicts Referent TypeReference
unconflicts.terms.adds.both
  (Text -> Text)
-> Text
-> (TypeReference -> Text)
-> (TypeReference -> Text)
-> Map Name TypeReference
-> IO ()
forall ref.
(Text -> Text)
-> Text -> (ref -> Text) -> (ref -> Text) -> Map Name ref -> IO ()
renderUnconflicts Text -> Text
Text.green Text
"+" (Text -> TypeReference -> Text
forall a b. a -> b -> a
const Text
"type") TypeReference -> Text
Reference.toText DefnsF Unconflicts Referent TypeReference
unconflicts.types.adds.both
  (Text -> Text)
-> Text
-> (Referent -> Text)
-> (Referent -> Text)
-> Map Name Referent
-> IO ()
forall ref.
(Text -> Text)
-> Text -> (ref -> Text) -> (ref -> Text) -> Map Name ref -> IO ()
renderUnconflicts Text -> Text
Text.red Text
"-" Referent -> Text
referentLabel Referent -> Text
Referent.toText DefnsF Unconflicts Referent TypeReference
unconflicts.terms.deletes.both
  (Text -> Text)
-> Text
-> (TypeReference -> Text)
-> (TypeReference -> Text)
-> Map Name TypeReference
-> IO ()
forall ref.
(Text -> Text)
-> Text -> (ref -> Text) -> (ref -> Text) -> Map Name ref -> IO ()
renderUnconflicts Text -> Text
Text.red Text
"-" (Text -> TypeReference -> Text
forall a b. a -> b -> a
const Text
"type") TypeReference -> Text
Reference.toText DefnsF Unconflicts Referent TypeReference
unconflicts.types.deletes.both
  (Text -> Text)
-> Text
-> (Referent -> Text)
-> (Referent -> Text)
-> Map Name Referent
-> IO ()
forall ref.
(Text -> Text)
-> Text -> (ref -> Text) -> (ref -> Text) -> Map Name ref -> IO ()
renderUnconflicts Text -> Text
Text.yellow Text
"%" Referent -> Text
referentLabel Referent -> Text
Referent.toText DefnsF Unconflicts Referent TypeReference
unconflicts.terms.updates.both
  (Text -> Text)
-> Text
-> (TypeReference -> Text)
-> (TypeReference -> Text)
-> Map Name TypeReference
-> IO ()
forall ref.
(Text -> Text)
-> Text -> (ref -> Text) -> (ref -> Text) -> Map Name ref -> IO ()
renderUnconflicts Text -> Text
Text.yellow Text
"%" (Text -> TypeReference -> Text
forall a b. a -> b -> a
const Text
"type") TypeReference -> Text
Reference.toText DefnsF Unconflicts Referent TypeReference
unconflicts.types.updates.both
  where
    renderConflicts :: Text -> Map Name Reference.Id -> Merge.EitherWay () -> IO ()
    renderConflicts :: Text -> Map Name Id -> EitherWay () -> IO ()
renderConflicts Text
label Map Name Id
conflicts EitherWay ()
who =
      Map Name Id
conflicts
        Map Name Id -> (Map Name Id -> [(Name, Id)]) -> [(Name, Id)]
forall a b. a -> (a -> b) -> b
& Map Name Id -> [(Name, Id)]
forall k a. Map k a -> [(k, a)]
Map.toList
        [(Name, Id)] -> ([(Name, Id)] -> [(Text, Id)]) -> [(Text, Id)]
forall a b. a -> (a -> b) -> b
& ASetter [(Name, Id)] [(Text, Id)] Name Text
-> (Name -> Text) -> [(Name, Id)] -> [(Text, Id)]
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over (((Name, Id) -> Identity (Text, Id))
-> [(Name, Id)] -> Identity [(Text, Id)]
Setter [(Name, Id)] [(Text, Id)] (Name, Id) (Text, Id)
forall (f :: * -> *) a b. Functor f => Setter (f a) (f b) a b
mapped (((Name, Id) -> Identity (Text, Id))
 -> [(Name, Id)] -> Identity [(Text, Id)])
-> ((Name -> Identity Text) -> (Name, Id) -> Identity (Text, Id))
-> ASetter [(Name, Id)] [(Text, Id)] Name Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name -> Identity Text) -> (Name, Id) -> Identity (Text, Id)
forall s t a b. Field1 s t a b => Lens s t a b
Lens (Name, Id) (Text, Id) Name Text
_1) Name -> Text
Name.toText
        [(Text, Id)] -> ([(Text, Id)] -> [(Text, Id)]) -> [(Text, Id)]
forall a b. a -> (a -> b) -> b
& ((Text, Id) -> Text) -> [(Text, Id)] -> [(Text, Id)]
forall a b. Alphabetical a => (b -> a) -> [b] -> [b]
sortAlphabeticallyOn (Text, Id) -> Text
forall a b. (a, b) -> a
fst
        [(Text, Id)] -> ([(Text, Id)] -> IO ()) -> IO ()
forall a b. a -> (a -> b) -> b
& ((Text, Id) -> IO ()) -> [(Text, Id)] -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ \(Text
name, Id
ref) ->
          Text -> IO ()
Text.putStrLn (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$
            Text -> Text
Text.magenta (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$
              Text
"! "
                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
Text.italic Text
label
                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" "
                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name
                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" "
                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Id -> Text
Reference.idToText Id
ref
                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" ("
                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (case EitherWay ()
who of Merge.Alice () -> Text
"Alice"; Merge.Bob () -> Text
"Bob")
                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")"

    renderUnconflicts ::
      (Text -> Text) ->
      Text ->
      (ref -> Text) ->
      (ref -> Text) ->
      Map Name ref ->
      IO ()
    renderUnconflicts :: forall ref.
(Text -> Text)
-> Text -> (ref -> Text) -> (ref -> Text) -> Map Name ref -> IO ()
renderUnconflicts Text -> Text
color Text
action ref -> Text
label ref -> Text
renderRef Map Name ref
unconflicts =
      Map Name ref
unconflicts
        Map Name ref -> (Map Name ref -> [(Name, ref)]) -> [(Name, ref)]
forall a b. a -> (a -> b) -> b
& Map Name ref -> [(Name, ref)]
forall k a. Map k a -> [(k, a)]
Map.toList
        [(Name, ref)] -> ([(Name, ref)] -> [(Text, ref)]) -> [(Text, ref)]
forall a b. a -> (a -> b) -> b
& ASetter [(Name, ref)] [(Text, ref)] Name Text
-> (Name -> Text) -> [(Name, ref)] -> [(Text, ref)]
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over (((Name, ref) -> Identity (Text, ref))
-> [(Name, ref)] -> Identity [(Text, ref)]
Setter [(Name, ref)] [(Text, ref)] (Name, ref) (Text, ref)
forall (f :: * -> *) a b. Functor f => Setter (f a) (f b) a b
mapped (((Name, ref) -> Identity (Text, ref))
 -> [(Name, ref)] -> Identity [(Text, ref)])
-> ((Name -> Identity Text) -> (Name, ref) -> Identity (Text, ref))
-> ASetter [(Name, ref)] [(Text, ref)] Name Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name -> Identity Text) -> (Name, ref) -> Identity (Text, ref)
forall s t a b. Field1 s t a b => Lens s t a b
Lens (Name, ref) (Text, ref) Name Text
_1) Name -> Text
Name.toText
        [(Text, ref)] -> ([(Text, ref)] -> [(Text, ref)]) -> [(Text, ref)]
forall a b. a -> (a -> b) -> b
& ((Text, ref) -> Text) -> [(Text, ref)] -> [(Text, ref)]
forall a b. Alphabetical a => (b -> a) -> [b] -> [b]
sortAlphabeticallyOn (Text, ref) -> Text
forall a b. (a, b) -> a
fst
        [(Text, ref)] -> ([(Text, ref)] -> IO ()) -> IO ()
forall a b. a -> (a -> b) -> b
& ((Text, ref) -> IO ()) -> [(Text, ref)] -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ \(Text
name, ref
ref) ->
          Text -> IO ()
Text.putStrLn (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$
            Text -> Text
color (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$
              Text
action
                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" "
                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
Text.italic (ref -> Text
label ref
ref)
                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" "
                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name
                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" "
                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ref -> Text
renderRef ref
ref

realDebugRenames :: Merge.TwoWay (DefnsF [] Merge.Rename Merge.Rename) -> IO ()
realDebugRenames :: TwoWay (DefnsF [] Rename Rename) -> IO ()
realDebugRenames TwoWay (DefnsF [] Rename Rename)
renames = do
  Text -> IO ()
Text.putStrLn (Text -> Text
Text.bold Text
"\n=== Alice renames ===")
  DefnsF [] Rename Rename -> IO ()
renderRenames TwoWay (DefnsF [] Rename Rename)
renames.alice
  Text -> IO ()
Text.putStrLn (Text -> Text
Text.bold Text
"\n=== Bob renames ===")
  DefnsF [] Rename Rename -> IO ()
renderRenames TwoWay (DefnsF [] Rename Rename)
renames.bob
  where
    renderRenames :: DefnsF [] Merge.Rename Merge.Rename -> IO ()
    renderRenames :: DefnsF [] Rename Rename -> IO ()
renderRenames DefnsF [] Rename Rename
renames = do
      [Rename] -> (Rename -> IO ()) -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ DefnsF [] Rename Rename
renames.terms \Rename
rename ->
        Text -> IO ()
Text.putStrLn (Text -> Text
Text.italic Text
"term" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Rename -> Text
renderRename Rename
rename)
      [Rename] -> (Rename -> IO ()) -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ DefnsF [] Rename Rename
renames.types \Rename
rename ->
        Text -> IO ()
Text.putStrLn (Text -> Text
Text.italic Text
"type" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Rename -> Text
renderRename Rename
rename)

    renderRename :: Merge.Rename -> Text
    renderRename :: Rename -> Text
renderRename Rename
rename =
      [Text] -> Text
Text.unwords ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$
        [Maybe Text] -> [Text]
forall a. [Maybe a] -> [a]
catMaybes
          [ case Set Name -> [Name]
forall a. Set a -> [a]
Set.toList Rename
rename.unchanged of
              [] -> Maybe Text
forall a. Maybe a
Nothing
              [Name]
unchanged -> Text -> Maybe Text
forall a. a -> Maybe a
Just ([Text] -> Text
Text.unwords ((Name -> Text) -> [Name] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Text
Name.toText [Name]
unchanged)),
            case Set Name -> [Name]
forall a. Set a -> [a]
Set.toList Rename
rename.deletes of
              [] -> Maybe Text
forall a. Maybe a
Nothing
              [Name]
deletes -> Text -> Maybe Text
forall a. a -> Maybe a
Just ([Text] -> Text
Text.unwords ((Name -> Text) -> [Name] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (\Name
name -> Text -> Text
Text.red (Text
"-" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Name -> Text
Name.toText Name
name)) [Name]
deletes)),
            case Set Name -> [Name]
forall a. Set a -> [a]
Set.toList Rename
rename.adds of
              [] -> Maybe Text
forall a. Maybe a
Nothing
              [Name]
adds -> Text -> Maybe Text
forall a. a -> Maybe a
Just ([Text] -> Text
Text.unwords ((Name -> Text) -> [Name] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (\Name
name -> Text -> Text
Text.green (Text
"+" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Name -> Text
Name.toText Name
name)) [Name]
adds))
          ]

realDebugSimpleRenames :: Merge.TwoWay (Defns Merge.SimpleRenames Merge.SimpleRenames) -> IO ()
realDebugSimpleRenames :: TwoWay (Defns SimpleRenames SimpleRenames) -> IO ()
realDebugSimpleRenames TwoWay (Defns SimpleRenames SimpleRenames)
renames = do
  Text -> IO ()
Text.putStrLn (Text -> Text
Text.bold Text
"\n=== Alice simple renames ===")
  Defns SimpleRenames SimpleRenames -> IO ()
renderRenames TwoWay (Defns SimpleRenames SimpleRenames)
renames.alice
  Text -> IO ()
Text.putStrLn (Text -> Text
Text.bold Text
"\n=== Bob simple renames ===")
  Defns SimpleRenames SimpleRenames -> IO ()
renderRenames TwoWay (Defns SimpleRenames SimpleRenames)
renames.bob
  where
    renderRenames :: Defns Merge.SimpleRenames Merge.SimpleRenames -> IO ()
    renderRenames :: Defns SimpleRenames SimpleRenames -> IO ()
renderRenames Defns SimpleRenames SimpleRenames
renames = do
      Defns SimpleRenames SimpleRenames
renames.terms.forwards
        Map Name Name
-> (Map Name Name -> [(Name, Name)]) -> [(Name, Name)]
forall a b. a -> (a -> b) -> b
& Map Name Name -> [(Name, Name)]
forall k a. Map k a -> [(k, a)]
Map.toList
        [(Name, Name)] -> ([(Name, Name)] -> [Text]) -> [Text]
forall a b. a -> (a -> b) -> b
& ((Name, Name) -> Text) -> [(Name, Name)] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (\(Name
old, Name
new) -> Text -> Text
Text.italic Text
"term" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Name -> Text
Name.toText Name
old Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" → " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Name -> Text
Name.toText Name
new)
        [Text] -> ([Text] -> Text) -> Text
forall a b. a -> (a -> b) -> b
& [Text] -> Text
Text.unlines
        Text -> (Text -> IO ()) -> IO ()
forall a b. a -> (a -> b) -> b
& Text -> IO ()
Text.putStr
      Defns SimpleRenames SimpleRenames
renames.types.forwards
        Map Name Name
-> (Map Name Name -> [(Name, Name)]) -> [(Name, Name)]
forall a b. a -> (a -> b) -> b
& Map Name Name -> [(Name, Name)]
forall k a. Map k a -> [(k, a)]
Map.toList
        [(Name, Name)] -> ([(Name, Name)] -> [Text]) -> [Text]
forall a b. a -> (a -> b) -> b
& ((Name, Name) -> Text) -> [(Name, Name)] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (\(Name
old, Name
new) -> Text -> Text
Text.italic Text
"type" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Name -> Text
Name.toText Name
old Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" → " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Name -> Text
Name.toText Name
new)
        [Text] -> ([Text] -> Text) -> Text
forall a b. a -> (a -> b) -> b
& [Text] -> Text
Text.unlines
        Text -> (Text -> IO ()) -> IO ()
forall a b. a -> (a -> b) -> b
& Text -> IO ()
Text.putStr

realDebugSynhashedNarrowedDefns :: Merge.TwoWay (Merge.Updated (DefnsF2 (Map Name) Merge.Synhashed Referent TypeReference)) -> IO ()
realDebugSynhashedNarrowedDefns :: TwoWay
  (Updated (DefnsF2 (Map Name) Synhashed Referent TypeReference))
-> IO ()
realDebugSynhashedNarrowedDefns TwoWay
  (Updated (DefnsF2 (Map Name) Synhashed Referent TypeReference))
defns = do
  Text -> IO ()
Text.putStrLn (Text -> Text
Text.bold Text
"\n=== Synhashed narrowed LCA→Alice defns (LCA) ===")
  DefnsF2 (Map Name) Synhashed Referent TypeReference -> IO ()
renderDefns TwoWay
  (Updated (DefnsF2 (Map Name) Synhashed Referent TypeReference))
defns.alice.old
  Text -> IO ()
Text.putStrLn (Text -> Text
Text.bold Text
"\n=== Synhashed narrowed LCA→Alice defns (Alice) ===")
  DefnsF2 (Map Name) Synhashed Referent TypeReference -> IO ()
renderDefns TwoWay
  (Updated (DefnsF2 (Map Name) Synhashed Referent TypeReference))
defns.alice.new
  Text -> IO ()
Text.putStrLn (Text -> Text
Text.bold Text
"\n=== Synhashed narrowed LCA→Bob defns (LCA) ===")
  DefnsF2 (Map Name) Synhashed Referent TypeReference -> IO ()
renderDefns TwoWay
  (Updated (DefnsF2 (Map Name) Synhashed Referent TypeReference))
defns.bob.old
  Text -> IO ()
Text.putStrLn (Text -> Text
Text.bold Text
"\n=== Synhashed narrowed LCA→Bob defns (Bob) ===")
  DefnsF2 (Map Name) Synhashed Referent TypeReference -> IO ()
renderDefns TwoWay
  (Updated (DefnsF2 (Map Name) Synhashed Referent TypeReference))
defns.bob.new
  where
    renderDefns :: DefnsF2 (Map Name) Merge.Synhashed Referent TypeReference -> IO ()
    renderDefns :: DefnsF2 (Map Name) Synhashed Referent TypeReference -> IO ()
renderDefns DefnsF2 (Map Name) Synhashed Referent TypeReference
defns = do
      (Referent -> Text) -> Map Name (Synhashed Referent) -> IO ()
forall ref. (ref -> Text) -> Map Name (Synhashed ref) -> IO ()
renderThings Referent -> Text
referentLabel DefnsF2 (Map Name) Synhashed Referent TypeReference
defns.terms
      (TypeReference -> Text)
-> Map Name (Synhashed TypeReference) -> IO ()
forall ref. (ref -> Text) -> Map Name (Synhashed ref) -> IO ()
renderThings (Text -> TypeReference -> Text
forall a b. a -> b -> a
const Text
"type") DefnsF2 (Map Name) Synhashed Referent TypeReference
defns.types

    renderThings :: (ref -> Text) -> Map Name (Merge.Synhashed ref) -> IO ()
    renderThings :: forall ref. (ref -> Text) -> Map Name (Synhashed ref) -> IO ()
renderThings ref -> Text
label =
      Map Name (Synhashed ref) -> [(Name, Synhashed ref)]
forall k a. Map k a -> [(k, a)]
Map.toList
        (Map Name (Synhashed ref) -> [(Name, Synhashed ref)])
-> ([(Name, Synhashed ref)] -> IO ())
-> Map Name (Synhashed ref)
-> IO ()
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> ASetter [(Name, Synhashed ref)] [(Text, Synhashed ref)] Name Text
-> (Name -> Text)
-> [(Name, Synhashed ref)]
-> [(Text, Synhashed ref)]
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over (((Name, Synhashed ref) -> Identity (Text, Synhashed ref))
-> [(Name, Synhashed ref)] -> Identity [(Text, Synhashed ref)]
Setter
  [(Name, Synhashed ref)]
  [(Text, Synhashed ref)]
  (Name, Synhashed ref)
  (Text, Synhashed ref)
forall (f :: * -> *) a b. Functor f => Setter (f a) (f b) a b
mapped (((Name, Synhashed ref) -> Identity (Text, Synhashed ref))
 -> [(Name, Synhashed ref)] -> Identity [(Text, Synhashed ref)])
-> ((Name -> Identity Text)
    -> (Name, Synhashed ref) -> Identity (Text, Synhashed ref))
-> ASetter
     [(Name, Synhashed ref)] [(Text, Synhashed ref)] Name Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name -> Identity Text)
-> (Name, Synhashed ref) -> Identity (Text, Synhashed ref)
forall s t a b. Field1 s t a b => Lens s t a b
Lens (Name, Synhashed ref) (Text, Synhashed ref) Name Text
_1) Name -> Text
Name.toText
        ([(Name, Synhashed ref)] -> [(Text, Synhashed ref)])
-> ([(Text, Synhashed ref)] -> IO ())
-> [(Name, Synhashed ref)]
-> IO ()
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> ((Text, Synhashed ref) -> Text)
-> [(Text, Synhashed ref)] -> [(Text, Synhashed ref)]
forall a b. Alphabetical a => (b -> a) -> [b] -> [b]
sortAlphabeticallyOn (Text, Synhashed ref) -> Text
forall a b. (a, b) -> a
fst
        ([(Text, Synhashed ref)] -> [(Text, Synhashed ref)])
-> ([(Text, Synhashed ref)] -> IO ())
-> [(Text, Synhashed ref)]
-> IO ()
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> ((Text, Synhashed ref) -> IO ())
-> [(Text, Synhashed ref)] -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ \(Text
name, Synhashed ref
ref) ->
          Text -> IO ()
Text.putStrLn (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$
            Text -> Text
Text.italic (ref -> Text
label (Synhashed ref -> ref
forall a. Synhashed a -> a
Synhashed.value Synhashed ref
ref))
              Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" "
              Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name
              Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" #"
              Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Hash -> Text
Hash.toBase32HexText (Synhashed ref -> Hash
forall a. Synhashed a -> Hash
Synhashed.hash Synhashed ref
ref)

referentLabel :: Referent -> Text
referentLabel :: Referent -> Text
referentLabel Referent
ref
  | Referent -> Bool
forall r. Referent' r -> Bool
Referent'.isConstructor Referent
ref = Text
"ctor"
  | Bool
otherwise = Text
"term"