-- | @branch.squash@ input handler
module Unison.Codebase.Editor.HandleInput.BranchSquash (handleBranchSquash) where

import Data.These (These (..))
import U.Codebase.Branch qualified as V2Branch
import U.Codebase.Causal (Causal (..))
import U.Codebase.Causal.Squash qualified as UCausal
import U.Codebase.Sqlite.Project (Project)
import U.Codebase.Sqlite.ProjectBranch (ProjectBranch)
import U.Codebase.Sqlite.V2.HashHandle qualified as HH
import Unison.Cli.Monad
import Unison.Cli.Monad qualified as Cli
import Unison.Cli.MonadUtils qualified as Cli
import Unison.Cli.ProjectUtils qualified as Project
import Unison.Cli.ProjectUtils qualified as ProjectUtils
import Unison.Codebase qualified as Codebase
import Unison.Codebase.Editor.HandleInput.Branch qualified as Branch
import Unison.Codebase.Editor.Output qualified as Output
import Unison.Prelude
import Unison.Project (ProjectAndBranch (..), ProjectBranchName, ProjectName)
import Unison.Sqlite qualified as Sqlite

data SquashDestination
  = -- Update an existing branch with the squash result
    ExistingBranch (ProjectAndBranch Project ProjectBranch)
  | -- Create a new branch from the squashed branch
    NewBranch ProjectUtils.Project ProjectBranchName

handleBranchSquash :: (ProjectAndBranch (Maybe ProjectName) ProjectBranchName) -> (ProjectAndBranch (Maybe ProjectName) ProjectBranchName) -> Cli ()
handleBranchSquash :: ProjectAndBranch (Maybe ProjectName) ProjectBranchName
-> ProjectAndBranch (Maybe ProjectName) ProjectBranchName -> Cli ()
handleBranchSquash ProjectAndBranch (Maybe ProjectName) ProjectBranchName
branchToSquash ProjectAndBranch (Maybe ProjectName) ProjectBranchName
mayDestBranch = do
  Project
currentProj <- Cli Project
Cli.getCurrentProject
  let sourceNames :: These ProjectName ProjectBranchName
sourceNames = case ProjectAndBranch (Maybe ProjectName) ProjectBranchName
branchToSquash of
        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 Maybe ProjectName
Nothing ProjectBranchName
branch -> ProjectBranchName -> These ProjectName ProjectBranchName
forall a b. b -> These a b
That ProjectBranchName
branch
  ProjectAndBranch Project ProjectBranch
sourcePAB <- These ProjectName ProjectBranchName
-> Cli (ProjectAndBranch Project ProjectBranch)
ProjectUtils.expectProjectAndBranchByTheseNames These ProjectName ProjectBranchName
sourceNames
  CausalBranch Transaction
causalBranchToSquash <- Transaction (CausalBranch Transaction)
-> Cli (CausalBranch Transaction)
forall a. Transaction a -> Cli a
Cli.runTransaction (Transaction (CausalBranch Transaction)
 -> Cli (CausalBranch Transaction))
-> Transaction (CausalBranch Transaction)
-> Cli (CausalBranch Transaction)
forall a b. (a -> b) -> a -> b
$ ProjectBranch -> Transaction (CausalBranch Transaction)
Codebase.expectProjectBranchRootCausal ProjectAndBranch Project ProjectBranch
sourcePAB.branch
  let destNames :: These ProjectName ProjectBranchName
destNames = case ProjectAndBranch (Maybe ProjectName) ProjectBranchName
mayDestBranch of
        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 Maybe ProjectName
Nothing ProjectBranchName
branch -> ProjectBranchName -> These ProjectName ProjectBranchName
forall a b. b -> These a b
That ProjectBranchName
branch
  Project
destProj <-
    Project -> Maybe Project -> Project
forall a. a -> Maybe a -> a
fromMaybe Project
currentProj (Maybe Project -> Project) -> Cli (Maybe Project) -> Cli Project
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MaybeT Cli Project -> Cli (Maybe Project)
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT do
      ProjectName
projName <- Maybe ProjectName -> MaybeT Cli ProjectName
forall (m :: * -> *) a. Applicative m => Maybe a -> MaybeT m a
hoistMaybe ProjectAndBranch (Maybe ProjectName) ProjectBranchName
branchToSquash.project
      Cli (Maybe Project) -> MaybeT Cli Project
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (Cli (Maybe Project) -> MaybeT Cli Project)
-> Cli (Maybe Project) -> MaybeT Cli Project
forall a b. (a -> b) -> a -> b
$ ProjectName -> Cli (Maybe Project)
Project.getProjectByName ProjectName
projName
  Maybe (ProjectAndBranch Project ProjectBranch)
mayDestPAB <- These ProjectName ProjectBranchName
-> Cli (Maybe (ProjectAndBranch Project ProjectBranch))
ProjectUtils.getProjectAndBranchByTheseNames These ProjectName ProjectBranchName
destNames
  let squashDest :: SquashDestination
squashDest = case Maybe (ProjectAndBranch Project ProjectBranch)
mayDestPAB of
        Just ProjectAndBranch Project ProjectBranch
destPAB -> ProjectAndBranch Project ProjectBranch -> SquashDestination
ExistingBranch ProjectAndBranch Project ProjectBranch
destPAB
        Maybe (ProjectAndBranch Project ProjectBranch)
Nothing -> Project -> ProjectBranchName -> SquashDestination
NewBranch Project
destProj ProjectAndBranch (Maybe ProjectName) ProjectBranchName
mayDestBranch.branch

  CausalBranch Transaction
squashResult <- Transaction (CausalBranch Transaction)
-> Cli (CausalBranch Transaction)
forall a. Transaction a -> Cli a
Cli.runTransaction (Transaction (CausalBranch Transaction)
 -> Cli (CausalBranch Transaction))
-> Transaction (CausalBranch Transaction)
-> Cli (CausalBranch Transaction)
forall a b. (a -> b) -> a -> b
$ CausalBranch Transaction -> Transaction (CausalBranch Transaction)
squashCausal CausalBranch Transaction
causalBranchToSquash
  let description :: Text
description = Text
"Squashed from " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> CausalHash -> Text
forall a. Show a => a -> Text
tShow CausalBranch Transaction
causalBranchToSquash.causalHash
  case SquashDestination
squashDest of
    NewBranch Project
project ProjectBranchName
newBranchName -> do
      (ProjectAndBranch ProjectId ProjectBranchId
newPAB, ProjectBranchName
_) <- Text
-> CreateFrom
-> Project
-> Transaction ProjectBranchName
-> Cli
     (ProjectAndBranch ProjectId ProjectBranchId, ProjectBranchName)
Branch.createBranch Text
description (CausalHash -> CreateFrom
Branch.CreateFrom'CausalHash CausalBranch Transaction
squashResult.causalHash) Project
project (ProjectBranchName -> Transaction ProjectBranchName
forall a. a -> Transaction a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ProjectBranchName
newBranchName)
      ProjectAndBranch Project ProjectBranch
destBranch <- Transaction (ProjectAndBranch Project ProjectBranch)
-> Cli (ProjectAndBranch Project ProjectBranch)
forall a. Transaction a -> Cli a
Cli.runTransaction (Transaction (ProjectAndBranch Project ProjectBranch)
 -> Cli (ProjectAndBranch Project ProjectBranch))
-> Transaction (ProjectAndBranch Project ProjectBranch)
-> Cli (ProjectAndBranch Project ProjectBranch)
forall a b. (a -> b) -> a -> b
$ ProjectAndBranch ProjectId ProjectBranchId
-> Transaction (ProjectAndBranch Project ProjectBranch)
ProjectUtils.expectProjectAndBranchByIds ProjectAndBranch ProjectId ProjectBranchId
newPAB
      Output -> Cli ()
Cli.respond (Output -> Cli ()) -> Output -> Cli ()
forall a b. (a -> b) -> a -> b
$ ProjectAndBranch Project ProjectBranch
-> ProjectAndBranch Project ProjectBranch -> Output
Output.BranchSquashSuccess ProjectAndBranch Project ProjectBranch
sourcePAB ProjectAndBranch Project ProjectBranch
destBranch
      () -> Cli ()
forall a. a -> Cli a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    ExistingBranch ProjectAndBranch Project ProjectBranch
destBranch -> do
      HasCallStack => ProjectBranch -> Text -> CausalHash -> Cli ()
ProjectBranch -> Text -> CausalHash -> Cli ()
Cli.setProjectBranchRootToCausalHash ProjectAndBranch Project ProjectBranch
destBranch.branch Text
description CausalBranch Transaction
squashResult.causalHash
      Output -> Cli ()
Cli.respond (Output -> Cli ()) -> Output -> Cli ()
forall a b. (a -> b) -> a -> b
$ ProjectAndBranch Project ProjectBranch
-> ProjectAndBranch Project ProjectBranch -> Output
Output.BranchSquashSuccess ProjectAndBranch Project ProjectBranch
sourcePAB ProjectAndBranch Project ProjectBranch
destBranch
  () -> Cli ()
forall a. a -> Cli a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

squashCausal :: V2Branch.CausalBranch Sqlite.Transaction -> Sqlite.Transaction (V2Branch.CausalBranch Sqlite.Transaction)
squashCausal :: CausalBranch Transaction -> Transaction (CausalBranch Transaction)
squashCausal CausalBranch Transaction
causalBranch = do
  HashHandle
-> CausalBranch Transaction
-> Transaction (CausalBranch Transaction)
UCausal.squashCausal HashHandle
HH.v2HashHandle CausalBranch Transaction
causalBranch