-- | @branch@ input handler
module Unison.Codebase.Editor.HandleInput.Branch
  ( CreateFrom (..),
    handleBranch,
    createBranch,
  )
where

import Control.Monad.Reader
import Data.UUID.V4 qualified as UUID
import U.Codebase.Sqlite.DbId
import U.Codebase.Sqlite.Project qualified as Sqlite
import U.Codebase.Sqlite.ProjectBranch (ProjectBranch (..))
import U.Codebase.Sqlite.ProjectBranch qualified as Sqlite
import U.Codebase.Sqlite.Queries qualified as Q
import U.Codebase.Sqlite.Queries qualified as Queries
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.Codebase qualified as Codebase
import Unison.Codebase.Branch (Branch)
import Unison.Codebase.Branch qualified as Branch
import Unison.Codebase.Editor.Input qualified as Input
import Unison.Codebase.Editor.Output qualified as Output
import Unison.Codebase.ProjectPath qualified as PP
import Unison.Prelude
import Unison.Project (ProjectAndBranch (..), ProjectBranchName, ProjectBranchNameKind (..), ProjectName, classifyProjectBranchName)
import Unison.Sqlite qualified as Sqlite

data CreateFrom
  = CreateFrom'NamespaceWithParent Sqlite.ProjectBranch (Branch IO)
  | CreateFrom'ParentBranch Sqlite.ProjectBranch
  | CreateFrom'Namespace (Branch IO)
  | CreateFrom'Nothingness

-- | Create a new project branch from an existing project branch or namespace.
handleBranch :: Input.BranchSourceI -> ProjectAndBranch (Maybe ProjectName) ProjectBranchName -> Cli ()
handleBranch :: BranchSourceI -> UnresolvedProjectBranch -> Cli ()
handleBranch BranchSourceI
sourceI projectAndBranchNames :: UnresolvedProjectBranch
projectAndBranchNames@(ProjectAndBranch Maybe ProjectName
mayProjectName ProjectBranchName
newBranchName) = do
  -- You can only create release branches with `branch.clone`
  --
  -- We do allow creating draft release branches with `branch`, but you'll get different output if you use
  -- `release.draft`
  case ProjectBranchName -> ProjectBranchNameKind
classifyProjectBranchName ProjectBranchName
newBranchName of
    ProjectBranchNameKind'Contributor Text
_user ProjectBranchName
_name -> () -> Cli ()
forall a. a -> Cli a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    ProjectBranchNameKind'DraftRelease Semver
_ver -> () -> Cli ()
forall a. a -> Cli a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    ProjectBranchNameKind'Release Semver
ver ->
      Output -> Cli ()
forall a. Output -> Cli a
Cli.returnEarly (ProjectBranchName -> Semver -> Output
Output.CannotCreateReleaseBranchWithBranchCommand ProjectBranchName
newBranchName Semver
ver)
    ProjectBranchNameKind
ProjectBranchNameKind'NothingSpecial -> () -> Cli ()
forall a. a -> Cli a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

  ProjectName
currentProjectName <- Cli (ProjectPathG Project ProjectBranch)
Cli.getCurrentProjectPath Cli (ProjectPathG Project ProjectBranch)
-> (ProjectPathG Project ProjectBranch -> ProjectName)
-> Cli ProjectName
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Getting
  ProjectName (ProjectPathG Project ProjectBranch) ProjectName
-> ProjectPathG Project ProjectBranch -> ProjectName
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view ((Project -> Const ProjectName Project)
-> ProjectPathG Project ProjectBranch
-> Const ProjectName (ProjectPathG Project ProjectBranch)
#project ((Project -> Const ProjectName Project)
 -> ProjectPathG Project ProjectBranch
 -> Const ProjectName (ProjectPathG Project ProjectBranch))
-> Getting ProjectName Project ProjectName
-> Getting
     ProjectName (ProjectPathG Project ProjectBranch) ProjectName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting ProjectName Project ProjectName
#name)
  let projectName :: ProjectName
projectName = (ProjectName -> Maybe ProjectName -> ProjectName
forall a. a -> Maybe a -> a
fromMaybe ProjectName
currentProjectName Maybe ProjectName
mayProjectName)
  Project
destProject <- do
    ((forall void. Output -> Transaction void) -> Transaction Project)
-> Cli Project
forall a.
((forall void. Output -> Transaction void) -> Transaction a)
-> Cli a
Cli.runTransactionWithRollback
      \forall void. Output -> Transaction void
rollback -> do
        ProjectName -> Transaction (Maybe Project)
Queries.loadProjectByName ProjectName
projectName Transaction (Maybe Project)
-> (Transaction (Maybe Project) -> Transaction Project)
-> Transaction Project
forall a b. a -> (a -> b) -> b
& Transaction Project
-> Transaction (Maybe Project) -> Transaction Project
forall (m :: * -> *) a. Monad m => m a -> m (Maybe a) -> m a
onNothingM do
          -- We can't make the *first* branch of a project with `branch`; the project has to already exist.
          Output -> Transaction Project
forall void. Output -> Transaction void
rollback (ProjectAndBranch ProjectName ProjectBranchName -> Output
Output.LocalProjectBranchDoesntExist (ProjectName
-> ProjectBranchName
-> ProjectAndBranch ProjectName ProjectBranchName
forall a b. a -> b -> ProjectAndBranch a b
ProjectAndBranch ProjectName
projectName ProjectBranchName
newBranchName))

  -- Compute what we should create the branch from.
  Maybe (ProjectAndBranch Project ProjectBranch)
maySrcProjectAndBranch <-
    case BranchSourceI
sourceI of
      BranchSourceI
Input.BranchSourceI'CurrentContext -> ProjectAndBranch Project ProjectBranch
-> Maybe (ProjectAndBranch Project ProjectBranch)
forall a. a -> Maybe a
Just (ProjectAndBranch Project ProjectBranch
 -> Maybe (ProjectAndBranch Project ProjectBranch))
-> (ProjectPathG Project ProjectBranch
    -> ProjectAndBranch Project ProjectBranch)
-> ProjectPathG Project ProjectBranch
-> Maybe (ProjectAndBranch Project ProjectBranch)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting
  (ProjectAndBranch Project ProjectBranch)
  (ProjectPathG Project ProjectBranch)
  (ProjectAndBranch Project ProjectBranch)
-> ProjectPathG Project ProjectBranch
-> ProjectAndBranch Project ProjectBranch
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting
  (ProjectAndBranch Project ProjectBranch)
  (ProjectPathG Project ProjectBranch)
  (ProjectAndBranch Project ProjectBranch)
forall p b p' b' (f :: * -> *).
Functor f =>
(ProjectAndBranch p b -> f (ProjectAndBranch p' b'))
-> ProjectPathG p b -> f (ProjectPathG p' b')
PP.projectAndBranch_ (ProjectPathG Project ProjectBranch
 -> Maybe (ProjectAndBranch Project ProjectBranch))
-> Cli (ProjectPathG Project ProjectBranch)
-> Cli (Maybe (ProjectAndBranch Project ProjectBranch))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Cli (ProjectPathG Project ProjectBranch)
Cli.getCurrentProjectPath
      BranchSourceI
Input.BranchSourceI'Empty -> Maybe (ProjectAndBranch Project ProjectBranch)
-> Cli (Maybe (ProjectAndBranch Project ProjectBranch))
forall a. a -> Cli a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (ProjectAndBranch Project ProjectBranch)
forall a. Maybe a
Nothing
      Input.BranchSourceI'UnresolvedProjectBranch UnresolvedProjectBranch
unresolvedProjectBranch -> do
        ProjectPathG Project ProjectBranch
pp <- Cli (ProjectPathG Project ProjectBranch)
Cli.getCurrentProjectPath
        ProjectAndBranch Project ProjectBranch
-> Maybe (ProjectAndBranch Project ProjectBranch)
forall a. a -> Maybe a
Just (ProjectAndBranch Project ProjectBranch
 -> Maybe (ProjectAndBranch Project ProjectBranch))
-> Cli (ProjectAndBranch Project ProjectBranch)
-> Cli (Maybe (ProjectAndBranch Project ProjectBranch))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Project
-> ProjectAndBranch (Maybe ProjectName) (Maybe ProjectBranchName)
-> Cli (ProjectAndBranch Project ProjectBranch)
ProjectUtils.resolveProjectBranchInProject (ProjectPathG Project ProjectBranch
pp ProjectPathG Project ProjectBranch
-> Getting Project (ProjectPathG Project ProjectBranch) Project
-> Project
forall s a. s -> Getting a s a -> a
^. Getting Project (ProjectPathG Project ProjectBranch) Project
#project) (UnresolvedProjectBranch
unresolvedProjectBranch UnresolvedProjectBranch
-> (UnresolvedProjectBranch
    -> ProjectAndBranch (Maybe ProjectName) (Maybe ProjectBranchName))
-> ProjectAndBranch (Maybe ProjectName) (Maybe ProjectBranchName)
forall a b. a -> (a -> b) -> b
& ASetter
  UnresolvedProjectBranch
  (ProjectAndBranch (Maybe ProjectName) (Maybe ProjectBranchName))
  ProjectBranchName
  (Maybe ProjectBranchName)
#branch ASetter
  UnresolvedProjectBranch
  (ProjectAndBranch (Maybe ProjectName) (Maybe ProjectBranchName))
  ProjectBranchName
  (Maybe ProjectBranchName)
-> (ProjectBranchName -> Maybe ProjectBranchName)
-> UnresolvedProjectBranch
-> ProjectAndBranch (Maybe ProjectName) (Maybe ProjectBranchName)
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ ProjectBranchName -> Maybe ProjectBranchName
forall a. a -> Maybe a
Just)

  case Maybe (ProjectAndBranch Project ProjectBranch)
maySrcProjectAndBranch of
    Just ProjectAndBranch Project ProjectBranch
srcProjectAndBranch -> do
      let description :: Text
description = Text
"Branch created from " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> forall target source. From source target => source -> target
into @Text (ProjectAndBranch Project ProjectBranch
srcProjectAndBranch ProjectAndBranch Project ProjectBranch
-> (ProjectAndBranch Project ProjectBranch
    -> ProjectAndBranch ProjectName ProjectBranchName)
-> ProjectAndBranch ProjectName ProjectBranchName
forall a b. a -> (a -> b) -> b
& (Project -> ProjectName)
-> (ProjectBranch -> ProjectBranchName)
-> ProjectAndBranch Project ProjectBranch
-> ProjectAndBranch ProjectName ProjectBranchName
forall a b c d.
(a -> b)
-> (c -> d) -> ProjectAndBranch a c -> ProjectAndBranch b d
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap (Getting ProjectName Project ProjectName -> Project -> ProjectName
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting ProjectName Project ProjectName
#name) (Getting ProjectBranchName ProjectBranch ProjectBranchName
-> ProjectBranch -> ProjectBranchName
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting ProjectBranchName ProjectBranch ProjectBranchName
#name))
      Cli (ProjectBranchId, ProjectBranchName) -> Cli ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Cli (ProjectBranchId, ProjectBranchName) -> Cli ())
-> Cli (ProjectBranchId, ProjectBranchName) -> Cli ()
forall a b. (a -> b) -> a -> b
$ Text
-> CreateFrom
-> Project
-> Transaction ProjectBranchName
-> Cli (ProjectBranchId, ProjectBranchName)
createBranch Text
description (ProjectBranch -> CreateFrom
CreateFrom'ParentBranch (Getting
  ProjectBranch
  (ProjectAndBranch Project ProjectBranch)
  ProjectBranch
-> ProjectAndBranch Project ProjectBranch -> ProjectBranch
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting
  ProjectBranch
  (ProjectAndBranch Project ProjectBranch)
  ProjectBranch
#branch ProjectAndBranch Project ProjectBranch
srcProjectAndBranch)) Project
destProject (ProjectBranchName -> Transaction ProjectBranchName
forall a. a -> Transaction a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ProjectBranchName
newBranchName)
    Maybe (ProjectAndBranch Project ProjectBranch)
Nothing -> do
      let description :: Text
description = Text
"Empty branch created"
      Cli (ProjectBranchId, ProjectBranchName) -> Cli ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Cli (ProjectBranchId, ProjectBranchName) -> Cli ())
-> Cli (ProjectBranchId, ProjectBranchName) -> Cli ()
forall a b. (a -> b) -> a -> b
$ Text
-> CreateFrom
-> Project
-> Transaction ProjectBranchName
-> Cli (ProjectBranchId, ProjectBranchName)
createBranch Text
description CreateFrom
CreateFrom'Nothingness Project
destProject (ProjectBranchName -> Transaction ProjectBranchName
forall a. a -> Transaction a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ProjectBranchName
newBranchName)

  Output -> Cli ()
Cli.respond (Output -> Cli ()) -> Output -> Cli ()
forall a b. (a -> b) -> a -> b
$
    CreatedProjectBranchFrom
-> ProjectAndBranch ProjectName ProjectBranchName -> Output
Output.CreatedProjectBranch
      ( case Maybe (ProjectAndBranch Project ProjectBranch)
maySrcProjectAndBranch of
          Just ProjectAndBranch Project ProjectBranch
sourceBranch ->
            if ProjectAndBranch Project ProjectBranch
sourceBranch ProjectAndBranch Project ProjectBranch
-> Getting
     ProjectId (ProjectAndBranch Project ProjectBranch) ProjectId
-> ProjectId
forall s a. s -> Getting a s a -> a
^. (Project -> Const ProjectId Project)
-> ProjectAndBranch Project ProjectBranch
-> Const ProjectId (ProjectAndBranch Project ProjectBranch)
#project ((Project -> Const ProjectId Project)
 -> ProjectAndBranch Project ProjectBranch
 -> Const ProjectId (ProjectAndBranch Project ProjectBranch))
-> Getting ProjectId Project ProjectId
-> Getting
     ProjectId (ProjectAndBranch Project ProjectBranch) ProjectId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting ProjectId Project ProjectId
#projectId ProjectId -> ProjectId -> Bool
forall a. Eq a => a -> a -> Bool
== Project
destProject Project -> Getting ProjectId Project ProjectId -> ProjectId
forall s a. s -> Getting a s a -> a
^. Getting ProjectId Project ProjectId
#projectId
              then ProjectBranchName -> CreatedProjectBranchFrom
Output.CreatedProjectBranchFrom'ParentBranch (ProjectAndBranch Project ProjectBranch
sourceBranch ProjectAndBranch Project ProjectBranch
-> Getting
     ProjectBranchName
     (ProjectAndBranch Project ProjectBranch)
     ProjectBranchName
-> ProjectBranchName
forall s a. s -> Getting a s a -> a
^. (ProjectBranch -> Const ProjectBranchName ProjectBranch)
-> ProjectAndBranch Project ProjectBranch
-> Const ProjectBranchName (ProjectAndBranch Project ProjectBranch)
#branch ((ProjectBranch -> Const ProjectBranchName ProjectBranch)
 -> ProjectAndBranch Project ProjectBranch
 -> Const
      ProjectBranchName (ProjectAndBranch Project ProjectBranch))
-> Getting ProjectBranchName ProjectBranch ProjectBranchName
-> Getting
     ProjectBranchName
     (ProjectAndBranch Project ProjectBranch)
     ProjectBranchName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting ProjectBranchName ProjectBranch ProjectBranchName
#name)
              else ProjectAndBranch Project ProjectBranch -> CreatedProjectBranchFrom
Output.CreatedProjectBranchFrom'OtherBranch ProjectAndBranch Project ProjectBranch
sourceBranch
          Maybe (ProjectAndBranch Project ProjectBranch)
Nothing -> CreatedProjectBranchFrom
Output.CreatedProjectBranchFrom'Nothingness
      )
      (UnresolvedProjectBranch
projectAndBranchNames UnresolvedProjectBranch
-> (UnresolvedProjectBranch
    -> ProjectAndBranch ProjectName ProjectBranchName)
-> ProjectAndBranch ProjectName ProjectBranchName
forall a b. a -> (a -> b) -> b
& ASetter
  UnresolvedProjectBranch
  (ProjectAndBranch ProjectName ProjectBranchName)
  (Maybe ProjectName)
  ProjectName
#project ASetter
  UnresolvedProjectBranch
  (ProjectAndBranch ProjectName ProjectBranchName)
  (Maybe ProjectName)
  ProjectName
-> ProjectName
-> UnresolvedProjectBranch
-> ProjectAndBranch ProjectName ProjectBranchName
forall s t a b. ASetter s t a b -> b -> s -> t
.~ ProjectName
projectName)

-- | @createBranch description createFrom project getNewBranchName@:
--
--   1. Creates a new branch row in @project@ at the name from @getNewBranchName@ (failing if branch already exists in @project@).
--   2. Switches to the new branch.
--
-- This bit of functionality is factored out from the main 'handleBranch' handler because it is also called by the
-- @release.draft@ command, which essentially just creates a branch, but with some different output for the user.
--
-- Returns the branch id and name of the newly-created branch.
createBranch ::
  Text ->
  CreateFrom ->
  Sqlite.Project ->
  Sqlite.Transaction ProjectBranchName ->
  Cli (ProjectBranchId, ProjectBranchName)
createBranch :: Text
-> CreateFrom
-> Project
-> Transaction ProjectBranchName
-> Cli (ProjectBranchId, ProjectBranchName)
createBranch Text
description CreateFrom
createFrom Project
project Transaction ProjectBranchName
getNewBranchName = do
  let projectId :: ProjectId
projectId = Project
project Project -> Getting ProjectId Project ProjectId -> ProjectId
forall s a. s -> Getting a s a -> a
^. Getting ProjectId Project ProjectId
#projectId
  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
  (Maybe ProjectBranchId
mayParentBranchId, CausalHashId
newBranchCausalHashId) <- case CreateFrom
createFrom of
    CreateFrom'ParentBranch ProjectBranch
parentBranch -> Transaction (Maybe ProjectBranchId, CausalHashId)
-> Cli (Maybe ProjectBranchId, CausalHashId)
forall a. Transaction a -> Cli a
Cli.runTransaction do
      CausalHashId
newBranchCausalHashId <- HasCallStack =>
ProjectId -> ProjectBranchId -> Transaction CausalHashId
ProjectId -> ProjectBranchId -> Transaction CausalHashId
Q.expectProjectBranchHead ProjectBranch
parentBranch.projectId ProjectBranch
parentBranch.branchId
      let parentBranchId :: Maybe ProjectBranchId
parentBranchId = if ProjectBranch
parentBranch.projectId ProjectId -> ProjectId -> Bool
forall a. Eq a => a -> a -> Bool
== ProjectId
projectId then ProjectBranchId -> Maybe ProjectBranchId
forall a. a -> Maybe a
Just ProjectBranch
parentBranch.branchId else Maybe ProjectBranchId
forall a. Maybe a
Nothing
      pure (Maybe ProjectBranchId
parentBranchId, CausalHashId
newBranchCausalHashId)
    CreateFrom
CreateFrom'Nothingness -> Transaction (Maybe ProjectBranchId, CausalHashId)
-> Cli (Maybe ProjectBranchId, CausalHashId)
forall a. Transaction a -> Cli a
Cli.runTransaction do
      (CausalHash
_, CausalHashId
causalHashId) <- Transaction (CausalHash, CausalHashId)
Codebase.emptyCausalHash
      (Maybe ProjectBranchId, CausalHashId)
-> Transaction (Maybe ProjectBranchId, CausalHashId)
forall a. a -> Transaction a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe ProjectBranchId
forall a. Maybe a
Nothing, CausalHashId
causalHashId)
    CreateFrom'NamespaceWithParent ProjectBranch
parentBranch Branch IO
namespace -> do
      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
$ Codebase IO Symbol Ann -> Branch IO -> IO ()
forall (m :: * -> *) v a. Codebase m v a -> Branch m -> m ()
Codebase.putBranch Codebase IO Symbol Ann
codebase Branch IO
namespace
      Transaction (Maybe ProjectBranchId, CausalHashId)
-> Cli (Maybe ProjectBranchId, CausalHashId)
forall a. Transaction a -> Cli a
Cli.runTransaction (Transaction (Maybe ProjectBranchId, CausalHashId)
 -> Cli (Maybe ProjectBranchId, CausalHashId))
-> Transaction (Maybe ProjectBranchId, CausalHashId)
-> Cli (Maybe ProjectBranchId, CausalHashId)
forall a b. (a -> b) -> a -> b
$ do
        CausalHashId
newBranchCausalHashId <- CausalHash -> Transaction CausalHashId
Q.expectCausalHashIdByCausalHash (Branch IO -> CausalHash
forall (m :: * -> *). Branch m -> CausalHash
Branch.headHash Branch IO
namespace)
        let parentBranchId :: Maybe ProjectBranchId
parentBranchId = if ProjectBranch
parentBranch.projectId ProjectId -> ProjectId -> Bool
forall a. Eq a => a -> a -> Bool
== ProjectId
projectId then ProjectBranchId -> Maybe ProjectBranchId
forall a. a -> Maybe a
Just ProjectBranch
parentBranch.branchId else Maybe ProjectBranchId
forall a. Maybe a
Nothing
        pure (Maybe ProjectBranchId
parentBranchId, CausalHashId
newBranchCausalHashId)
    CreateFrom'Namespace Branch IO
branch -> do
      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
$ Codebase IO Symbol Ann -> Branch IO -> IO ()
forall (m :: * -> *) v a. Codebase m v a -> Branch m -> m ()
Codebase.putBranch Codebase IO Symbol Ann
codebase Branch IO
branch
      Transaction (Maybe ProjectBranchId, CausalHashId)
-> Cli (Maybe ProjectBranchId, CausalHashId)
forall a. Transaction a -> Cli a
Cli.runTransaction (Transaction (Maybe ProjectBranchId, CausalHashId)
 -> Cli (Maybe ProjectBranchId, CausalHashId))
-> Transaction (Maybe ProjectBranchId, CausalHashId)
-> Cli (Maybe ProjectBranchId, CausalHashId)
forall a b. (a -> b) -> a -> b
$ do
        CausalHashId
newBranchCausalHashId <- CausalHash -> Transaction CausalHashId
Q.expectCausalHashIdByCausalHash (Branch IO -> CausalHash
forall (m :: * -> *). Branch m -> CausalHash
Branch.headHash Branch IO
branch)
        pure (Maybe ProjectBranchId
forall a. Maybe a
Nothing, CausalHashId
newBranchCausalHashId)
  (ProjectBranchName
newBranchName, ProjectBranchId
newBranchId) <-
    ((forall void. Output -> Transaction void)
 -> Transaction (ProjectBranchName, ProjectBranchId))
-> Cli (ProjectBranchName, ProjectBranchId)
forall a.
((forall void. Output -> Transaction void) -> Transaction a)
-> Cli a
Cli.runTransactionWithRollback \forall void. Output -> Transaction void
rollback -> do
      ProjectBranchName
newBranchName <- Transaction ProjectBranchName
getNewBranchName
      ProjectId -> ProjectBranchName -> Transaction Bool
Queries.projectBranchExistsByName ProjectId
projectId ProjectBranchName
newBranchName Transaction Bool
-> (Bool -> Transaction (ProjectBranchName, ProjectBranchId))
-> Transaction (ProjectBranchName, ProjectBranchId)
forall a b. Transaction a -> (a -> Transaction b) -> Transaction b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Bool
True -> Output -> Transaction (ProjectBranchName, ProjectBranchId)
forall void. Output -> Transaction void
rollback (ProjectAndBranch ProjectName ProjectBranchName -> Output
Output.ProjectAndBranchNameAlreadyExists (ProjectName
-> ProjectBranchName
-> ProjectAndBranch ProjectName ProjectBranchName
forall a b. a -> b -> ProjectAndBranch a b
ProjectAndBranch (Project
project Project -> Getting ProjectName Project ProjectName -> ProjectName
forall s a. s -> Getting a s a -> a
^. Getting ProjectName Project ProjectName
#name) ProjectBranchName
newBranchName))
        Bool
False -> do
          -- Here, we are forking to `foo/bar`, where project `foo` does exist, and it does not have a branch named
          -- `bar`, so the fork will succeed.
          ProjectBranchId
newBranchId <- IO ProjectBranchId -> Transaction ProjectBranchId
forall a. HasCallStack => IO a -> Transaction a
Sqlite.unsafeIO (UUID -> ProjectBranchId
ProjectBranchId (UUID -> ProjectBranchId) -> IO UUID -> IO ProjectBranchId
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO UUID
UUID.nextRandom)
          HasCallStack =>
Text -> CausalHashId -> ProjectBranch -> Transaction ()
Text -> CausalHashId -> ProjectBranch -> Transaction ()
Queries.insertProjectBranch
            Text
description
            CausalHashId
newBranchCausalHashId
            Sqlite.ProjectBranch
              { ProjectId
projectId :: ProjectId
$sel:projectId:ProjectBranch :: ProjectId
projectId,
                $sel:branchId:ProjectBranch :: ProjectBranchId
branchId = ProjectBranchId
newBranchId,
                $sel:name:ProjectBranch :: ProjectBranchName
name = ProjectBranchName
newBranchName,
                $sel:parentBranchId:ProjectBranch :: Maybe ProjectBranchId
parentBranchId = Maybe ProjectBranchId
mayParentBranchId
              }
          pure (ProjectBranchName
newBranchName, ProjectBranchId
newBranchId)

  ProjectAndBranch ProjectId ProjectBranchId -> Cli ()
Cli.switchProject (ProjectId
-> ProjectBranchId -> ProjectAndBranch ProjectId ProjectBranchId
forall a b. a -> b -> ProjectAndBranch a b
ProjectAndBranch ProjectId
projectId ProjectBranchId
newBranchId)
  pure (ProjectBranchId
newBranchId, ProjectBranchName
newBranchName)