module Unison.CommandLine.BranchRelativePath
  ( BranchRelativePath (..),
    parseBranchRelativePath,
    branchRelativePathParser,
    parseIncrementalBranchRelativePath,
    IncrementalBranchRelativePath (..),
    toText,
  )
where

import Data.Set qualified as Set
import Data.Text qualified as Text
import Data.These (These (..))
import Text.Builder qualified
import Text.Megaparsec qualified as Megaparsec
import Text.Megaparsec.Char qualified as Megaparsec
import Unison.Codebase.Path qualified as Path
import Unison.Codebase.Path.Parse qualified as Path
import Unison.Codebase.ProjectPath (ProjectPathG (..))
import Unison.Prelude
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

data BranchRelativePath
  = -- | A path rooted at some specified branch/project
    BranchPathInCurrentProject ProjectBranchName Path.Absolute
  | QualifiedBranchPath ProjectName ProjectBranchName Path.Absolute
  | -- | A path which is relative to the user's current location.
    UnqualifiedPath Path.Path'
  deriving stock (BranchRelativePath -> BranchRelativePath -> Bool
(BranchRelativePath -> BranchRelativePath -> Bool)
-> (BranchRelativePath -> BranchRelativePath -> Bool)
-> Eq BranchRelativePath
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: BranchRelativePath -> BranchRelativePath -> Bool
== :: BranchRelativePath -> BranchRelativePath -> Bool
$c/= :: BranchRelativePath -> BranchRelativePath -> Bool
/= :: BranchRelativePath -> BranchRelativePath -> Bool
Eq, Int -> BranchRelativePath -> ShowS
[BranchRelativePath] -> ShowS
BranchRelativePath -> String
(Int -> BranchRelativePath -> ShowS)
-> (BranchRelativePath -> String)
-> ([BranchRelativePath] -> ShowS)
-> Show BranchRelativePath
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> BranchRelativePath -> ShowS
showsPrec :: Int -> BranchRelativePath -> ShowS
$cshow :: BranchRelativePath -> String
show :: BranchRelativePath -> String
$cshowList :: [BranchRelativePath] -> ShowS
showList :: [BranchRelativePath] -> ShowS
Show)

-- | Strings without colons are parsed as loose code paths. A path with a colon may specify:
-- 1. A project and branch
-- 2. Only a branch, in which case the project is assumed to be the current project
-- 3. Only a path, in which case the path is rooted at the branch root
--
-- Specifying only a project is not allowed.
--
-- >>> parseBranchRelativePath "foo"
-- Right (UnqualifiedPath foo)
-- >>> parseBranchRelativePath "foo/bar:"
-- Right (QualifiedBranchPath (UnsafeProjectName "foo") (UnsafeProjectBranchName "bar") .)
-- >>> parseBranchRelativePath "foo/bar:.some.path"
-- Right (QualifiedBranchPath (UnsafeProjectName "foo") (UnsafeProjectBranchName "bar") .some.path)
-- >>> parseBranchRelativePath "/bar:.some.path"
-- Right (BranchPathInCurrentProject (UnsafeProjectBranchName "bar") .some.path)
-- >>> parseBranchRelativePath ":.some.path"
-- Right (UnqualifiedPath .some.path)
--
-- >>> parseBranchRelativePath ".branch"
-- Right (UnqualifiedPath .branch)
parseBranchRelativePath :: String -> Either (P.Pretty CT.ColorText) BranchRelativePath
parseBranchRelativePath :: String -> Either (Pretty ColorText) BranchRelativePath
parseBranchRelativePath String
str =
  case Parsec Void Text BranchRelativePath
-> String
-> Text
-> Either (ParseErrorBundle Text Void) BranchRelativePath
forall e s a.
Parsec e s a -> String -> s -> Either (ParseErrorBundle s e) a
Megaparsec.parse Parsec Void Text BranchRelativePath
branchRelativePathParser String
"<none>" (String -> Text
Text.pack String
str) of
    Left ParseErrorBundle Text Void
e -> Pretty ColorText -> Either (Pretty ColorText) BranchRelativePath
forall a b. a -> Either a b
Left (String -> Pretty ColorText
forall s. IsString s => String -> Pretty s
P.string (ParseErrorBundle Text Void -> String
forall s e.
(VisualStream s, TraversableStream s, ShowErrorComponent e) =>
ParseErrorBundle s e -> String
Megaparsec.errorBundlePretty ParseErrorBundle Text Void
e))
    Right BranchRelativePath
x -> BranchRelativePath -> Either (Pretty ColorText) BranchRelativePath
forall a b. b -> Either a b
Right BranchRelativePath
x

-- |
-- >>> from @BranchRelativePath @Text (BranchPathInCurrentProject "foo" (Path.absoluteEmpty "bar"))
instance From BranchRelativePath Text where
  from :: BranchRelativePath -> Text
from = \case
    BranchPathInCurrentProject ProjectBranchName
branch Absolute
path ->
      Builder -> Text
Text.Builder.run (Builder -> Text) -> Builder -> Text
forall a b. (a -> b) -> a -> b
$
        Char -> Builder
Text.Builder.char Char
'/'
          Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Builder
Text.Builder.text (forall target source. From source target => source -> target
into @Text ProjectBranchName
branch)
          Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Char -> Builder
Text.Builder.char Char
':'
          Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Builder
Text.Builder.text (Absolute -> Text
Path.absToText Absolute
path)
    QualifiedBranchPath ProjectName
proj ProjectBranchName
branch Absolute
path ->
      Builder -> Text
Text.Builder.run (Builder -> Text) -> Builder -> Text
forall a b. (a -> b) -> a -> b
$
        Text -> Builder
Text.Builder.text (forall target source. From source target => source -> target
into @Text ProjectName
proj)
          Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Char -> Builder
Text.Builder.char Char
'/'
          Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Builder
Text.Builder.text (forall target source. From source target => source -> target
into @Text ProjectBranchName
branch)
          Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Char -> Builder
Text.Builder.char Char
':'
          Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Builder
Text.Builder.text (Absolute -> Text
Path.absToText Absolute
path)
    UnqualifiedPath Path'
path ->
      Path' -> Text
Path.toText' Path'
path

data IncrementalBranchRelativePath
  = -- | no dots, slashes, or colons, so could be a project name or a single path segment
    ProjectOrPath' Text Path.Path'
  | -- | dots, no slashes or colons, must be a relative or absolute path
    OnlyPath' 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.Absolute)
  | PathRelativeToCurrentBranch Path.Absolute
  deriving stock (Int -> IncrementalBranchRelativePath -> ShowS
[IncrementalBranchRelativePath] -> ShowS
IncrementalBranchRelativePath -> String
(Int -> IncrementalBranchRelativePath -> ShowS)
-> (IncrementalBranchRelativePath -> String)
-> ([IncrementalBranchRelativePath] -> ShowS)
-> Show IncrementalBranchRelativePath
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> IncrementalBranchRelativePath -> ShowS
showsPrec :: Int -> IncrementalBranchRelativePath -> ShowS
$cshow :: IncrementalBranchRelativePath -> String
show :: IncrementalBranchRelativePath -> String
$cshowList :: [IncrementalBranchRelativePath] -> ShowS
showList :: [IncrementalBranchRelativePath] -> ShowS
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 :: String -> Either (Pretty ColorText) IncrementalBranchRelativePath
parseIncrementalBranchRelativePath String
str =
  case Parsec Void Text IncrementalBranchRelativePath
-> String
-> Text
-> Either
     (ParseErrorBundle Text Void) IncrementalBranchRelativePath
forall e s a.
Parsec e s a -> String -> s -> Either (ParseErrorBundle s e) a
Megaparsec.parse Parsec Void Text IncrementalBranchRelativePath
incrementalBranchRelativePathParser String
"<none>" (String -> Text
Text.pack String
str) of
    Left ParseErrorBundle Text Void
e -> Pretty ColorText
-> Either (Pretty ColorText) IncrementalBranchRelativePath
forall a b. a -> Either a b
Left (String -> Pretty ColorText
forall s. IsString s => String -> Pretty s
P.string (ParseErrorBundle Text Void -> String
forall s e.
(VisualStream s, TraversableStream s, ShowErrorComponent e) =>
ParseErrorBundle s e -> String
Megaparsec.errorBundlePretty ParseErrorBundle Text Void
e))
    Right IncrementalBranchRelativePath
x -> IncrementalBranchRelativePath
-> Either (Pretty ColorText) IncrementalBranchRelativePath
forall a b. b -> Either a b
Right IncrementalBranchRelativePath
x

incrementalBranchRelativePathParser :: Megaparsec.Parsec Void Text IncrementalBranchRelativePath
incrementalBranchRelativePathParser :: Parsec Void Text IncrementalBranchRelativePath
incrementalBranchRelativePathParser =
  [Parsec Void Text IncrementalBranchRelativePath]
-> Parsec Void Text IncrementalBranchRelativePath
forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum
    [ Maybe ProjectName -> Parsec Void Text IncrementalBranchRelativePath
startingAtSlash Maybe ProjectName
forall a. Maybe a
Nothing,
      Parsec Void Text IncrementalBranchRelativePath
pathRelativeToCurrentBranch,
      Parsec Void Text IncrementalBranchRelativePath
projectName
    ]
  where
    projectName :: Parsec Void Text IncrementalBranchRelativePath
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.
      Parsec Void Text (ProjectName, Bool)
-> Parsec Void Text Path'
-> Parsec Void Text (These (Int, (ProjectName, Bool)) (Int, Path'))
forall a b.
Parsec Void Text a
-> Parsec Void Text b -> Parsec Void Text (These (Int, a) (Int, b))
parseThese Parsec Void Text (ProjectName, Bool)
Project.projectNameParser Parsec Void Text Path'
path' Parsec Void Text (These (Int, (ProjectName, Bool)) (Int, Path'))
-> (These (Int, (ProjectName, Bool)) (Int, Path')
    -> Parsec Void Text IncrementalBranchRelativePath)
-> Parsec Void Text IncrementalBranchRelativePath
forall a b.
ParsecT Void Text Identity a
-> (a -> ParsecT Void Text Identity b)
-> ParsecT Void Text Identity b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        -- project name parser consumed the slash
        This (Int
_, (ProjectName
projectName, Bool
True)) ->
          Maybe ProjectName -> Parsec Void Text IncrementalBranchRelativePath
startingAtBranch (ProjectName -> Maybe ProjectName
forall a. a -> Maybe a
Just ProjectName
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 (Int
_, (ProjectName
projectName, Bool
False)) ->
          let end :: Parsec Void Text IncrementalBranchRelativePath
end = do
                ParsecT Void Text Identity ()
forall e s (m :: * -> *). MonadParsec e s m => m ()
Megaparsec.eof
                pure (ProjectName -> IncrementalBranchRelativePath
IncompleteProject ProjectName
projectName)
           in Parsec Void Text IncrementalBranchRelativePath
end Parsec Void Text IncrementalBranchRelativePath
-> Parsec Void Text IncrementalBranchRelativePath
-> Parsec Void Text IncrementalBranchRelativePath
forall a.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe ProjectName -> Parsec Void Text IncrementalBranchRelativePath
startingAtSlash (ProjectName -> Maybe ProjectName
forall a. a -> Maybe a
Just ProjectName
projectName)
        -- The string doesn't parse as a project name but does parse as a path
        That (Int
_, Path'
path) -> IncrementalBranchRelativePath
-> Parsec Void Text IncrementalBranchRelativePath
forall a. a -> ParsecT Void Text Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Path' -> IncrementalBranchRelativePath
OnlyPath' Path'
path)
        -- The string parses both as a project name and a path
        These (Int, (ProjectName, Bool))
_ (Int
_, Path'
path) -> Text -> Path' -> IncrementalBranchRelativePath
ProjectOrPath' (Text -> Path' -> IncrementalBranchRelativePath)
-> ParsecT Void Text Identity Text
-> ParsecT
     Void Text Identity (Path' -> IncrementalBranchRelativePath)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void Text Identity Text
ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *). MonadParsec e s m => m (Tokens s)
Megaparsec.takeRest ParsecT Void Text Identity (Path' -> IncrementalBranchRelativePath)
-> Parsec Void Text Path'
-> Parsec Void Text IncrementalBranchRelativePath
forall a b.
ParsecT Void Text Identity (a -> b)
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Path' -> Parsec Void Text Path'
forall a. a -> ParsecT Void Text Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Path'
path

    startingAtBranch :: Maybe ProjectName -> Megaparsec.Parsec Void Text IncrementalBranchRelativePath
    startingAtBranch :: Maybe ProjectName -> Parsec Void Text IncrementalBranchRelativePath
startingAtBranch Maybe ProjectName
mproj =
      Parsec Void Text (Maybe ProjectBranchName)
optionalBranch Parsec Void Text (Maybe ProjectBranchName)
-> (Maybe ProjectBranchName
    -> Parsec Void Text IncrementalBranchRelativePath)
-> Parsec Void Text IncrementalBranchRelativePath
forall a b.
ParsecT Void Text Identity a
-> (a -> ParsecT Void Text Identity b)
-> ParsecT Void Text Identity b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Maybe ProjectBranchName
Nothing -> IncrementalBranchRelativePath
-> Parsec Void Text IncrementalBranchRelativePath
forall a. a -> ParsecT Void Text Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe ProjectName
-> Maybe ProjectBranchName -> IncrementalBranchRelativePath
IncompleteBranch Maybe ProjectName
mproj Maybe ProjectBranchName
forall a. Maybe a
Nothing)
        Just ProjectBranchName
branch ->
          Either
  (ProjectAndBranch ProjectName ProjectBranchName) ProjectBranchName
-> Parsec Void Text IncrementalBranchRelativePath
startingAtColon (Either
  (ProjectAndBranch ProjectName ProjectBranchName) ProjectBranchName
-> (ProjectName
    -> Either
         (ProjectAndBranch ProjectName ProjectBranchName) ProjectBranchName)
-> Maybe ProjectName
-> Either
     (ProjectAndBranch ProjectName ProjectBranchName) ProjectBranchName
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (ProjectBranchName
-> Either
     (ProjectAndBranch ProjectName ProjectBranchName) ProjectBranchName
forall a b. b -> Either a b
Right ProjectBranchName
branch) (\ProjectName
proj -> ProjectAndBranch ProjectName ProjectBranchName
-> Either
     (ProjectAndBranch ProjectName ProjectBranchName) ProjectBranchName
forall a b. a -> Either a b
Left (ProjectName
-> ProjectBranchName
-> ProjectAndBranch ProjectName ProjectBranchName
forall a b. a -> b -> ProjectAndBranch a b
ProjectAndBranch ProjectName
proj ProjectBranchName
branch)) Maybe ProjectName
mproj)
            Parsec Void Text IncrementalBranchRelativePath
-> Parsec Void Text IncrementalBranchRelativePath
-> Parsec Void Text IncrementalBranchRelativePath
forall a.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> IncrementalBranchRelativePath
-> Parsec Void Text IncrementalBranchRelativePath
forall a. a -> ParsecT Void Text Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe ProjectName
-> Maybe ProjectBranchName -> IncrementalBranchRelativePath
IncompleteBranch Maybe ProjectName
mproj (ProjectBranchName -> Maybe ProjectBranchName
forall a. a -> Maybe a
Just ProjectBranchName
branch))

    startingAtSlash ::
      Maybe ProjectName ->
      Megaparsec.Parsec Void Text IncrementalBranchRelativePath
    startingAtSlash :: Maybe ProjectName -> Parsec Void Text IncrementalBranchRelativePath
startingAtSlash Maybe ProjectName
mproj = Token Text -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
Megaparsec.char Char
Token Text
'/' ParsecT Void Text Identity Char
-> Parsec Void Text IncrementalBranchRelativePath
-> Parsec Void Text IncrementalBranchRelativePath
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Maybe ProjectName -> Parsec Void Text IncrementalBranchRelativePath
startingAtBranch Maybe ProjectName
mproj

    startingAtColon ::
      (Either (ProjectAndBranch ProjectName ProjectBranchName) ProjectBranchName) ->
      Megaparsec.Parsec Void Text IncrementalBranchRelativePath
    startingAtColon :: Either
  (ProjectAndBranch ProjectName ProjectBranchName) ProjectBranchName
-> Parsec Void Text IncrementalBranchRelativePath
startingAtColon Either
  (ProjectAndBranch ProjectName ProjectBranchName) ProjectBranchName
projStuff = do
      Char
_ <- Token Text -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
Megaparsec.char Char
Token Text
':'
      Maybe Absolute
p <- Parsec Void Text Absolute -> Parsec Void Text (Maybe Absolute)
forall a. Parsec Void Text a -> Parsec Void Text (Maybe a)
optionalEof Parsec Void Text Absolute
brPath
      pure (Either
  (ProjectAndBranch ProjectName ProjectBranchName) ProjectBranchName
-> Maybe Absolute -> IncrementalBranchRelativePath
IncompletePath Either
  (ProjectAndBranch ProjectName ProjectBranchName) ProjectBranchName
projStuff Maybe Absolute
p)

    pathRelativeToCurrentBranch :: Megaparsec.Parsec Void Text IncrementalBranchRelativePath
    pathRelativeToCurrentBranch :: Parsec Void Text IncrementalBranchRelativePath
pathRelativeToCurrentBranch = do
      Char
_ <- Token Text -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
Megaparsec.char Char
Token Text
':'
      Absolute
p <- Parsec Void Text Absolute
brPath
      pure (Absolute -> IncrementalBranchRelativePath
PathRelativeToCurrentBranch Absolute
p)

    optionalEof :: Megaparsec.Parsec Void Text a -> Megaparsec.Parsec Void Text (Maybe a)
    optionalEof :: forall a. Parsec Void Text a -> Parsec Void Text (Maybe a)
optionalEof Parsec Void Text a
pa = a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a)
-> Parsec Void Text a -> ParsecT Void Text Identity (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parsec Void Text a
pa ParsecT Void Text Identity (Maybe a)
-> ParsecT Void Text Identity (Maybe a)
-> ParsecT Void Text Identity (Maybe a)
forall a.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Maybe a
forall a. Maybe a
Nothing Maybe a
-> ParsecT Void Text Identity ()
-> ParsecT Void Text Identity (Maybe a)
forall a b.
a -> ParsecT Void Text Identity b -> ParsecT Void Text Identity a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ ParsecT Void Text Identity ()
forall e s (m :: * -> *). MonadParsec e s m => m ()
Megaparsec.eof)

    optionalBranch :: Megaparsec.Parsec Void Text (Maybe ProjectBranchName)
    optionalBranch :: Parsec Void Text (Maybe ProjectBranchName)
optionalBranch = Parsec Void Text ProjectBranchName
-> Parsec Void Text (Maybe ProjectBranchName)
forall a. Parsec Void Text a -> Parsec Void Text (Maybe a)
optionalEof Parsec Void Text ProjectBranchName
branchNameParser

    branchNameParser :: Parsec Void Text ProjectBranchName
branchNameParser = Bool -> Parsec Void Text ProjectBranchName
Project.projectBranchNameParser Bool
False

    brPath :: Megaparsec.Parsec Void Text Path.Absolute
    brPath :: Parsec Void Text Absolute
brPath = do
      Int
offset <- ParsecT Void Text Identity Int
forall e s (m :: * -> *). MonadParsec e s m => m Int
Megaparsec.getOffset
      Parsec Void Text Path'
path' Parsec Void Text Path'
-> (Path' -> Parsec Void Text Absolute)
-> Parsec Void Text Absolute
forall a b.
ParsecT Void Text Identity a
-> (a -> ParsecT Void Text Identity b)
-> ParsecT Void Text Identity b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \(Path.Path' Either Absolute Relative
inner) -> case Either Absolute Relative
inner of
        Left Absolute
_ -> Int -> Text -> Parsec Void Text Absolute
forall a. Int -> Text -> Parsec Void Text a
failureAt Int
offset Text
"Branch qualified paths don't require a leading '.'"
        -- Branch relative paths are written as relative paths, but are always absolute to the branch root
        Right (Path.Relative Path
x) -> Absolute -> Parsec Void Text Absolute
forall a. a -> ParsecT Void Text Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Absolute -> Parsec Void Text Absolute)
-> Absolute -> Parsec Void Text Absolute
forall a b. (a -> b) -> a -> b
$ Path -> Absolute
Path.Absolute Path
x
    path' :: Parsec Void Text Path'
path' = Parsec Void Text Path' -> Parsec Void Text Path'
forall a.
ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
Megaparsec.try do
      Int
offset <- ParsecT Void Text Identity Int
forall e s (m :: * -> *). MonadParsec e s m => m Int
Megaparsec.getOffset
      Text
pathStr <- ParsecT Void Text Identity Text
ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *). MonadParsec e s m => m (Tokens s)
Megaparsec.takeRest
      case String -> Either Text Path'
Path.parsePath' (Text -> String
Text.unpack Text
pathStr) of
        Left Text
err -> Int -> Text -> Parsec Void Text Path'
forall a. Int -> Text -> Parsec Void Text a
failureAt Int
offset Text
err
        Right Path'
x -> Path' -> Parsec Void Text Path'
forall a. a -> ParsecT Void Text Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Path'
x

    failureAt :: forall a. Int -> Text -> Megaparsec.Parsec Void Text a
    failureAt :: forall a. Int -> Text -> Parsec Void Text a
failureAt Int
offset Text
str = ParseError Text Void -> ParsecT Void Text Identity a
forall a. ParseError Text Void -> ParsecT Void Text Identity a
forall e s (m :: * -> *) a.
MonadParsec e s m =>
ParseError s e -> m a
Megaparsec.parseError (Int -> Set (ErrorFancy Void) -> ParseError Text Void
forall s e. Int -> Set (ErrorFancy e) -> ParseError s e
Megaparsec.FancyError Int
offset (ErrorFancy Void -> Set (ErrorFancy Void)
forall a. a -> Set a
Set.singleton (String -> ErrorFancy Void
forall e. String -> ErrorFancy e
Megaparsec.ErrorFail (Text -> String
Text.unpack Text
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 :: forall a b.
Parsec Void Text a
-> Parsec Void Text b -> Parsec Void Text (These (Int, a) (Int, b))
parseThese Parsec Void Text a
pa Parsec Void Text b
pb = do
      Either (ParseError Text Void) (Int, a)
ea <- ParsecT Void Text Identity (Int, a)
-> ParsecT
     Void Text Identity (Either (ParseError Text Void) (Int, a))
forall a.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity (Either (ParseError Text Void) a)
forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> m (Either (ParseError s e) a)
Megaparsec.observing (ParsecT Void Text Identity (Int, a)
 -> ParsecT
      Void Text Identity (Either (ParseError Text Void) (Int, a)))
-> ParsecT Void Text Identity (Int, a)
-> ParsecT
     Void Text Identity (Either (ParseError Text Void) (Int, a))
forall a b. (a -> b) -> a -> b
$ ParsecT Void Text Identity (Int, a)
-> ParsecT Void Text Identity (Int, a)
forall a.
ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
Megaparsec.lookAhead (ParsecT Void Text Identity (Int, a)
 -> ParsecT Void Text Identity (Int, a))
-> ParsecT Void Text Identity (Int, a)
-> ParsecT Void Text Identity (Int, a)
forall a b. (a -> b) -> a -> b
$ ParsecT Void Text Identity (Int, a)
-> ParsecT Void Text Identity (Int, a)
forall a.
ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
Megaparsec.try (ParsecT Void Text Identity (Int, a)
 -> ParsecT Void Text Identity (Int, a))
-> ParsecT Void Text Identity (Int, a)
-> ParsecT Void Text Identity (Int, a)
forall a b. (a -> b) -> a -> b
$ (Text -> Int) -> (Text, a) -> (Int, a)
forall a b c. (a -> b) -> (a, c) -> (b, c)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first Text -> Int
Text.length ((Text, a) -> (Int, a))
-> ParsecT Void Text Identity (Text, a)
-> ParsecT Void Text Identity (Int, a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parsec Void Text a -> ParsecT Void Text Identity (Tokens Text, a)
forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> m (Tokens s, a)
Megaparsec.match Parsec Void Text a
pa
      Either (ParseError Text Void) (Int, b)
eb <- ParsecT Void Text Identity (Int, b)
-> ParsecT
     Void Text Identity (Either (ParseError Text Void) (Int, b))
forall a.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity (Either (ParseError Text Void) a)
forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> m (Either (ParseError s e) a)
Megaparsec.observing (ParsecT Void Text Identity (Int, b)
 -> ParsecT
      Void Text Identity (Either (ParseError Text Void) (Int, b)))
-> ParsecT Void Text Identity (Int, b)
-> ParsecT
     Void Text Identity (Either (ParseError Text Void) (Int, b))
forall a b. (a -> b) -> a -> b
$ ParsecT Void Text Identity (Int, b)
-> ParsecT Void Text Identity (Int, b)
forall a.
ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
Megaparsec.lookAhead (ParsecT Void Text Identity (Int, b)
 -> ParsecT Void Text Identity (Int, b))
-> ParsecT Void Text Identity (Int, b)
-> ParsecT Void Text Identity (Int, b)
forall a b. (a -> b) -> a -> b
$ ParsecT Void Text Identity (Int, b)
-> ParsecT Void Text Identity (Int, b)
forall a.
ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
Megaparsec.try (ParsecT Void Text Identity (Int, b)
 -> ParsecT Void Text Identity (Int, b))
-> ParsecT Void Text Identity (Int, b)
-> ParsecT Void Text Identity (Int, b)
forall a b. (a -> b) -> a -> b
$ (Text -> Int) -> (Text, b) -> (Int, b)
forall a b c. (a -> b) -> (a, c) -> (b, c)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first Text -> Int
Text.length ((Text, b) -> (Int, b))
-> ParsecT Void Text Identity (Text, b)
-> ParsecT Void Text Identity (Int, b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parsec Void Text b -> ParsecT Void Text Identity (Tokens Text, b)
forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> m (Tokens s, a)
Megaparsec.match Parsec Void Text b
pb
      case (Either (ParseError Text Void) (Int, a)
ea, Either (ParseError Text Void) (Int, b)
eb) of
        (Left ParseError Text Void
aerr, Left ParseError Text Void
berr) ->
          ParseError Text Void -> Parsec Void Text (These (Int, a) (Int, b))
forall a. ParseError Text Void -> ParsecT Void Text Identity a
forall e s (m :: * -> *) a.
MonadParsec e s m =>
ParseError s e -> m a
Megaparsec.parseError (ParseError Text Void
aerr ParseError Text Void
-> ParseError Text Void -> ParseError Text Void
forall a. Semigroup a => a -> a -> a
<> ParseError Text Void
berr)
        (Left ParseError Text Void
_, Right (Int
blen, b
b)) -> do
          Maybe String -> Int -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe String -> Int -> m (Tokens s)
Megaparsec.takeP Maybe String
forall a. Maybe a
Nothing Int
blen
          pure ((Int, b) -> These (Int, a) (Int, b)
forall a b. b -> These a b
That (Int
blen, b
b))
        (Right (Int
alen, a
a), Left ParseError Text Void
_) -> do
          Maybe String -> Int -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe String -> Int -> m (Tokens s)
Megaparsec.takeP Maybe String
forall a. Maybe a
Nothing Int
alen
          pure ((Int, a) -> These (Int, a) (Int, b)
forall a b. a -> These a b
This (Int
alen, a
a))
        (Right (Int, a)
a, Right (Int, b)
b) -> These (Int, a) (Int, b)
-> Parsec Void Text (These (Int, a) (Int, b))
forall a. a -> ParsecT Void Text Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Int, a) -> (Int, b) -> These (Int, a) (Int, b)
forall a b. a -> b -> These a b
These (Int, a)
a (Int, b)
b)

branchRelativePathParser :: Megaparsec.Parsec Void Text BranchRelativePath
branchRelativePathParser :: Parsec Void Text BranchRelativePath
branchRelativePathParser =
  Parsec Void Text IncrementalBranchRelativePath
incrementalBranchRelativePathParser Parsec Void Text IncrementalBranchRelativePath
-> (IncrementalBranchRelativePath
    -> Parsec Void Text BranchRelativePath)
-> Parsec Void Text BranchRelativePath
forall a b.
ParsecT Void Text Identity a
-> (a -> ParsecT Void Text Identity b)
-> ParsecT Void Text Identity b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    ProjectOrPath' Text
_txt Path'
path -> BranchRelativePath -> Parsec Void Text BranchRelativePath
forall a. a -> ParsecT Void Text Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Path' -> BranchRelativePath
UnqualifiedPath Path'
path)
    OnlyPath' Path'
path -> BranchRelativePath -> Parsec Void Text BranchRelativePath
forall a. a -> ParsecT Void Text Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Path' -> BranchRelativePath
UnqualifiedPath Path'
path)
    IncompleteProject ProjectName
_proj -> String -> Parsec Void Text BranchRelativePath
forall a. String -> ParsecT Void Text Identity a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Branch relative paths require a branch. Expected `/` here."
    IncompleteBranch Maybe ProjectName
_mproj Maybe ProjectBranchName
_mbranch -> String -> Parsec Void Text BranchRelativePath
forall a. String -> ParsecT Void Text Identity a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Branch relative paths require a colon. Expected `:` here."
    PathRelativeToCurrentBranch Absolute
p -> BranchRelativePath -> Parsec Void Text BranchRelativePath
forall a. a -> ParsecT Void Text Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Path' -> BranchRelativePath
UnqualifiedPath (Absolute -> Path'
Path.AbsolutePath' Absolute
p))
    IncompletePath Either
  (ProjectAndBranch ProjectName ProjectBranchName) ProjectBranchName
projStuff Maybe Absolute
mpath ->
      case Either
  (ProjectAndBranch ProjectName ProjectBranchName) ProjectBranchName
projStuff of
        Left (ProjectAndBranch ProjectName
projName ProjectBranchName
branchName) ->
          BranchRelativePath -> Parsec Void Text BranchRelativePath
forall a. a -> ParsecT Void Text Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (BranchRelativePath -> Parsec Void Text BranchRelativePath)
-> BranchRelativePath -> Parsec Void Text BranchRelativePath
forall a b. (a -> b) -> a -> b
$ ProjectName -> ProjectBranchName -> Absolute -> BranchRelativePath
QualifiedBranchPath ProjectName
projName ProjectBranchName
branchName (Absolute -> Maybe Absolute -> Absolute
forall a. a -> Maybe a -> a
fromMaybe Absolute
Path.absoluteEmpty Maybe Absolute
mpath)
        Right ProjectBranchName
branch ->
          BranchRelativePath -> Parsec Void Text BranchRelativePath
forall a. a -> ParsecT Void Text Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (BranchRelativePath -> Parsec Void Text BranchRelativePath)
-> BranchRelativePath -> Parsec Void Text BranchRelativePath
forall a b. (a -> b) -> a -> b
$ ProjectBranchName -> Absolute -> BranchRelativePath
BranchPathInCurrentProject ProjectBranchName
branch (Absolute -> Maybe Absolute -> Absolute
forall a. a -> Maybe a -> a
fromMaybe Absolute
Path.absoluteEmpty Maybe Absolute
mpath)

toText :: BranchRelativePath -> Text
toText :: BranchRelativePath -> Text
toText = \case
  BranchPathInCurrentProject ProjectBranchName
pbName Absolute
path -> ()
-> ProjectBranchName
-> Absolute
-> ProjectPathG () ProjectBranchName
forall proj branch.
proj -> branch -> Absolute -> ProjectPathG proj branch
ProjectPath () ProjectBranchName
pbName Absolute
path ProjectPathG () ProjectBranchName
-> (ProjectPathG () ProjectBranchName -> Text) -> Text
forall a b. a -> (a -> b) -> b
& forall target source. From source target => source -> target
into @Text
  QualifiedBranchPath ProjectName
projName ProjectBranchName
pbName Absolute
path -> ProjectName
-> ProjectBranchName
-> Absolute
-> ProjectPathG ProjectName ProjectBranchName
forall proj branch.
proj -> branch -> Absolute -> ProjectPathG proj branch
ProjectPath ProjectName
projName ProjectBranchName
pbName Absolute
path ProjectPathG ProjectName ProjectBranchName
-> (ProjectPathG ProjectName ProjectBranchName -> Text) -> Text
forall a b. a -> (a -> b) -> b
& forall target source. From source target => source -> target
into @Text
  UnqualifiedPath Path'
path' -> Path' -> Text
Path.toText' Path'
path'