{-# OPTIONS_GHC -fno-warn-orphans #-}

-- | Projects.
--
-- The syntax-related parsing code (what makes a valid project name, etc) could conceivably be moved into a different
-- package, but for now we have just defined the one blessed project/branch name syntax that we allow.
module Unison.Project
  ( ProjectName,
    projectNameUserSlug,
    projectNameToUserProjectSlugs,
    prependUserSlugToProjectName,
    isValidNewProjectName,
    ProjectBranchName,
    projectBranchNameUserSlug,
    projectBranchNameToValidProjectBranchNameText,
    ProjectBranchNameKind (..),
    classifyProjectBranchName,
    ProjectBranchNameOrLatestRelease (..),
    ProjectBranchSpecifier (..),
    ProjectAndBranch (..),
    projectAndBranchNamesParser,
    fullyQualifiedProjectAndBranchNamesParser,
    projectAndOptionalBranchParser,
    branchWithOptionalProjectParser,
    ProjectAndBranchNames (..),
    projectAndBranchNamesParser2,
    projectNameParser,
    projectBranchNameParser,
    defaultBranchName,

    -- ** Semver
    Semver (..),
  )
where

import Data.Char qualified as Char
import Data.Kind (Type)
import Data.Text qualified as Text
import Data.Text.Read qualified as Text (decimal)
import Data.These (These (..))
import Text.Megaparsec qualified as Megaparsec
import Text.Megaparsec.Char qualified as Megaparsec
import TextBuilder (TextBuilder)
import TextBuilder qualified
import Unison.Core.Project (ProjectAndBranch (..), ProjectBranchName (..), ProjectName (..))
import Unison.Prelude
import Witch

instance From ProjectName Text

instance TryFrom Text ProjectName where
  tryFrom :: Text -> Either (TryFromException Text ProjectName) ProjectName
tryFrom =
    (Text -> Maybe ProjectName)
-> Text -> Either (TryFromException Text ProjectName) ProjectName
forall source target.
(source -> Maybe target)
-> source -> Either (TryFromException source target) target
maybeTryFrom (((ProjectName, Bool) -> ProjectName)
-> Maybe (ProjectName, Bool) -> Maybe ProjectName
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ProjectName, Bool) -> ProjectName
forall a b. (a, b) -> a
fst (Maybe (ProjectName, Bool) -> Maybe ProjectName)
-> (Text -> Maybe (ProjectName, Bool)) -> Text -> Maybe ProjectName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Parsec Void Text (ProjectName, Bool)
-> Text -> Maybe (ProjectName, Bool)
forall e s a. (Ord e, Stream s) => Parsec e s a -> s -> Maybe a
Megaparsec.parseMaybe Parsec Void Text (ProjectName, Bool)
projectNameParser)

-- Parse a project name, and whether it ended in a forward slash (which is, of course, not part of the name)
projectNameParser :: Megaparsec.Parsec Void Text (ProjectName, Bool)
projectNameParser :: Parsec Void Text (ProjectName, Bool)
projectNameParser = do
  userSlug <-
    [ParsecT Void Text Identity TextBuilder]
-> ParsecT Void Text Identity TextBuilder
forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum
      [ do
          user <- ParsecT Void Text Identity TextBuilder
userSlugParser
          pure (TextBuilder.char '@' <> user <> TextBuilder.char '/'),
        TextBuilder -> ParsecT Void Text Identity TextBuilder
forall a. a -> ParsecT Void Text Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TextBuilder
forall a. Monoid a => a
mempty
      ]
  projectSlug <- projectSlugParser
  hasTrailingSlash <- isJust <$> optional (Megaparsec.char '/')
  pure (UnsafeProjectName (TextBuilder.toText (userSlug <> projectSlug)), hasTrailingSlash)
  where
    projectSlugParser :: Megaparsec.Parsec Void Text TextBuilder
    projectSlugParser :: ParsecT Void Text Identity TextBuilder
projectSlugParser = do
      c0 <- (Token Text -> Bool) -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
(Token s -> Bool) -> m (Token s)
Megaparsec.satisfy Char -> Bool
Token Text -> Bool
isStartChar
      c1 <- Megaparsec.takeWhileP Nothing (\Token Text
c -> Char -> Bool
isStartChar Char
Token Text
c Bool -> Bool -> Bool
|| Char -> Bool
Char.isDigit Char
Token Text
c Bool -> Bool -> Bool
|| Char
Token Text
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'-')
      pure (TextBuilder.char c0 <> TextBuilder.text c1)
      where
        isStartChar :: Char -> Bool
        isStartChar :: Char -> Bool
isStartChar Char
c =
          Char -> Bool
Char.isAlpha Char
c Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'_'

-- Parse a project name, and whether it ended in a forward slash (which is, of course, not part of the name)
newProjectNameParser :: Megaparsec.Parsec Void Text (ProjectName, Bool)
newProjectNameParser :: Parsec Void Text (ProjectName, Bool)
newProjectNameParser = do
  userSlug <-
    [ParsecT Void Text Identity TextBuilder]
-> ParsecT Void Text Identity TextBuilder
forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum
      [ do
          user <- ParsecT Void Text Identity TextBuilder
userSlugParser
          pure (TextBuilder.char '@' <> user <> TextBuilder.char '/'),
        TextBuilder -> ParsecT Void Text Identity TextBuilder
forall a. a -> ParsecT Void Text Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TextBuilder
forall a. Monoid a => a
mempty
      ]
  projectSlug <- projectSlugParser
  hasTrailingSlash <- isJust <$> optional (Megaparsec.char '/')
  pure (UnsafeProjectName (TextBuilder.toText (userSlug <> projectSlug)), hasTrailingSlash)
  where
    projectSlugParser :: Megaparsec.Parsec Void Text TextBuilder
    projectSlugParser :: ParsecT Void Text Identity TextBuilder
projectSlugParser = do
      name <- Maybe [Char]
-> (Token Text -> Bool) -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe [Char] -> (Token s -> Bool) -> m (Tokens s)
Megaparsec.takeWhile1P Maybe [Char]
forall a. Maybe a
Nothing \Token Text
c -> Char -> Bool
Char.isAsciiLower Char
Token Text
c Bool -> Bool -> Bool
|| Char -> Bool
Char.isAsciiUpper Char
Token Text
c Bool -> Bool -> Bool
|| Char -> Bool
Char.isDigit Char
Token Text
c Bool -> Bool -> Bool
|| Char
Token Text
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'-' Bool -> Bool -> Bool
|| Char
Token Text
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'_'
      when (name == "p" || name == "code") do
        fail ("Project cannot be named 'code' or 'p'")
      pure (TextBuilder.text name)

isValidNewProjectName :: ProjectName -> Bool
isValidNewProjectName :: ProjectName -> Bool
isValidNewProjectName (UnsafeProjectName Text
projectName) =
  Either (ParseErrorBundle Text Void) (ProjectName, Bool) -> Bool
forall a b. Either a b -> Bool
isRight (Parsec Void Text (ProjectName, Bool)
-> [Char]
-> Text
-> Either (ParseErrorBundle Text Void) (ProjectName, Bool)
forall e s a.
Parsec e s a -> [Char] -> s -> Either (ParseErrorBundle s e) a
Megaparsec.parse Parsec Void Text (ProjectName, Bool)
newProjectNameParser [Char]
"" Text
projectName)

-- | Get the user slug at the beginning of a project name, if there is one.
--
-- >>> projectNameUserSlug "@arya/lens"
-- Just "arya"
--
-- >>> projectNameUserSlug "lens"
-- Nothing
projectNameUserSlug :: ProjectName -> Maybe Text
projectNameUserSlug :: ProjectName -> Maybe Text
projectNameUserSlug (UnsafeProjectName Text
projectName) =
  if HasCallStack => Text -> Char
Text -> Char
Text.head Text
projectName Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'@'
    then Text -> Maybe Text
forall a. a -> Maybe a
Just ((Char -> Bool) -> Text -> Text
Text.takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'/') (Int -> Text -> Text
Text.drop Int
1 Text
projectName))
    else Maybe Text
forall a. Maybe a
Nothing

-- | Parse a "@arya/lens" into the "arya" and "lens" parts.
--
-- If there's no "arya" part, returns the empty string there.
--
-- >>> projectNameToUserProjectSlugs (UnsafeProjectName "@arya/lens")
-- ("arya","lens")
--
-- >>> projectNameToUserProjectSlugs (UnsafeProjectName "lens")
-- ("","lens")
projectNameToUserProjectSlugs :: ProjectName -> (Text, Text)
projectNameToUserProjectSlugs :: ProjectName -> (Text, Text)
projectNameToUserProjectSlugs (UnsafeProjectName Text
name) =
  case (Char -> Bool) -> Text -> (Text, Text)
Text.span (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'/') Text
name of
    (Text
project, Text
"") -> (Text
"", Text
project)
    (Text
atUser, Text
slashProject) -> (Int -> Text -> Text
Text.drop Int
1 Text
atUser, Int -> Text -> Text
Text.drop Int
1 Text
slashProject)

-- | Prepend a user slug to a project name, if it doesn't already have one.
--
-- >>> prependUserSlugToProjectName "arya" "lens"
-- "@arya/lens"
--
-- >>> prependUserSlugToProjectName "runar" "@unison/base"
-- "@unison/base"
--
-- >>> prependUserSlugToProjectName "???invalid???" "@unison/base"
-- "@unison/base"
prependUserSlugToProjectName :: Text -> ProjectName -> ProjectName
prependUserSlugToProjectName :: Text -> ProjectName -> ProjectName
prependUserSlugToProjectName Text
userSlug (UnsafeProjectName Text
projectName) =
  if HasCallStack => Text -> Char
Text -> Char
Text.head Text
projectName Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'@'
    then Text -> ProjectName
UnsafeProjectName Text
projectName
    else ProjectName -> Maybe ProjectName -> ProjectName
forall a. a -> Maybe a -> a
fromMaybe (Text -> ProjectName
UnsafeProjectName Text
projectName) ((ProjectName, Bool) -> ProjectName
forall a b. (a, b) -> a
fst ((ProjectName, Bool) -> ProjectName)
-> Maybe (ProjectName, Bool) -> Maybe ProjectName
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parsec Void Text (ProjectName, Bool)
-> Text -> Maybe (ProjectName, Bool)
forall e s a. (Ord e, Stream s) => Parsec e s a -> s -> Maybe a
Megaparsec.parseMaybe Parsec Void Text (ProjectName, Bool)
projectNameParser Text
newProjectName)
  where
    newProjectName :: Text
newProjectName =
      TextBuilder -> Text
TextBuilder.toText (TextBuilder -> Text) -> TextBuilder -> Text
forall a b. (a -> b) -> a -> b
$
        Char -> TextBuilder
TextBuilder.char Char
'@'
          TextBuilder -> TextBuilder -> TextBuilder
forall a. Semigroup a => a -> a -> a
<> Text -> TextBuilder
TextBuilder.text Text
userSlug
          TextBuilder -> TextBuilder -> TextBuilder
forall a. Semigroup a => a -> a -> a
<> Char -> TextBuilder
TextBuilder.char Char
'/'
          TextBuilder -> TextBuilder -> TextBuilder
forall a. Semigroup a => a -> a -> a
<> Text -> TextBuilder
TextBuilder.text Text
projectName

instance From ProjectBranchName Text

instance TryFrom Text ProjectBranchName where
  tryFrom :: Text
-> Either
     (TryFromException Text ProjectBranchName) ProjectBranchName
tryFrom =
    (Text -> Maybe ProjectBranchName)
-> Text
-> Either
     (TryFromException Text ProjectBranchName) ProjectBranchName
forall source target.
(source -> Maybe target)
-> source -> Either (TryFromException source target) target
maybeTryFrom (Parsec Void Text ProjectBranchName
-> Text -> Maybe ProjectBranchName
forall e s a. (Ord e, Stream s) => Parsec e s a -> s -> Maybe a
Megaparsec.parseMaybe (Bool -> Parsec Void Text ProjectBranchName
projectBranchNameParser Bool
True))

projectBranchNameParser :: Bool -> Megaparsec.Parsec Void Text ProjectBranchName
projectBranchNameParser :: Bool -> Parsec Void Text ProjectBranchName
projectBranchNameParser Bool
allowLeadingSlash =
  StructuredProjectBranchName -> ProjectBranchName
unstructureStructuredProjectName (StructuredProjectBranchName -> ProjectBranchName)
-> ParsecT Void Text Identity StructuredProjectBranchName
-> Parsec Void Text ProjectBranchName
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bool -> ParsecT Void Text Identity StructuredProjectBranchName
structuredProjectBranchNameParser Bool
allowLeadingSlash

-- An internal type that captures the structure of a project branch name after parsing. 'classifyProjectBranchName' is
-- how a user can recover this structure for the few cases it's relevant (e.g. during push)
data StructuredProjectBranchName
  = StructuredProjectBranchName'Contributor !TextBuilder !TextBuilder
  | StructuredProjectBranchName'DraftRelease !Semver
  | StructuredProjectBranchName'Release !Semver
  | StructuredProjectBranchName'NothingSpecial !TextBuilder

unstructureStructuredProjectName :: StructuredProjectBranchName -> ProjectBranchName
unstructureStructuredProjectName :: StructuredProjectBranchName -> ProjectBranchName
unstructureStructuredProjectName =
  Text -> ProjectBranchName
UnsafeProjectBranchName (Text -> ProjectBranchName)
-> (StructuredProjectBranchName -> Text)
-> StructuredProjectBranchName
-> ProjectBranchName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TextBuilder -> Text
TextBuilder.toText (TextBuilder -> Text)
-> (StructuredProjectBranchName -> TextBuilder)
-> StructuredProjectBranchName
-> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. \case
    StructuredProjectBranchName'Contributor TextBuilder
user TextBuilder
name ->
      Char -> TextBuilder
TextBuilder.char Char
'@' TextBuilder -> TextBuilder -> TextBuilder
forall a. Semigroup a => a -> a -> a
<> TextBuilder
user TextBuilder -> TextBuilder -> TextBuilder
forall a. Semigroup a => a -> a -> a
<> Char -> TextBuilder
TextBuilder.char Char
'/' TextBuilder -> TextBuilder -> TextBuilder
forall a. Semigroup a => a -> a -> a
<> TextBuilder
name
    StructuredProjectBranchName'DraftRelease Semver
ver -> TextBuilder
"releases/drafts/" TextBuilder -> TextBuilder -> TextBuilder
forall a. Semigroup a => a -> a -> a
<> Semver -> TextBuilder
unstructureSemver Semver
ver
    StructuredProjectBranchName'Release Semver
ver -> TextBuilder
"releases/" TextBuilder -> TextBuilder -> TextBuilder
forall a. Semigroup a => a -> a -> a
<> Semver -> TextBuilder
unstructureSemver Semver
ver
    StructuredProjectBranchName'NothingSpecial TextBuilder
name -> TextBuilder
name
  where
    unstructureSemver :: Semver -> TextBuilder
    unstructureSemver :: Semver -> TextBuilder
unstructureSemver (Semver Int
x Int
y Int
z) =
      Int -> TextBuilder
forall a. Integral a => a -> TextBuilder
TextBuilder.decimal Int
x
        TextBuilder -> TextBuilder -> TextBuilder
forall a. Semigroup a => a -> a -> a
<> Char -> TextBuilder
TextBuilder.char Char
'.'
        TextBuilder -> TextBuilder -> TextBuilder
forall a. Semigroup a => a -> a -> a
<> Int -> TextBuilder
forall a. Integral a => a -> TextBuilder
TextBuilder.decimal Int
y
        TextBuilder -> TextBuilder -> TextBuilder
forall a. Semigroup a => a -> a -> a
<> Char -> TextBuilder
TextBuilder.char Char
'.'
        TextBuilder -> TextBuilder -> TextBuilder
forall a. Semigroup a => a -> a -> a
<> Int -> TextBuilder
forall a. Integral a => a -> TextBuilder
TextBuilder.decimal Int
z

structuredProjectBranchNameParser :: Bool -> Megaparsec.Parsec Void Text StructuredProjectBranchName
structuredProjectBranchNameParser :: Bool -> ParsecT Void Text Identity StructuredProjectBranchName
structuredProjectBranchNameParser Bool
allowLeadingSlash = do
  _ <- Bool
-> ParsecT Void Text Identity () -> ParsecT Void Text Identity ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
allowLeadingSlash (ParsecT Void Text Identity (Maybe Char)
-> ParsecT Void Text Identity ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ParsecT Void Text Identity Char
-> ParsecT Void Text Identity (Maybe Char)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (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
'/')))
  branch <-
    asum
      [ do
          _ <- Megaparsec.string "releases/drafts/"
          ver <- semverParser
          pure (StructuredProjectBranchName'DraftRelease ver),
        do
          _ <- Megaparsec.string "releases/"
          ver <- semverParser
          pure (StructuredProjectBranchName'Release ver),
        do
          user <- userSlugParser
          branch <- branchSlugParser
          pure (StructuredProjectBranchName'Contributor user branch),
        do
          branch <- branchSlugParser
          pure (StructuredProjectBranchName'NothingSpecial branch)
      ]
  -- Because our branch has a sort of /-delimited pseudo-structure, we fail on trailing forward slashes.
  --
  -- This (perhaps among other things) lets us successfully parse something like "releases/drafts/1.2.3" as a branch
  -- with an optional project component in a straightforward way, which might otherwise succeed with
  -- project="releases", branch="drafts", leftovers="/1.2.3" (as it did before this line was added).
  Megaparsec.notFollowedBy (Megaparsec.char '/')
  pure branch
  where
    branchSlugParser :: Megaparsec.Parsec Void Text TextBuilder
    branchSlugParser :: ParsecT Void Text Identity TextBuilder
branchSlugParser = do
      c0 <- (Token Text -> Bool) -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
(Token s -> Bool) -> m (Token s)
Megaparsec.satisfy Char -> Bool
Token Text -> Bool
isStartChar
      c1 <- Megaparsec.takeWhileP Nothing (\Token Text
c -> Char -> Bool
isStartChar Char
Token Text
c Bool -> Bool -> Bool
|| Char -> Bool
Char.isDigit Char
Token Text
c Bool -> Bool -> Bool
|| Char
Token Text
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'-')
      pure (TextBuilder.char c0 <> TextBuilder.text c1)
      where
        isStartChar :: Char -> Bool
        isStartChar :: Char -> Bool
isStartChar Char
c =
          Char -> Bool
Char.isAlpha Char
c Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'_'

data Semver
  = Semver !Int !Int !Int
  deriving stock (Semver -> Semver -> Bool
(Semver -> Semver -> Bool)
-> (Semver -> Semver -> Bool) -> Eq Semver
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Semver -> Semver -> Bool
== :: Semver -> Semver -> Bool
$c/= :: Semver -> Semver -> Bool
/= :: Semver -> Semver -> Bool
Eq, Int -> Semver -> ShowS
[Semver] -> ShowS
Semver -> [Char]
(Int -> Semver -> ShowS)
-> (Semver -> [Char]) -> ([Semver] -> ShowS) -> Show Semver
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Semver -> ShowS
showsPrec :: Int -> Semver -> ShowS
$cshow :: Semver -> [Char]
show :: Semver -> [Char]
$cshowList :: [Semver] -> ShowS
showList :: [Semver] -> ShowS
Show)

instance From Semver Text where
  from :: Semver -> Text
from (Semver Int
x Int
y Int
z) =
    (TextBuilder -> Text
TextBuilder.toText (TextBuilder -> Text)
-> ([TextBuilder] -> TextBuilder) -> [TextBuilder] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [TextBuilder] -> TextBuilder
forall m. Monoid m => [m] -> m
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold)
      [ Int -> TextBuilder
forall a. Integral a => a -> TextBuilder
TextBuilder.decimal Int
x,
        Char -> TextBuilder
TextBuilder.char Char
'.',
        Int -> TextBuilder
forall a. Integral a => a -> TextBuilder
TextBuilder.decimal Int
y,
        Char -> TextBuilder
TextBuilder.char Char
'.',
        Int -> TextBuilder
forall a. Integral a => a -> TextBuilder
TextBuilder.decimal Int
z
      ]

instance TryFrom Text Semver where
  tryFrom :: Text -> Either (TryFromException Text Semver) Semver
tryFrom =
    (Text -> Maybe Semver)
-> Text -> Either (TryFromException Text Semver) Semver
forall source target.
(source -> Maybe target)
-> source -> Either (TryFromException source target) target
maybeTryFrom (Parsec Void Text Semver -> Text -> Maybe Semver
forall e s a. (Ord e, Stream s) => Parsec e s a -> s -> Maybe a
Megaparsec.parseMaybe Parsec Void Text Semver
semverParser)

semverParser :: Megaparsec.Parsec Void Text Semver
semverParser :: Parsec Void Text Semver
semverParser = do
  x <- ParsecT Void Text Identity Int
decimalParser
  _ <- Megaparsec.char '.'
  y <- decimalParser
  _ <- Megaparsec.char '.'
  z <- decimalParser
  pure (Semver x y z)
  where
    decimalParser :: ParsecT Void Text Identity Int
decimalParser = do
      digits <- Maybe [Char]
-> (Token Text -> Bool) -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe [Char] -> (Token s -> Bool) -> m (Tokens s)
Megaparsec.takeWhile1P ([Char] -> Maybe [Char]
forall a. a -> Maybe a
Just [Char]
"decimal") Char -> Bool
Token Text -> Bool
Char.isDigit
      pure case Text.decimal digits of
        Right (Int
n, Text
_) -> Int
n
        Left [Char]
_ -> Int
0 -- impossible

-- | Though a branch name is just a flat string, we have logic that handles certain strings specially.
--
-- A branch's name indicates it is exactly one of the following:
--
--   * A contributor branch like "@arya/topic"
--   * A draft release branch like "releases/drafts/1.2.3"
--   * A release branch like "releases/1.2.3"
--   * None of the above, like "topic"
--
-- Note these classifications are only tied to the branch's (mutable) name, and are not really otherwise indicative of
-- much.
--
-- For instance,
--
--   - The existence of a local "releases/1.2.3" branch does not necessarily imply the existence of some remote release
--     version "1.2.3".
--   - The existence of a local "@arya/topic@ branch does not necessarily imply the existence of some remote "arya"
--     user made some "topic" branch at some point.
--
-- That said, we do try to make the system mostly make sense by rejecting certain inputs (e.g. you should not be able
-- to easily create a local branch called "releases/1.2.3" out of thin air; you should have to clone it from
-- somewhere). But ultimately, again, branch names are best thought of as opaque, flat strings.
data ProjectBranchNameKind
  = ProjectBranchNameKind'Contributor !Text !ProjectBranchName
  | ProjectBranchNameKind'DraftRelease !Semver
  | ProjectBranchNameKind'Release !Semver
  | ProjectBranchNameKind'NothingSpecial

-- | Classify a project branch name.
--
-- >>> classifyProjectBranchName "@arya/topic"
-- Contributor "arya" "topic"
--
-- >>> classifyProjectBranchName "releases/drafts/1.2.3"
-- DraftRelease (Semver 1 2 3)
--
-- >>> classifyProjectBranchName "releases/1.2.3"
-- Release (Semver 1 2 3)
--
-- >>> classifyProjectBranchName "topic"
-- NothingSpecial
classifyProjectBranchName :: ProjectBranchName -> ProjectBranchNameKind
classifyProjectBranchName :: ProjectBranchName -> ProjectBranchNameKind
classifyProjectBranchName (UnsafeProjectBranchName Text
branchName) =
  case ParsecT Void Text Identity StructuredProjectBranchName
-> Text -> Maybe StructuredProjectBranchName
forall e s a. (Ord e, Stream s) => Parsec e s a -> s -> Maybe a
Megaparsec.parseMaybe (Bool -> ParsecT Void Text Identity StructuredProjectBranchName
structuredProjectBranchNameParser Bool
False) Text
branchName of
    Just (StructuredProjectBranchName'Contributor TextBuilder
user TextBuilder
name) ->
      Text -> ProjectBranchName -> ProjectBranchNameKind
ProjectBranchNameKind'Contributor (TextBuilder -> Text
TextBuilder.toText TextBuilder
user) (Text -> ProjectBranchName
UnsafeProjectBranchName (TextBuilder -> Text
TextBuilder.toText TextBuilder
name))
    Just (StructuredProjectBranchName'DraftRelease Semver
ver) -> Semver -> ProjectBranchNameKind
ProjectBranchNameKind'DraftRelease Semver
ver
    Just (StructuredProjectBranchName'Release Semver
ver) -> Semver -> ProjectBranchNameKind
ProjectBranchNameKind'Release Semver
ver
    Just (StructuredProjectBranchName'NothingSpecial TextBuilder
_name) -> ProjectBranchNameKind
ProjectBranchNameKind'NothingSpecial
    Maybe StructuredProjectBranchName
Nothing -> [Char] -> ProjectBranchNameKind
forall a. HasCallStack => [Char] -> a
error ([Char] -> ShowS
reportBug [Char]
"E800424" ([Char]
"Invalid project branch name: " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> [Char]
Text.unpack Text
branchName))

-- | Get the user slug at the beginning of a project branch name, if there is one.
--
-- >>> projectBranchNameUserSlug "@arya/topic"
-- Just "arya"
--
-- >>> projectBranchNameUserSlug "topic"
-- Nothing
projectBranchNameUserSlug :: ProjectBranchName -> Maybe Text
projectBranchNameUserSlug :: ProjectBranchName -> Maybe Text
projectBranchNameUserSlug (UnsafeProjectBranchName Text
branchName) =
  if HasCallStack => Text -> Char
Text -> Char
Text.head Text
branchName Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'@'
    then Text -> Maybe Text
forall a. a -> Maybe a
Just ((Char -> Bool) -> Text -> Text
Text.takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'/') (Int -> Text -> Text
Text.drop Int
1 Text
branchName))
    else Maybe Text
forall a. Maybe a
Nothing

-- | Mangle a project branch name into a text fragment that is itself a valid project branch name.
--
-- >>> TextBuilder.toText (projectBranchNameToValidProjectBranchNameText (UnsafeProjectBranchName "@arya/topic"))
-- "arya-topic"
--
-- >>> TextBuilder.toText (projectBranchNameToValidProjectBranchNameText (UnsafeProjectBranchName "releases/drafts/1.2.3"))
-- "releases-drafts-1-2-3"
--
-- >>> TextBuilder.toText (projectBranchNameToValidProjectBranchNameText (UnsafeProjectBranchName "releases/1.2.3"))
-- "releases-1-2-3"
--
-- >>> TextBuilder.toText (projectBranchNameToValidProjectBranchNameText (UnsafeProjectBranchName "topic"))
-- "topic"
projectBranchNameToValidProjectBranchNameText :: ProjectBranchName -> TextBuilder
projectBranchNameToValidProjectBranchNameText :: ProjectBranchName -> TextBuilder
projectBranchNameToValidProjectBranchNameText ProjectBranchName
name =
  case ProjectBranchName -> ProjectBranchNameKind
classifyProjectBranchName ProjectBranchName
name of
    ProjectBranchNameKind'Contributor Text
user ProjectBranchName
name1 ->
      Text -> TextBuilder
TextBuilder.text Text
user
        TextBuilder -> TextBuilder -> TextBuilder
forall a. Semigroup a => a -> a -> a
<> Char -> TextBuilder
TextBuilder.char Char
'-'
        TextBuilder -> TextBuilder -> TextBuilder
forall a. Semigroup a => a -> a -> a
<> ProjectBranchName -> TextBuilder
projectBranchNameToValidProjectBranchNameText ProjectBranchName
name1
    ProjectBranchNameKind'DraftRelease Semver
semver -> TextBuilder
"releases-drafts-" TextBuilder -> TextBuilder -> TextBuilder
forall a. Semigroup a => a -> a -> a
<> Semver -> TextBuilder
mangleSemver Semver
semver
    ProjectBranchNameKind'Release Semver
semver -> TextBuilder
"releases-" TextBuilder -> TextBuilder -> TextBuilder
forall a. Semigroup a => a -> a -> a
<> Semver -> TextBuilder
mangleSemver Semver
semver
    ProjectBranchNameKind
ProjectBranchNameKind'NothingSpecial -> Text -> TextBuilder
TextBuilder.text (forall target source. From source target => source -> target
into @Text ProjectBranchName
name)
  where
    mangleSemver :: Semver -> TextBuilder
    mangleSemver :: Semver -> TextBuilder
mangleSemver (Semver Int
x Int
y Int
z) =
      Int -> TextBuilder
forall a. Integral a => a -> TextBuilder
TextBuilder.decimal Int
x
        TextBuilder -> TextBuilder -> TextBuilder
forall a. Semigroup a => a -> a -> a
<> Char -> TextBuilder
TextBuilder.char Char
'-'
        TextBuilder -> TextBuilder -> TextBuilder
forall a. Semigroup a => a -> a -> a
<> Int -> TextBuilder
forall a. Integral a => a -> TextBuilder
TextBuilder.decimal Int
y
        TextBuilder -> TextBuilder -> TextBuilder
forall a. Semigroup a => a -> a -> a
<> Char -> TextBuilder
TextBuilder.char Char
'-'
        TextBuilder -> TextBuilder -> TextBuilder
forall a. Semigroup a => a -> a -> a
<> Int -> TextBuilder
forall a. Integral a => a -> TextBuilder
TextBuilder.decimal Int
z

-- | A project branch name, or the latest release of its project.
data ProjectBranchNameOrLatestRelease
  = ProjectBranchNameOrLatestRelease'LatestRelease
  | ProjectBranchNameOrLatestRelease'Name !ProjectBranchName
  deriving stock (ProjectBranchNameOrLatestRelease
-> ProjectBranchNameOrLatestRelease -> Bool
(ProjectBranchNameOrLatestRelease
 -> ProjectBranchNameOrLatestRelease -> Bool)
-> (ProjectBranchNameOrLatestRelease
    -> ProjectBranchNameOrLatestRelease -> Bool)
-> Eq ProjectBranchNameOrLatestRelease
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ProjectBranchNameOrLatestRelease
-> ProjectBranchNameOrLatestRelease -> Bool
== :: ProjectBranchNameOrLatestRelease
-> ProjectBranchNameOrLatestRelease -> Bool
$c/= :: ProjectBranchNameOrLatestRelease
-> ProjectBranchNameOrLatestRelease -> Bool
/= :: ProjectBranchNameOrLatestRelease
-> ProjectBranchNameOrLatestRelease -> Bool
Eq, Int -> ProjectBranchNameOrLatestRelease -> ShowS
[ProjectBranchNameOrLatestRelease] -> ShowS
ProjectBranchNameOrLatestRelease -> [Char]
(Int -> ProjectBranchNameOrLatestRelease -> ShowS)
-> (ProjectBranchNameOrLatestRelease -> [Char])
-> ([ProjectBranchNameOrLatestRelease] -> ShowS)
-> Show ProjectBranchNameOrLatestRelease
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ProjectBranchNameOrLatestRelease -> ShowS
showsPrec :: Int -> ProjectBranchNameOrLatestRelease -> ShowS
$cshow :: ProjectBranchNameOrLatestRelease -> [Char]
show :: ProjectBranchNameOrLatestRelease -> [Char]
$cshowList :: [ProjectBranchNameOrLatestRelease] -> ShowS
showList :: [ProjectBranchNameOrLatestRelease] -> ShowS
Show)

-- | How a project branch can be specified.
data ProjectBranchSpecifier :: Type -> Type where
  -- | By name.
  ProjectBranchSpecifier'Name :: ProjectBranchSpecifier ProjectBranchName
  -- | By name, or "the latest release"
  ProjectBranchSpecifier'NameOrLatestRelease :: ProjectBranchSpecifier ProjectBranchNameOrLatestRelease

projectBranchSpecifierParser :: ProjectBranchSpecifier branch -> Megaparsec.Parsec Void Text branch
projectBranchSpecifierParser :: forall branch.
ProjectBranchSpecifier branch -> Parsec Void Text branch
projectBranchSpecifierParser = \case
  ProjectBranchSpecifier branch
ProjectBranchSpecifier'Name -> Bool -> Parsec Void Text ProjectBranchName
projectBranchNameParser Bool
False
  ProjectBranchSpecifier branch
ProjectBranchSpecifier'NameOrLatestRelease ->
    [Parsec Void Text branch] -> Parsec Void Text branch
forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum
      [ branch
ProjectBranchNameOrLatestRelease
ProjectBranchNameOrLatestRelease'LatestRelease branch
-> ParsecT Void Text Identity Text -> Parsec Void Text branch
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 Text
"releases/latest",
        ProjectBranchName -> branch
ProjectBranchName -> ProjectBranchNameOrLatestRelease
ProjectBranchNameOrLatestRelease'Name (ProjectBranchName -> branch)
-> Parsec Void Text ProjectBranchName -> Parsec Void Text branch
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bool -> Parsec Void Text ProjectBranchName
projectBranchNameParser Bool
False
      ]

instance From (ProjectAndBranch ProjectName ProjectBranchName) Text where
  from :: ProjectAndBranch ProjectName ProjectBranchName -> Text
from (ProjectAndBranch ProjectName
project ProjectBranchName
branch) =
    TextBuilder -> Text
TextBuilder.toText (TextBuilder -> Text) -> TextBuilder -> Text
forall a b. (a -> b) -> a -> b
$
      Text -> TextBuilder
TextBuilder.text (forall target source. From source target => source -> target
into @Text ProjectName
project)
        TextBuilder -> TextBuilder -> TextBuilder
forall a. Semigroup a => a -> a -> a
<> Char -> TextBuilder
TextBuilder.char Char
'/'
        TextBuilder -> TextBuilder -> TextBuilder
forall a. Semigroup a => a -> a -> a
<> Text -> TextBuilder
TextBuilder.text (forall target source. From source target => source -> target
into @Text ProjectBranchName
branch)

-- | Sometimes, it's convenient (to users) if we defer interpreting certain names (like "foo") as a project name or
-- branch name, instead leaving it up to a command handler to handle the ambiguity.
--
-- For example, we might want "switch foo" to switch to either the project "foo", or the branch "foo", or complain if
-- both exist.
--
-- This type is useful for those situtations.
data ProjectAndBranchNames
  = ProjectAndBranchNames'Ambiguous ProjectName ProjectBranchName
  | ProjectAndBranchNames'Unambiguous (These ProjectName ProjectBranchName)
  deriving stock (ProjectAndBranchNames -> ProjectAndBranchNames -> Bool
(ProjectAndBranchNames -> ProjectAndBranchNames -> Bool)
-> (ProjectAndBranchNames -> ProjectAndBranchNames -> Bool)
-> Eq ProjectAndBranchNames
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ProjectAndBranchNames -> ProjectAndBranchNames -> Bool
== :: ProjectAndBranchNames -> ProjectAndBranchNames -> Bool
$c/= :: ProjectAndBranchNames -> ProjectAndBranchNames -> Bool
/= :: ProjectAndBranchNames -> ProjectAndBranchNames -> Bool
Eq, Int -> ProjectAndBranchNames -> ShowS
[ProjectAndBranchNames] -> ShowS
ProjectAndBranchNames -> [Char]
(Int -> ProjectAndBranchNames -> ShowS)
-> (ProjectAndBranchNames -> [Char])
-> ([ProjectAndBranchNames] -> ShowS)
-> Show ProjectAndBranchNames
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ProjectAndBranchNames -> ShowS
showsPrec :: Int -> ProjectAndBranchNames -> ShowS
$cshow :: ProjectAndBranchNames -> [Char]
show :: ProjectAndBranchNames -> [Char]
$cshowList :: [ProjectAndBranchNames] -> ShowS
showList :: [ProjectAndBranchNames] -> ShowS
Show)

instance TryFrom Text ProjectAndBranchNames where
  tryFrom :: Text
-> Either
     (TryFromException Text ProjectAndBranchNames) ProjectAndBranchNames
tryFrom =
    (Text -> Maybe ProjectAndBranchNames)
-> Text
-> Either
     (TryFromException Text ProjectAndBranchNames) ProjectAndBranchNames
forall source target.
(source -> Maybe target)
-> source -> Either (TryFromException source target) target
maybeTryFrom (Parsec Void Text ProjectAndBranchNames
-> Text -> Maybe ProjectAndBranchNames
forall e s a. (Ord e, Stream s) => Parsec e s a -> s -> Maybe a
Megaparsec.parseMaybe Parsec Void Text ProjectAndBranchNames
projectAndBranchNamesParser2)

projectAndBranchNamesParser2 :: Megaparsec.Parsec Void Text ProjectAndBranchNames
projectAndBranchNamesParser2 :: Parsec Void Text ProjectAndBranchNames
projectAndBranchNamesParser2 = do
  ParsecT Void Text Identity Char
-> ParsecT Void Text Identity (Maybe Char)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (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 (Maybe Char)
-> (Maybe Char -> Parsec Void Text ProjectAndBranchNames)
-> Parsec Void Text ProjectAndBranchNames
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 Char
Nothing ->
      [Parsec Void Text ProjectAndBranchNames]
-> Parsec Void Text ProjectAndBranchNames
forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum
        [ Parsec Void Text ProjectAndBranchNames
-> Parsec Void Text ProjectAndBranchNames
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
            (project, hasTrailingSlash) <- Parsec Void Text (ProjectName, Bool)
projectNameParser
            if hasTrailingSlash
              then do
                optional (Megaparsec.lookAhead Megaparsec.anySingle) >>= \case
                  Maybe Char
Nothing -> ProjectAndBranchNames -> Parsec Void Text ProjectAndBranchNames
forall a. a -> ParsecT Void Text Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (These ProjectName ProjectBranchName -> ProjectAndBranchNames
ProjectAndBranchNames'Unambiguous (ProjectName -> These ProjectName ProjectBranchName
forall a b. a -> These a b
This ProjectName
project))
                  Just Char
nextChar
                    -- This project looks like "<name>/<digit>" so far... we want to fail here, and pick back up at
                    -- `unambiguousBranchParser` below, because a string like "releases/1.2.3" is a valid branch, and
                    -- we don't want to succeed with project name "releases" and leftovers "1.2.3"
                    --
                    -- Technically it's pointless to fall back on `unambiguousBranchParser` if the project name is not
                    -- exactly "releases", but oh well.
                    | Char -> Bool
Char.isDigit Char
nextChar -> Parsec Void Text ProjectAndBranchNames
forall a. ParsecT Void Text Identity a
forall (f :: * -> *) a. Alternative f => f a
empty
                    -- If the character after "<name>/" is the valid start of a branch, then parse a branch.
                    | Char -> Bool
Char.isAlpha Char
nextChar Bool -> Bool -> Bool
|| Char
nextChar Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'@' Bool -> Bool -> Bool
|| Char
nextChar Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'_' -> do
                        branch <- Bool -> Parsec Void Text ProjectBranchName
projectBranchNameParser Bool
False
                        pure (ProjectAndBranchNames'Unambiguous (These project branch))
                    -- Otherwise, some invalid start-of-branch character follows, like a close paren or something.
                    | Bool
otherwise -> ProjectAndBranchNames -> Parsec Void Text ProjectAndBranchNames
forall a. a -> ParsecT Void Text Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (These ProjectName ProjectBranchName -> ProjectAndBranchNames
ProjectAndBranchNames'Unambiguous (ProjectName -> These ProjectName ProjectBranchName
forall a b. a -> These a b
This ProjectName
project))
              else pure case Megaparsec.parseMaybe (projectBranchNameParser False) (into @Text project) of
                Maybe ProjectBranchName
Nothing -> These ProjectName ProjectBranchName -> ProjectAndBranchNames
ProjectAndBranchNames'Unambiguous (ProjectName -> These ProjectName ProjectBranchName
forall a b. a -> These a b
This ProjectName
project)
                Just ProjectBranchName
branch -> ProjectName -> ProjectBranchName -> ProjectAndBranchNames
ProjectAndBranchNames'Ambiguous ProjectName
project ProjectBranchName
branch,
          Parsec Void Text ProjectAndBranchNames
unambiguousBranchParser
        ]
    Just Char
_ -> Parsec Void Text ProjectAndBranchNames
unambiguousBranchParser
  where
    unambiguousBranchParser :: Parsec Void Text ProjectAndBranchNames
unambiguousBranchParser = do
      branch <- Bool -> Parsec Void Text ProjectBranchName
projectBranchNameParser Bool
False
      pure (ProjectAndBranchNames'Unambiguous (That branch))

-- TODO this should go away in favor of ProjectAndBranchNames
instance From (These ProjectName ProjectBranchName) Text where
  from :: These ProjectName ProjectBranchName -> Text
from = \case
    This ProjectName
project1 -> forall target source. From source target => source -> target
into @Text ProjectName
project1
    That ProjectBranchName
branch1 -> TextBuilder -> Text
TextBuilder.toText (Char -> TextBuilder
TextBuilder.char Char
'/' TextBuilder -> TextBuilder -> TextBuilder
forall a. Semigroup a => a -> a -> a
<> Text -> TextBuilder
TextBuilder.text (forall target source. From source target => source -> target
into @Text ProjectBranchName
branch1))
    These ProjectName
project1 ProjectBranchName
branch1 ->
      TextBuilder -> Text
TextBuilder.toText (TextBuilder -> Text) -> TextBuilder -> Text
forall a b. (a -> b) -> a -> b
$
        Text -> TextBuilder
TextBuilder.text (forall target source. From source target => source -> target
into @Text ProjectName
project1)
          TextBuilder -> TextBuilder -> TextBuilder
forall a. Semigroup a => a -> a -> a
<> Char -> TextBuilder
TextBuilder.char Char
'/'
          TextBuilder -> TextBuilder -> TextBuilder
forall a. Semigroup a => a -> a -> a
<> Text -> TextBuilder
TextBuilder.text (forall target source. From source target => source -> target
into @Text ProjectBranchName
branch1)

instance TryFrom Text (These ProjectName ProjectBranchName) where
  tryFrom :: Text
-> Either
     (TryFromException Text (These ProjectName ProjectBranchName))
     (These ProjectName ProjectBranchName)
tryFrom =
    (Text -> Maybe (These ProjectName ProjectBranchName))
-> Text
-> Either
     (TryFromException Text (These ProjectName ProjectBranchName))
     (These ProjectName ProjectBranchName)
forall source target.
(source -> Maybe target)
-> source -> Either (TryFromException source target) target
maybeTryFrom (Parsec Void Text (These ProjectName ProjectBranchName)
-> Text -> Maybe (These ProjectName ProjectBranchName)
forall e s a. (Ord e, Stream s) => Parsec e s a -> s -> Maybe a
Megaparsec.parseMaybe (ProjectBranchSpecifier ProjectBranchName
-> Parsec Void Text (These ProjectName ProjectBranchName)
forall branch.
ProjectBranchSpecifier branch
-> Parsec Void Text (These ProjectName branch)
projectAndBranchNamesParser ProjectBranchSpecifier ProjectBranchName
ProjectBranchSpecifier'Name))

-- Valid things:
--
--   1. project
--   2. project/
--   3. project/branch
--   4. /branch
projectAndBranchNamesParser ::
  forall branch.
  ProjectBranchSpecifier branch ->
  Megaparsec.Parsec Void Text (These ProjectName branch)
projectAndBranchNamesParser :: forall branch.
ProjectBranchSpecifier branch
-> Parsec Void Text (These ProjectName branch)
projectAndBranchNamesParser ProjectBranchSpecifier branch
specifier = do
  Parsec Void Text (ProjectName, Bool)
-> ParsecT Void Text Identity (Maybe (ProjectName, Bool))
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional Parsec Void Text (ProjectName, Bool)
projectNameParser ParsecT Void Text Identity (Maybe (ProjectName, Bool))
-> (Maybe (ProjectName, Bool)
    -> ParsecT Void Text Identity (These ProjectName branch))
-> ParsecT Void Text Identity (These ProjectName branch)
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 (ProjectName, Bool)
Nothing -> do
      _ <- 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
'/'
      branch <- projectBranchSpecifierParser specifier
      pure (That branch)
    Just (ProjectName
project, Bool
hasTrailingSlash) ->
      if Bool
hasTrailingSlash
        then do
          Parsec Void Text branch
-> ParsecT Void Text Identity (Maybe branch)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (ProjectBranchSpecifier branch -> Parsec Void Text branch
forall branch.
ProjectBranchSpecifier branch -> Parsec Void Text branch
projectBranchSpecifierParser ProjectBranchSpecifier branch
specifier) ParsecT Void Text Identity (Maybe branch)
-> (Maybe branch -> These ProjectName branch)
-> ParsecT Void Text Identity (These ProjectName branch)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \case
            Maybe branch
Nothing -> ProjectName -> These ProjectName branch
forall a b. a -> These a b
This ProjectName
project
            Just branch
branch -> ProjectName -> branch -> These ProjectName branch
forall a b. a -> b -> These a b
These ProjectName
project branch
branch
        else These ProjectName branch
-> ParsecT Void Text Identity (These ProjectName branch)
forall a. a -> ParsecT Void Text Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ProjectName -> These ProjectName branch
forall a b. a -> These a b
This ProjectName
project)

-- | Parse a fully specified myproject/mybranch name.
--
-- >>> import Text.Megaparsec (parseMaybe)
-- >>> parseMaybe fullyQualifiedProjectAndBranchNamesParser ("myproject/mybranch" :: Text)
-- Just (ProjectAndBranch {project = UnsafeProjectName "myproject", branch = UnsafeProjectBranchName "mybranch"})
fullyQualifiedProjectAndBranchNamesParser :: Megaparsec.Parsec Void Text (ProjectAndBranch ProjectName ProjectBranchName)
fullyQualifiedProjectAndBranchNamesParser :: Parsec Void Text (ProjectAndBranch ProjectName ProjectBranchName)
fullyQualifiedProjectAndBranchNamesParser = do
  (project, hadSlash) <- Parsec Void Text (ProjectName, Bool)
projectNameParser
  if hadSlash
    then pure ()
    else void $ Megaparsec.char '/'
  branch <- projectBranchNameParser False
  pure (ProjectAndBranch project branch)

-- | @project/branch@ syntax, where the branch is optional.
instance From (ProjectAndBranch ProjectName (Maybe ProjectBranchName)) Text where
  from :: ProjectAndBranch ProjectName (Maybe ProjectBranchName) -> Text
from = \case
    ProjectAndBranch ProjectName
project Maybe ProjectBranchName
Nothing -> forall target source. From source target => source -> target
into @Text ProjectName
project
    ProjectAndBranch ProjectName
project (Just ProjectBranchName
branch) ->
      TextBuilder -> Text
TextBuilder.toText (TextBuilder -> Text) -> TextBuilder -> Text
forall a b. (a -> b) -> a -> b
$
        Text -> TextBuilder
TextBuilder.text (forall target source. From source target => source -> target
into @Text ProjectName
project)
          TextBuilder -> TextBuilder -> TextBuilder
forall a. Semigroup a => a -> a -> a
<> Char -> TextBuilder
TextBuilder.char Char
'/'
          TextBuilder -> TextBuilder -> TextBuilder
forall a. Semigroup a => a -> a -> a
<> Text -> TextBuilder
TextBuilder.text (forall target source. From source target => source -> target
into @Text ProjectBranchName
branch)

instance TryFrom Text (ProjectAndBranch ProjectName (Maybe ProjectBranchName)) where
  tryFrom :: Text
-> Either
     (TryFromException
        Text (ProjectAndBranch ProjectName (Maybe ProjectBranchName)))
     (ProjectAndBranch ProjectName (Maybe ProjectBranchName))
tryFrom =
    (Text
 -> Maybe (ProjectAndBranch ProjectName (Maybe ProjectBranchName)))
-> Text
-> Either
     (TryFromException
        Text (ProjectAndBranch ProjectName (Maybe ProjectBranchName)))
     (ProjectAndBranch ProjectName (Maybe ProjectBranchName))
forall source target.
(source -> Maybe target)
-> source -> Either (TryFromException source target) target
maybeTryFrom (Parsec
  Void Text (ProjectAndBranch ProjectName (Maybe ProjectBranchName))
-> Text
-> Maybe (ProjectAndBranch ProjectName (Maybe ProjectBranchName))
forall e s a. (Ord e, Stream s) => Parsec e s a -> s -> Maybe a
Megaparsec.parseMaybe (ProjectBranchSpecifier ProjectBranchName
-> Parsec
     Void Text (ProjectAndBranch ProjectName (Maybe ProjectBranchName))
forall branch.
ProjectBranchSpecifier branch
-> Parsec Void Text (ProjectAndBranch ProjectName (Maybe branch))
projectAndOptionalBranchParser ProjectBranchSpecifier ProjectBranchName
ProjectBranchSpecifier'Name))

-- | Attempt to parse a project and branch name from a string where both are required.
instance TryFrom Text (ProjectAndBranch ProjectName ProjectBranchName) where
  tryFrom :: Text
-> Either
     (TryFromException
        Text (ProjectAndBranch ProjectName ProjectBranchName))
     (ProjectAndBranch ProjectName ProjectBranchName)
tryFrom =
    (Text -> Maybe (ProjectAndBranch ProjectName ProjectBranchName))
-> Text
-> Either
     (TryFromException
        Text (ProjectAndBranch ProjectName ProjectBranchName))
     (ProjectAndBranch ProjectName ProjectBranchName)
forall source target.
(source -> Maybe target)
-> source -> Either (TryFromException source target) target
maybeTryFrom ((Text -> Maybe (ProjectAndBranch ProjectName ProjectBranchName))
 -> Text
 -> Either
      (TryFromException
         Text (ProjectAndBranch ProjectName ProjectBranchName))
      (ProjectAndBranch ProjectName ProjectBranchName))
-> (Text -> Maybe (ProjectAndBranch ProjectName ProjectBranchName))
-> Text
-> Either
     (TryFromException
        Text (ProjectAndBranch ProjectName ProjectBranchName))
     (ProjectAndBranch ProjectName ProjectBranchName)
forall a b. (a -> b) -> a -> b
$ \Text
txt -> do
      ProjectAndBranch projectName mayBranchName <- Parsec
  Void Text (ProjectAndBranch ProjectName (Maybe ProjectBranchName))
-> Text
-> Maybe (ProjectAndBranch ProjectName (Maybe ProjectBranchName))
forall e s a. (Ord e, Stream s) => Parsec e s a -> s -> Maybe a
Megaparsec.parseMaybe (ProjectBranchSpecifier ProjectBranchName
-> Parsec
     Void Text (ProjectAndBranch ProjectName (Maybe ProjectBranchName))
forall branch.
ProjectBranchSpecifier branch
-> Parsec Void Text (ProjectAndBranch ProjectName (Maybe branch))
projectAndOptionalBranchParser ProjectBranchSpecifier ProjectBranchName
ProjectBranchSpecifier'Name) Text
txt
      ProjectAndBranch projectName <$> mayBranchName

instance TryFrom Text (ProjectAndBranch ProjectName (Maybe ProjectBranchNameOrLatestRelease)) where
  tryFrom :: Text
-> Either
     (TryFromException
        Text
        (ProjectAndBranch
           ProjectName (Maybe ProjectBranchNameOrLatestRelease)))
     (ProjectAndBranch
        ProjectName (Maybe ProjectBranchNameOrLatestRelease))
tryFrom =
    (Text
 -> Maybe
      (ProjectAndBranch
         ProjectName (Maybe ProjectBranchNameOrLatestRelease)))
-> Text
-> Either
     (TryFromException
        Text
        (ProjectAndBranch
           ProjectName (Maybe ProjectBranchNameOrLatestRelease)))
     (ProjectAndBranch
        ProjectName (Maybe ProjectBranchNameOrLatestRelease))
forall source target.
(source -> Maybe target)
-> source -> Either (TryFromException source target) target
maybeTryFrom (Parsec
  Void
  Text
  (ProjectAndBranch
     ProjectName (Maybe ProjectBranchNameOrLatestRelease))
-> Text
-> Maybe
     (ProjectAndBranch
        ProjectName (Maybe ProjectBranchNameOrLatestRelease))
forall e s a. (Ord e, Stream s) => Parsec e s a -> s -> Maybe a
Megaparsec.parseMaybe (ProjectBranchSpecifier ProjectBranchNameOrLatestRelease
-> Parsec
     Void
     Text
     (ProjectAndBranch
        ProjectName (Maybe ProjectBranchNameOrLatestRelease))
forall branch.
ProjectBranchSpecifier branch
-> Parsec Void Text (ProjectAndBranch ProjectName (Maybe branch))
projectAndOptionalBranchParser ProjectBranchSpecifier ProjectBranchNameOrLatestRelease
ProjectBranchSpecifier'NameOrLatestRelease))

-- Valid things:
--
--   1. project
--   2. project/
--   3. project/branch
projectAndOptionalBranchParser ::
  forall branch.
  ProjectBranchSpecifier branch ->
  Megaparsec.Parsec Void Text (ProjectAndBranch ProjectName (Maybe branch))
projectAndOptionalBranchParser :: forall branch.
ProjectBranchSpecifier branch
-> Parsec Void Text (ProjectAndBranch ProjectName (Maybe branch))
projectAndOptionalBranchParser ProjectBranchSpecifier branch
specifier = do
  (project, hasTrailingSlash) <- Parsec Void Text (ProjectName, Bool)
projectNameParser
  fmap (ProjectAndBranch project) $
    if hasTrailingSlash
      then optional (projectBranchSpecifierParser specifier)
      else pure Nothing

-- | @project/branch@ syntax, where the project is optional. The branch can optionally be preceded by a forward slash.
instance From (ProjectAndBranch (Maybe ProjectName) ProjectBranchName) Text where
  from :: ProjectAndBranch (Maybe ProjectName) ProjectBranchName -> Text
from = \case
    ProjectAndBranch Maybe ProjectName
Nothing ProjectBranchName
branch -> forall target source. From source target => source -> target
into @Text ProjectBranchName
branch
    ProjectAndBranch (Just ProjectName
project) ProjectBranchName
branch ->
      TextBuilder -> Text
TextBuilder.toText (TextBuilder -> Text) -> TextBuilder -> Text
forall a b. (a -> b) -> a -> b
$
        Text -> TextBuilder
TextBuilder.text (forall target source. From source target => source -> target
into @Text ProjectName
project)
          TextBuilder -> TextBuilder -> TextBuilder
forall a. Semigroup a => a -> a -> a
<> Char -> TextBuilder
TextBuilder.char Char
'/'
          TextBuilder -> TextBuilder -> TextBuilder
forall a. Semigroup a => a -> a -> a
<> Text -> TextBuilder
TextBuilder.text (forall target source. From source target => source -> target
into @Text ProjectBranchName
branch)

instance TryFrom Text (ProjectAndBranch (Maybe ProjectName) ProjectBranchName) where
  tryFrom :: Text
-> Either
     (TryFromException
        Text (ProjectAndBranch (Maybe ProjectName) ProjectBranchName))
     (ProjectAndBranch (Maybe ProjectName) ProjectBranchName)
tryFrom =
    (Text
 -> Maybe (ProjectAndBranch (Maybe ProjectName) ProjectBranchName))
-> Text
-> Either
     (TryFromException
        Text (ProjectAndBranch (Maybe ProjectName) ProjectBranchName))
     (ProjectAndBranch (Maybe ProjectName) ProjectBranchName)
forall source target.
(source -> Maybe target)
-> source -> Either (TryFromException source target) target
maybeTryFrom (Parsec
  Void Text (ProjectAndBranch (Maybe ProjectName) ProjectBranchName)
-> Text
-> Maybe (ProjectAndBranch (Maybe ProjectName) ProjectBranchName)
forall e s a. (Ord e, Stream s) => Parsec e s a -> s -> Maybe a
Megaparsec.parseMaybe Parsec
  Void Text (ProjectAndBranch (Maybe ProjectName) ProjectBranchName)
branchWithOptionalProjectParser)

-- Valid things:
--
--   1. branch
--   2. /branch
--   3. project/branch
branchWithOptionalProjectParser :: Megaparsec.Parsec Void Text (ProjectAndBranch (Maybe ProjectName) ProjectBranchName)
branchWithOptionalProjectParser :: Parsec
  Void Text (ProjectAndBranch (Maybe ProjectName) ProjectBranchName)
branchWithOptionalProjectParser =
  [Parsec
   Void Text (ProjectAndBranch (Maybe ProjectName) ProjectBranchName)]
-> Parsec
     Void Text (ProjectAndBranch (Maybe ProjectName) ProjectBranchName)
forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum
    [ Parsec
  Void Text (ProjectAndBranch (Maybe ProjectName) ProjectBranchName)
-> Parsec
     Void Text (ProjectAndBranch (Maybe ProjectName) ProjectBranchName)
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
        (project, hasTrailingSlash) <- Parsec Void Text (ProjectName, Bool)
projectNameParser
        guard hasTrailingSlash
        branch <- projectBranchNameParser False
        pure (ProjectAndBranch (Just project) branch),
      do
        branch <- Bool -> Parsec Void Text ProjectBranchName
projectBranchNameParser Bool
True
        pure (ProjectAndBranch Nothing branch)
    ]

------------------------------------------------------------------------------------------------------------------------

-- Projects and branches may begin with a "user slug", which looks like "@arya/". This parser parses such slugs,
-- returning just the username (e.g. "arya").
--
-- slug       = @ start-char char* /
-- start-char = alpha
-- char       = alpha | digit | -
userSlugParser :: Megaparsec.Parsec Void Text TextBuilder
userSlugParser :: ParsecT Void Text Identity TextBuilder
userSlugParser = do
  _ <- 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
'@'
  c0 <- Megaparsec.satisfy Char.isAlpha
  c1 <- Megaparsec.takeWhileP Nothing (\Token Text
c -> Char -> Bool
Char.isAlpha Char
Token Text
c Bool -> Bool -> Bool
|| Char -> Bool
Char.isDigit Char
Token Text
c Bool -> Bool -> Bool
|| Char
Token Text
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'-')
  _ <- Megaparsec.char '/'
  pure (TextBuilder.char c0 <> TextBuilder.text c1)

----

defaultBranchName :: ProjectBranchName
defaultBranchName :: ProjectBranchName
defaultBranchName = Text -> ProjectBranchName
UnsafeProjectBranchName Text
"main"