mirror of
https://github.com/unisonweb/unison.git
synced 2024-10-04 13:47:26 +03:00
Checkpoint
This commit is contained in:
parent
29fd307ad9
commit
2c98ad1b1e
@ -50,7 +50,7 @@ module Unison.Codebase
|
|||||||
getShallowCausalAtPath,
|
getShallowCausalAtPath,
|
||||||
getBranchAtPath,
|
getBranchAtPath,
|
||||||
Operations.expectCausalBranchByCausalHash,
|
Operations.expectCausalBranchByCausalHash,
|
||||||
getShallowCausalFromRoot,
|
getShallowCausalAtPathFromRootHash,
|
||||||
getShallowRootBranch,
|
getShallowRootBranch,
|
||||||
getShallowRootCausal,
|
getShallowRootCausal,
|
||||||
getShallowProjectRootBranch,
|
getShallowProjectRootBranch,
|
||||||
@ -184,15 +184,13 @@ runTransactionWithRollback ::
|
|||||||
runTransactionWithRollback Codebase {withConnection} action =
|
runTransactionWithRollback Codebase {withConnection} action =
|
||||||
withConnection \conn -> Sqlite.runTransactionWithRollback conn action
|
withConnection \conn -> Sqlite.runTransactionWithRollback conn action
|
||||||
|
|
||||||
getShallowCausalFromRoot ::
|
getShallowCausalAtPathFromRootHash ::
|
||||||
-- Optional root branch, if Nothing use the codebase's root branch.
|
-- Causal to start at, if Nothing use the codebase's root branch.
|
||||||
Maybe CausalHash ->
|
CausalHash ->
|
||||||
Path.Path ->
|
Path.Path ->
|
||||||
Sqlite.Transaction (V2Branch.CausalBranch Sqlite.Transaction)
|
Sqlite.Transaction (V2Branch.CausalBranch Sqlite.Transaction)
|
||||||
getShallowCausalFromRoot mayRootHash p = do
|
getShallowCausalAtPathFromRootHash rootCausalHash p = do
|
||||||
rootCausal <- case mayRootHash of
|
rootCausal <- Operations.expectCausalBranchByCausalHash rootCausalHash
|
||||||
Nothing -> getShallowRootCausal
|
|
||||||
Just ch -> Operations.expectCausalBranchByCausalHash ch
|
|
||||||
getShallowCausalAtPath p (Just rootCausal)
|
getShallowCausalAtPath p (Just rootCausal)
|
||||||
|
|
||||||
-- | Get the shallow representation of the root branches without loading the children or
|
-- | Get the shallow representation of the root branches without loading the children or
|
||||||
@ -240,19 +238,18 @@ getShallowBranchAtPath path branch = do
|
|||||||
childBranch <- V2Causal.value childCausal
|
childBranch <- V2Causal.value childCausal
|
||||||
getShallowBranchAtPath p childBranch
|
getShallowBranchAtPath p childBranch
|
||||||
|
|
||||||
getShallowProjectRootBranch :: Db.ProjectId -> Db.ProjectBranchId -> Sqlite.Transaction (V2Branch.Branch Sqlite.Transaction)
|
getShallowProjectRootBranch :: ProjectBranch -> Sqlite.Transaction (V2Branch.Branch Sqlite.Transaction)
|
||||||
getShallowProjectRootBranch projectId projectBranchId = do
|
getShallowProjectRootBranch ProjectBranch {causalHashId} = do
|
||||||
ProjectBranch {causalHashId} <- Q.expectProjectBranch projectId projectBranchId
|
|
||||||
causalHash <- Q.expectCausalHash causalHashId
|
causalHash <- Q.expectCausalHash causalHashId
|
||||||
Operations.expectCausalBranchByCausalHash causalHash >>= V2Causal.value
|
Operations.expectCausalBranchByCausalHash causalHash >>= V2Causal.value
|
||||||
|
|
||||||
-- | Recursively descend into causals following the given path,
|
-- | Recursively descend into causals following the given path,
|
||||||
-- Use the root causal if none is provided.
|
-- Use the root causal if none is provided.
|
||||||
getShallowBranchAtProjectPath ::
|
getShallowBranchAtProjectPath ::
|
||||||
PP.ProjectPathIds ->
|
PP.ProjectPath ->
|
||||||
Sqlite.Transaction (V2Branch.Branch Sqlite.Transaction)
|
Sqlite.Transaction (V2Branch.Branch Sqlite.Transaction)
|
||||||
getShallowBranchAtProjectPath (PP.ProjectPath projectId projectBranchId path) = do
|
getShallowBranchAtProjectPath (PP.ProjectPath _project projectBranch path) = do
|
||||||
projectRootBranch <- getShallowProjectRootBranch projectId projectBranchId
|
projectRootBranch <- getShallowProjectRootBranch projectBranch
|
||||||
getShallowBranchAtPath (Path.unabsolute path) projectRootBranch
|
getShallowBranchAtPath (Path.unabsolute path) projectRootBranch
|
||||||
|
|
||||||
getShallowProjectRootByNames :: ProjectAndBranch ProjectName ProjectBranchName -> Sqlite.Transaction (Maybe (V2Branch.CausalBranch Sqlite.Transaction))
|
getShallowProjectRootByNames :: ProjectAndBranch ProjectName ProjectBranchName -> Sqlite.Transaction (Maybe (V2Branch.CausalBranch Sqlite.Transaction))
|
||||||
|
@ -11,8 +11,6 @@ module Unison.Codebase.ProjectPath
|
|||||||
asIds_,
|
asIds_,
|
||||||
asNames_,
|
asNames_,
|
||||||
asProjectAndBranch_,
|
asProjectAndBranch_,
|
||||||
project_,
|
|
||||||
branch_,
|
|
||||||
)
|
)
|
||||||
where
|
where
|
||||||
|
|
||||||
@ -27,11 +25,11 @@ import Unison.Prelude
|
|||||||
import Unison.Project (ProjectAndBranch (..), ProjectBranchName, ProjectName)
|
import Unison.Project (ProjectAndBranch (..), ProjectBranchName, ProjectName)
|
||||||
|
|
||||||
data ProjectPathG proj branch = ProjectPath
|
data ProjectPathG proj branch = ProjectPath
|
||||||
{ projPathProject :: proj,
|
{ project :: proj,
|
||||||
projPathBranch :: branch,
|
branch :: branch,
|
||||||
projPathPath :: Path.Absolute
|
absPath :: Path.Absolute
|
||||||
}
|
}
|
||||||
deriving stock (Eq, Ord, Show)
|
deriving stock (Eq, Ord, Show, Generic)
|
||||||
|
|
||||||
type ProjectPathIds = ProjectPathG ProjectId ProjectBranchId
|
type ProjectPathIds = ProjectPathG ProjectId ProjectBranchId
|
||||||
|
|
||||||
@ -42,18 +40,6 @@ type ProjectPath = ProjectPathG Project ProjectBranch
|
|||||||
fromProjectAndBranch :: ProjectAndBranch Project ProjectBranch -> Path.Absolute -> ProjectPath
|
fromProjectAndBranch :: ProjectAndBranch Project ProjectBranch -> Path.Absolute -> ProjectPath
|
||||||
fromProjectAndBranch (ProjectAndBranch proj branch) path = ProjectPath proj branch path
|
fromProjectAndBranch (ProjectAndBranch proj branch) path = ProjectPath proj branch path
|
||||||
|
|
||||||
project_ :: Lens' (ProjectPathG p b) p
|
|
||||||
project_ = lens get set
|
|
||||||
where
|
|
||||||
get (ProjectPath p _ _) = p
|
|
||||||
set (ProjectPath _ b path) p = ProjectPath p b path
|
|
||||||
|
|
||||||
branch_ :: Lens' (ProjectPathG p b) b
|
|
||||||
branch_ = lens get set
|
|
||||||
where
|
|
||||||
get (ProjectPath _ b _) = b
|
|
||||||
set (ProjectPath p _ path) b = ProjectPath p b path
|
|
||||||
|
|
||||||
-- | Project a project context into a project path of just IDs
|
-- | Project a project context into a project path of just IDs
|
||||||
asIds_ :: Lens' ProjectPath ProjectPathIds
|
asIds_ :: Lens' ProjectPath ProjectPathIds
|
||||||
asIds_ = lens get set
|
asIds_ = lens get set
|
||||||
@ -61,8 +47,8 @@ asIds_ = lens get set
|
|||||||
get (ProjectPath proj branch path) = ProjectPath (proj ^. #projectId) (branch ^. #branchId) path
|
get (ProjectPath proj branch path) = ProjectPath (proj ^. #projectId) (branch ^. #branchId) path
|
||||||
set p (ProjectPath pId bId path) =
|
set p (ProjectPath pId bId path) =
|
||||||
p
|
p
|
||||||
& project_ . #projectId .~ pId
|
& #project . #projectId .~ pId
|
||||||
& branch_ . #branchId .~ bId
|
& #branch . #branchId .~ bId
|
||||||
& absPath_ .~ path
|
& absPath_ .~ path
|
||||||
|
|
||||||
-- | Project a project context into a project path of just names
|
-- | Project a project context into a project path of just names
|
||||||
@ -72,15 +58,15 @@ asNames_ = lens get set
|
|||||||
get (ProjectPath proj branch path) = ProjectPath (proj ^. #name) (branch ^. #name) path
|
get (ProjectPath proj branch path) = ProjectPath (proj ^. #name) (branch ^. #name) path
|
||||||
set p (ProjectPath pName bName path) =
|
set p (ProjectPath pName bName path) =
|
||||||
p
|
p
|
||||||
& project_ . #name .~ pName
|
& #project . #name .~ pName
|
||||||
& branch_ . #name .~ bName
|
& #branch . #name .~ bName
|
||||||
& absPath_ .~ path
|
& absPath_ .~ path
|
||||||
|
|
||||||
asProjectAndBranch_ :: Lens' ProjectPath (ProjectAndBranch Project ProjectBranch)
|
asProjectAndBranch_ :: Lens' ProjectPath (ProjectAndBranch Project ProjectBranch)
|
||||||
asProjectAndBranch_ = lens get set
|
asProjectAndBranch_ = lens get set
|
||||||
where
|
where
|
||||||
get (ProjectPath proj branch _) = ProjectAndBranch proj branch
|
get (ProjectPath proj branch _) = ProjectAndBranch proj branch
|
||||||
set p (ProjectAndBranch proj branch) = p & project_ .~ proj & branch_ .~ branch
|
set p (ProjectAndBranch proj branch) = p & #project .~ proj & #branch .~ branch
|
||||||
|
|
||||||
instance Bifunctor ProjectPathG where
|
instance Bifunctor ProjectPathG where
|
||||||
bimap f g (ProjectPath p b path) = ProjectPath (f p) (g b) path
|
bimap f g (ProjectPath p b path) = ProjectPath (f p) (g b) path
|
||||||
|
@ -8,7 +8,7 @@ module Unison.Cli.MonadUtils
|
|||||||
getCurrentPath,
|
getCurrentPath,
|
||||||
getCurrentProjectName,
|
getCurrentProjectName,
|
||||||
getCurrentProjectBranchName,
|
getCurrentProjectBranchName,
|
||||||
getProjectPath,
|
getCurrentProjectPath,
|
||||||
resolvePath,
|
resolvePath,
|
||||||
resolvePath',
|
resolvePath',
|
||||||
resolveSplit',
|
resolveSplit',
|
||||||
@ -95,8 +95,6 @@ import U.Codebase.Branch qualified as V2 (Branch)
|
|||||||
import U.Codebase.Branch qualified as V2Branch
|
import U.Codebase.Branch qualified as V2Branch
|
||||||
import U.Codebase.Causal qualified as V2Causal
|
import U.Codebase.Causal qualified as V2Causal
|
||||||
import U.Codebase.HashTags (CausalHash (..))
|
import U.Codebase.HashTags (CausalHash (..))
|
||||||
import U.Codebase.Sqlite.Project (Project (..))
|
|
||||||
import U.Codebase.Sqlite.ProjectBranch (ProjectBranch (..))
|
|
||||||
import U.Codebase.Sqlite.Queries qualified as Q
|
import U.Codebase.Sqlite.Queries qualified as Q
|
||||||
import Unison.Cli.Monad (Cli)
|
import Unison.Cli.Monad (Cli)
|
||||||
import Unison.Cli.Monad qualified as Cli
|
import Unison.Cli.Monad qualified as Cli
|
||||||
@ -146,28 +144,28 @@ getConfig key = do
|
|||||||
------------------------------------------------------------------------------------------------------------------------
|
------------------------------------------------------------------------------------------------------------------------
|
||||||
-- Getting paths, path resolution, etc.
|
-- Getting paths, path resolution, etc.
|
||||||
|
|
||||||
getProjectPath :: Cli PP.ProjectPath
|
getCurrentProjectPath :: Cli PP.ProjectPath
|
||||||
getProjectPath = do
|
getCurrentProjectPath = do
|
||||||
(PP.ProjectPath projId branchId path) <- Cli.getProjectPathIds
|
(PP.ProjectPath projId branchId path) <- Cli.getProjectPathIds
|
||||||
-- TODO: Reset to a valid project on error.
|
-- TODO: Reset to a valid project on error.
|
||||||
(Project {name = projName}, ProjectBranch {name = branchName}) <- fmap (fromMaybe (error $ reportBug "E794202" ("Project branch not found in database for ids: " <> show (projId, branchId)))) . Cli.runTransaction . runMaybeT $ do
|
(proj, branch) <- fmap (fromMaybe (error $ reportBug "E794202" ("Project branch not found in database for ids: " <> show (projId, branchId)))) . Cli.runTransaction . runMaybeT $ do
|
||||||
project <- MaybeT $ Q.loadProject projId
|
project <- MaybeT $ Q.loadProject projId
|
||||||
branch <- MaybeT $ Q.loadProjectBranch projId branchId
|
branch <- MaybeT $ Q.loadProjectBranch projId branchId
|
||||||
pure (project, branch)
|
pure (project, branch)
|
||||||
pure (PP.ProjectPath (projId, projName) (branchId, branchName) path)
|
pure (PP.ProjectPath proj branch path)
|
||||||
|
|
||||||
-- | Get the current path relative to the current project.
|
-- | Get the current path relative to the current project.
|
||||||
getCurrentPath :: Cli Path.Absolute
|
getCurrentPath :: Cli Path.Absolute
|
||||||
getCurrentPath = do
|
getCurrentPath = do
|
||||||
view PP.absPath_ <$> getProjectPath
|
view PP.absPath_ <$> getCurrentProjectPath
|
||||||
|
|
||||||
getCurrentProjectName :: Cli ProjectName
|
getCurrentProjectName :: Cli ProjectName
|
||||||
getCurrentProjectName = do
|
getCurrentProjectName = do
|
||||||
view (PP.ctxAsNames_ . PP.project_) <$> getProjectPath
|
view (PP.asNames_ . #project) <$> getCurrentProjectPath
|
||||||
|
|
||||||
getCurrentProjectBranchName :: Cli ProjectBranchName
|
getCurrentProjectBranchName :: Cli ProjectBranchName
|
||||||
getCurrentProjectBranchName = do
|
getCurrentProjectBranchName = do
|
||||||
view (PP.ctxAsNames_ . PP.branch_) <$> getProjectPath
|
view (PP.asNames_ . #branch) <$> getCurrentProjectPath
|
||||||
|
|
||||||
-- | Resolve a @Path@ (interpreted as relative) to a @Path.Absolute@, per the current path.
|
-- | Resolve a @Path@ (interpreted as relative) to a @Path.Absolute@, per the current path.
|
||||||
resolvePath :: Path -> Cli Path.Absolute
|
resolvePath :: Path -> Cli Path.Absolute
|
||||||
|
@ -13,8 +13,6 @@ module Unison.Cli.ProjectUtils
|
|||||||
expectProjectAndBranchByIds,
|
expectProjectAndBranchByIds,
|
||||||
getProjectAndBranchByTheseNames,
|
getProjectAndBranchByTheseNames,
|
||||||
expectProjectAndBranchByTheseNames,
|
expectProjectAndBranchByTheseNames,
|
||||||
getCurrentProject,
|
|
||||||
getCurrentProjectBranch,
|
|
||||||
|
|
||||||
-- * Loading remote project info
|
-- * Loading remote project info
|
||||||
expectRemoteProjectById,
|
expectRemoteProjectById,
|
||||||
@ -40,7 +38,6 @@ import Data.These (These (..))
|
|||||||
import U.Codebase.Sqlite.DbId
|
import U.Codebase.Sqlite.DbId
|
||||||
import U.Codebase.Sqlite.Project (Project)
|
import U.Codebase.Sqlite.Project (Project)
|
||||||
import U.Codebase.Sqlite.Project qualified as Sqlite
|
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.ProjectBranch qualified as Sqlite
|
||||||
import U.Codebase.Sqlite.Queries qualified as Queries
|
import U.Codebase.Sqlite.Queries qualified as Queries
|
||||||
import Unison.Cli.Monad (Cli)
|
import Unison.Cli.Monad (Cli)
|
||||||
@ -66,13 +63,13 @@ resolveBranchRelativePath brp = do
|
|||||||
case brp of
|
case brp of
|
||||||
BranchPathInCurrentProject projBranchName path -> do
|
BranchPathInCurrentProject projBranchName path -> do
|
||||||
projectAndBranch <- expectProjectAndBranchByTheseNames (That projBranchName)
|
projectAndBranch <- expectProjectAndBranchByTheseNames (That projBranchName)
|
||||||
pure $ PP.ctxFromProjectAndBranch projectAndBranch path
|
pure $ PP.fromProjectAndBranch projectAndBranch path
|
||||||
QualifiedBranchPath projName projBranchName path -> do
|
QualifiedBranchPath projName projBranchName path -> do
|
||||||
projectAndBranch <- expectProjectAndBranchByTheseNames (These projName projBranchName)
|
projectAndBranch <- expectProjectAndBranchByTheseNames (These projName projBranchName)
|
||||||
pure $ PP.ctxFromProjectAndBranch projectAndBranch path
|
pure $ PP.fromProjectAndBranch projectAndBranch path
|
||||||
UnqualifiedPath newPath' -> do
|
UnqualifiedPath newPath' -> do
|
||||||
ppCtx <- Cli.getProjectPath
|
pp <- Cli.getCurrentProjectPath
|
||||||
pure $ ppCtx & PP.absPath_ %~ \curPath -> Path.resolve curPath newPath'
|
pure $ pp & PP.absPath_ %~ \curPath -> Path.resolve curPath newPath'
|
||||||
|
|
||||||
-- @findTemporaryBranchName projectId preferred@ finds some unused branch name in @projectId@ with a name
|
-- @findTemporaryBranchName projectId preferred@ finds some unused branch name in @projectId@ with a name
|
||||||
-- like @preferred@.
|
-- like @preferred@.
|
||||||
@ -95,20 +92,6 @@ findTemporaryBranchName projectId preferred = do
|
|||||||
|
|
||||||
pure (fromJust (List.find (\name -> not (Set.member name allBranchNames)) allCandidates))
|
pure (fromJust (List.find (\name -> not (Set.member name allBranchNames)) allCandidates))
|
||||||
|
|
||||||
-- | Get the current project+branch+branch path that a user is on.
|
|
||||||
getCurrentProjectBranch :: Cli (PP.ProjectPath Sqlite.Project Sqlite.ProjectBranch)
|
|
||||||
getCurrentProjectBranch = do
|
|
||||||
ppCtx <- Cli.getProjectPath
|
|
||||||
Cli.runTransaction $ do
|
|
||||||
proj <- Queries.expectProject (ppCtx ^. PP.ctxAsIds_ . PP.project_)
|
|
||||||
branch <- Queries.expectProjectBranch (proj ^. #projectId) (ppCtx ^. PP.ctxAsIds_ . PP.branch_)
|
|
||||||
pure $ PP.ProjectPath proj branch (ppCtx ^. PP.absPath_)
|
|
||||||
|
|
||||||
getCurrentProject :: Cli Sqlite.Project
|
|
||||||
getCurrentProject = do
|
|
||||||
ppCtx <- Cli.getProjectPath
|
|
||||||
Cli.runTransaction (Queries.expectProject (ppCtx ^. PP.ctxAsIds_ . PP.project_))
|
|
||||||
|
|
||||||
expectProjectBranchByName :: Sqlite.Project -> ProjectBranchName -> Cli Sqlite.ProjectBranch
|
expectProjectBranchByName :: Sqlite.Project -> ProjectBranchName -> Cli Sqlite.ProjectBranch
|
||||||
expectProjectBranchByName project branchName =
|
expectProjectBranchByName project branchName =
|
||||||
Cli.runTransaction (Queries.loadProjectBranchByName (project ^. #projectId) branchName) & onNothingM do
|
Cli.runTransaction (Queries.loadProjectBranchByName (project ^. #projectId) branchName) & onNothingM do
|
||||||
@ -124,8 +107,8 @@ hydrateNames :: These ProjectName ProjectBranchName -> Cli (ProjectAndBranch Pro
|
|||||||
hydrateNames = \case
|
hydrateNames = \case
|
||||||
This projectName -> pure (ProjectAndBranch projectName (unsafeFrom @Text "main"))
|
This projectName -> pure (ProjectAndBranch projectName (unsafeFrom @Text "main"))
|
||||||
That branchName -> do
|
That branchName -> do
|
||||||
ppCtx <- Cli.getProjectPath
|
pp <- Cli.getCurrentProjectPath
|
||||||
pure (ProjectAndBranch (ppCtx ^. PP.ctxAsNames_ . PP.project_) branchName)
|
pure (ProjectAndBranch (pp ^. PP.asNames_ . #project) branchName)
|
||||||
These projectName branchName -> pure (ProjectAndBranch projectName branchName)
|
These projectName branchName -> pure (ProjectAndBranch projectName branchName)
|
||||||
|
|
||||||
-- Expect a local project+branch by ids.
|
-- Expect a local project+branch by ids.
|
||||||
@ -147,9 +130,9 @@ getProjectAndBranchByTheseNames ::
|
|||||||
getProjectAndBranchByTheseNames = \case
|
getProjectAndBranchByTheseNames = \case
|
||||||
This projectName -> getProjectAndBranchByTheseNames (These projectName (unsafeFrom @Text "main"))
|
This projectName -> getProjectAndBranchByTheseNames (These projectName (unsafeFrom @Text "main"))
|
||||||
That branchName -> runMaybeT do
|
That branchName -> runMaybeT do
|
||||||
currentProjectBranch <- lift getCurrentProjectBranch
|
(PP.ProjectPath proj _branch _path) <- lift Cli.getCurrentProjectPath
|
||||||
branch <- MaybeT (Cli.runTransaction (Queries.loadProjectBranchByName (currentProjectBranch ^. PP.project_ . #projectId) branchName))
|
branch <- MaybeT (Cli.runTransaction (Queries.loadProjectBranchByName (proj ^. #projectId) branchName))
|
||||||
pure (ProjectAndBranch (currentProjectBranch ^. PP.project_) branch)
|
pure (ProjectAndBranch proj branch)
|
||||||
These projectName branchName -> do
|
These projectName branchName -> do
|
||||||
Cli.runTransaction do
|
Cli.runTransaction do
|
||||||
runMaybeT do
|
runMaybeT do
|
||||||
@ -167,7 +150,7 @@ expectProjectAndBranchByTheseNames ::
|
|||||||
expectProjectAndBranchByTheseNames = \case
|
expectProjectAndBranchByTheseNames = \case
|
||||||
This projectName -> expectProjectAndBranchByTheseNames (These projectName (unsafeFrom @Text "main"))
|
This projectName -> expectProjectAndBranchByTheseNames (These projectName (unsafeFrom @Text "main"))
|
||||||
That branchName -> do
|
That branchName -> do
|
||||||
PP.ProjectPath project _branch _restPath <- getCurrentProjectBranch
|
PP.ProjectPath project _branch _restPath <- Cli.getCurrentProjectPath
|
||||||
branch <-
|
branch <-
|
||||||
Cli.runTransaction (Queries.loadProjectBranchByName (project ^. #projectId) branchName) & onNothingM do
|
Cli.runTransaction (Queries.loadProjectBranchByName (project ^. #projectId) branchName) & onNothingM do
|
||||||
Cli.returnEarly (LocalProjectBranchDoesntExist (ProjectAndBranch (project ^. #name) branchName))
|
Cli.returnEarly (LocalProjectBranchDoesntExist (ProjectAndBranch (project ^. #name) branchName))
|
||||||
@ -188,21 +171,21 @@ expectProjectAndBranchByTheseNames = \case
|
|||||||
-- 2. If we have an unambiguous `/branch` or `project/branch`, resolve it using the current
|
-- 2. If we have an unambiguous `/branch` or `project/branch`, resolve it using the current
|
||||||
-- project, defaulting to 'main' if branch is unspecified.
|
-- project, defaulting to 'main' if branch is unspecified.
|
||||||
-- 3. If we just have a path, resolve it using the current project.
|
-- 3. If we just have a path, resolve it using the current project.
|
||||||
resolveProjectPath :: PP.ProjectPath -> ProjectAndBranch (Maybe ProjectName) (Maybe ProjectBranchName) -> Maybe Path' -> Cli PP.ProjectPath
|
resolveProjectPath :: Project -> ProjectAndBranch (Maybe ProjectName) (Maybe ProjectBranchName) -> Maybe Path' -> Cli PP.ProjectPath
|
||||||
resolveProjectPath ppCtx mayProjAndBranch mayPath' = do
|
resolveProjectPath defaultProj mayProjAndBranch mayPath' = do
|
||||||
projAndBranch <- resolveProjectBranch ppCtx mayProjAndBranch
|
projAndBranch <- resolveProjectBranch defaultProj mayProjAndBranch
|
||||||
absPath <- fromMaybe Path.absoluteEmpty <$> traverse Cli.resolvePath' mayPath'
|
absPath <- fromMaybe Path.absoluteEmpty <$> traverse Cli.resolvePath' mayPath'
|
||||||
pure $ PP.ctxFromProjectAndBranch projAndBranch absPath
|
pure $ PP.fromProjectAndBranch projAndBranch absPath
|
||||||
|
|
||||||
-- | Expect/resolve branch reference with the following rules:
|
-- | Expect/resolve branch reference with the following rules:
|
||||||
--
|
--
|
||||||
-- 1. If the project is missing, use the provided project.
|
-- 1. If the project is missing, use the provided project.
|
||||||
-- 2. If we have an unambiguous `/branch` or `project/branch`, resolve it using the provided
|
-- 2. If we have an unambiguous `/branch` or `project/branch`, resolve it using the provided
|
||||||
-- project, defaulting to 'main' if branch is unspecified.
|
-- project, defaulting to 'main' if branch is unspecified.
|
||||||
resolveProjectBranch :: ProjectAndBranch Project ProjectBranch -> ProjectAndBranch (Maybe ProjectName) (Maybe ProjectBranchName) -> Cli (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch)
|
resolveProjectBranch :: Project -> ProjectAndBranch (Maybe ProjectName) (Maybe ProjectBranchName) -> Cli (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch)
|
||||||
resolveProjectBranch ppCtx (ProjectAndBranch mayProjectName mayBranchName) = do
|
resolveProjectBranch defaultProj (ProjectAndBranch mayProjectName mayBranchName) = do
|
||||||
let branchName = fromMaybe (unsafeFrom @Text "main") mayBranchName
|
let branchName = fromMaybe (unsafeFrom @Text "main") mayBranchName
|
||||||
let projectName = fromMaybe (ppCtx ^. PP.ctxAsNames_ . PP.project_) mayProjectName
|
let projectName = fromMaybe (defaultProj ^. #name) mayProjectName
|
||||||
projectAndBranch <- expectProjectAndBranchByTheseNames (These projectName branchName)
|
projectAndBranch <- expectProjectAndBranchByTheseNames (These projectName branchName)
|
||||||
pure projectAndBranch
|
pure projectAndBranch
|
||||||
|
|
||||||
@ -289,7 +272,7 @@ expectRemoteProjectBranchByTheseNames includeSquashed = \case
|
|||||||
let remoteBranchName = unsafeFrom @Text "main"
|
let remoteBranchName = unsafeFrom @Text "main"
|
||||||
expectRemoteProjectBranchByName includeSquashed (ProjectAndBranch (remoteProjectId, remoteProjectName) remoteBranchName)
|
expectRemoteProjectBranchByName includeSquashed (ProjectAndBranch (remoteProjectId, remoteProjectName) remoteBranchName)
|
||||||
That branchName -> do
|
That branchName -> do
|
||||||
PP.ProjectPath localProject localBranch _restPath <- getCurrentProjectBranch
|
PP.ProjectPath localProject localBranch _restPath <- Cli.getCurrentProjectPath
|
||||||
let localProjectId = localProject ^. #projectId
|
let localProjectId = localProject ^. #projectId
|
||||||
let localBranchId = localBranch ^. #branchId
|
let localBranchId = localBranch ^. #branchId
|
||||||
Cli.runTransaction (Queries.loadRemoteProjectBranch localProjectId Share.hardCodedUri localBranchId) >>= \case
|
Cli.runTransaction (Queries.loadRemoteProjectBranch localProjectId Share.hardCodedUri localBranchId) >>= \case
|
||||||
|
@ -18,10 +18,8 @@ import Unison.Cli.Monad qualified as Cli
|
|||||||
import Unison.Cli.MonadUtils qualified as Cli
|
import Unison.Cli.MonadUtils qualified as Cli
|
||||||
import Unison.Cli.ProjectUtils qualified as ProjectUtils
|
import Unison.Cli.ProjectUtils qualified as ProjectUtils
|
||||||
import Unison.Codebase qualified as Codebase
|
import Unison.Codebase qualified as Codebase
|
||||||
import Unison.Codebase.Branch qualified as Branch (headHash)
|
|
||||||
import Unison.Codebase.Editor.Input qualified as Input
|
import Unison.Codebase.Editor.Input qualified as Input
|
||||||
import Unison.Codebase.Editor.Output qualified as Output
|
import Unison.Codebase.Editor.Output qualified as Output
|
||||||
import Unison.Codebase.Path qualified as Path
|
|
||||||
import Unison.Codebase.ProjectPath qualified as PP
|
import Unison.Codebase.ProjectPath qualified as PP
|
||||||
import Unison.Prelude
|
import Unison.Prelude
|
||||||
import Unison.Project (ProjectAndBranch (..), ProjectBranchName, ProjectBranchNameKind (..), ProjectName, classifyProjectBranchName)
|
import Unison.Project (ProjectAndBranch (..), ProjectBranchName, ProjectBranchNameKind (..), ProjectName, classifyProjectBranchName)
|
||||||
@ -41,7 +39,7 @@ handleBranch sourceI projectAndBranchNames@(ProjectAndBranch mayProjectName newB
|
|||||||
Cli.returnEarly (Output.CannotCreateReleaseBranchWithBranchCommand newBranchName ver)
|
Cli.returnEarly (Output.CannotCreateReleaseBranchWithBranchCommand newBranchName ver)
|
||||||
ProjectBranchNameKind'NothingSpecial -> pure ()
|
ProjectBranchNameKind'NothingSpecial -> pure ()
|
||||||
|
|
||||||
currentProjectName <- Cli.getProjectPath <&> view (PP.ctxAsNames_ . PP.project_)
|
currentProjectName <- Cli.getCurrentProjectPath <&> view (PP.asNames_ . #project)
|
||||||
destProject <- do
|
destProject <- do
|
||||||
Cli.runTransactionWithRollback
|
Cli.runTransactionWithRollback
|
||||||
\rollback -> do
|
\rollback -> do
|
||||||
@ -51,22 +49,21 @@ handleBranch sourceI projectAndBranchNames@(ProjectAndBranch mayProjectName newB
|
|||||||
rollback (Output.LocalProjectBranchDoesntExist (ProjectAndBranch projectName newBranchName))
|
rollback (Output.LocalProjectBranchDoesntExist (ProjectAndBranch projectName newBranchName))
|
||||||
|
|
||||||
-- Compute what we should create the branch from.
|
-- Compute what we should create the branch from.
|
||||||
maySrcBranch <-
|
maySrcProjectAndBranch <-
|
||||||
case sourceI of
|
case sourceI of
|
||||||
Input.BranchSourceI'CurrentContext -> Just <$> ProjectUtils.getCurrentProjectBranch
|
Input.BranchSourceI'CurrentContext -> Just . view PP.projectAndBranch_ <$> Cli.getCurrentProjectPath
|
||||||
Input.BranchSourceI'Empty -> pure Nothing
|
Input.BranchSourceI'Empty -> pure Nothing
|
||||||
Input.BranchSourceI'UnresolvedProjectBranch unresolvedProjectBranch -> do
|
Input.BranchSourceI'UnresolvedProjectBranch unresolvedProjectBranch -> do
|
||||||
ppCtx <- Cli.getProjectPath
|
pp <- Cli.getCurrentProjectPath
|
||||||
ProjectAndBranch _proj branch <- ProjectUtils.resolveProjectBranch ppCtx (unresolvedProjectBranch & #branch %~ Just)
|
Just <$> ProjectUtils.resolveProjectBranch (pp ^. #project) (unresolvedProjectBranch & #branch %~ Just)
|
||||||
pure $ Just branch
|
|
||||||
|
|
||||||
_ <- doCreateBranch maySrcBranch project newBranchName
|
_ <- doCreateBranch (view #branch <$> maySrcProjectAndBranch) destProject newBranchName
|
||||||
|
|
||||||
Cli.respond $
|
Cli.respond $
|
||||||
Output.CreatedProjectBranch
|
Output.CreatedProjectBranch
|
||||||
( case maySrcBranch of
|
( case maySrcProjectAndBranch of
|
||||||
Just sourceBranch ->
|
Just sourceBranch ->
|
||||||
if sourceBranch ^. #project . #projectId == project ^. #projectId
|
if sourceBranch ^. #project . #projectId == destProject ^. #projectId
|
||||||
then Output.CreatedProjectBranchFrom'ParentBranch (sourceBranch ^. #branch . #name)
|
then Output.CreatedProjectBranchFrom'ParentBranch (sourceBranch ^. #branch . #name)
|
||||||
else Output.CreatedProjectBranchFrom'OtherBranch sourceBranch
|
else Output.CreatedProjectBranchFrom'OtherBranch sourceBranch
|
||||||
Nothing -> Output.CreatedProjectBranchFrom'Nothingness
|
Nothing -> Output.CreatedProjectBranchFrom'Nothingness
|
||||||
@ -86,7 +83,7 @@ doCreateBranch ::
|
|||||||
-- If no parent branch is provided, make an empty branch.
|
-- If no parent branch is provided, make an empty branch.
|
||||||
Maybe Sqlite.ProjectBranch ->
|
Maybe Sqlite.ProjectBranch ->
|
||||||
Sqlite.Project ->
|
Sqlite.Project ->
|
||||||
Sqlite.Transaction ProjectBranchName ->
|
ProjectBranchName ->
|
||||||
Cli ProjectBranchId
|
Cli ProjectBranchId
|
||||||
doCreateBranch mayParentBranch project getNewBranchName = do
|
doCreateBranch mayParentBranch project getNewBranchName = do
|
||||||
let projectId = project ^. #projectId
|
let projectId = project ^. #projectId
|
||||||
|
@ -21,6 +21,7 @@ import Unison.Cli.ProjectUtils qualified as Project
|
|||||||
import Unison.Codebase (Codebase)
|
import Unison.Codebase (Codebase)
|
||||||
import Unison.Codebase qualified as Codebase
|
import Unison.Codebase qualified as Codebase
|
||||||
import Unison.Codebase.Path qualified as Path
|
import Unison.Codebase.Path qualified as Path
|
||||||
|
import Unison.Codebase.ProjectPath qualified as PP
|
||||||
import Unison.Codebase.SqliteCodebase.Conversions qualified as Conversions
|
import Unison.Codebase.SqliteCodebase.Conversions qualified as Conversions
|
||||||
import Unison.ConstructorType qualified as ConstructorType
|
import Unison.ConstructorType qualified as ConstructorType
|
||||||
import Unison.HashQualified qualified as HQ
|
import Unison.HashQualified qualified as HQ
|
||||||
@ -28,8 +29,7 @@ import Unison.Name (Name)
|
|||||||
import Unison.Name qualified as Name
|
import Unison.Name qualified as Name
|
||||||
import Unison.Parser.Ann (Ann (..))
|
import Unison.Parser.Ann (Ann (..))
|
||||||
import Unison.Prelude
|
import Unison.Prelude
|
||||||
import Unison.Project (ProjectAndBranch)
|
import Unison.Project (ProjectAndBranch (ProjectAndBranch))
|
||||||
import Unison.Project.Util (projectBranchPath)
|
|
||||||
import Unison.Referent qualified as Referent
|
import Unison.Referent qualified as Referent
|
||||||
import Unison.Server.CodebaseServer qualified as Server
|
import Unison.Server.CodebaseServer qualified as Server
|
||||||
import Unison.Sqlite qualified as Sqlite
|
import Unison.Sqlite qualified as Sqlite
|
||||||
@ -39,37 +39,25 @@ import Web.Browser (openBrowser)
|
|||||||
openUI :: Path.Path' -> Cli ()
|
openUI :: Path.Path' -> Cli ()
|
||||||
openUI path' = do
|
openUI path' = do
|
||||||
Cli.Env {serverBaseUrl} <- ask
|
Cli.Env {serverBaseUrl} <- ask
|
||||||
currentPath <- Cli.getCurrentPath
|
defnPath <- Cli.resolvePath' path'
|
||||||
let absPath = Path.resolve currentPath path'
|
pp <- Cli.getCurrentProjectPath
|
||||||
whenJust serverBaseUrl \url -> do
|
whenJust serverBaseUrl \url -> do
|
||||||
Project.getProjectBranchForPath absPath >>= \case
|
openUIForProject url pp defnPath
|
||||||
Nothing -> openUIForLooseCode url path'
|
|
||||||
Just (projectBranch, pathWithinBranch) -> openUIForProject url projectBranch pathWithinBranch
|
|
||||||
|
|
||||||
openUIForProject :: Server.BaseUrl -> ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch -> Path.Path -> Cli ()
|
openUIForProject :: Server.BaseUrl -> PP.ProjectPath -> Path.Absolute -> Cli ()
|
||||||
openUIForProject url projectAndBranch pathFromProjectRoot = do
|
openUIForProject url (PP.ProjectPath project projectBranch perspective) defnPath = do
|
||||||
currentPath <- Cli.getCurrentPath
|
|
||||||
perspective <-
|
|
||||||
Project.getProjectBranchForPath currentPath <&> \case
|
|
||||||
Nothing ->
|
|
||||||
-- The current path is outside the project the argument was in. Use the project root
|
|
||||||
-- as the perspective.
|
|
||||||
Path.empty
|
|
||||||
Just (_projectBranch, pathWithinBranch) -> pathWithinBranch
|
|
||||||
mayDefinitionRef <- getDefinitionRef perspective
|
mayDefinitionRef <- getDefinitionRef perspective
|
||||||
let projectBranchNames = bimap Project.name ProjectBranch.name projectAndBranch
|
let projectBranchNames = bimap Project.name ProjectBranch.name (ProjectAndBranch project projectBranch)
|
||||||
_success <- liftIO . openBrowser . Text.unpack $ Server.urlFor (Server.ProjectBranchUI projectBranchNames perspective mayDefinitionRef) url
|
_success <- liftIO . openBrowser . Text.unpack $ Server.urlFor (Server.ProjectBranchUI projectBranchNames perspective mayDefinitionRef) url
|
||||||
pure ()
|
pure ()
|
||||||
where
|
where
|
||||||
pathToBranchFromCodebaseRoot :: Path.Absolute
|
|
||||||
pathToBranchFromCodebaseRoot = projectBranchPath (bimap Project.projectId ProjectBranch.branchId projectAndBranch)
|
|
||||||
-- If the provided ui path matches a definition, find it.
|
-- If the provided ui path matches a definition, find it.
|
||||||
getDefinitionRef :: Path.Path -> Cli (Maybe (Server.DefinitionReference))
|
getDefinitionRef :: Path.Absolute -> Cli (Maybe (Server.DefinitionReference))
|
||||||
getDefinitionRef perspective = runMaybeT $ do
|
getDefinitionRef perspective = runMaybeT $ do
|
||||||
Cli.Env {codebase} <- lift ask
|
Cli.Env {codebase} <- lift ask
|
||||||
let absPathToDefinition = Path.unabsolute $ Path.resolve pathToBranchFromCodebaseRoot (Path.Relative pathFromProjectRoot)
|
(pathToDefinitionNamespace, _nameSeg) <- hoistMaybe $ Lens.unsnoc defnPath
|
||||||
(pathToDefinitionNamespace, _nameSeg) <- hoistMaybe $ Lens.unsnoc absPathToDefinition
|
let defnNamespaceProjectPath = pp & PP.absPath_ .~ pathToDefinitionNamespace
|
||||||
namespaceBranch <- lift $ Cli.runTransaction (Codebase.getShallowBranchAtPath pathToDefinitionNamespace Nothing)
|
namespaceBranch <- lift . Cli.runTransaction $ Codebase.getShallowBranchAtProjectPath defnNamespaceProjectPath
|
||||||
fqn <- hoistMaybe $ do
|
fqn <- hoistMaybe $ do
|
||||||
pathFromPerspective <- List.stripPrefix (Path.toList perspective) (Path.toList pathFromProjectRoot)
|
pathFromPerspective <- List.stripPrefix (Path.toList perspective) (Path.toList pathFromProjectRoot)
|
||||||
Path.toName . Path.fromList $ pathFromPerspective
|
Path.toName . Path.fromList $ pathFromPerspective
|
||||||
|
@ -101,7 +101,7 @@ noCompletions ::
|
|||||||
String ->
|
String ->
|
||||||
Codebase m v a ->
|
Codebase m v a ->
|
||||||
AuthenticatedHttpClient ->
|
AuthenticatedHttpClient ->
|
||||||
Path.Absolute ->
|
PP.ProjectPath ->
|
||||||
m [System.Console.Haskeline.Completion.Completion]
|
m [System.Console.Haskeline.Completion.Completion]
|
||||||
noCompletions _ _ _ _ = pure []
|
noCompletions _ _ _ _ = pure []
|
||||||
|
|
||||||
@ -145,7 +145,7 @@ completeWithinNamespace ::
|
|||||||
Sqlite.Transaction [System.Console.Haskeline.Completion.Completion]
|
Sqlite.Transaction [System.Console.Haskeline.Completion.Completion]
|
||||||
completeWithinNamespace compTypes query ppCtx = do
|
completeWithinNamespace compTypes query ppCtx = do
|
||||||
shortHashLen <- Codebase.hashLength
|
shortHashLen <- Codebase.hashLength
|
||||||
b <- Codebase.getShallowBranchAtProjectPath (queryProjectPath ^. PP.ctxAsIds_)
|
b <- Codebase.getShallowBranchAtProjectPath (queryProjectPath ^. PP.asIds_)
|
||||||
currentBranchSuggestions <- do
|
currentBranchSuggestions <- do
|
||||||
nib <- namesInBranch shortHashLen b
|
nib <- namesInBranch shortHashLen b
|
||||||
nib
|
nib
|
||||||
|
@ -177,7 +177,7 @@ projectBranchOptions codebase _projCtx _searchBranch0 = do
|
|||||||
-- E.g. '@unison/base/main'
|
-- E.g. '@unison/base/main'
|
||||||
projectBranchOptionsWithinCurrentProject :: OptionFetcher
|
projectBranchOptionsWithinCurrentProject :: OptionFetcher
|
||||||
projectBranchOptionsWithinCurrentProject codebase projCtx _searchBranch0 = do
|
projectBranchOptionsWithinCurrentProject codebase projCtx _searchBranch0 = do
|
||||||
Codebase.runTransaction codebase (Q.loadAllProjectBranchesBeginningWith (projCtx ^. PP.asIds_ . PP.project_) Nothing)
|
Codebase.runTransaction codebase (Q.loadAllProjectBranchesBeginningWith (projCtx ^. PP.asIds_ . #project) Nothing)
|
||||||
<&> fmap (into @Text . snd)
|
<&> fmap (into @Text . snd)
|
||||||
|
|
||||||
-- | Exported from here just so the debug command and actual implementation can use the same
|
-- | Exported from here just so the debug command and actual implementation can use the same
|
||||||
|
@ -147,7 +147,7 @@ module Unison.CommandLine.InputPatterns
|
|||||||
)
|
)
|
||||||
where
|
where
|
||||||
|
|
||||||
import Control.Lens ((^.))
|
import Control.Lens ((.~), (^.))
|
||||||
import Control.Lens.Cons qualified as Cons
|
import Control.Lens.Cons qualified as Cons
|
||||||
import Data.List (intercalate)
|
import Data.List (intercalate)
|
||||||
import Data.List.Extra qualified as List
|
import Data.List.Extra qualified as List
|
||||||
@ -1840,7 +1840,7 @@ mergeOldSquashInputPattern =
|
|||||||
[src, dest] -> do
|
[src, dest] -> do
|
||||||
src <- parseUnresolvedProjectBranch src
|
src <- parseUnresolvedProjectBranch src
|
||||||
dest <- parseUnresolvedProjectBranch dest
|
dest <- parseUnresolvedProjectBranch dest
|
||||||
Just $ Input.MergeLocalBranchI src dest Branch.SquashMerge
|
Just $ Input.MergeLocalBranchI src (Just dest) Branch.SquashMerge
|
||||||
_ -> Nothing
|
_ -> Nothing
|
||||||
}
|
}
|
||||||
where
|
where
|
||||||
@ -3349,7 +3349,7 @@ namespaceOrProjectBranchArg config =
|
|||||||
ArgumentType
|
ArgumentType
|
||||||
{ typeName = "namespace or branch",
|
{ typeName = "namespace or branch",
|
||||||
suggestions =
|
suggestions =
|
||||||
let namespaceSuggestions = \q cb _http ppCtx -> Codebase.runTransaction cb (prefixCompleteNamespace q ppCtx)
|
let namespaceSuggestions = \q cb _http pp -> Codebase.runTransaction cb (prefixCompleteNamespace q pp)
|
||||||
in unionSuggestions
|
in unionSuggestions
|
||||||
[ projectAndOrBranchSuggestions config,
|
[ projectAndOrBranchSuggestions config,
|
||||||
namespaceSuggestions
|
namespaceSuggestions
|
||||||
@ -3375,8 +3375,8 @@ dependencyArg :: ArgumentType
|
|||||||
dependencyArg =
|
dependencyArg =
|
||||||
ArgumentType
|
ArgumentType
|
||||||
{ typeName = "project dependency",
|
{ typeName = "project dependency",
|
||||||
suggestions = \q cb _http p -> Codebase.runTransaction cb do
|
suggestions = \q cb _http pp -> Codebase.runTransaction cb do
|
||||||
prefixCompleteNamespace q (p Path.:> NameSegment.libSegment),
|
prefixCompleteNamespace q (pp & PP.path_ .~ Path.singleton NameSegment.libSegment),
|
||||||
fzfResolver = Just Resolvers.projectDependencyResolver
|
fzfResolver = Just Resolvers.projectDependencyResolver
|
||||||
}
|
}
|
||||||
|
|
||||||
@ -3464,12 +3464,12 @@ projectAndOrBranchSuggestions ::
|
|||||||
AuthenticatedHttpClient ->
|
AuthenticatedHttpClient ->
|
||||||
ProjectPath ->
|
ProjectPath ->
|
||||||
m [Line.Completion]
|
m [Line.Completion]
|
||||||
projectAndOrBranchSuggestions config inputStr codebase _httpClient ppCtx = do
|
projectAndOrBranchSuggestions config inputStr codebase _httpClient pp = do
|
||||||
case Text.uncons input of
|
case Text.uncons input of
|
||||||
-- Things like "/foo" would be parsed as unambiguous branches in the logic below, except we also want to
|
-- Things like "/foo" would be parsed as unambiguous branches in the logic below, except we also want to
|
||||||
-- handle "/<TAB>" and "/@<TAB>" inputs, which aren't valid branch names, but are valid branch prefixes. So,
|
-- handle "/<TAB>" and "/@<TAB>" inputs, which aren't valid branch names, but are valid branch prefixes. So,
|
||||||
-- if the input begins with a forward slash, just rip it off and treat the rest as the branch prefix.
|
-- if the input begins with a forward slash, just rip it off and treat the rest as the branch prefix.
|
||||||
Just ('/', input1) -> handleBranchesComplete input1 codebase path
|
Just ('/', input1) -> handleBranchesComplete input1 codebase pp
|
||||||
_ ->
|
_ ->
|
||||||
case tryInto @ProjectAndBranchNames input of
|
case tryInto @ProjectAndBranchNames input of
|
||||||
-- This case handles inputs like "", "@", and possibly other things that don't look like a valid project
|
-- This case handles inputs like "", "@", and possibly other things that don't look like a valid project
|
||||||
@ -3490,12 +3490,12 @@ projectAndOrBranchSuggestions config inputStr codebase _httpClient ppCtx = do
|
|||||||
Nothing -> pure []
|
Nothing -> pure []
|
||||||
Just project -> do
|
Just project -> do
|
||||||
let projectId = project ^. #projectId
|
let projectId = project ^. #projectId
|
||||||
fmap (filterBranches config path) do
|
fmap (filterBranches config pp) do
|
||||||
Queries.loadAllProjectBranchesBeginningWith projectId Nothing
|
Queries.loadAllProjectBranchesBeginningWith projectId Nothing
|
||||||
pure (map (projectBranchToCompletion projectName) branches)
|
pure (map (projectBranchToCompletion projectName) branches)
|
||||||
-- This branch is probably dead due to intercepting inputs that begin with "/" above
|
-- This branch is probably dead due to intercepting inputs that begin with "/" above
|
||||||
Right (ProjectAndBranchNames'Unambiguous (That branchName)) ->
|
Right (ProjectAndBranchNames'Unambiguous (That branchName)) ->
|
||||||
handleBranchesComplete (into @Text branchName) codebase path
|
handleBranchesComplete (into @Text branchName) codebase pp
|
||||||
Right (ProjectAndBranchNames'Unambiguous (These projectName branchName)) -> do
|
Right (ProjectAndBranchNames'Unambiguous (These projectName branchName)) -> do
|
||||||
branches <-
|
branches <-
|
||||||
Codebase.runTransaction codebase do
|
Codebase.runTransaction codebase do
|
||||||
@ -3503,12 +3503,11 @@ projectAndOrBranchSuggestions config inputStr codebase _httpClient ppCtx = do
|
|||||||
Nothing -> pure []
|
Nothing -> pure []
|
||||||
Just project -> do
|
Just project -> do
|
||||||
let projectId = project ^. #projectId
|
let projectId = project ^. #projectId
|
||||||
fmap (filterBranches config path) do
|
fmap (filterBranches config pp) do
|
||||||
Queries.loadAllProjectBranchesBeginningWith projectId (Just $ into @Text branchName)
|
Queries.loadAllProjectBranchesBeginningWith projectId (Just $ into @Text branchName)
|
||||||
pure (map (projectBranchToCompletion projectName) branches)
|
pure (map (projectBranchToCompletion projectName) branches)
|
||||||
where
|
where
|
||||||
input = Text.strip . Text.pack $ inputStr
|
input = Text.strip . Text.pack $ inputStr
|
||||||
currentProjectId = ppCtx ^. (PP.ctxAsIds_ . PP.project_)
|
|
||||||
|
|
||||||
handleAmbiguousComplete ::
|
handleAmbiguousComplete ::
|
||||||
MonadIO m =>
|
MonadIO m =>
|
||||||
@ -3519,14 +3518,10 @@ projectAndOrBranchSuggestions config inputStr codebase _httpClient ppCtx = do
|
|||||||
(branches, projects) <-
|
(branches, projects) <-
|
||||||
Codebase.runTransaction codebase do
|
Codebase.runTransaction codebase do
|
||||||
branches <-
|
branches <-
|
||||||
case mayCurrentProjectId of
|
fmap (filterBranches config pp) do
|
||||||
Nothing -> pure []
|
Queries.loadAllProjectBranchesBeginningWith currentProjectId (Just input)
|
||||||
Just currentProjectId ->
|
projects <- case projectInclusion config of
|
||||||
fmap (filterBranches config path) do
|
OnlyWithinCurrentProject -> Queries.loadProject currentProjectId <&> maybeToList
|
||||||
Queries.loadAllProjectBranchesBeginningWith currentProjectId (Just input)
|
|
||||||
projects <- case (projectInclusion config, mayCurrentProjectId) of
|
|
||||||
(OnlyWithinCurrentProject, Just currentProjectId) -> Queries.loadProject currentProjectId <&> maybeToList
|
|
||||||
(OnlyWithinCurrentProject, Nothing) -> pure []
|
|
||||||
_ -> Queries.loadAllProjectsBeginningWith (Just input) <&> filterProjects
|
_ -> Queries.loadAllProjectsBeginningWith (Just input) <&> filterProjects
|
||||||
pure (branches, projects)
|
pure (branches, projects)
|
||||||
let branchCompletions = map currentProjectBranchToCompletion branches
|
let branchCompletions = map currentProjectBranchToCompletion branches
|
||||||
@ -3602,25 +3597,26 @@ projectAndOrBranchSuggestions config inputStr codebase _httpClient ppCtx = do
|
|||||||
|
|
||||||
-- Complete the text into a branch name within the provided project
|
-- Complete the text into a branch name within the provided project
|
||||||
handleBranchesComplete :: MonadIO m => Text -> Codebase m v a -> PP.ProjectPath -> m [Completion]
|
handleBranchesComplete :: MonadIO m => Text -> Codebase m v a -> PP.ProjectPath -> m [Completion]
|
||||||
handleBranchesComplete branchName codebase ppCtx = do
|
handleBranchesComplete branchName codebase pp = do
|
||||||
let projId = ppCtx ^. PP.ctxAsIds_ . PP.project_
|
let projId = pp ^. PP.asIds_ . #project
|
||||||
branches <-
|
branches <-
|
||||||
Codebase.runTransaction codebase do
|
Codebase.runTransaction codebase do
|
||||||
fmap (filterBranches config path) do
|
fmap (filterBranches config pp) do
|
||||||
Queries.loadAllProjectBranchesBeginningWith projId (Just branchName)
|
Queries.loadAllProjectBranchesBeginningWith projId (Just branchName)
|
||||||
pure (map currentProjectBranchToCompletion branches)
|
pure (map currentProjectBranchToCompletion branches)
|
||||||
|
|
||||||
filterProjects :: [Sqlite.Project] -> [Sqlite.Project]
|
filterProjects :: [Sqlite.Project] -> [Sqlite.Project]
|
||||||
filterProjects projects =
|
filterProjects projects =
|
||||||
case (mayCurrentProjectId, projectInclusion config) of
|
case (projectInclusion config) of
|
||||||
(_, AllProjects) -> projects
|
AllProjects -> projects
|
||||||
(Nothing, _) -> projects
|
OnlyOutsideCurrentProject -> projects & filter (\Sqlite.Project {projectId} -> projectId /= currentProjectId)
|
||||||
(Just currentProjId, OnlyOutsideCurrentProject) -> projects & filter (\Sqlite.Project {projectId} -> projectId /= currentProjId)
|
OnlyWithinCurrentProject ->
|
||||||
(Just currentBranchId, OnlyWithinCurrentProject) ->
|
|
||||||
projects
|
projects
|
||||||
& List.find (\Sqlite.Project {projectId} -> projectId == currentBranchId)
|
& List.find (\Sqlite.Project {projectId} -> projectId == currentProjectId)
|
||||||
& maybeToList
|
& maybeToList
|
||||||
|
|
||||||
|
PP.ProjectPath currentProjectId _currentBranchId _currentPath = pp ^. PP.asIds_
|
||||||
|
|
||||||
projectToCompletion :: Sqlite.Project -> Completion
|
projectToCompletion :: Sqlite.Project -> Completion
|
||||||
projectToCompletion project =
|
projectToCompletion project =
|
||||||
Completion
|
Completion
|
||||||
@ -3646,20 +3642,20 @@ handleBranchesComplete ::
|
|||||||
Codebase m v a ->
|
Codebase m v a ->
|
||||||
PP.ProjectPath ->
|
PP.ProjectPath ->
|
||||||
m [Completion]
|
m [Completion]
|
||||||
handleBranchesComplete config branchName codebase ppCtx = do
|
handleBranchesComplete config branchName codebase pp = do
|
||||||
branches <-
|
branches <-
|
||||||
Codebase.runTransaction codebase do
|
Codebase.runTransaction codebase do
|
||||||
fmap (filterBranches config ppCtx) do
|
fmap (filterBranches config pp) do
|
||||||
Queries.loadAllProjectBranchesBeginningWith (ppCtx ^. PP.ctxAsIds_ . PP.project_) (Just branchName)
|
Queries.loadAllProjectBranchesBeginningWith (pp ^. PP.asIds_ . #project) (Just branchName)
|
||||||
pure (map currentProjectBranchToCompletion branches)
|
pure (map currentProjectBranchToCompletion branches)
|
||||||
|
|
||||||
filterBranches :: ProjectBranchSuggestionsConfig -> PP.ProjectPath -> [(ProjectBranchId, a)] -> [(ProjectBranchId, a)]
|
filterBranches :: ProjectBranchSuggestionsConfig -> PP.ProjectPath -> [(ProjectBranchId, a)] -> [(ProjectBranchId, a)]
|
||||||
filterBranches config ppCtx branches =
|
filterBranches config pp branches =
|
||||||
case (branchInclusion config) of
|
case (branchInclusion config) of
|
||||||
AllBranches -> branches
|
AllBranches -> branches
|
||||||
ExcludeCurrentBranch -> branches & filter (\(branchId, _) -> branchId /= currentBranchId)
|
ExcludeCurrentBranch -> branches & filter (\(branchId, _) -> branchId /= currentBranchId)
|
||||||
where
|
where
|
||||||
currentBranchId = ppCtx ^. PP.ctxAsIds_ . PP.branch_
|
currentBranchId = pp ^. PP.asIds_ . #branch
|
||||||
|
|
||||||
currentProjectBranchToCompletion :: (ProjectBranchId, ProjectBranchName) -> Completion
|
currentProjectBranchToCompletion :: (ProjectBranchId, ProjectBranchName) -> Completion
|
||||||
currentProjectBranchToCompletion (_, branchName) =
|
currentProjectBranchToCompletion (_, branchName) =
|
||||||
@ -3677,20 +3673,20 @@ branchRelativePathSuggestions ::
|
|||||||
AuthenticatedHttpClient ->
|
AuthenticatedHttpClient ->
|
||||||
PP.ProjectPath ->
|
PP.ProjectPath ->
|
||||||
m [Line.Completion]
|
m [Line.Completion]
|
||||||
branchRelativePathSuggestions config inputStr codebase _httpClient ppCtx = do
|
branchRelativePathSuggestions config inputStr codebase _httpClient pp = do
|
||||||
case parseIncrementalBranchRelativePath inputStr of
|
case parseIncrementalBranchRelativePath inputStr of
|
||||||
Left _ -> pure []
|
Left _ -> pure []
|
||||||
Right ibrp -> case ibrp of
|
Right ibrp -> case ibrp of
|
||||||
BranchRelativePath.ProjectOrPath' _txt _path -> do
|
BranchRelativePath.ProjectOrPath' _txt _path -> do
|
||||||
namespaceSuggestions <- Codebase.runTransaction codebase (prefixCompleteNamespace inputStr currentPath)
|
namespaceSuggestions <- Codebase.runTransaction codebase (prefixCompleteNamespace inputStr pp)
|
||||||
projectSuggestions <- projectNameSuggestions WithSlash inputStr codebase
|
projectSuggestions <- projectNameSuggestions WithSlash inputStr codebase
|
||||||
pure (namespaceSuggestions ++ projectSuggestions)
|
pure (namespaceSuggestions ++ projectSuggestions)
|
||||||
BranchRelativePath.OnlyPath' _path ->
|
BranchRelativePath.OnlyPath' _path ->
|
||||||
Codebase.runTransaction codebase (prefixCompleteNamespace inputStr currentPath)
|
Codebase.runTransaction codebase (prefixCompleteNamespace inputStr pp)
|
||||||
BranchRelativePath.IncompleteProject _proj ->
|
BranchRelativePath.IncompleteProject _proj ->
|
||||||
projectNameSuggestions WithSlash inputStr codebase
|
projectNameSuggestions WithSlash inputStr codebase
|
||||||
BranchRelativePath.IncompleteBranch mproj mbranch -> case mproj of
|
BranchRelativePath.IncompleteBranch mproj mbranch -> case mproj of
|
||||||
Nothing -> map suffixPathSep <$> handleBranchesComplete config (maybe "" into mbranch) codebase ppCtx
|
Nothing -> map suffixPathSep <$> handleBranchesComplete config (maybe "" into mbranch) codebase pp
|
||||||
Just projectName -> do
|
Just projectName -> do
|
||||||
branches <-
|
branches <-
|
||||||
Codebase.runTransaction codebase do
|
Codebase.runTransaction codebase do
|
||||||
@ -3698,18 +3694,16 @@ branchRelativePathSuggestions config inputStr codebase _httpClient ppCtx = do
|
|||||||
Nothing -> pure []
|
Nothing -> pure []
|
||||||
Just project -> do
|
Just project -> do
|
||||||
let projectId = project ^. #projectId
|
let projectId = project ^. #projectId
|
||||||
fmap (filterBranches config ppCtx) do
|
fmap (filterBranches config pp) do
|
||||||
Queries.loadAllProjectBranchesBeginningWith projectId (into @Text <$> mbranch)
|
Queries.loadAllProjectBranchesBeginningWith projectId (into @Text <$> mbranch)
|
||||||
pure (map (projectBranchToCompletionWithSep projectName) branches)
|
pure (map (projectBranchToCompletionWithSep projectName) branches)
|
||||||
BranchRelativePath.PathRelativeToCurrentBranch relPath -> Codebase.runTransaction codebase do
|
BranchRelativePath.PathRelativeToCurrentBranch relPath -> Codebase.runTransaction codebase do
|
||||||
-- TODO: Verify this works as intendid
|
-- TODO: Verify this works as intendid
|
||||||
map prefixPathSep <$> prefixCompleteNamespace (Path.convert relPath) mempty
|
map prefixPathSep <$> prefixCompleteNamespace (Path.convert relPath) pp
|
||||||
BranchRelativePath.IncompletePath projStuff mpath -> do
|
BranchRelativePath.IncompletePath projStuff mpath -> do
|
||||||
Codebase.runTransaction codebase do
|
Codebase.runTransaction codebase do
|
||||||
map (addBranchPrefix projStuff) <$> prefixCompleteNamespace (maybe "" Path.convert mpath) ppCtx
|
map (addBranchPrefix projStuff) <$> prefixCompleteNamespace (maybe "" Path.convert mpath) pp
|
||||||
where
|
where
|
||||||
currentPath = ppCtx ^. PP.absPath_
|
|
||||||
|
|
||||||
projectBranchToCompletionWithSep :: ProjectName -> (ProjectBranchId, ProjectBranchName) -> Completion
|
projectBranchToCompletionWithSep :: ProjectName -> (ProjectBranchId, ProjectBranchName) -> Completion
|
||||||
projectBranchToCompletionWithSep projectName (_, branchName) =
|
projectBranchToCompletionWithSep projectName (_, branchName) =
|
||||||
Completion
|
Completion
|
||||||
|
@ -83,7 +83,7 @@ getUserInput codebase authHTTPClient ppCtx currentProjectRoot numberedArgs =
|
|||||||
Just a -> pure a
|
Just a -> pure a
|
||||||
go :: Line.InputT IO Input
|
go :: Line.InputT IO Input
|
||||||
go = do
|
go = do
|
||||||
let (PP.ProjectPath projectName projectBranchName path) = ppCtx ^. PP.ctxAsNames_
|
let (PP.ProjectPath projectName projectBranchName path) = ppCtx ^. PP.asNames_
|
||||||
let promptString =
|
let promptString =
|
||||||
P.sep
|
P.sep
|
||||||
":"
|
":"
|
||||||
|
@ -45,7 +45,6 @@ import Unison.Auth.Types qualified as Auth
|
|||||||
import Unison.Builtin.Decls qualified as DD
|
import Unison.Builtin.Decls qualified as DD
|
||||||
import Unison.Cli.MergeTypes (MergeSourceAndTarget (..))
|
import Unison.Cli.MergeTypes (MergeSourceAndTarget (..))
|
||||||
import Unison.Cli.Pretty
|
import Unison.Cli.Pretty
|
||||||
import Unison.Cli.ProjectUtils qualified as ProjectUtils
|
|
||||||
import Unison.Cli.ServantClientUtils qualified as ServantClientUtils
|
import Unison.Cli.ServantClientUtils qualified as ServantClientUtils
|
||||||
import Unison.Codebase.Editor.DisplayObject (DisplayObject (..))
|
import Unison.Codebase.Editor.DisplayObject (DisplayObject (..))
|
||||||
import Unison.Codebase.Editor.Input qualified as Input
|
import Unison.Codebase.Editor.Input qualified as Input
|
||||||
@ -455,7 +454,7 @@ notifyNumbered = \case
|
|||||||
)
|
)
|
||||||
where
|
where
|
||||||
switch = IP.makeExample IP.projectSwitch
|
switch = IP.makeExample IP.projectSwitch
|
||||||
AmbiguousReset sourceOfAmbiguity (ProjectAndBranch pn0 bn0, path) (ProjectAndBranch currentProject branch) ->
|
AmbiguousReset sourceOfAmbiguity (ProjectAndBranch _pn0 _bn0, path) (ProjectAndBranch currentProject branch) ->
|
||||||
( P.wrap
|
( P.wrap
|
||||||
( openingLine
|
( openingLine
|
||||||
<> prettyProjectAndBranchName (ProjectAndBranch currentProject branch)
|
<> prettyProjectAndBranchName (ProjectAndBranch currentProject branch)
|
||||||
@ -495,7 +494,7 @@ notifyNumbered = \case
|
|||||||
E.AmbiguousReset'Target -> \xs -> "<some hash>" : xs
|
E.AmbiguousReset'Target -> \xs -> "<some hash>" : xs
|
||||||
reset = IP.makeExample IP.reset
|
reset = IP.makeExample IP.reset
|
||||||
relPath0 = prettyPath path
|
relPath0 = prettyPath path
|
||||||
absPath0 = review ProjectUtils.projectBranchPathPrism (ProjectAndBranch (pn0 ^. #projectId) (bn0 ^. #branchId), path)
|
absPath0 = Path.Absolute path
|
||||||
ListNamespaceDependencies _ppe _path Empty -> ("This namespace has no external dependencies.", mempty)
|
ListNamespaceDependencies _ppe _path Empty -> ("This namespace has no external dependencies.", mempty)
|
||||||
ListNamespaceDependencies ppe path' externalDependencies ->
|
ListNamespaceDependencies ppe path' externalDependencies ->
|
||||||
( P.column2Header (P.hiBlack "External dependency") ("Dependents in " <> prettyAbsolute path') $
|
( P.column2Header (P.hiBlack "External dependency") ("Dependents in " <> prettyAbsolute path') $
|
||||||
@ -910,7 +909,7 @@ notifyUser dir = \case
|
|||||||
prettyProjectAndBranchName projectAndBranch <> "is empty. There is nothing to push."
|
prettyProjectAndBranchName projectAndBranch <> "is empty. There is nothing to push."
|
||||||
CreatedNewBranch path ->
|
CreatedNewBranch path ->
|
||||||
pure $
|
pure $
|
||||||
"☝️ The namespace " <> prettyAbsoluteStripProject path <> " is empty."
|
"☝️ The namespace " <> prettyAbsolute path <> " is empty."
|
||||||
-- RenameOutput rootPath oldName newName r -> do
|
-- RenameOutput rootPath oldName newName r -> do
|
||||||
-- nameChange "rename" "renamed" oldName newName r
|
-- nameChange "rename" "renamed" oldName newName r
|
||||||
-- AliasOutput rootPath existingName newName r -> do
|
-- AliasOutput rootPath existingName newName r -> do
|
||||||
|
@ -239,7 +239,7 @@ data DefinitionReference
|
|||||||
data Service
|
data Service
|
||||||
= LooseCodeUI Path.Absolute (Maybe DefinitionReference)
|
= LooseCodeUI Path.Absolute (Maybe DefinitionReference)
|
||||||
| -- (Project branch names, perspective within project, definition reference)
|
| -- (Project branch names, perspective within project, definition reference)
|
||||||
ProjectBranchUI (ProjectAndBranch ProjectName ProjectBranchName) Path.Path (Maybe DefinitionReference)
|
ProjectBranchUI (ProjectAndBranch ProjectName ProjectBranchName) Path.Absolute (Maybe DefinitionReference)
|
||||||
| Api
|
| Api
|
||||||
deriving stock (Show)
|
deriving stock (Show)
|
||||||
|
|
||||||
@ -299,13 +299,13 @@ urlFor :: Service -> BaseUrl -> Text
|
|||||||
urlFor service baseUrl =
|
urlFor service baseUrl =
|
||||||
case service of
|
case service of
|
||||||
LooseCodeUI perspective def ->
|
LooseCodeUI perspective def ->
|
||||||
tShow baseUrl <> "/" <> toUrlPath ([DontEscape "ui", DontEscape "non-project-code"] <> path (Path.unabsolute perspective) def)
|
tShow baseUrl <> "/" <> toUrlPath ([DontEscape "ui", DontEscape "non-project-code"] <> path perspective def)
|
||||||
ProjectBranchUI (ProjectAndBranch projectName branchName) perspective def ->
|
ProjectBranchUI (ProjectAndBranch projectName branchName) perspective def ->
|
||||||
tShow baseUrl <> "/" <> toUrlPath ([DontEscape "ui", DontEscape "projects", DontEscape $ into @Text projectName, DontEscape $ into @Text branchName] <> path perspective def)
|
tShow baseUrl <> "/" <> toUrlPath ([DontEscape "ui", DontEscape "projects", DontEscape $ into @Text projectName, DontEscape $ into @Text branchName] <> path perspective def)
|
||||||
Api -> tShow baseUrl <> "/" <> toUrlPath [DontEscape "api"]
|
Api -> tShow baseUrl <> "/" <> toUrlPath [DontEscape "api"]
|
||||||
where
|
where
|
||||||
path :: Path.Path -> Maybe DefinitionReference -> [URISegment]
|
path :: Path.Absolute -> Maybe DefinitionReference -> [URISegment]
|
||||||
path ns def =
|
path (Path.Absolute ns) def =
|
||||||
let nsPath = namespacePath ns
|
let nsPath = namespacePath ns
|
||||||
in case definitionPath def of
|
in case definitionPath def of
|
||||||
Just defPath -> case nsPath of
|
Just defPath -> case nsPath of
|
||||||
|
Loading…
Reference in New Issue
Block a user