-- | @pull@ input handler
module Unison.Codebase.Editor.HandleInput.Pull
  ( handlePull,
    loadPropagateDiffDefaultPatch,
    mergeBranchAndPropagateDefaultPatch,
    propagatePatch,
  )
where

import Control.Monad.Reader (ask)
import Data.Text qualified as Text
import Data.These
import U.Codebase.Branch qualified as V2.Branch
import U.Codebase.Causal qualified
import U.Codebase.Sqlite.Operations qualified as Operations
import U.Codebase.Sqlite.Project qualified as Sqlite (Project (..))
import U.Codebase.Sqlite.ProjectBranch qualified as Sqlite (ProjectBranch (..))
import U.Codebase.Sqlite.Queries qualified as Queries
import Unison.Cli.DownloadUtils
import Unison.Cli.MergeTypes (MergeSource (..))
import Unison.Cli.Monad (Cli)
import Unison.Cli.Monad qualified as Cli
import Unison.Cli.MonadUtils qualified as Cli
import Unison.Cli.NamesUtils qualified as Cli
import Unison.Cli.ProjectUtils qualified as ProjectUtils
import Unison.Cli.Share.Projects qualified as Share
import Unison.Codebase qualified as Codebase
import Unison.Codebase.Branch (Branch (..))
import Unison.Codebase.Branch qualified as Branch
import Unison.Codebase.Branch.Merge qualified as Branch
import Unison.Codebase.Editor.HandleInput.Merge2 (AliceMergeInfo (..), BobMergeInfo (..), LcaMergeInfo (..), MergeInfo (..), doMerge)
import Unison.Codebase.Editor.HandleInput.NamespaceDiffUtils (diffHelper)
import Unison.Codebase.Editor.Input
import Unison.Codebase.Editor.Input qualified as Input
import Unison.Codebase.Editor.Output
import Unison.Codebase.Editor.Output qualified as Output
import Unison.Codebase.Editor.Propagate qualified as Propagate
import Unison.Codebase.Editor.RemoteRepo (ReadRemoteNamespace (..), printReadRemoteNamespace)
import Unison.Codebase.Patch (Patch (..))
import Unison.Codebase.Path qualified as Path
import Unison.Codebase.ProjectPath qualified as PP
import Unison.CommandLine.InputPattern qualified as InputPattern
import Unison.CommandLine.InputPatterns qualified as InputPatterns
import Unison.NameSegment qualified as NameSegment
import Unison.Prelude
import Unison.Project (ProjectAndBranch (..), ProjectBranchNameOrLatestRelease (..), ProjectName)
import Witch (unsafeFrom)

handlePull :: PullSourceTarget -> PullMode -> Cli ()
handlePull :: PullSourceTarget -> PullMode -> Cli ()
handlePull PullSourceTarget
unresolvedSourceAndTarget PullMode
pullMode = do
  let includeSquashed :: IncludeSquashedHead
includeSquashed = case PullMode
pullMode of
        PullMode
Input.PullWithHistory -> IncludeSquashedHead
Share.NoSquashedHead
        PullMode
Input.PullWithoutHistory -> IncludeSquashedHead
Share.IncludeSquashedHead

  (ReadRemoteNamespace RemoteProjectBranch
source, ProjectAndBranch Project ProjectBranch
target) <- IncludeSquashedHead
-> PullSourceTarget
-> Cli
     (ReadRemoteNamespace RemoteProjectBranch,
      ProjectAndBranch Project ProjectBranch)
resolveSourceAndTarget IncludeSquashedHead
includeSquashed PullSourceTarget
unresolvedSourceAndTarget

  CausalHash
remoteCausalHash <- do
    case ReadRemoteNamespace RemoteProjectBranch
source of
      ReadShare'LooseCode ReadShareLooseCode
repo -> ReadShareLooseCode -> Cli (Either ShareError CausalHash)
downloadLooseCodeFromShare ReadShareLooseCode
repo Cli (Either ShareError CausalHash)
-> (Cli (Either ShareError CausalHash) -> Cli CausalHash)
-> Cli CausalHash
forall a b. a -> (a -> b) -> b
& (ShareError -> Cli CausalHash)
-> Cli (Either ShareError CausalHash) -> Cli CausalHash
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> m (Either a b) -> m b
onLeftM (Output -> Cli CausalHash
forall a. Output -> Cli a
Cli.returnEarly (Output -> Cli CausalHash)
-> (ShareError -> Output) -> ShareError -> Cli CausalHash
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShareError -> Output
Output.ShareError)
      ReadShare'ProjectBranch RemoteProjectBranch
remoteBranch ->
        HasCallStack =>
IncludeSquashedHead
-> RemoteProjectBranch -> Cli (Either ShareError CausalHash)
IncludeSquashedHead
-> RemoteProjectBranch -> Cli (Either ShareError CausalHash)
downloadProjectBranchFromShare
          ( case PullMode
pullMode of
              PullMode
Input.PullWithHistory -> IncludeSquashedHead
Share.NoSquashedHead
              PullMode
Input.PullWithoutHistory -> IncludeSquashedHead
Share.IncludeSquashedHead
          )
          RemoteProjectBranch
remoteBranch
          Cli (Either ShareError CausalHash)
-> (Cli (Either ShareError CausalHash) -> Cli CausalHash)
-> Cli CausalHash
forall a b. a -> (a -> b) -> b
& (ShareError -> Cli CausalHash)
-> Cli (Either ShareError CausalHash) -> Cli CausalHash
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> m (Either a b) -> m b
onLeftM (Output -> Cli CausalHash
forall a. Output -> Cli a
Cli.returnEarly (Output -> Cli CausalHash)
-> (ShareError -> Output) -> ShareError -> Cli CausalHash
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShareError -> Output
Output.ShareError)

  Bool
remoteBranchIsEmpty <-
    Transaction Bool -> Cli Bool
forall a. Transaction a -> Cli a
Cli.runTransaction do
      CausalBranch Transaction
causal <- CausalHash -> Transaction (CausalBranch Transaction)
Operations.expectCausalBranchByCausalHash CausalHash
remoteCausalHash
      Branch Transaction
branch <- CausalBranch Transaction
causal.value
      Branch Transaction -> Transaction Bool
forall (m :: * -> *). Branch m -> Transaction Bool
V2.Branch.isEmpty Branch Transaction
branch

  Bool -> Cli () -> Cli ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
remoteBranchIsEmpty (Output -> Cli ()
Cli.respond (ReadRemoteNamespace RemoteProjectBranch -> Output
PulledEmptyBranch ReadRemoteNamespace RemoteProjectBranch
source))

  let targetProjectPath :: ProjectPath
targetProjectPath = ProjectAndBranch Project ProjectBranch -> ProjectPath
PP.projectBranchRoot (Project -> ProjectBranch -> ProjectAndBranch Project ProjectBranch
forall a b. a -> b -> ProjectAndBranch a b
ProjectAndBranch ProjectAndBranch Project ProjectBranch
target.project ProjectAndBranch Project ProjectBranch
target.branch)

  let description :: Text
description =
        [Text] -> Text
Text.unwords
          [ String -> Text
Text.pack (String -> Text)
-> (InputPattern -> String) -> InputPattern -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InputPattern -> String
InputPattern.patternName (InputPattern -> Text) -> InputPattern -> Text
forall a b. (a -> b) -> a -> b
$
              case PullMode
pullMode of
                PullMode
PullWithoutHistory -> InputPattern
InputPatterns.pullWithoutHistory
                PullMode
PullWithHistory -> InputPattern
InputPatterns.pull,
            (RemoteProjectBranch -> Text)
-> ReadRemoteNamespace RemoteProjectBranch -> Text
forall a. (a -> Text) -> ReadRemoteNamespace a -> Text
printReadRemoteNamespace (\RemoteProjectBranch
remoteBranch -> forall target source. From source target => source -> target
into @Text (ProjectName
-> ProjectBranchName
-> ProjectAndBranch ProjectName ProjectBranchName
forall a b. a -> b -> ProjectAndBranch a b
ProjectAndBranch RemoteProjectBranch
remoteBranch.projectName RemoteProjectBranch
remoteBranch.branchName)) ReadRemoteNamespace RemoteProjectBranch
source,
            case ProjectAndBranch Project ProjectBranch
target of
              ProjectAndBranch Project
project ProjectBranch
branch -> forall target source. From source target => source -> target
into @Text (ProjectName
-> ProjectBranchName
-> ProjectAndBranch ProjectName ProjectBranchName
forall a b. a -> b -> ProjectAndBranch a b
ProjectAndBranch Project
project.name ProjectBranch
branch.name)
          ]

  case PullMode
pullMode of
    PullMode
Input.PullWithHistory -> do
      Branch IO
targetBranch <- ProjectPath -> Cli (Branch IO)
Cli.getBranchFromProjectPath ProjectPath
targetProjectPath

      if Branch0 IO -> Bool
forall (m :: * -> *). Branch0 m -> Bool
Branch.isEmpty0 (Branch0 IO -> Bool) -> Branch0 IO -> Bool
forall a b. (a -> b) -> a -> b
$ Branch IO -> Branch0 IO
forall (m :: * -> *). Branch m -> Branch0 m
Branch.head Branch IO
targetBranch
        then do
          Cli.Env {Codebase IO Symbol Ann
codebase :: Codebase IO Symbol Ann
$sel:codebase:Env :: Env -> Codebase IO Symbol Ann
codebase} <- Cli Env
forall r (m :: * -> *). MonadReader r m => m r
ask
          Branch IO
remoteBranchObject <- 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 Codebase IO Symbol Ann
codebase CausalHash
remoteCausalHash)
          Cli Bool -> Cli ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Cli Bool -> Cli ()) -> Cli Bool -> Cli ()
forall a b. (a -> b) -> a -> b
$ Text -> ProjectPath -> (Branch IO -> Cli (Branch IO)) -> Cli Bool
Cli.updateAtM Text
description ProjectPath
targetProjectPath (Cli (Branch IO) -> Branch IO -> Cli (Branch IO)
forall a b. a -> b -> a
const (Cli (Branch IO) -> Branch IO -> Cli (Branch IO))
-> Cli (Branch IO) -> Branch IO -> Cli (Branch IO)
forall a b. (a -> b) -> a -> b
$ Branch IO -> Cli (Branch IO)
forall a. a -> Cli a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Branch IO
remoteBranchObject)
          Output -> Cli ()
Cli.respond (Output -> Cli ()) -> Output -> Cli ()
forall a b. (a -> b) -> a -> b
$ ProjectAndBranch Project ProjectBranch -> Output
MergeOverEmpty ProjectAndBranch Project ProjectBranch
target
        else do
          Output -> Cli ()
Cli.respond Output
AboutToMerge

          let aliceCausalHash :: CausalHash
aliceCausalHash = Branch IO -> CausalHash
forall (m :: * -> *). Branch m -> CausalHash
Branch.headHash Branch IO
targetBranch
          Maybe CausalHash
lcaCausalHash <- Transaction (Maybe CausalHash) -> Cli (Maybe CausalHash)
forall a. Transaction a -> Cli a
Cli.runTransaction (CausalHash -> CausalHash -> Transaction (Maybe CausalHash)
Operations.lca CausalHash
aliceCausalHash CausalHash
remoteCausalHash)

          MergeInfo -> Cli ()
doMerge
            MergeInfo
              { $sel:alice:MergeInfo :: AliceMergeInfo
alice =
                  AliceMergeInfo
                    { $sel:causalHash:AliceMergeInfo :: CausalHash
causalHash = CausalHash
aliceCausalHash,
                      $sel:projectAndBranch:AliceMergeInfo :: ProjectAndBranch Project ProjectBranch
projectAndBranch = ProjectAndBranch Project ProjectBranch
target
                    },
                $sel:bob:MergeInfo :: BobMergeInfo
bob =
                  BobMergeInfo
                    { $sel:causalHash:BobMergeInfo :: CausalHash
causalHash = CausalHash
remoteCausalHash,
                      $sel:source:BobMergeInfo :: MergeSource
source =
                        case ReadRemoteNamespace RemoteProjectBranch
source of
                          ReadShare'ProjectBranch RemoteProjectBranch
remoteBranch ->
                            ProjectAndBranch ProjectName ProjectBranchName -> MergeSource
MergeSource'RemoteProjectBranch (ProjectName
-> ProjectBranchName
-> ProjectAndBranch ProjectName ProjectBranchName
forall a b. a -> b -> ProjectAndBranch a b
ProjectAndBranch RemoteProjectBranch
remoteBranch.projectName RemoteProjectBranch
remoteBranch.branchName)
                          ReadShare'LooseCode ReadShareLooseCode
info -> ReadShareLooseCode -> MergeSource
MergeSource'RemoteLooseCode ReadShareLooseCode
info
                    },
                $sel:lca:MergeInfo :: LcaMergeInfo
lca =
                  LcaMergeInfo
                    { $sel:causalHash:LcaMergeInfo :: Maybe CausalHash
causalHash = Maybe CausalHash
lcaCausalHash
                    },
                Text
description :: Text
$sel:description:MergeInfo :: Text
description
              }
    PullMode
Input.PullWithoutHistory -> do
      Cli.Env {Codebase IO Symbol Ann
$sel:codebase:Env :: Env -> Codebase IO Symbol Ann
codebase :: Codebase IO Symbol Ann
codebase} <- Cli Env
forall r (m :: * -> *). MonadReader r m => m r
ask
      Branch IO
remoteBranchObject <- 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 Codebase IO Symbol Ann
codebase CausalHash
remoteCausalHash)

      Bool
didUpdate <-
        Text -> ProjectPath -> (Branch IO -> Cli (Branch IO)) -> Cli Bool
Cli.updateAtM
          Text
description
          ProjectPath
targetProjectPath
          (\Branch IO
targetBranchObject -> Branch IO -> Cli (Branch IO)
forall a. a -> Cli a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Branch IO -> Cli (Branch IO)) -> Branch IO -> Cli (Branch IO)
forall a b. (a -> b) -> a -> b
$ Branch IO
remoteBranchObject Branch IO -> Branch IO -> Branch IO
forall (m :: * -> *). Monad m => Branch m -> Branch m -> Branch m
`Branch.consBranchSnapshot` Branch IO
targetBranchObject)

      Output -> Cli ()
Cli.respond
        if Bool
didUpdate
          then ReadRemoteNamespace RemoteProjectBranch
-> ProjectAndBranch Project ProjectBranch -> Output
PullSuccessful ReadRemoteNamespace RemoteProjectBranch
source ProjectAndBranch Project ProjectBranch
target
          else ReadRemoteNamespace RemoteProjectBranch
-> ProjectAndBranch Project ProjectBranch -> Output
PullAlreadyUpToDate ReadRemoteNamespace RemoteProjectBranch
source ProjectAndBranch Project ProjectBranch
target

resolveSourceAndTarget ::
  Share.IncludeSquashedHead ->
  PullSourceTarget ->
  Cli
    ( ReadRemoteNamespace Share.RemoteProjectBranch,
      ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch
    )
resolveSourceAndTarget :: IncludeSquashedHead
-> PullSourceTarget
-> Cli
     (ReadRemoteNamespace RemoteProjectBranch,
      ProjectAndBranch Project ProjectBranch)
resolveSourceAndTarget IncludeSquashedHead
includeSquashed = \case
  PullSourceTarget
Input.PullSourceTarget0 -> (ReadRemoteNamespace RemoteProjectBranch
 -> ProjectAndBranch Project ProjectBranch
 -> (ReadRemoteNamespace RemoteProjectBranch,
     ProjectAndBranch Project ProjectBranch))
-> Cli (ReadRemoteNamespace RemoteProjectBranch)
-> Cli (ProjectAndBranch Project ProjectBranch)
-> Cli
     (ReadRemoteNamespace RemoteProjectBranch,
      ProjectAndBranch Project ProjectBranch)
forall a b c. (a -> b -> c) -> Cli a -> Cli b -> Cli c
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 (,) (IncludeSquashedHead
-> Cli (ReadRemoteNamespace RemoteProjectBranch)
resolveImplicitSource IncludeSquashedHead
includeSquashed) Cli (ProjectAndBranch Project ProjectBranch)
resolveImplicitTarget
  Input.PullSourceTarget1 ReadRemoteNamespace
  (These ProjectName ProjectBranchNameOrLatestRelease)
source -> (ReadRemoteNamespace RemoteProjectBranch
 -> ProjectAndBranch Project ProjectBranch
 -> (ReadRemoteNamespace RemoteProjectBranch,
     ProjectAndBranch Project ProjectBranch))
-> Cli (ReadRemoteNamespace RemoteProjectBranch)
-> Cli (ProjectAndBranch Project ProjectBranch)
-> Cli
     (ReadRemoteNamespace RemoteProjectBranch,
      ProjectAndBranch Project ProjectBranch)
forall a b c. (a -> b -> c) -> Cli a -> Cli b -> Cli c
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 (,) (IncludeSquashedHead
-> ReadRemoteNamespace
     (These ProjectName ProjectBranchNameOrLatestRelease)
-> Cli (ReadRemoteNamespace RemoteProjectBranch)
resolveExplicitSource IncludeSquashedHead
includeSquashed ReadRemoteNamespace
  (These ProjectName ProjectBranchNameOrLatestRelease)
source) Cli (ProjectAndBranch Project ProjectBranch)
resolveImplicitTarget
  Input.PullSourceTarget2 ReadRemoteNamespace
  (These ProjectName ProjectBranchNameOrLatestRelease)
source0 ProjectAndBranch (Maybe ProjectName) ProjectBranchName
target0 -> do
    ReadRemoteNamespace RemoteProjectBranch
source <- IncludeSquashedHead
-> ReadRemoteNamespace
     (These ProjectName ProjectBranchNameOrLatestRelease)
-> Cli (ReadRemoteNamespace RemoteProjectBranch)
resolveExplicitSource IncludeSquashedHead
includeSquashed ReadRemoteNamespace
  (These ProjectName ProjectBranchNameOrLatestRelease)
source0
    Maybe (ProjectAndBranch Project ProjectBranch)
maybeTarget <-
      These ProjectName ProjectBranchName
-> Cli (Maybe (ProjectAndBranch Project ProjectBranch))
ProjectUtils.getProjectAndBranchByTheseNames case ProjectAndBranch (Maybe ProjectName) ProjectBranchName
target0 of
        ProjectAndBranch Maybe ProjectName
Nothing ProjectBranchName
branch -> ProjectBranchName -> These ProjectName ProjectBranchName
forall a b. b -> These a b
That ProjectBranchName
branch
        ProjectAndBranch (Just ProjectName
project) ProjectBranchName
branch -> ProjectName
-> ProjectBranchName -> These ProjectName ProjectBranchName
forall a b. a -> b -> These a b
These ProjectName
project ProjectBranchName
branch
    ProjectAndBranch Project ProjectBranch
target <- Maybe (ProjectAndBranch Project ProjectBranch)
maybeTarget Maybe (ProjectAndBranch Project ProjectBranch)
-> (Maybe (ProjectAndBranch Project ProjectBranch)
    -> Cli (ProjectAndBranch Project ProjectBranch))
-> Cli (ProjectAndBranch Project ProjectBranch)
forall a b. a -> (a -> b) -> b
& Cli (ProjectAndBranch Project ProjectBranch)
-> Maybe (ProjectAndBranch Project ProjectBranch)
-> Cli (ProjectAndBranch Project ProjectBranch)
forall (m :: * -> *) a. Applicative m => m a -> Maybe a -> m a
onNothing (Output -> Cli (ProjectAndBranch Project ProjectBranch)
forall a. Output -> Cli a
Cli.returnEarly (ReadRemoteNamespace RemoteProjectBranch
-> ProjectAndBranch (Maybe ProjectName) ProjectBranchName -> Output
Output.PullIntoMissingBranch ReadRemoteNamespace RemoteProjectBranch
source ProjectAndBranch (Maybe ProjectName) ProjectBranchName
target0))
    pure (ReadRemoteNamespace RemoteProjectBranch
source, ProjectAndBranch Project ProjectBranch
target)

resolveImplicitSource :: Share.IncludeSquashedHead -> Cli (ReadRemoteNamespace Share.RemoteProjectBranch)
resolveImplicitSource :: IncludeSquashedHead
-> Cli (ReadRemoteNamespace RemoteProjectBranch)
resolveImplicitSource IncludeSquashedHead
includeSquashed = do
  ProjectPath
pp <- Cli ProjectPath
Cli.getCurrentProjectPath
  let localProjectAndBranch :: ProjectAndBranch Project ProjectBranch
localProjectAndBranch = ProjectPath -> ProjectAndBranch Project ProjectBranch
forall p b. ProjectPathG p b -> ProjectAndBranch p b
PP.toProjectAndBranch ProjectPath
pp
  (RemoteProjectId
remoteProjectId, ProjectName
remoteProjectName, RemoteProjectBranchId
remoteBranchId, ProjectBranchName
remoteBranchName) <-
    ((forall void. Output -> Transaction void)
 -> Transaction
      (RemoteProjectId, ProjectName, RemoteProjectBranchId,
       ProjectBranchName))
-> Cli
     (RemoteProjectId, ProjectName, RemoteProjectBranchId,
      ProjectBranchName)
forall a.
((forall void. Output -> Transaction void) -> Transaction a)
-> Cli a
Cli.runTransactionWithRollback \forall void. Output -> Transaction void
rollback -> do
      let localProjectId :: ProjectId
localProjectId = ProjectAndBranch Project ProjectBranch
localProjectAndBranch.project.projectId
      let localBranchId :: ProjectBranchId
localBranchId = ProjectAndBranch Project ProjectBranch
localProjectAndBranch.branch.branchId
      ProjectId
-> URI
-> ProjectBranchId
-> Transaction
     (Maybe (RemoteProjectId, Maybe RemoteProjectBranchId))
Queries.loadRemoteProjectBranch ProjectId
localProjectId URI
Share.hardCodedUri ProjectBranchId
localBranchId Transaction (Maybe (RemoteProjectId, Maybe RemoteProjectBranchId))
-> (Maybe (RemoteProjectId, Maybe RemoteProjectBranchId)
    -> Transaction
         (RemoteProjectId, ProjectName, RemoteProjectBranchId,
          ProjectBranchName))
-> Transaction
     (RemoteProjectId, ProjectName, RemoteProjectBranchId,
      ProjectBranchName)
forall a b. Transaction a -> (a -> Transaction b) -> Transaction b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Just (RemoteProjectId
remoteProjectId, Just RemoteProjectBranchId
remoteBranchId) -> do
          ProjectName
remoteProjectName <- RemoteProjectId -> URI -> Transaction ProjectName
Queries.expectRemoteProjectName RemoteProjectId
remoteProjectId URI
Share.hardCodedUri
          ProjectBranchName
remoteBranchName <-
            URI
-> RemoteProjectId
-> RemoteProjectBranchId
-> Transaction ProjectBranchName
Queries.expectRemoteProjectBranchName
              URI
Share.hardCodedUri
              RemoteProjectId
remoteProjectId
              RemoteProjectBranchId
remoteBranchId
          pure (RemoteProjectId
remoteProjectId, ProjectName
remoteProjectName, RemoteProjectBranchId
remoteBranchId, ProjectBranchName
remoteBranchName)
        Maybe (RemoteProjectId, Maybe RemoteProjectBranchId)
_ -> Output
-> Transaction
     (RemoteProjectId, ProjectName, RemoteProjectBranchId,
      ProjectBranchName)
forall void. Output -> Transaction void
rollback (URI -> ProjectAndBranch Project ProjectBranch -> Output
Output.NoAssociatedRemoteProjectBranch URI
Share.hardCodedUri ProjectAndBranch Project ProjectBranch
localProjectAndBranch)
  RemoteProjectBranch
remoteBranch <-
    IncludeSquashedHead
-> ProjectAndBranch
     (RemoteProjectId, ProjectName)
     (RemoteProjectBranchId, ProjectBranchName)
-> Cli RemoteProjectBranch
ProjectUtils.expectRemoteProjectBranchById IncludeSquashedHead
includeSquashed (ProjectAndBranch
   (RemoteProjectId, ProjectName)
   (RemoteProjectBranchId, ProjectBranchName)
 -> Cli RemoteProjectBranch)
-> ProjectAndBranch
     (RemoteProjectId, ProjectName)
     (RemoteProjectBranchId, ProjectBranchName)
-> Cli RemoteProjectBranch
forall a b. (a -> b) -> a -> b
$
      (RemoteProjectId, ProjectName)
-> (RemoteProjectBranchId, ProjectBranchName)
-> ProjectAndBranch
     (RemoteProjectId, ProjectName)
     (RemoteProjectBranchId, ProjectBranchName)
forall a b. a -> b -> ProjectAndBranch a b
ProjectAndBranch
        (RemoteProjectId
remoteProjectId, ProjectName
remoteProjectName)
        (RemoteProjectBranchId
remoteBranchId, ProjectBranchName
remoteBranchName)
  pure (RemoteProjectBranch -> ReadRemoteNamespace RemoteProjectBranch
forall a. a -> ReadRemoteNamespace a
ReadShare'ProjectBranch RemoteProjectBranch
remoteBranch)

resolveExplicitSource ::
  Share.IncludeSquashedHead ->
  ReadRemoteNamespace (These ProjectName ProjectBranchNameOrLatestRelease) ->
  Cli (ReadRemoteNamespace Share.RemoteProjectBranch)
resolveExplicitSource :: IncludeSquashedHead
-> ReadRemoteNamespace
     (These ProjectName ProjectBranchNameOrLatestRelease)
-> Cli (ReadRemoteNamespace RemoteProjectBranch)
resolveExplicitSource IncludeSquashedHead
includeSquashed = \case
  ReadShare'LooseCode ReadShareLooseCode
namespace -> ReadRemoteNamespace RemoteProjectBranch
-> Cli (ReadRemoteNamespace RemoteProjectBranch)
forall a. a -> Cli a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ReadShareLooseCode -> ReadRemoteNamespace RemoteProjectBranch
forall a. ReadShareLooseCode -> ReadRemoteNamespace a
ReadShare'LooseCode ReadShareLooseCode
namespace)
  ReadShare'ProjectBranch (This ProjectName
remoteProjectName) -> do
    RemoteProject
remoteProject <- ProjectName -> Cli RemoteProject
ProjectUtils.expectRemoteProjectByName ProjectName
remoteProjectName
    let remoteProjectId :: RemoteProjectId
remoteProjectId = RemoteProject
remoteProject.projectId
    let remoteBranchName :: ProjectBranchName
remoteBranchName = forall source target.
(HasCallStack, TryFrom source target, Show source, Typeable source,
 Typeable target) =>
source -> target
unsafeFrom @Text Text
"main"
    RemoteProjectBranch
remoteProjectBranch <-
      IncludeSquashedHead
-> ProjectAndBranch
     (RemoteProjectId, ProjectName) ProjectBranchName
-> Cli RemoteProjectBranch
ProjectUtils.expectRemoteProjectBranchByName
        IncludeSquashedHead
includeSquashed
        ((RemoteProjectId, ProjectName)
-> ProjectBranchName
-> ProjectAndBranch
     (RemoteProjectId, ProjectName) ProjectBranchName
forall a b. a -> b -> ProjectAndBranch a b
ProjectAndBranch (RemoteProjectId
remoteProjectId, ProjectName
remoteProjectName) ProjectBranchName
remoteBranchName)
    pure (RemoteProjectBranch -> ReadRemoteNamespace RemoteProjectBranch
forall a. a -> ReadRemoteNamespace a
ReadShare'ProjectBranch RemoteProjectBranch
remoteProjectBranch)
  ReadShare'ProjectBranch (That ProjectBranchNameOrLatestRelease
branchNameOrLatestRelease) -> do
    ProjectAndBranch Project ProjectBranch
localProjectAndBranch <- ProjectPath -> ProjectAndBranch Project ProjectBranch
forall p b. ProjectPathG p b -> ProjectAndBranch p b
PP.toProjectAndBranch (ProjectPath -> ProjectAndBranch Project ProjectBranch)
-> Cli ProjectPath -> Cli (ProjectAndBranch Project ProjectBranch)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Cli ProjectPath
Cli.getCurrentProjectPath
    let localProjectId :: ProjectId
localProjectId = ProjectAndBranch Project ProjectBranch
localProjectAndBranch.project.projectId
    let localBranchId :: ProjectBranchId
localBranchId = ProjectAndBranch Project ProjectBranch
localProjectAndBranch.branch.branchId
    Transaction (Maybe (RemoteProjectId, Maybe RemoteProjectBranchId))
-> Cli (Maybe (RemoteProjectId, Maybe RemoteProjectBranchId))
forall a. Transaction a -> Cli a
Cli.runTransaction (ProjectId
-> URI
-> ProjectBranchId
-> Transaction
     (Maybe (RemoteProjectId, Maybe RemoteProjectBranchId))
Queries.loadRemoteProjectBranch ProjectId
localProjectId URI
Share.hardCodedUri ProjectBranchId
localBranchId) Cli (Maybe (RemoteProjectId, Maybe RemoteProjectBranchId))
-> (Maybe (RemoteProjectId, Maybe RemoteProjectBranchId)
    -> Cli (ReadRemoteNamespace RemoteProjectBranch))
-> Cli (ReadRemoteNamespace RemoteProjectBranch)
forall a b. Cli a -> (a -> Cli b) -> Cli b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Just (RemoteProjectId
remoteProjectId, Maybe RemoteProjectBranchId
_maybeProjectBranchId) -> do
        ProjectName
remoteProjectName <- Transaction ProjectName -> Cli ProjectName
forall a. Transaction a -> Cli a
Cli.runTransaction (RemoteProjectId -> URI -> Transaction ProjectName
Queries.expectRemoteProjectName RemoteProjectId
remoteProjectId URI
Share.hardCodedUri)
        ProjectBranchName
remoteBranchName <-
          case ProjectBranchNameOrLatestRelease
branchNameOrLatestRelease of
            ProjectBranchNameOrLatestRelease'Name ProjectBranchName
name -> ProjectBranchName -> Cli ProjectBranchName
forall a. a -> Cli a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ProjectBranchName
name
            ProjectBranchNameOrLatestRelease
ProjectBranchNameOrLatestRelease'LatestRelease -> do
              RemoteProject
remoteProject <- RemoteProjectId -> ProjectName -> Cli RemoteProject
ProjectUtils.expectRemoteProjectById RemoteProjectId
remoteProjectId ProjectName
remoteProjectName
              RemoteProject -> Cli ProjectBranchName
ProjectUtils.expectLatestReleaseBranchName RemoteProject
remoteProject
        RemoteProjectBranch
remoteProjectBranch <-
          IncludeSquashedHead
-> ProjectAndBranch
     (RemoteProjectId, ProjectName) ProjectBranchName
-> Cli RemoteProjectBranch
ProjectUtils.expectRemoteProjectBranchByName
            IncludeSquashedHead
includeSquashed
            ((RemoteProjectId, ProjectName)
-> ProjectBranchName
-> ProjectAndBranch
     (RemoteProjectId, ProjectName) ProjectBranchName
forall a b. a -> b -> ProjectAndBranch a b
ProjectAndBranch (RemoteProjectId
remoteProjectId, ProjectName
remoteProjectName) ProjectBranchName
remoteBranchName)
        pure (RemoteProjectBranch -> ReadRemoteNamespace RemoteProjectBranch
forall a. a -> ReadRemoteNamespace a
ReadShare'ProjectBranch RemoteProjectBranch
remoteProjectBranch)
      Maybe (RemoteProjectId, Maybe RemoteProjectBranchId)
Nothing -> do
        Output -> Cli (ReadRemoteNamespace RemoteProjectBranch)
forall a. Output -> Cli a
Cli.returnEarly (Output -> Cli (ReadRemoteNamespace RemoteProjectBranch))
-> Output -> Cli (ReadRemoteNamespace RemoteProjectBranch)
forall a b. (a -> b) -> a -> b
$
          URI -> ProjectAndBranch ProjectName ProjectBranchName -> Output
Output.NoAssociatedRemoteProject URI
Share.hardCodedUri (ProjectAndBranch Project ProjectBranch
-> ProjectAndBranch ProjectName ProjectBranchName
ProjectUtils.justTheNames ProjectAndBranch Project ProjectBranch
localProjectAndBranch)
  ReadShare'ProjectBranch (These ProjectName
projectName ProjectBranchNameOrLatestRelease
branchNameOrLatestRelease) -> do
    RemoteProject
remoteProject <- ProjectName -> Cli RemoteProject
ProjectUtils.expectRemoteProjectByName ProjectName
projectName
    let remoteProjectId :: RemoteProjectId
remoteProjectId = RemoteProject
remoteProject.projectId
    ProjectBranchName
branchName <-
      case ProjectBranchNameOrLatestRelease
branchNameOrLatestRelease of
        ProjectBranchNameOrLatestRelease'Name ProjectBranchName
name -> ProjectBranchName -> Cli ProjectBranchName
forall a. a -> Cli a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ProjectBranchName
name
        ProjectBranchNameOrLatestRelease
ProjectBranchNameOrLatestRelease'LatestRelease -> RemoteProject -> Cli ProjectBranchName
ProjectUtils.expectLatestReleaseBranchName RemoteProject
remoteProject
    RemoteProjectBranch
remoteProjectBranch <-
      IncludeSquashedHead
-> ProjectAndBranch
     (RemoteProjectId, ProjectName) ProjectBranchName
-> Cli RemoteProjectBranch
ProjectUtils.expectRemoteProjectBranchByName
        IncludeSquashedHead
includeSquashed
        ((RemoteProjectId, ProjectName)
-> ProjectBranchName
-> ProjectAndBranch
     (RemoteProjectId, ProjectName) ProjectBranchName
forall a b. a -> b -> ProjectAndBranch a b
ProjectAndBranch (RemoteProjectId
remoteProjectId, ProjectName
projectName) ProjectBranchName
branchName)
    pure (RemoteProjectBranch -> ReadRemoteNamespace RemoteProjectBranch
forall a. a -> ReadRemoteNamespace a
ReadShare'ProjectBranch RemoteProjectBranch
remoteProjectBranch)

resolveImplicitTarget :: Cli (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch)
resolveImplicitTarget :: Cli (ProjectAndBranch Project ProjectBranch)
resolveImplicitTarget = do
  ProjectPath -> ProjectAndBranch Project ProjectBranch
forall p b. ProjectPathG p b -> ProjectAndBranch p b
PP.toProjectAndBranch (ProjectPath -> ProjectAndBranch Project ProjectBranch)
-> Cli ProjectPath -> Cli (ProjectAndBranch Project ProjectBranch)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Cli ProjectPath
Cli.getCurrentProjectPath

-- | supply `dest0` if you want to print diff messages
--   supply unchangedMessage if you want to display it if merge had no effect
mergeBranchAndPropagateDefaultPatch ::
  Branch.MergeMode ->
  Text ->
  Maybe Output ->
  Branch IO ->
  Maybe (Either PP.ProjectPath (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch)) ->
  PP.ProjectPath ->
  Cli ()
mergeBranchAndPropagateDefaultPatch :: MergeMode
-> Text
-> Maybe Output
-> Branch IO
-> Maybe
     (Either ProjectPath (ProjectAndBranch Project ProjectBranch))
-> ProjectPath
-> Cli ()
mergeBranchAndPropagateDefaultPatch MergeMode
mode Text
inputDescription Maybe Output
unchangedMessage Branch IO
srcb Maybe (Either ProjectPath (ProjectAndBranch Project ProjectBranch))
maybeDest0 ProjectPath
dest =
  Cli Bool -> Cli () -> Cli () -> Cli ()
forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM
    Cli Bool
mergeBranch
    (Text
-> Maybe
     (Either ProjectPath (ProjectAndBranch Project ProjectBranch))
-> ProjectPath
-> Cli ()
loadPropagateDiffDefaultPatch Text
inputDescription Maybe (Either ProjectPath (ProjectAndBranch Project ProjectBranch))
maybeDest0 ProjectPath
dest)
    (Maybe Output -> (Output -> Cli ()) -> Cli ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Maybe Output
unchangedMessage Output -> Cli ()
Cli.respond)
  where
    mergeBranch :: Cli Bool
    mergeBranch :: Cli Bool
mergeBranch =
      String -> Cli Bool -> Cli Bool
forall a. String -> Cli a -> Cli a
Cli.time String
"mergeBranch" do
        Cli.Env {Codebase IO Symbol Ann
$sel:codebase:Env :: Env -> Codebase IO Symbol Ann
codebase :: Codebase IO Symbol Ann
codebase} <- Cli Env
forall r (m :: * -> *). MonadReader r m => m r
ask
        Branch IO
destb <- ProjectPath -> Cli (Branch IO)
Cli.getBranchFromProjectPath ProjectPath
dest
        Branch IO
merged <- IO (Branch IO) -> Cli (Branch IO)
forall a. IO a -> Cli a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO ((Branch IO -> Branch IO -> IO (Maybe (Branch IO)))
-> MergeMode -> Branch IO -> Branch IO -> IO (Branch IO)
forall (m :: * -> *).
Monad m =>
(Branch m -> Branch m -> m (Maybe (Branch m)))
-> MergeMode -> Branch m -> Branch m -> m (Branch m)
Branch.merge'' (Codebase IO Symbol Ann
-> Branch IO -> Branch IO -> IO (Maybe (Branch IO))
forall (m :: * -> *) v a.
MonadIO m =>
Codebase m v a -> Branch m -> Branch m -> m (Maybe (Branch m))
Codebase.lca Codebase IO Symbol Ann
codebase) MergeMode
mode Branch IO
srcb Branch IO
destb)
        Bool
b <- Text -> ProjectPath -> (Branch IO -> Cli (Branch IO)) -> Cli Bool
Cli.updateAtM Text
inputDescription ProjectPath
dest (Cli (Branch IO) -> Branch IO -> Cli (Branch IO)
forall a b. a -> b -> a
const (Cli (Branch IO) -> Branch IO -> Cli (Branch IO))
-> Cli (Branch IO) -> Branch IO -> Cli (Branch IO)
forall a b. (a -> b) -> a -> b
$ Branch IO -> Cli (Branch IO)
forall a. a -> Cli a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Branch IO
merged)
        Maybe (Either ProjectPath (ProjectAndBranch Project ProjectBranch))
-> (Either ProjectPath (ProjectAndBranch Project ProjectBranch)
    -> Cli ())
-> Cli ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Maybe (Either ProjectPath (ProjectAndBranch Project ProjectBranch))
maybeDest0 \Either ProjectPath (ProjectAndBranch Project ProjectBranch)
dest0 -> do
          (PrettyPrintEnv
ppe, BranchDiffOutput Symbol Ann
diff) <- Branch0 IO
-> Branch0 IO -> Cli (PrettyPrintEnv, BranchDiffOutput Symbol Ann)
diffHelper (Branch IO -> Branch0 IO
forall (m :: * -> *). Branch m -> Branch0 m
Branch.head Branch IO
destb) (Branch IO -> Branch0 IO
forall (m :: * -> *). Branch m -> Branch0 m
Branch.head Branch IO
merged)
          NumberedOutput -> Cli ()
Cli.respondNumbered (Either ProjectPath (ProjectAndBranch Project ProjectBranch)
-> ProjectPath
-> PrettyPrintEnv
-> BranchDiffOutput Symbol Ann
-> NumberedOutput
ShowDiffAfterMerge Either ProjectPath (ProjectAndBranch Project ProjectBranch)
dest0 ProjectPath
dest PrettyPrintEnv
ppe BranchDiffOutput Symbol Ann
diff)
        pure Bool
b

loadPropagateDiffDefaultPatch ::
  Text ->
  Maybe (Either PP.ProjectPath (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch)) ->
  PP.ProjectPath ->
  Cli ()
loadPropagateDiffDefaultPatch :: Text
-> Maybe
     (Either ProjectPath (ProjectAndBranch Project ProjectBranch))
-> ProjectPath
-> Cli ()
loadPropagateDiffDefaultPatch Text
inputDescription Maybe (Either ProjectPath (ProjectAndBranch Project ProjectBranch))
maybeDest0 ProjectPath
dest = do
  Output -> Cli ()
Cli.respond Output
Output.AboutToPropagatePatch
  String -> Cli () -> Cli ()
forall a. String -> Cli a -> Cli a
Cli.time String
"loadPropagateDiffDefaultPatch" do
    Branch0 IO
original <- ProjectPath -> Cli (Branch0 IO)
Cli.getBranch0FromProjectPath ProjectPath
dest
    Patch
patch <- IO Patch -> Cli Patch
forall a. IO a -> Cli a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Patch -> Cli Patch) -> IO Patch -> Cli Patch
forall a b. (a -> b) -> a -> b
$ NameSegment -> Branch0 IO -> IO Patch
forall (m :: * -> *).
Applicative m =>
NameSegment -> Branch0 m -> m Patch
Branch.getPatch NameSegment
NameSegment.defaultPatchSegment Branch0 IO
original
    Bool
patchDidChange <- Text -> Patch -> ProjectPath -> Cli Bool
propagatePatch Text
inputDescription Patch
patch ProjectPath
dest
    Bool -> Cli () -> Cli ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
patchDidChange do
      Maybe (Either ProjectPath (ProjectAndBranch Project ProjectBranch))
-> (Either ProjectPath (ProjectAndBranch Project ProjectBranch)
    -> Cli ())
-> Cli ()
forall (m :: * -> *) a.
Applicative m =>
Maybe a -> (a -> m ()) -> m ()
whenJust Maybe (Either ProjectPath (ProjectAndBranch Project ProjectBranch))
maybeDest0 \Either ProjectPath (ProjectAndBranch Project ProjectBranch)
dest0 -> do
        Output -> Cli ()
Cli.respond Output
Output.CalculatingDiff
        Branch IO
patched <- ProjectPath -> Cli (Branch IO)
Cli.getBranchFromProjectPath ProjectPath
dest
        let patchPath :: Path'
patchPath = Either Absolute Relative -> Path'
Path.Path' (Relative -> Either Absolute Relative
forall a b. b -> Either a b
Right (Path -> Relative
Path.Relative ([NameSegment] -> Path
Path.fromList [NameSegment
NameSegment.defaultPatchSegment])))
        (PrettyPrintEnv
ppe, BranchDiffOutput Symbol Ann
diff) <- Branch0 IO
-> Branch0 IO -> Cli (PrettyPrintEnv, BranchDiffOutput Symbol Ann)
diffHelper Branch0 IO
original (Branch IO -> Branch0 IO
forall (m :: * -> *). Branch m -> Branch0 m
Branch.head Branch IO
patched)
        NumberedOutput -> Cli ()
Cli.respondNumbered (Either ProjectPath (ProjectAndBranch Project ProjectBranch)
-> ProjectPath
-> Path'
-> PrettyPrintEnv
-> BranchDiffOutput Symbol Ann
-> NumberedOutput
ShowDiffAfterMergePropagate Either ProjectPath (ProjectAndBranch Project ProjectBranch)
dest0 ProjectPath
dest Path'
patchPath PrettyPrintEnv
ppe BranchDiffOutput Symbol Ann
diff)

-- Returns True if the operation changed the namespace, False otherwise.
propagatePatch ::
  Text ->
  Patch ->
  PP.ProjectPath ->
  Cli Bool
propagatePatch :: Text -> Patch -> ProjectPath -> Cli Bool
propagatePatch Text
inputDescription Patch
patch ProjectPath
scopePath = do
  String -> Cli Bool -> Cli Bool
forall a. String -> Cli a -> Cli a
Cli.time String
"propagatePatch" do
    Names
rootNames <- ProjectBranch -> Cli Names
Cli.projectBranchNames ProjectPath
scopePath.branch
    Text -> (ProjectPath, Branch0 IO -> Cli (Branch0 IO)) -> Cli Bool
Cli.stepAt'
      (Text
inputDescription Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" (applying patch)")
      (ProjectPath
scopePath, Names -> Patch -> Branch0 IO -> Cli (Branch0 IO)
Propagate.propagateAndApply Names
rootNames Patch
patch)