From 8c30267c1a14a680c51460deda1b4a65f2a6dc2d Mon Sep 17 00:00:00 2001 From: Travis Staton Date: Fri, 19 Jan 2024 14:29:39 -0500 Subject: [PATCH 1/2] add parseIncrementalBranchRelativePath --- .../Unison/CommandLine/BranchRelativePath.hs | 179 ++++++++++++++---- unison-core/src/Unison/Project.hs | 2 + 2 files changed, 148 insertions(+), 33 deletions(-) diff --git a/unison-cli/src/Unison/CommandLine/BranchRelativePath.hs b/unison-cli/src/Unison/CommandLine/BranchRelativePath.hs index cbdfb3403f..626e5507fd 100644 --- a/unison-cli/src/Unison/CommandLine/BranchRelativePath.hs +++ b/unison-cli/src/Unison/CommandLine/BranchRelativePath.hs @@ -3,11 +3,12 @@ module Unison.CommandLine.BranchRelativePath parseBranchRelativePath, branchRelativePathParser, ResolvedBranchRelativePath (..), + parseIncrementalBranchRelativePath, + IncrementalBranchRelativePath (..), ) where import Control.Lens (view) -import Data.Char (isSpace) import Data.Set qualified as Set import Data.Text qualified as Text import Data.These (These (..)) @@ -19,7 +20,7 @@ import U.Codebase.Sqlite.ProjectBranch qualified as Sqlite import Unison.Codebase.Path qualified as Path import Unison.Codebase.Path.Parse qualified as Path import Unison.Prelude -import Unison.Project (ProjectBranchName, ProjectBranchSpecifier (..), ProjectName) +import Unison.Project (ProjectAndBranch (..), ProjectBranchName, ProjectName) import Unison.Project qualified as Project import Unison.Util.ColorText qualified as CT import Unison.Util.Pretty qualified as P @@ -78,12 +79,12 @@ instance From BranchRelativePath Text where Right (projName, branchName) -> into @Text (These projName branchName) data ResolvedBranchRelativePath - = ResolvedBranchRelative (Project.ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch) (Maybe Path.Relative) + = ResolvedBranchRelative (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch) (Maybe Path.Relative) | ResolvedLoosePath Path.Absolute instance From ResolvedBranchRelativePath BranchRelativePath where from = \case - ResolvedBranchRelative (Project.ProjectAndBranch proj branch) mRel -> case mRel of + ResolvedBranchRelative (ProjectAndBranch proj branch) mRel -> case mRel of Nothing -> BranchRelative (This (Right (view #name proj, view #name branch))) Just rel -> BranchRelative (These (Right (view #name proj, view #name branch)) rel) ResolvedLoosePath p -> LoosePath (Path.absoluteToPath' p) @@ -91,45 +92,157 @@ instance From ResolvedBranchRelativePath BranchRelativePath where instance From ResolvedBranchRelativePath Text where from = from . into @BranchRelativePath -branchRelativePathParser :: Megaparsec.Parsec Void Text BranchRelativePath -branchRelativePathParser = +data IncrementalBranchRelativePath + = -- | no dots, slashes, or colons + ProjectOrRelative Text Path.Path' + | -- | dots, no slashes or colons + LooseCode Path.Path' + | -- | valid project/branch, no colon + IncompleteBranch (Maybe ProjectName) (Maybe ProjectBranchName) + | -- | valid project/branch, with colon + IncompletePath (Either (ProjectAndBranch ProjectName ProjectBranchName) ProjectBranchName) (Maybe Path.Relative) + | PathRelativeToCurrentBranch Path.Relative + deriving stock (Show) + +-- | +-- >>> parseIncrementalBranchRelativePath "foo" +-- Right (ProjectOrRelative "foo" foo) +-- +-- >>> parseIncrementalBranchRelativePath "foo/bar:" +-- Right (IncompletePath (Left (ProjectAndBranch {project = UnsafeProjectName "foo", branch = UnsafeProjectBranchName "bar"})) Nothing) +-- +-- >>> parseIncrementalBranchRelativePath "foo/bar:some.path" +-- Right (IncompletePath (Left (ProjectAndBranch {project = UnsafeProjectName "foo", branch = UnsafeProjectBranchName "bar"})) (Just some.path)) +-- +-- >>> parseIncrementalBranchRelativePath "/bar:some.path" +-- Right (IncompletePath (Right (UnsafeProjectBranchName "bar")) (Just some.path)) +-- +-- >>> parseIncrementalBranchRelativePath ":some.path" +-- Right (PathRelativeToCurrentBranch some.path) +parseIncrementalBranchRelativePath :: String -> Either (P.Pretty CT.ColorText) IncrementalBranchRelativePath +parseIncrementalBranchRelativePath str = + case Megaparsec.parse incrementalBranchRelativePathParser "" (Text.pack str) of + Left e -> Left (P.string (Megaparsec.errorBundlePretty e)) + Right x -> Right x + +incrementalBranchRelativePathParser :: Megaparsec.Parsec Void Text IncrementalBranchRelativePath +incrementalBranchRelativePathParser = asum - [ LoosePath <$> path', - BranchRelative <$> branchRelative + [ projectName, + startingAtSlash Nothing, + pathRelativeToCurrentBranch ] where - branchRelative :: Megaparsec.Parsec Void Text (These (Either ProjectBranchName (ProjectName, ProjectBranchName)) Path.Relative) - branchRelative = asum [fullPath, currentBranchRootPath] + projectName = do + -- Attempt to parse a project name from the string prefix, or a + -- Path' cosuming the entire string, switch based on if we + -- unambiguously parse one or the other. + parseThese Project.projectNameParser path' >>= \case + -- project name parser consumed the slash + This (_, (projectName, True)) -> + startingAtBranch (Just projectName) + -- project name parser did not consume a slash + -- + -- Either we are at the end of input or the next character + -- is not a slash, so we have invalid input + This (_, (projectName, False)) -> + let end = do + Megaparsec.eof + pure (IncompleteBranch (Just projectName) Nothing) + in end <|> startingAtSlash (Just projectName) + -- The string doesn't parse as a project name but does parse as a path + That (_, path) -> pure (LooseCode path) + -- The string parses both as a project name and a path + These _ (_, path) -> ProjectOrRelative <$> Megaparsec.takeRest <*> pure path - path' = Megaparsec.try do - offset <- Megaparsec.getOffset - pathStr <- Megaparsec.takeWhile1P (Just "path char") (not . isSpace) - case Path.parsePath' (Text.unpack pathStr) of - Left err -> failureAt offset err - Right x -> pure x + startingAtBranch :: Maybe ProjectName -> Megaparsec.Parsec Void Text IncrementalBranchRelativePath + startingAtBranch mproj = do + mbranch <- optionalBranch + case mproj of + Nothing -> do + case mbranch of + Nothing -> pure (IncompleteBranch Nothing Nothing) + Just branch -> startingAtColon (Right branch) + Just proj -> + case mbranch of + Nothing -> pure (IncompleteBranch (Just proj) Nothing) + Just branch -> + startingAtColon (Left (ProjectAndBranch proj branch)) + <|> pure (IncompleteBranch (Just proj) (Just branch)) + + startingAtSlash :: + Maybe ProjectName -> + Megaparsec.Parsec Void Text IncrementalBranchRelativePath + startingAtSlash mproj = Megaparsec.char '/' *> startingAtBranch mproj + + startingAtColon :: + (Either (ProjectAndBranch ProjectName ProjectBranchName) ProjectBranchName) -> + Megaparsec.Parsec Void Text IncrementalBranchRelativePath + startingAtColon projStuff = do + _ <- Megaparsec.char ':' + p <- optionalEof relPath + pure (IncompletePath projStuff p) + + pathRelativeToCurrentBranch :: Megaparsec.Parsec Void Text IncrementalBranchRelativePath + pathRelativeToCurrentBranch = do + _ <- Megaparsec.char ':' + p <- relPath + pure (PathRelativeToCurrentBranch p) + + optionalEof :: Megaparsec.Parsec Void Text a -> Megaparsec.Parsec Void Text (Maybe a) + optionalEof pa = Just <$> pa <|> Nothing <$ Megaparsec.eof + + optionalBranch :: Megaparsec.Parsec Void Text (Maybe ProjectBranchName) + optionalBranch = optionalEof branchNameParser + + branchNameParser = Project.projectBranchNameParser False relPath = do offset <- Megaparsec.getOffset path' >>= \(Path.Path' inner) -> case inner of Left _ -> failureAt offset "Expected a relative path but found an absolute path" Right x -> pure x - - fullPath = do - projectAndBranchNames <- do - projectBranch <- Project.projectAndBranchNamesParser ProjectBranchSpecifier'Name - offset <- Megaparsec.getOffset - _ <- Megaparsec.char ':' - case projectBranch of - This _ -> failureAt offset "Expected a project and branch before the colon (e.g. project/branch:a.path)" - That pbn -> pure (Left pbn) - These pn pbn -> pure (Right (pn, pbn)) - optional relPath <&> \case - Nothing -> This projectAndBranchNames - Just rp -> These projectAndBranchNames rp - - currentBranchRootPath = do - _ <- Megaparsec.char ':' - That <$> relPath + path' = Megaparsec.try do + offset <- Megaparsec.getOffset + pathStr <- Megaparsec.takeRest + case Path.parsePath' (Text.unpack pathStr) of + Left err -> failureAt offset err + Right x -> pure x failureAt :: forall a. Int -> String -> Megaparsec.Parsec Void Text a failureAt offset str = Megaparsec.parseError (Megaparsec.FancyError offset (Set.singleton (Megaparsec.ErrorFail str))) + + parseThese :: + forall a b. + Megaparsec.Parsec Void Text a -> + Megaparsec.Parsec Void Text b -> + Megaparsec.Parsec Void Text (These (Int, a) (Int, b)) + parseThese pa pb = do + ea <- Megaparsec.observing $ Megaparsec.lookAhead $ Megaparsec.try $ first Text.length <$> Megaparsec.match pa + eb <- Megaparsec.observing $ Megaparsec.lookAhead $ Megaparsec.try $ first Text.length <$> Megaparsec.match pb + case (ea, eb) of + (Left aerr, Left berr) -> + Megaparsec.parseError (aerr <> berr) + (Left _, Right (blen, b)) -> do + Megaparsec.takeP Nothing blen + pure (That (blen, b)) + (Right (alen, a), Left _) -> do + Megaparsec.takeP Nothing alen + pure (This (alen, a)) + (Right a, Right b) -> pure (These a b) + +branchRelativePathParser :: Megaparsec.Parsec Void Text BranchRelativePath +branchRelativePathParser = + incrementalBranchRelativePathParser >>= \case + ProjectOrRelative _txt path -> pure (LoosePath path) + LooseCode path -> pure (LoosePath path) + IncompleteBranch _mproj _mbranch -> fail "Branch relative paths require a colon. Expected `:` here." + PathRelativeToCurrentBranch p -> pure (BranchRelative (That p)) + IncompletePath projStuff mpath -> + case projStuff of + Left (ProjectAndBranch projName branchName) -> case mpath of + Nothing -> pure (BranchRelative (This (Right (projName, branchName)))) + Just path -> pure (BranchRelative (These (Right (projName, branchName)) path)) + Right branch -> case mpath of + Nothing -> pure (BranchRelative (This (Left branch))) + Just path -> pure (BranchRelative (These (Left branch) path)) diff --git a/unison-core/src/Unison/Project.hs b/unison-core/src/Unison/Project.hs index bd0186b141..155b4a2be7 100644 --- a/unison-core/src/Unison/Project.hs +++ b/unison-core/src/Unison/Project.hs @@ -18,6 +18,8 @@ module Unison.Project projectAndBranchNamesParser, ProjectAndBranchNames (..), projectAndBranchNamesParser2, + projectNameParser, + projectBranchNameParser, -- ** Semver Semver (..), From 973469ae05bef7e3232ee4276ee71399a2abaae8 Mon Sep 17 00:00:00 2001 From: Travis Staton Date: Wed, 24 Jan 2024 12:27:36 -0500 Subject: [PATCH 2/2] tab-complete branch relative paths --- .../Unison/CommandLine/BranchRelativePath.hs | 38 +-- .../src/Unison/CommandLine/InputPatterns.hs | 258 ++++++++++++++---- 2 files changed, 232 insertions(+), 64 deletions(-) diff --git a/unison-cli/src/Unison/CommandLine/BranchRelativePath.hs b/unison-cli/src/Unison/CommandLine/BranchRelativePath.hs index 626e5507fd..59326deef9 100644 --- a/unison-cli/src/Unison/CommandLine/BranchRelativePath.hs +++ b/unison-cli/src/Unison/CommandLine/BranchRelativePath.hs @@ -97,7 +97,9 @@ data IncrementalBranchRelativePath ProjectOrRelative Text Path.Path' | -- | dots, no slashes or colons LooseCode Path.Path' - | -- | valid project/branch, no colon + | -- | valid project, no slash + IncompleteProject ProjectName + | -- | valid project/branch, slash, no colon IncompleteBranch (Maybe ProjectName) (Maybe ProjectBranchName) | -- | valid project/branch, with colon IncompletePath (Either (ProjectAndBranch ProjectName ProjectBranchName) ProjectBranchName) (Maybe Path.Relative) @@ -119,6 +121,12 @@ data IncrementalBranchRelativePath -- -- >>> parseIncrementalBranchRelativePath ":some.path" -- Right (PathRelativeToCurrentBranch some.path) +-- +-- >>> parseIncrementalBranchRelativePath "/branch" +-- Right (IncompleteBranch Nothing (Just (UnsafeProjectBranchName "branch"))) +-- +-- >>> parseIncrementalBranchRelativePath "/" +-- Right (IncompleteBranch Nothing Nothing) parseIncrementalBranchRelativePath :: String -> Either (P.Pretty CT.ColorText) IncrementalBranchRelativePath parseIncrementalBranchRelativePath str = case Megaparsec.parse incrementalBranchRelativePathParser "" (Text.pack str) of @@ -128,9 +136,9 @@ parseIncrementalBranchRelativePath str = incrementalBranchRelativePathParser :: Megaparsec.Parsec Void Text IncrementalBranchRelativePath incrementalBranchRelativePathParser = asum - [ projectName, - startingAtSlash Nothing, - pathRelativeToCurrentBranch + [ startingAtSlash Nothing, + pathRelativeToCurrentBranch, + projectName ] where projectName = do @@ -148,7 +156,7 @@ incrementalBranchRelativePathParser = This (_, (projectName, False)) -> let end = do Megaparsec.eof - pure (IncompleteBranch (Just projectName) Nothing) + pure (IncompleteProject projectName) in end <|> startingAtSlash (Just projectName) -- The string doesn't parse as a project name but does parse as a path That (_, path) -> pure (LooseCode path) @@ -156,19 +164,12 @@ incrementalBranchRelativePathParser = These _ (_, path) -> ProjectOrRelative <$> Megaparsec.takeRest <*> pure path startingAtBranch :: Maybe ProjectName -> Megaparsec.Parsec Void Text IncrementalBranchRelativePath - startingAtBranch mproj = do - mbranch <- optionalBranch - case mproj of - Nothing -> do - case mbranch of - Nothing -> pure (IncompleteBranch Nothing Nothing) - Just branch -> startingAtColon (Right branch) - Just proj -> - case mbranch of - Nothing -> pure (IncompleteBranch (Just proj) Nothing) - Just branch -> - startingAtColon (Left (ProjectAndBranch proj branch)) - <|> pure (IncompleteBranch (Just proj) (Just branch)) + startingAtBranch mproj = + optionalBranch >>= \case + Nothing -> pure (IncompleteBranch mproj Nothing) + Just branch -> + startingAtColon (maybe (Right branch) (\proj -> Left (ProjectAndBranch proj branch)) mproj) + <|> pure (IncompleteBranch mproj (Just branch)) startingAtSlash :: Maybe ProjectName -> @@ -236,6 +237,7 @@ branchRelativePathParser = incrementalBranchRelativePathParser >>= \case ProjectOrRelative _txt path -> pure (LoosePath path) LooseCode path -> pure (LoosePath path) + IncompleteProject _proj -> fail "Branch relative paths require a branch. Expected `/` here." IncompleteBranch _mproj _mbranch -> fail "Branch relative paths require a colon. Expected `:` here." PathRelativeToCurrentBranch p -> pure (BranchRelative (That p)) IncompletePath projStuff mpath -> diff --git a/unison-cli/src/Unison/CommandLine/InputPatterns.hs b/unison-cli/src/Unison/CommandLine/InputPatterns.hs index d92377e331..61260818a9 100644 --- a/unison-cli/src/Unison/CommandLine/InputPatterns.hs +++ b/unison-cli/src/Unison/CommandLine/InputPatterns.hs @@ -4,7 +4,7 @@ module Unison.CommandLine.InputPatterns where -import Control.Lens (preview, (^.)) +import Control.Lens (preview, review, (^.)) import Control.Lens.Cons qualified as Cons import Data.List (intercalate) import Data.List.Extra qualified as List @@ -24,7 +24,7 @@ import U.Codebase.Sqlite.DbId (ProjectBranchId, ProjectId) import U.Codebase.Sqlite.Project qualified as Sqlite import U.Codebase.Sqlite.Queries qualified as Queries import Unison.Auth.HTTPClient (AuthenticatedHttpClient) -import Unison.Cli.Pretty (prettyProjectName, prettyProjectNameSlash, prettySlashProjectBranchName, prettyURI) +import Unison.Cli.Pretty (prettyProjectAndBranchName, prettyProjectName, prettyProjectNameSlash, prettySlashProjectBranchName, prettyURI) import Unison.Cli.ProjectUtils qualified as ProjectUtils import Unison.Codebase (Codebase) import Unison.Codebase qualified as Codebase @@ -45,7 +45,8 @@ import Unison.Codebase.SyncMode qualified as SyncMode import Unison.Codebase.Verbosity (Verbosity) import Unison.Codebase.Verbosity qualified as Verbosity import Unison.CommandLine -import Unison.CommandLine.BranchRelativePath (parseBranchRelativePath) +import Unison.CommandLine.BranchRelativePath (parseBranchRelativePath, parseIncrementalBranchRelativePath) +import Unison.CommandLine.BranchRelativePath qualified as BranchRelativePath import Unison.CommandLine.Completion import Unison.CommandLine.FZFResolvers qualified as Resolvers import Unison.CommandLine.InputPattern (ArgumentType (..), InputPattern (InputPattern), IsOptional (..), unionSuggestions) @@ -1171,8 +1172,8 @@ forkLocal = "fork" ["copy.namespace"] I.Visible - [ ("namespace", Required, namespaceArg), - ("new location", Required, newNameArg) + [ ("source location", Required, branchRelativePathArg), + ("dest location", Required, branchRelativePathArg) ] ( P.wrapColumn2 [ ( makeExample forkLocal ["src", "dest"], @@ -3340,7 +3341,7 @@ projectAndOrBranchSuggestions config inputStr codebase _httpClient path = do Nothing -> pure [] Just project -> do let projectId = project ^. #projectId - fmap filterBranches do + fmap (filterBranches config path) do Queries.loadAllProjectBranchesBeginningWith projectId Nothing pure (map (projectBranchToCompletion projectName) branches) -- This branch is probably dead due to intercepting inputs that begin with "/" above @@ -3353,13 +3354,13 @@ projectAndOrBranchSuggestions config inputStr codebase _httpClient path = do Nothing -> pure [] Just project -> do let projectId = project ^. #projectId - fmap filterBranches do + fmap (filterBranches config path) do Queries.loadAllProjectBranchesBeginningWith projectId (Just $ into @Text branchName) pure (map (projectBranchToCompletion projectName) branches) where input = Text.strip . Text.pack $ inputStr - (mayCurrentProjectId, mayCurrentBranchId) = case projectContextFromPath path of + (mayCurrentProjectId, _mayCurrentBranchId) = case projectContextFromPath path of LooseCodePath {} -> (Nothing, Nothing) ProjectBranchPath projectId branchId _ -> (Just projectId, Just branchId) @@ -3375,7 +3376,7 @@ projectAndOrBranchSuggestions config inputStr codebase _httpClient path = do case mayCurrentProjectId of Nothing -> pure [] Just currentProjectId -> - fmap filterBranches do + fmap (filterBranches config path) do Queries.loadAllProjectBranchesBeginningWith currentProjectId (Just input) projects <- case (projectInclusion config, mayCurrentProjectId) of (OnlyWithinCurrentProject, Just currentProjectId) -> Queries.loadProject currentProjectId <&> maybeToList @@ -3460,17 +3461,10 @@ projectAndOrBranchSuggestions config inputStr codebase _httpClient path = do Nothing -> pure [] Just (ProjectAndBranch currentProjectId _, _) -> Codebase.runTransaction codebase do - fmap filterBranches do + fmap (filterBranches config path) do Queries.loadAllProjectBranchesBeginningWith currentProjectId (Just branchName) pure (map currentProjectBranchToCompletion branches) - filterBranches :: [(ProjectBranchId, a)] -> [(ProjectBranchId, a)] - filterBranches branches = - case (mayCurrentBranchId, branchInclusion config) of - (_, AllBranches) -> branches - (Nothing, _) -> branches - (Just currentBranchId, ExcludeCurrentBranch) -> branches & filter (\(branchId, _) -> branchId /= currentBranchId) - filterProjects :: [Sqlite.Project] -> [Sqlite.Project] filterProjects projects = case (mayCurrentProjectId, projectInclusion config) of @@ -3482,31 +3476,169 @@ projectAndOrBranchSuggestions config inputStr codebase _httpClient path = do & List.find (\Sqlite.Project {projectId} -> projectId == currentBranchId) & maybeToList - currentProjectBranchToCompletion :: (ProjectBranchId, ProjectBranchName) -> Completion - currentProjectBranchToCompletion (_, branchName) = +projectToCompletion :: Sqlite.Project -> Completion +projectToCompletion project = + Completion + { replacement = stringProjectName, + display = P.toAnsiUnbroken (prettyProjectNameSlash (project ^. #name)), + isFinished = False + } + where + stringProjectName = Text.unpack (into @Text (project ^. #name) <> "/") + +projectBranchToCompletion :: ProjectName -> (ProjectBranchId, ProjectBranchName) -> Completion +projectBranchToCompletion projectName (_, branchName) = + Completion + { replacement = Text.unpack (into @Text (ProjectAndBranch projectName branchName)), + display = P.toAnsiUnbroken (prettySlashProjectBranchName branchName), + isFinished = False + } + +handleBranchesComplete :: + MonadIO m => + ProjectBranchSuggestionsConfig -> + Text -> + Codebase m v a -> + Path.Absolute -> + m [Completion] +handleBranchesComplete config branchName codebase path = do + branches <- + case preview ProjectUtils.projectBranchPathPrism path of + Nothing -> pure [] + Just (ProjectAndBranch currentProjectId _, _) -> + Codebase.runTransaction codebase do + fmap (filterBranches config path) do + Queries.loadAllProjectBranchesBeginningWith currentProjectId (Just branchName) + pure (map currentProjectBranchToCompletion branches) + +filterBranches :: ProjectBranchSuggestionsConfig -> Path.Absolute -> [(ProjectBranchId, a)] -> [(ProjectBranchId, a)] +filterBranches config path branches = + case (mayCurrentBranchId, branchInclusion config) of + (_, AllBranches) -> branches + (Nothing, _) -> branches + (Just currentBranchId, ExcludeCurrentBranch) -> branches & filter (\(branchId, _) -> branchId /= currentBranchId) + where + (_mayCurrentProjectId, mayCurrentBranchId) = case projectContextFromPath path of + LooseCodePath {} -> (Nothing, Nothing) + ProjectBranchPath projectId branchId _ -> (Just projectId, Just branchId) + +currentProjectBranchToCompletion :: (ProjectBranchId, ProjectBranchName) -> Completion +currentProjectBranchToCompletion (_, branchName) = + Completion + { replacement = '/' : Text.unpack (into @Text branchName), + display = P.toAnsiUnbroken (prettySlashProjectBranchName branchName), + isFinished = False + } + +branchRelativePathSuggestions :: + MonadIO m => + ProjectBranchSuggestionsConfig -> + String -> + Codebase m v a -> + AuthenticatedHttpClient -> + Path.Absolute -> -- Current path + m [Line.Completion] +branchRelativePathSuggestions config inputStr codebase _httpClient currentPath = do + case parseIncrementalBranchRelativePath inputStr of + Left _ -> pure [] + Right ibrp -> case ibrp of + BranchRelativePath.ProjectOrRelative _txt _path -> do + namespaceSuggestions <- Codebase.runTransaction codebase (prefixCompleteNamespace inputStr currentPath) + projectSuggestions <- projectNameSuggestions WithSlash inputStr codebase + pure (namespaceSuggestions ++ projectSuggestions) + BranchRelativePath.LooseCode _path -> + Codebase.runTransaction codebase (prefixCompleteNamespace inputStr currentPath) + BranchRelativePath.IncompleteProject _proj -> + projectNameSuggestions WithSlash inputStr codebase + BranchRelativePath.IncompleteBranch mproj mbranch -> case mproj of + Nothing -> map suffixPathSep <$> handleBranchesComplete config (maybe "" into mbranch) codebase currentPath + Just projectName -> do + branches <- + Codebase.runTransaction codebase do + Queries.loadProjectByName projectName >>= \case + Nothing -> pure [] + Just project -> do + let projectId = project ^. #projectId + fmap (filterBranches config currentPath) do + Queries.loadAllProjectBranchesBeginningWith projectId (into @Text <$> mbranch) + pure (map (projectBranchToCompletionWithSep projectName) branches) + BranchRelativePath.PathRelativeToCurrentBranch relPath -> Codebase.runTransaction codebase do + mprojectBranch <- runMaybeT do + (projectId, branchId) <- MaybeT (pure $ (,) <$> mayCurrentProjectId <*> mayCurrentBranchId) + MaybeT (Queries.loadProjectBranch projectId branchId) + case mprojectBranch of + Nothing -> pure [] + Just projectBranch -> do + let branchPath = review ProjectUtils.projectBranchPathPrism (projectAndBranch, mempty) + projectAndBranch = ProjectAndBranch (projectBranch ^. #projectId) (projectBranch ^. #branchId) + map prefixPathSep <$> prefixCompleteNamespace (Path.convert relPath) branchPath + BranchRelativePath.IncompletePath projStuff mpath -> do + Codebase.runTransaction codebase do + mprojectBranch <- runMaybeT do + case projStuff of + Left names@(ProjectAndBranch projectName branchName) -> do + (,Left names) <$> MaybeT (Queries.loadProjectBranchByNames projectName branchName) + Right branchName -> do + currentProjectId <- MaybeT (pure mayCurrentProjectId) + projectBranch <- MaybeT (Queries.loadProjectBranchByName currentProjectId branchName) + pure (projectBranch, Right (projectBranch ^. #name)) + case mprojectBranch of + Nothing -> pure [] + Just (projectBranch, prefix) -> do + let branchPath = review ProjectUtils.projectBranchPathPrism (projectAndBranch, mempty) + projectAndBranch = ProjectAndBranch (projectBranch ^. #projectId) (projectBranch ^. #branchId) + map (addBranchPrefix prefix) <$> prefixCompleteNamespace (maybe "" Path.convert mpath) branchPath + where + (mayCurrentProjectId, mayCurrentBranchId) = case projectContextFromPath currentPath of + LooseCodePath {} -> (Nothing, Nothing) + ProjectBranchPath projectId branchId _ -> (Just projectId, Just branchId) + + projectBranchToCompletionWithSep :: ProjectName -> (ProjectBranchId, ProjectBranchName) -> Completion + projectBranchToCompletionWithSep projectName (_, branchName) = Completion - { replacement = '/' : Text.unpack (into @Text branchName), - display = P.toAnsiUnbroken (prettySlashProjectBranchName branchName), + { replacement = Text.unpack (into @Text (ProjectAndBranch projectName branchName) <> branchPathSep), + display = P.toAnsiUnbroken (prettySlashProjectBranchName branchName <> branchPathSepPretty), isFinished = False } - projectBranchToCompletion :: ProjectName -> (ProjectBranchId, ProjectBranchName) -> Completion - projectBranchToCompletion projectName (_, branchName) = - Completion - { replacement = Text.unpack (into @Text (ProjectAndBranch projectName branchName)), - display = P.toAnsiUnbroken (prettySlashProjectBranchName branchName), - isFinished = False + prefixPathSep :: Completion -> Completion + prefixPathSep c = + c + { Line.replacement = branchPathSep <> Line.replacement c, + Line.display = P.toAnsiUnbroken branchPathSepPretty <> Line.display c } - projectToCompletion :: Sqlite.Project -> Completion - projectToCompletion project = - Completion - { replacement = stringProjectName, - display = P.toAnsiUnbroken (prettyProjectNameSlash (project ^. #name)), - isFinished = False + suffixPathSep :: Completion -> Completion + suffixPathSep c = + c + { Line.replacement = Line.replacement c <> branchPathSep, + Line.display = Line.display c <> P.toAnsiUnbroken branchPathSepPretty } - where - stringProjectName = Text.unpack (into @Text (project ^. #name) <> "/") + + addBranchPrefix :: + Either (ProjectAndBranch ProjectName ProjectBranchName) ProjectBranchName -> + Completion -> + Completion + addBranchPrefix eproj = + let (prefixText, prefixPretty) = case eproj of + Left pb -> + ( into @Text pb, + prettyProjectAndBranchName pb + ) + Right branch -> + ( "/" <> into @Text branch, + prettySlashProjectBranchName branch + ) + in \c -> + c + { Line.replacement = Text.unpack prefixText <> branchPathSep <> Line.replacement c, + Line.display = P.toAnsiUnbroken (prefixPretty <> branchPathSepPretty) <> Line.display c + } + + branchPathSepPretty = P.hiBlack branchPathSep + + branchPathSep :: IsString s => s + branchPathSep = ":" -- | A project name, branch name, or both. projectAndBranchNamesArg :: ProjectBranchSuggestionsConfig -> ArgumentType @@ -3535,26 +3667,60 @@ projectBranchNameWithOptionalProjectNameArg = fzfResolver = Just Resolvers.projectBranchResolver } +branchRelativePathArg :: ArgumentType +branchRelativePathArg = + ArgumentType + { typeName = "branch-relative-path", + suggestions = branchRelativePathSuggestions config, + fzfResolver = Nothing + } + where + config = + ProjectBranchSuggestionsConfig + { showProjectCompletions = True, + projectInclusion = AllProjects, + branchInclusion = AllBranches + } + -- | A project name. projectNameArg :: ArgumentType projectNameArg = ArgumentType { typeName = "project-name", - suggestions = \(Text.strip . Text.pack -> input) codebase _httpClient _path -> do - projects <- - Codebase.runTransaction codebase do - Queries.loadAllProjectsBeginningWith (Just input) - pure $ map projectToCompletion projects, + suggestions = \input codebase _httpClient _path -> projectNameSuggestions NoSlash input codebase, fzfResolver = Just $ Resolvers.multiResolver [Resolvers.projectNameOptions] } + +data OptionalSlash + = WithSlash + | NoSlash + +projectNameSuggestions :: + MonadIO m => + OptionalSlash -> + String -> + Codebase m v a -> + m [Line.Completion] +projectNameSuggestions slash (Text.strip . Text.pack -> input) codebase = do + projects <- + Codebase.runTransaction codebase do + Queries.loadAllProjectsBeginningWith (Just input) + pure $ map projectToCompletion projects where projectToCompletion :: Sqlite.Project -> Completion - projectToCompletion project = - Completion - { replacement = Text.unpack (into @Text (project ^. #name)), - display = P.toAnsiUnbroken (prettyProjectName (project ^. #name)), - isFinished = False - } + projectToCompletion = + let toPretty = case slash of + NoSlash -> prettyProjectName + WithSlash -> prettyProjectNameSlash + toText project = case slash of + NoSlash -> into @Text (project ^. #name) + WithSlash -> Text.snoc (into @Text (project ^. #name)) '/' + in \project -> + Completion + { replacement = Text.unpack (toText project), + display = P.toAnsiUnbroken (toPretty (project ^. #name)), + isFinished = False + } parsePullSource :: Text -> Maybe (ReadRemoteNamespace (These ProjectName ProjectBranchNameOrLatestRelease)) parsePullSource =