Skip to content

Commit

Permalink
Merge pull request #4636 from unisonweb/travis/branch-relative-path-c…
Browse files Browse the repository at this point in the history 
…ompletion
  • Loading branch information
@aryairani
aryairani authored Jan 24, 2024
2 parents 48b9cf0 + 973469a commit 2ab2ef5
Show file tree
Hide file tree
Showing 3 changed files with 362 additions and 79 deletions.
181 changes: 148 additions & 33 deletions unison-cli/src/Unison/CommandLine/BranchRelativePath.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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 (..))
Expand All @@ -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
Expand Down Expand Up @@ -78,58 +79,172 @@ 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)

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, 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)
| 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 "/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 "<none>" (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
[ startingAtSlash Nothing,
pathRelativeToCurrentBranch,
projectName
]
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 (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)
-- 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 =
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 ->
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)
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 ->
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))
Loading

0 comments on commit 2ab2ef5

Please sign in to comment.