diff --git a/parser-typechecker/src/Unison/Codebase.hs b/parser-typechecker/src/Unison/Codebase.hs index b02dd2749..629988421 100644 --- a/parser-typechecker/src/Unison/Codebase.hs +++ b/parser-typechecker/src/Unison/Codebase.hs @@ -50,7 +50,7 @@ module Unison.Codebase getShallowCausalAtPath, getBranchAtPath, Operations.expectCausalBranchByCausalHash, - getShallowCausalFromRoot, + getShallowCausalAtPathFromRootHash, getShallowRootBranch, getShallowRootCausal, getShallowProjectRootBranch, @@ -184,15 +184,13 @@ runTransactionWithRollback :: runTransactionWithRollback Codebase {withConnection} action = withConnection \conn -> Sqlite.runTransactionWithRollback conn action -getShallowCausalFromRoot :: - -- Optional root branch, if Nothing use the codebase's root branch. - Maybe CausalHash -> +getShallowCausalAtPathFromRootHash :: + -- Causal to start at, if Nothing use the codebase's root branch. + CausalHash -> Path.Path -> Sqlite.Transaction (V2Branch.CausalBranch Sqlite.Transaction) -getShallowCausalFromRoot mayRootHash p = do - rootCausal <- case mayRootHash of - Nothing -> getShallowRootCausal - Just ch -> Operations.expectCausalBranchByCausalHash ch +getShallowCausalAtPathFromRootHash rootCausalHash p = do + rootCausal <- Operations.expectCausalBranchByCausalHash rootCausalHash getShallowCausalAtPath p (Just rootCausal) -- | 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 getShallowBranchAtPath p childBranch -getShallowProjectRootBranch :: Db.ProjectId -> Db.ProjectBranchId -> Sqlite.Transaction (V2Branch.Branch Sqlite.Transaction) -getShallowProjectRootBranch projectId projectBranchId = do - ProjectBranch {causalHashId} <- Q.expectProjectBranch projectId projectBranchId +getShallowProjectRootBranch :: ProjectBranch -> Sqlite.Transaction (V2Branch.Branch Sqlite.Transaction) +getShallowProjectRootBranch ProjectBranch {causalHashId} = do causalHash <- Q.expectCausalHash causalHashId Operations.expectCausalBranchByCausalHash causalHash >>= V2Causal.value -- | Recursively descend into causals following the given path, -- Use the root causal if none is provided. getShallowBranchAtProjectPath :: - PP.ProjectPathIds -> + PP.ProjectPath -> Sqlite.Transaction (V2Branch.Branch Sqlite.Transaction) -getShallowBranchAtProjectPath (PP.ProjectPath projectId projectBranchId path) = do - projectRootBranch <- getShallowProjectRootBranch projectId projectBranchId +getShallowBranchAtProjectPath (PP.ProjectPath _project projectBranch path) = do + projectRootBranch <- getShallowProjectRootBranch projectBranch getShallowBranchAtPath (Path.unabsolute path) projectRootBranch getShallowProjectRootByNames :: ProjectAndBranch ProjectName ProjectBranchName -> Sqlite.Transaction (Maybe (V2Branch.CausalBranch Sqlite.Transaction)) diff --git a/parser-typechecker/src/Unison/Codebase/ProjectPath.hs b/parser-typechecker/src/Unison/Codebase/ProjectPath.hs index a11b7ccd2..dc6497fd1 100644 --- a/parser-typechecker/src/Unison/Codebase/ProjectPath.hs +++ b/parser-typechecker/src/Unison/Codebase/ProjectPath.hs @@ -11,8 +11,6 @@ module Unison.Codebase.ProjectPath asIds_, asNames_, asProjectAndBranch_, - project_, - branch_, ) where @@ -27,11 +25,11 @@ import Unison.Prelude import Unison.Project (ProjectAndBranch (..), ProjectBranchName, ProjectName) data ProjectPathG proj branch = ProjectPath - { projPathProject :: proj, - projPathBranch :: branch, - projPathPath :: Path.Absolute + { project :: proj, + branch :: branch, + absPath :: Path.Absolute } - deriving stock (Eq, Ord, Show) + deriving stock (Eq, Ord, Show, Generic) type ProjectPathIds = ProjectPathG ProjectId ProjectBranchId @@ -42,18 +40,6 @@ type ProjectPath = ProjectPathG Project ProjectBranch fromProjectAndBranch :: ProjectAndBranch Project ProjectBranch -> Path.Absolute -> ProjectPath 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 asIds_ :: Lens' ProjectPath ProjectPathIds asIds_ = lens get set @@ -61,8 +47,8 @@ asIds_ = lens get set get (ProjectPath proj branch path) = ProjectPath (proj ^. #projectId) (branch ^. #branchId) path set p (ProjectPath pId bId path) = p - & project_ . #projectId .~ pId - & branch_ . #branchId .~ bId + & #project . #projectId .~ pId + & #branch . #branchId .~ bId & absPath_ .~ path -- | 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 set p (ProjectPath pName bName path) = p - & project_ . #name .~ pName - & branch_ . #name .~ bName + & #project . #name .~ pName + & #branch . #name .~ bName & absPath_ .~ path asProjectAndBranch_ :: Lens' ProjectPath (ProjectAndBranch Project ProjectBranch) asProjectAndBranch_ = lens get set where 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 bimap f g (ProjectPath p b path) = ProjectPath (f p) (g b) path diff --git a/unison-cli/src/Unison/Cli/MonadUtils.hs b/unison-cli/src/Unison/Cli/MonadUtils.hs index 6eb5a755f..29661ee6a 100644 --- a/unison-cli/src/Unison/Cli/MonadUtils.hs +++ b/unison-cli/src/Unison/Cli/MonadUtils.hs @@ -8,7 +8,7 @@ module Unison.Cli.MonadUtils getCurrentPath, getCurrentProjectName, getCurrentProjectBranchName, - getProjectPath, + getCurrentProjectPath, resolvePath, resolvePath', resolveSplit', @@ -95,8 +95,6 @@ import U.Codebase.Branch qualified as V2 (Branch) import U.Codebase.Branch qualified as V2Branch import U.Codebase.Causal qualified as V2Causal 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 Unison.Cli.Monad (Cli) import Unison.Cli.Monad qualified as Cli @@ -146,28 +144,28 @@ getConfig key = do ------------------------------------------------------------------------------------------------------------------------ -- Getting paths, path resolution, etc. -getProjectPath :: Cli PP.ProjectPath -getProjectPath = do +getCurrentProjectPath :: Cli PP.ProjectPath +getCurrentProjectPath = do (PP.ProjectPath projId branchId path) <- Cli.getProjectPathIds -- 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 branch <- MaybeT $ Q.loadProjectBranch projId branchId 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. getCurrentPath :: Cli Path.Absolute getCurrentPath = do - view PP.absPath_ <$> getProjectPath + view PP.absPath_ <$> getCurrentProjectPath getCurrentProjectName :: Cli ProjectName getCurrentProjectName = do - view (PP.ctxAsNames_ . PP.project_) <$> getProjectPath + view (PP.asNames_ . #project) <$> getCurrentProjectPath getCurrentProjectBranchName :: Cli ProjectBranchName 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. resolvePath :: Path -> Cli Path.Absolute diff --git a/unison-cli/src/Unison/Cli/ProjectUtils.hs b/unison-cli/src/Unison/Cli/ProjectUtils.hs index 6ed7ff03e..8d9b66c15 100644 --- a/unison-cli/src/Unison/Cli/ProjectUtils.hs +++ b/unison-cli/src/Unison/Cli/ProjectUtils.hs @@ -13,8 +13,6 @@ module Unison.Cli.ProjectUtils expectProjectAndBranchByIds, getProjectAndBranchByTheseNames, expectProjectAndBranchByTheseNames, - getCurrentProject, - getCurrentProjectBranch, -- * Loading remote project info expectRemoteProjectById, @@ -40,7 +38,6 @@ import Data.These (These (..)) import U.Codebase.Sqlite.DbId import U.Codebase.Sqlite.Project (Project) 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 Queries import Unison.Cli.Monad (Cli) @@ -66,13 +63,13 @@ resolveBranchRelativePath brp = do case brp of BranchPathInCurrentProject projBranchName path -> do projectAndBranch <- expectProjectAndBranchByTheseNames (That projBranchName) - pure $ PP.ctxFromProjectAndBranch projectAndBranch path + pure $ PP.fromProjectAndBranch projectAndBranch path QualifiedBranchPath projName projBranchName path -> do projectAndBranch <- expectProjectAndBranchByTheseNames (These projName projBranchName) - pure $ PP.ctxFromProjectAndBranch projectAndBranch path + pure $ PP.fromProjectAndBranch projectAndBranch path UnqualifiedPath newPath' -> do - ppCtx <- Cli.getProjectPath - pure $ ppCtx & PP.absPath_ %~ \curPath -> Path.resolve curPath newPath' + pp <- Cli.getCurrentProjectPath + pure $ pp & PP.absPath_ %~ \curPath -> Path.resolve curPath newPath' -- @findTemporaryBranchName projectId preferred@ finds some unused branch name in @projectId@ with a name -- like @preferred@. @@ -95,20 +92,6 @@ findTemporaryBranchName projectId preferred = do 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 project branchName = Cli.runTransaction (Queries.loadProjectBranchByName (project ^. #projectId) branchName) & onNothingM do @@ -124,8 +107,8 @@ hydrateNames :: These ProjectName ProjectBranchName -> Cli (ProjectAndBranch Pro hydrateNames = \case This projectName -> pure (ProjectAndBranch projectName (unsafeFrom @Text "main")) That branchName -> do - ppCtx <- Cli.getProjectPath - pure (ProjectAndBranch (ppCtx ^. PP.ctxAsNames_ . PP.project_) branchName) + pp <- Cli.getCurrentProjectPath + pure (ProjectAndBranch (pp ^. PP.asNames_ . #project) branchName) These projectName branchName -> pure (ProjectAndBranch projectName branchName) -- Expect a local project+branch by ids. @@ -147,9 +130,9 @@ getProjectAndBranchByTheseNames :: getProjectAndBranchByTheseNames = \case This projectName -> getProjectAndBranchByTheseNames (These projectName (unsafeFrom @Text "main")) That branchName -> runMaybeT do - currentProjectBranch <- lift getCurrentProjectBranch - branch <- MaybeT (Cli.runTransaction (Queries.loadProjectBranchByName (currentProjectBranch ^. PP.project_ . #projectId) branchName)) - pure (ProjectAndBranch (currentProjectBranch ^. PP.project_) branch) + (PP.ProjectPath proj _branch _path) <- lift Cli.getCurrentProjectPath + branch <- MaybeT (Cli.runTransaction (Queries.loadProjectBranchByName (proj ^. #projectId) branchName)) + pure (ProjectAndBranch proj branch) These projectName branchName -> do Cli.runTransaction do runMaybeT do @@ -167,7 +150,7 @@ expectProjectAndBranchByTheseNames :: expectProjectAndBranchByTheseNames = \case This projectName -> expectProjectAndBranchByTheseNames (These projectName (unsafeFrom @Text "main")) That branchName -> do - PP.ProjectPath project _branch _restPath <- getCurrentProjectBranch + PP.ProjectPath project _branch _restPath <- Cli.getCurrentProjectPath branch <- Cli.runTransaction (Queries.loadProjectBranchByName (project ^. #projectId) branchName) & onNothingM do 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 -- project, defaulting to 'main' if branch is unspecified. -- 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 ppCtx mayProjAndBranch mayPath' = do - projAndBranch <- resolveProjectBranch ppCtx mayProjAndBranch +resolveProjectPath :: Project -> ProjectAndBranch (Maybe ProjectName) (Maybe ProjectBranchName) -> Maybe Path' -> Cli PP.ProjectPath +resolveProjectPath defaultProj mayProjAndBranch mayPath' = do + projAndBranch <- resolveProjectBranch defaultProj mayProjAndBranch 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: -- -- 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 -- project, defaulting to 'main' if branch is unspecified. -resolveProjectBranch :: ProjectAndBranch Project ProjectBranch -> ProjectAndBranch (Maybe ProjectName) (Maybe ProjectBranchName) -> Cli (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch) -resolveProjectBranch ppCtx (ProjectAndBranch mayProjectName mayBranchName) = do +resolveProjectBranch :: Project -> ProjectAndBranch (Maybe ProjectName) (Maybe ProjectBranchName) -> Cli (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch) +resolveProjectBranch defaultProj (ProjectAndBranch mayProjectName mayBranchName) = do 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) pure projectAndBranch @@ -289,7 +272,7 @@ expectRemoteProjectBranchByTheseNames includeSquashed = \case let remoteBranchName = unsafeFrom @Text "main" expectRemoteProjectBranchByName includeSquashed (ProjectAndBranch (remoteProjectId, remoteProjectName) remoteBranchName) That branchName -> do - PP.ProjectPath localProject localBranch _restPath <- getCurrentProjectBranch + PP.ProjectPath localProject localBranch _restPath <- Cli.getCurrentProjectPath let localProjectId = localProject ^. #projectId let localBranchId = localBranch ^. #branchId Cli.runTransaction (Queries.loadRemoteProjectBranch localProjectId Share.hardCodedUri localBranchId) >>= \case diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Branch.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Branch.hs index 8df791dec..1393ce8ff 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Branch.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Branch.hs @@ -18,10 +18,8 @@ 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 qualified as Branch (headHash) import Unison.Codebase.Editor.Input qualified as Input import Unison.Codebase.Editor.Output qualified as Output -import Unison.Codebase.Path qualified as Path import Unison.Codebase.ProjectPath qualified as PP import Unison.Prelude import Unison.Project (ProjectAndBranch (..), ProjectBranchName, ProjectBranchNameKind (..), ProjectName, classifyProjectBranchName) @@ -41,7 +39,7 @@ handleBranch sourceI projectAndBranchNames@(ProjectAndBranch mayProjectName newB Cli.returnEarly (Output.CannotCreateReleaseBranchWithBranchCommand newBranchName ver) ProjectBranchNameKind'NothingSpecial -> pure () - currentProjectName <- Cli.getProjectPath <&> view (PP.ctxAsNames_ . PP.project_) + currentProjectName <- Cli.getCurrentProjectPath <&> view (PP.asNames_ . #project) destProject <- do Cli.runTransactionWithRollback \rollback -> do @@ -51,22 +49,21 @@ handleBranch sourceI projectAndBranchNames@(ProjectAndBranch mayProjectName newB rollback (Output.LocalProjectBranchDoesntExist (ProjectAndBranch projectName newBranchName)) -- Compute what we should create the branch from. - maySrcBranch <- + maySrcProjectAndBranch <- 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'UnresolvedProjectBranch unresolvedProjectBranch -> do - ppCtx <- Cli.getProjectPath - ProjectAndBranch _proj branch <- ProjectUtils.resolveProjectBranch ppCtx (unresolvedProjectBranch & #branch %~ Just) - pure $ Just branch + pp <- Cli.getCurrentProjectPath + Just <$> ProjectUtils.resolveProjectBranch (pp ^. #project) (unresolvedProjectBranch & #branch %~ Just) - _ <- doCreateBranch maySrcBranch project newBranchName + _ <- doCreateBranch (view #branch <$> maySrcProjectAndBranch) destProject newBranchName Cli.respond $ Output.CreatedProjectBranch - ( case maySrcBranch of + ( case maySrcProjectAndBranch of Just sourceBranch -> - if sourceBranch ^. #project . #projectId == project ^. #projectId + if sourceBranch ^. #project . #projectId == destProject ^. #projectId then Output.CreatedProjectBranchFrom'ParentBranch (sourceBranch ^. #branch . #name) else Output.CreatedProjectBranchFrom'OtherBranch sourceBranch Nothing -> Output.CreatedProjectBranchFrom'Nothingness @@ -86,7 +83,7 @@ doCreateBranch :: -- If no parent branch is provided, make an empty branch. Maybe Sqlite.ProjectBranch -> Sqlite.Project -> - Sqlite.Transaction ProjectBranchName -> + ProjectBranchName -> Cli ProjectBranchId doCreateBranch mayParentBranch project getNewBranchName = do let projectId = project ^. #projectId diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/UI.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/UI.hs index 85ce5922f..9a6c5dcb3 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/UI.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/UI.hs @@ -21,6 +21,7 @@ import Unison.Cli.ProjectUtils qualified as Project import Unison.Codebase (Codebase) import Unison.Codebase qualified as Codebase import Unison.Codebase.Path qualified as Path +import Unison.Codebase.ProjectPath qualified as PP import Unison.Codebase.SqliteCodebase.Conversions qualified as Conversions import Unison.ConstructorType qualified as ConstructorType import Unison.HashQualified qualified as HQ @@ -28,8 +29,7 @@ import Unison.Name (Name) import Unison.Name qualified as Name import Unison.Parser.Ann (Ann (..)) import Unison.Prelude -import Unison.Project (ProjectAndBranch) -import Unison.Project.Util (projectBranchPath) +import Unison.Project (ProjectAndBranch (ProjectAndBranch)) import Unison.Referent qualified as Referent import Unison.Server.CodebaseServer qualified as Server import Unison.Sqlite qualified as Sqlite @@ -39,37 +39,25 @@ import Web.Browser (openBrowser) openUI :: Path.Path' -> Cli () openUI path' = do Cli.Env {serverBaseUrl} <- ask - currentPath <- Cli.getCurrentPath - let absPath = Path.resolve currentPath path' + defnPath <- Cli.resolvePath' path' + pp <- Cli.getCurrentProjectPath whenJust serverBaseUrl \url -> do - Project.getProjectBranchForPath absPath >>= \case - Nothing -> openUIForLooseCode url path' - Just (projectBranch, pathWithinBranch) -> openUIForProject url projectBranch pathWithinBranch + openUIForProject url pp defnPath -openUIForProject :: Server.BaseUrl -> ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch -> Path.Path -> Cli () -openUIForProject url projectAndBranch pathFromProjectRoot = 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 +openUIForProject :: Server.BaseUrl -> PP.ProjectPath -> Path.Absolute -> Cli () +openUIForProject url (PP.ProjectPath project projectBranch perspective) defnPath = do 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 pure () where - pathToBranchFromCodebaseRoot :: Path.Absolute - pathToBranchFromCodebaseRoot = projectBranchPath (bimap Project.projectId ProjectBranch.branchId projectAndBranch) -- 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 Cli.Env {codebase} <- lift ask - let absPathToDefinition = Path.unabsolute $ Path.resolve pathToBranchFromCodebaseRoot (Path.Relative pathFromProjectRoot) - (pathToDefinitionNamespace, _nameSeg) <- hoistMaybe $ Lens.unsnoc absPathToDefinition - namespaceBranch <- lift $ Cli.runTransaction (Codebase.getShallowBranchAtPath pathToDefinitionNamespace Nothing) + (pathToDefinitionNamespace, _nameSeg) <- hoistMaybe $ Lens.unsnoc defnPath + let defnNamespaceProjectPath = pp & PP.absPath_ .~ pathToDefinitionNamespace + namespaceBranch <- lift . Cli.runTransaction $ Codebase.getShallowBranchAtProjectPath defnNamespaceProjectPath fqn <- hoistMaybe $ do pathFromPerspective <- List.stripPrefix (Path.toList perspective) (Path.toList pathFromProjectRoot) Path.toName . Path.fromList $ pathFromPerspective diff --git a/unison-cli/src/Unison/CommandLine/Completion.hs b/unison-cli/src/Unison/CommandLine/Completion.hs index bd0cf9c0e..7249aea28 100644 --- a/unison-cli/src/Unison/CommandLine/Completion.hs +++ b/unison-cli/src/Unison/CommandLine/Completion.hs @@ -101,7 +101,7 @@ noCompletions :: String -> Codebase m v a -> AuthenticatedHttpClient -> - Path.Absolute -> + PP.ProjectPath -> m [System.Console.Haskeline.Completion.Completion] noCompletions _ _ _ _ = pure [] @@ -145,7 +145,7 @@ completeWithinNamespace :: Sqlite.Transaction [System.Console.Haskeline.Completion.Completion] completeWithinNamespace compTypes query ppCtx = do shortHashLen <- Codebase.hashLength - b <- Codebase.getShallowBranchAtProjectPath (queryProjectPath ^. PP.ctxAsIds_) + b <- Codebase.getShallowBranchAtProjectPath (queryProjectPath ^. PP.asIds_) currentBranchSuggestions <- do nib <- namesInBranch shortHashLen b nib diff --git a/unison-cli/src/Unison/CommandLine/FZFResolvers.hs b/unison-cli/src/Unison/CommandLine/FZFResolvers.hs index 2d3b8a821..704fdc2b3 100644 --- a/unison-cli/src/Unison/CommandLine/FZFResolvers.hs +++ b/unison-cli/src/Unison/CommandLine/FZFResolvers.hs @@ -177,7 +177,7 @@ projectBranchOptions codebase _projCtx _searchBranch0 = do -- E.g. '@unison/base/main' projectBranchOptionsWithinCurrentProject :: OptionFetcher 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) -- | Exported from here just so the debug command and actual implementation can use the same diff --git a/unison-cli/src/Unison/CommandLine/InputPatterns.hs b/unison-cli/src/Unison/CommandLine/InputPatterns.hs index 45208c254..93f8f58e1 100644 --- a/unison-cli/src/Unison/CommandLine/InputPatterns.hs +++ b/unison-cli/src/Unison/CommandLine/InputPatterns.hs @@ -147,7 +147,7 @@ module Unison.CommandLine.InputPatterns ) where -import Control.Lens ((^.)) +import Control.Lens ((.~), (^.)) import Control.Lens.Cons qualified as Cons import Data.List (intercalate) import Data.List.Extra qualified as List @@ -1840,7 +1840,7 @@ mergeOldSquashInputPattern = [src, dest] -> do src <- parseUnresolvedProjectBranch src dest <- parseUnresolvedProjectBranch dest - Just $ Input.MergeLocalBranchI src dest Branch.SquashMerge + Just $ Input.MergeLocalBranchI src (Just dest) Branch.SquashMerge _ -> Nothing } where @@ -3349,7 +3349,7 @@ namespaceOrProjectBranchArg config = ArgumentType { typeName = "namespace or branch", 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 [ projectAndOrBranchSuggestions config, namespaceSuggestions @@ -3375,8 +3375,8 @@ dependencyArg :: ArgumentType dependencyArg = ArgumentType { typeName = "project dependency", - suggestions = \q cb _http p -> Codebase.runTransaction cb do - prefixCompleteNamespace q (p Path.:> NameSegment.libSegment), + suggestions = \q cb _http pp -> Codebase.runTransaction cb do + prefixCompleteNamespace q (pp & PP.path_ .~ Path.singleton NameSegment.libSegment), fzfResolver = Just Resolvers.projectDependencyResolver } @@ -3464,12 +3464,12 @@ projectAndOrBranchSuggestions :: AuthenticatedHttpClient -> ProjectPath -> m [Line.Completion] -projectAndOrBranchSuggestions config inputStr codebase _httpClient ppCtx = do +projectAndOrBranchSuggestions config inputStr codebase _httpClient pp = do case Text.uncons input of -- Things like "/foo" would be parsed as unambiguous branches in the logic below, except we also want to -- handle "/" and "/@" 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. - Just ('/', input1) -> handleBranchesComplete input1 codebase path + Just ('/', input1) -> handleBranchesComplete input1 codebase pp _ -> case tryInto @ProjectAndBranchNames input of -- 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 [] Just project -> do let projectId = project ^. #projectId - fmap (filterBranches config path) do + fmap (filterBranches config pp) do Queries.loadAllProjectBranchesBeginningWith projectId Nothing pure (map (projectBranchToCompletion projectName) branches) -- This branch is probably dead due to intercepting inputs that begin with "/" above Right (ProjectAndBranchNames'Unambiguous (That branchName)) -> - handleBranchesComplete (into @Text branchName) codebase path + handleBranchesComplete (into @Text branchName) codebase pp Right (ProjectAndBranchNames'Unambiguous (These projectName branchName)) -> do branches <- Codebase.runTransaction codebase do @@ -3503,12 +3503,11 @@ projectAndOrBranchSuggestions config inputStr codebase _httpClient ppCtx = do Nothing -> pure [] Just project -> do let projectId = project ^. #projectId - fmap (filterBranches config path) do + fmap (filterBranches config pp) do Queries.loadAllProjectBranchesBeginningWith projectId (Just $ into @Text branchName) pure (map (projectBranchToCompletion projectName) branches) where input = Text.strip . Text.pack $ inputStr - currentProjectId = ppCtx ^. (PP.ctxAsIds_ . PP.project_) handleAmbiguousComplete :: MonadIO m => @@ -3519,14 +3518,10 @@ projectAndOrBranchSuggestions config inputStr codebase _httpClient ppCtx = do (branches, projects) <- Codebase.runTransaction codebase do branches <- - case mayCurrentProjectId of - Nothing -> pure [] - Just currentProjectId -> - fmap (filterBranches config path) do - Queries.loadAllProjectBranchesBeginningWith currentProjectId (Just input) - projects <- case (projectInclusion config, mayCurrentProjectId) of - (OnlyWithinCurrentProject, Just currentProjectId) -> Queries.loadProject currentProjectId <&> maybeToList - (OnlyWithinCurrentProject, Nothing) -> pure [] + fmap (filterBranches config pp) do + Queries.loadAllProjectBranchesBeginningWith currentProjectId (Just input) + projects <- case projectInclusion config of + OnlyWithinCurrentProject -> Queries.loadProject currentProjectId <&> maybeToList _ -> Queries.loadAllProjectsBeginningWith (Just input) <&> filterProjects pure (branches, projects) 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 handleBranchesComplete :: MonadIO m => Text -> Codebase m v a -> PP.ProjectPath -> m [Completion] - handleBranchesComplete branchName codebase ppCtx = do - let projId = ppCtx ^. PP.ctxAsIds_ . PP.project_ + handleBranchesComplete branchName codebase pp = do + let projId = pp ^. PP.asIds_ . #project branches <- Codebase.runTransaction codebase do - fmap (filterBranches config path) do + fmap (filterBranches config pp) do Queries.loadAllProjectBranchesBeginningWith projId (Just branchName) pure (map currentProjectBranchToCompletion branches) filterProjects :: [Sqlite.Project] -> [Sqlite.Project] filterProjects projects = - case (mayCurrentProjectId, projectInclusion config) of - (_, AllProjects) -> projects - (Nothing, _) -> projects - (Just currentProjId, OnlyOutsideCurrentProject) -> projects & filter (\Sqlite.Project {projectId} -> projectId /= currentProjId) - (Just currentBranchId, OnlyWithinCurrentProject) -> + case (projectInclusion config) of + AllProjects -> projects + OnlyOutsideCurrentProject -> projects & filter (\Sqlite.Project {projectId} -> projectId /= currentProjectId) + OnlyWithinCurrentProject -> projects - & List.find (\Sqlite.Project {projectId} -> projectId == currentBranchId) + & List.find (\Sqlite.Project {projectId} -> projectId == currentProjectId) & maybeToList + PP.ProjectPath currentProjectId _currentBranchId _currentPath = pp ^. PP.asIds_ + projectToCompletion :: Sqlite.Project -> Completion projectToCompletion project = Completion @@ -3646,20 +3642,20 @@ handleBranchesComplete :: Codebase m v a -> PP.ProjectPath -> m [Completion] -handleBranchesComplete config branchName codebase ppCtx = do +handleBranchesComplete config branchName codebase pp = do branches <- Codebase.runTransaction codebase do - fmap (filterBranches config ppCtx) do - Queries.loadAllProjectBranchesBeginningWith (ppCtx ^. PP.ctxAsIds_ . PP.project_) (Just branchName) + fmap (filterBranches config pp) do + Queries.loadAllProjectBranchesBeginningWith (pp ^. PP.asIds_ . #project) (Just branchName) pure (map currentProjectBranchToCompletion branches) filterBranches :: ProjectBranchSuggestionsConfig -> PP.ProjectPath -> [(ProjectBranchId, a)] -> [(ProjectBranchId, a)] -filterBranches config ppCtx branches = +filterBranches config pp branches = case (branchInclusion config) of AllBranches -> branches ExcludeCurrentBranch -> branches & filter (\(branchId, _) -> branchId /= currentBranchId) where - currentBranchId = ppCtx ^. PP.ctxAsIds_ . PP.branch_ + currentBranchId = pp ^. PP.asIds_ . #branch currentProjectBranchToCompletion :: (ProjectBranchId, ProjectBranchName) -> Completion currentProjectBranchToCompletion (_, branchName) = @@ -3677,20 +3673,20 @@ branchRelativePathSuggestions :: AuthenticatedHttpClient -> PP.ProjectPath -> m [Line.Completion] -branchRelativePathSuggestions config inputStr codebase _httpClient ppCtx = do +branchRelativePathSuggestions config inputStr codebase _httpClient pp = do case parseIncrementalBranchRelativePath inputStr of Left _ -> pure [] Right ibrp -> case ibrp of BranchRelativePath.ProjectOrPath' _txt _path -> do - namespaceSuggestions <- Codebase.runTransaction codebase (prefixCompleteNamespace inputStr currentPath) + namespaceSuggestions <- Codebase.runTransaction codebase (prefixCompleteNamespace inputStr pp) projectSuggestions <- projectNameSuggestions WithSlash inputStr codebase pure (namespaceSuggestions ++ projectSuggestions) BranchRelativePath.OnlyPath' _path -> - Codebase.runTransaction codebase (prefixCompleteNamespace inputStr currentPath) + Codebase.runTransaction codebase (prefixCompleteNamespace inputStr pp) BranchRelativePath.IncompleteProject _proj -> projectNameSuggestions WithSlash inputStr codebase 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 branches <- Codebase.runTransaction codebase do @@ -3698,18 +3694,16 @@ branchRelativePathSuggestions config inputStr codebase _httpClient ppCtx = do Nothing -> pure [] Just project -> do let projectId = project ^. #projectId - fmap (filterBranches config ppCtx) do + fmap (filterBranches config pp) do Queries.loadAllProjectBranchesBeginningWith projectId (into @Text <$> mbranch) pure (map (projectBranchToCompletionWithSep projectName) branches) BranchRelativePath.PathRelativeToCurrentBranch relPath -> Codebase.runTransaction codebase do -- 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 Codebase.runTransaction codebase do - map (addBranchPrefix projStuff) <$> prefixCompleteNamespace (maybe "" Path.convert mpath) ppCtx + map (addBranchPrefix projStuff) <$> prefixCompleteNamespace (maybe "" Path.convert mpath) pp where - currentPath = ppCtx ^. PP.absPath_ - projectBranchToCompletionWithSep :: ProjectName -> (ProjectBranchId, ProjectBranchName) -> Completion projectBranchToCompletionWithSep projectName (_, branchName) = Completion diff --git a/unison-cli/src/Unison/CommandLine/Main.hs b/unison-cli/src/Unison/CommandLine/Main.hs index 0d43f1cd9..78873f0d6 100644 --- a/unison-cli/src/Unison/CommandLine/Main.hs +++ b/unison-cli/src/Unison/CommandLine/Main.hs @@ -83,7 +83,7 @@ getUserInput codebase authHTTPClient ppCtx currentProjectRoot numberedArgs = Just a -> pure a go :: Line.InputT IO Input go = do - let (PP.ProjectPath projectName projectBranchName path) = ppCtx ^. PP.ctxAsNames_ + let (PP.ProjectPath projectName projectBranchName path) = ppCtx ^. PP.asNames_ let promptString = P.sep ":" diff --git a/unison-cli/src/Unison/CommandLine/OutputMessages.hs b/unison-cli/src/Unison/CommandLine/OutputMessages.hs index b3d0e4990..08777b6c9 100644 --- a/unison-cli/src/Unison/CommandLine/OutputMessages.hs +++ b/unison-cli/src/Unison/CommandLine/OutputMessages.hs @@ -45,7 +45,6 @@ import Unison.Auth.Types qualified as Auth import Unison.Builtin.Decls qualified as DD import Unison.Cli.MergeTypes (MergeSourceAndTarget (..)) import Unison.Cli.Pretty -import Unison.Cli.ProjectUtils qualified as ProjectUtils import Unison.Cli.ServantClientUtils qualified as ServantClientUtils import Unison.Codebase.Editor.DisplayObject (DisplayObject (..)) import Unison.Codebase.Editor.Input qualified as Input @@ -455,7 +454,7 @@ notifyNumbered = \case ) where 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 ( openingLine <> prettyProjectAndBranchName (ProjectAndBranch currentProject branch) @@ -495,7 +494,7 @@ notifyNumbered = \case E.AmbiguousReset'Target -> \xs -> "" : xs reset = IP.makeExample IP.reset 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' externalDependencies -> ( 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." CreatedNewBranch path -> pure $ - "☝️ The namespace " <> prettyAbsoluteStripProject path <> " is empty." + "☝️ The namespace " <> prettyAbsolute path <> " is empty." -- RenameOutput rootPath oldName newName r -> do -- nameChange "rename" "renamed" oldName newName r -- AliasOutput rootPath existingName newName r -> do diff --git a/unison-share-api/src/Unison/Server/CodebaseServer.hs b/unison-share-api/src/Unison/Server/CodebaseServer.hs index 6ad9c77e6..f634360db 100644 --- a/unison-share-api/src/Unison/Server/CodebaseServer.hs +++ b/unison-share-api/src/Unison/Server/CodebaseServer.hs @@ -239,7 +239,7 @@ data DefinitionReference data Service = LooseCodeUI Path.Absolute (Maybe DefinitionReference) | -- (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 deriving stock (Show) @@ -299,13 +299,13 @@ urlFor :: Service -> BaseUrl -> Text urlFor service baseUrl = case service of 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 -> tShow baseUrl <> "/" <> toUrlPath ([DontEscape "ui", DontEscape "projects", DontEscape $ into @Text projectName, DontEscape $ into @Text branchName] <> path perspective def) Api -> tShow baseUrl <> "/" <> toUrlPath [DontEscape "api"] where - path :: Path.Path -> Maybe DefinitionReference -> [URISegment] - path ns def = + path :: Path.Absolute -> Maybe DefinitionReference -> [URISegment] + path (Path.Absolute ns) def = let nsPath = namespacePath ns in case definitionPath def of Just defPath -> case nsPath of