mirror of
https://github.com/unisonweb/unison.git
synced 2024-09-11 10:35:57 +03:00
allow pulling <project>/releases/latest
This commit is contained in:
parent
b784c9c19a
commit
8e97fc693d
@ -111,7 +111,7 @@ data ReadRemoteNamespace a
|
||||
| -- | A remote project+branch, specified by name (e.g. @unison/base/main).
|
||||
-- Currently assumed to be hosted on Share, though we could include a ShareCodeserver in here, too.
|
||||
ReadShare'ProjectBranch !a
|
||||
deriving stock (Eq, Show, Generic)
|
||||
deriving stock (Eq, Functor, Show, Generic)
|
||||
|
||||
data ReadGitRemoteNamespace = ReadGitRemoteNamespace
|
||||
{ repo :: !ReadGitRepo,
|
||||
|
@ -68,6 +68,7 @@ dependencies:
|
||||
- text-builder
|
||||
- text-rope
|
||||
- these
|
||||
- these-lens
|
||||
- time
|
||||
- transformers
|
||||
- unison-codebase
|
||||
@ -188,6 +189,7 @@ default-extensions:
|
||||
- GeneralizedNewtypeDeriving
|
||||
- ImportQualifiedPost
|
||||
- InstanceSigs
|
||||
- KindSignatures
|
||||
- LambdaCase
|
||||
- MultiParamTypeClasses
|
||||
- MultiWayIf
|
||||
|
@ -150,6 +150,7 @@ import Unison.PrettyPrintEnv.Names qualified as PPE
|
||||
import Unison.PrettyPrintEnvDecl qualified as PPE hiding (biasTo, empty)
|
||||
import Unison.PrettyPrintEnvDecl qualified as PPED
|
||||
import Unison.PrettyPrintEnvDecl.Names qualified as PPED
|
||||
import Unison.Project (ProjectBranchNameOrLatestRelease (..))
|
||||
import Unison.Reference (Reference (..), TermReference)
|
||||
import Unison.Reference qualified as Reference
|
||||
import Unison.Referent (Referent)
|
||||
@ -2466,8 +2467,8 @@ doFetchCompiler username branch =
|
||||
-- fetching info
|
||||
prj =
|
||||
These
|
||||
(unsafeFrom $ "@" <> Text.pack username <> "/internal")
|
||||
(unsafeFrom $ Text.pack branch)
|
||||
(unsafeFrom @Text $ "@" <> Text.pack username <> "/internal")
|
||||
(ProjectBranchNameOrLatestRelease'Name . unsafeFrom @Text $ Text.pack branch)
|
||||
|
||||
sourceTarget =
|
||||
PullSourceTarget2
|
||||
|
@ -49,9 +49,10 @@ import Unison.Codebase.SyncMode qualified as SyncMode
|
||||
import Unison.Codebase.Verbosity qualified as Verbosity
|
||||
import Unison.CommandLine.InputPattern qualified as InputPattern
|
||||
import Unison.CommandLine.InputPatterns qualified as InputPatterns
|
||||
import Unison.Core.Project (ProjectBranchName (UnsafeProjectBranchName))
|
||||
import Unison.NameSegment (NameSegment (..))
|
||||
import Unison.Prelude
|
||||
import Unison.Project (ProjectAndBranch (..), ProjectBranchName, ProjectName)
|
||||
import Unison.Project (ProjectAndBranch (..), ProjectBranchNameOrLatestRelease (..), ProjectName)
|
||||
import Unison.Share.API.Hash qualified as Share
|
||||
import Unison.Share.Codeserver qualified as Codeserver
|
||||
import Unison.Share.Sync qualified as Share
|
||||
@ -59,6 +60,7 @@ import Unison.Share.Sync.Types qualified as Share
|
||||
import Unison.Share.Types (codeserverBaseURL)
|
||||
import Unison.Sync.Common qualified as Common
|
||||
import Unison.Sync.Types qualified as Share
|
||||
import Witch (unsafeFrom)
|
||||
|
||||
doPullRemoteBranch :: PullSourceTarget -> SyncMode.SyncMode -> PullMode -> Verbosity.Verbosity -> Cli ()
|
||||
doPullRemoteBranch unresolvedSourceAndTarget syncMode pullMode verbosity = do
|
||||
@ -151,13 +153,53 @@ resolveImplicitSource =
|
||||
pure (ReadShare'ProjectBranch remoteBranch)
|
||||
|
||||
resolveExplicitSource ::
|
||||
ReadRemoteNamespace (These ProjectName ProjectBranchName) ->
|
||||
ReadRemoteNamespace (These ProjectName ProjectBranchNameOrLatestRelease) ->
|
||||
Cli (ReadRemoteNamespace Share.RemoteProjectBranch)
|
||||
resolveExplicitSource = \case
|
||||
ReadRemoteNamespaceGit namespace -> pure (ReadRemoteNamespaceGit namespace)
|
||||
ReadShare'LooseCode namespace -> pure (ReadShare'LooseCode namespace)
|
||||
ReadShare'ProjectBranch projectAndBranchNames ->
|
||||
ReadShare'ProjectBranch <$> ProjectUtils.expectRemoteProjectBranchByTheseNames projectAndBranchNames
|
||||
ReadShare'ProjectBranch (This remoteProjectName) -> do
|
||||
remoteProject <- ProjectUtils.expectRemoteProjectByName remoteProjectName
|
||||
let remoteProjectId = remoteProject ^. #projectId
|
||||
let remoteBranchName = unsafeFrom @Text "main"
|
||||
remoteProjectBranch <-
|
||||
ProjectUtils.expectRemoteProjectBranchByName
|
||||
(ProjectAndBranch (remoteProjectId, remoteProjectName) remoteBranchName)
|
||||
pure (ReadShare'ProjectBranch remoteProjectBranch)
|
||||
ReadShare'ProjectBranch (That branchNameOrLatestRelease) -> do
|
||||
(ProjectAndBranch localProject localBranch, _restPath) <- ProjectUtils.expectCurrentProjectBranch
|
||||
let localProjectId = localProject ^. #projectId
|
||||
let localBranchId = localBranch ^. #branchId
|
||||
Cli.runTransaction (Queries.loadRemoteProjectBranch localProjectId Share.hardCodedUri localBranchId) >>= \case
|
||||
Just (remoteProjectId, _maybeProjectBranchId) -> do
|
||||
remoteProjectName <- Cli.runTransaction (Queries.expectRemoteProjectName remoteProjectId Share.hardCodedUri)
|
||||
remoteBranchName <- resolveRemoteBranchName remoteProjectName branchNameOrLatestRelease
|
||||
remoteProjectBranch <-
|
||||
ProjectUtils.expectRemoteProjectBranchByName
|
||||
(ProjectAndBranch (remoteProjectId, remoteProjectName) remoteBranchName)
|
||||
pure (ReadShare'ProjectBranch remoteProjectBranch)
|
||||
Nothing -> do
|
||||
Cli.returnEarly $
|
||||
Output.NoAssociatedRemoteProject
|
||||
Share.hardCodedUri
|
||||
(ProjectAndBranch (localProject ^. #name) (localBranch ^. #name))
|
||||
ReadShare'ProjectBranch (These projectName branchNameOrLatestRelease) -> do
|
||||
remoteProject <- ProjectUtils.expectRemoteProjectByName projectName
|
||||
let remoteProjectId = remoteProject ^. #projectId
|
||||
branchName <- resolveRemoteBranchName projectName branchNameOrLatestRelease
|
||||
remoteProjectBranch <-
|
||||
ProjectUtils.expectRemoteProjectBranchByName
|
||||
(ProjectAndBranch (remoteProjectId, projectName) branchName)
|
||||
pure (ReadShare'ProjectBranch remoteProjectBranch)
|
||||
where
|
||||
resolveRemoteBranchName :: ProjectName -> ProjectBranchNameOrLatestRelease -> Cli ProjectBranchName
|
||||
resolveRemoteBranchName projectName = \case
|
||||
ProjectBranchNameOrLatestRelease'Name branchName -> pure branchName
|
||||
ProjectBranchNameOrLatestRelease'LatestRelease -> do
|
||||
remoteProject <- ProjectUtils.expectRemoteProjectByName projectName
|
||||
case remoteProject ^. #latestRelease of
|
||||
Nothing -> Cli.returnEarly (Output.ProjectHasNoReleases projectName)
|
||||
Just semver -> pure (UnsafeProjectBranchName ("releases/" <> into @Text semver))
|
||||
|
||||
resolveImplicitTarget :: Cli (Either Path' (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch))
|
||||
resolveImplicitTarget =
|
||||
|
@ -45,7 +45,7 @@ import Unison.HashQualified qualified as HQ
|
||||
import Unison.Name (Name)
|
||||
import Unison.NameSegment (NameSegment)
|
||||
import Unison.Prelude
|
||||
import Unison.Project (ProjectAndBranch, ProjectAndBranchNames, ProjectBranchName, ProjectName, Semver)
|
||||
import Unison.Project (ProjectAndBranch, ProjectAndBranchNames, ProjectBranchName, ProjectName, Semver, ProjectBranchNameOrLatestRelease)
|
||||
import Unison.ShortHash (ShortHash)
|
||||
import Unison.Util.Pretty qualified as P
|
||||
|
||||
@ -268,8 +268,8 @@ data GistInput = GistInput
|
||||
-- | Pull source and target: either neither is specified, or only a source, or both.
|
||||
data PullSourceTarget
|
||||
= PullSourceTarget0
|
||||
| PullSourceTarget1 (ReadRemoteNamespace (These ProjectName ProjectBranchName))
|
||||
| PullSourceTarget2 (ReadRemoteNamespace (These ProjectName ProjectBranchName)) LooseCodeOrProject
|
||||
| PullSourceTarget1 (ReadRemoteNamespace (These ProjectName ProjectBranchNameOrLatestRelease))
|
||||
| PullSourceTarget2 (ReadRemoteNamespace (These ProjectName ProjectBranchNameOrLatestRelease)) LooseCodeOrProject
|
||||
deriving stock (Eq, Show)
|
||||
|
||||
data PushSource
|
||||
|
@ -382,6 +382,7 @@ data Output
|
||||
| FetchingLatestReleaseOfBase
|
||||
| FailedToFetchLatestReleaseOfBase
|
||||
| HappyCoding
|
||||
| ProjectHasNoReleases ProjectName
|
||||
|
||||
-- | What did we create a project branch from?
|
||||
--
|
||||
@ -603,6 +604,7 @@ isFailure o = case o of
|
||||
FetchingLatestReleaseOfBase {} -> False
|
||||
FailedToFetchLatestReleaseOfBase {} -> True
|
||||
HappyCoding {} -> False
|
||||
ProjectHasNoReleases {} -> True
|
||||
|
||||
isNumberedFailure :: NumberedOutput -> Bool
|
||||
isNumberedFailure = \case
|
||||
|
@ -1,10 +1,9 @@
|
||||
module Unison.Codebase.Editor.UriParser
|
||||
( repoPath,
|
||||
( readRemoteNamespaceParser,
|
||||
writeGitRepo,
|
||||
deprecatedWriteGitRemoteNamespace,
|
||||
writeRemoteNamespace,
|
||||
writeRemoteNamespaceWith,
|
||||
parseReadRemoteNamespace,
|
||||
parseReadShareLooseCode,
|
||||
)
|
||||
where
|
||||
@ -34,7 +33,7 @@ import Unison.Codebase.Path qualified as Path
|
||||
import Unison.Codebase.ShortCausalHash (ShortCausalHash (..))
|
||||
import Unison.NameSegment (NameSegment (..))
|
||||
import Unison.Prelude
|
||||
import Unison.Project (ProjectBranchName, ProjectName, projectAndBranchNamesParser)
|
||||
import Unison.Project (ProjectBranchName, ProjectBranchSpecifier (..), ProjectName, projectAndBranchNamesParser)
|
||||
import Unison.Syntax.Lexer qualified
|
||||
import Unison.Util.Pretty qualified as P
|
||||
import Unison.Util.Pretty.MegaParsec qualified as P
|
||||
@ -59,29 +58,23 @@ type P = P.Parsec Void Text.Text
|
||||
|
||||
-- $ git clone [user@]server:project.git[:treeish][:[#hash][.path]]
|
||||
|
||||
repoPath :: P (ReadRemoteNamespace (These ProjectName ProjectBranchName))
|
||||
repoPath =
|
||||
readRemoteNamespaceParser :: ProjectBranchSpecifier branch -> P (ReadRemoteNamespace (These ProjectName branch))
|
||||
readRemoteNamespaceParser specifier =
|
||||
P.label "generic repo" $
|
||||
ReadRemoteNamespaceGit <$> readGitRemoteNamespace
|
||||
<|> ReadShare'ProjectBranch <$> projectAndBranchNamesParserInTheContextOfAlsoParsingLooseCodePaths
|
||||
<|> ReadShare'ProjectBranch <$> projectAndBranchNamesParserInTheContextOfAlsoParsingLooseCodePaths specifier
|
||||
<|> ReadShare'LooseCode <$> readShareLooseCode
|
||||
|
||||
projectAndBranchNamesParserInTheContextOfAlsoParsingLooseCodePaths :: P (These ProjectName ProjectBranchName)
|
||||
projectAndBranchNamesParserInTheContextOfAlsoParsingLooseCodePaths =
|
||||
projectAndBranchNamesParserInTheContextOfAlsoParsingLooseCodePaths ::
|
||||
ProjectBranchSpecifier branch ->
|
||||
P (These ProjectName branch)
|
||||
projectAndBranchNamesParserInTheContextOfAlsoParsingLooseCodePaths specifier =
|
||||
P.try do
|
||||
projectAndBranch <- projectAndBranchNamesParser
|
||||
projectAndBranch <- projectAndBranchNamesParser specifier
|
||||
-- we don't want to succeed parsing the 'foo' off of 'foo.bar', leaving '.bar' behind
|
||||
P.notFollowedBy (C.char '.')
|
||||
pure projectAndBranch
|
||||
|
||||
parseReadRemoteNamespace ::
|
||||
String ->
|
||||
String ->
|
||||
Either (P.Pretty P.ColorText) (ReadRemoteNamespace (These ProjectName ProjectBranchName))
|
||||
parseReadRemoteNamespace label input =
|
||||
let printError err = P.lines [P.string "I couldn't parse the repository address given above.", P.prettyPrintParseError input err]
|
||||
in first printError (P.parse repoPath label (Text.pack input))
|
||||
|
||||
parseReadShareLooseCode :: String -> String -> Either (P.Pretty P.ColorText) ReadShareLooseCode
|
||||
parseReadShareLooseCode label input =
|
||||
let printError err = P.lines [P.string "I couldn't parse this as a share path.", P.prettyPrintParseError input err]
|
||||
@ -93,7 +86,8 @@ parseReadShareLooseCode label input =
|
||||
-- Just (WriteRemoteNamespaceGit (WriteGitRemoteNamespace {repo = WriteGitRepo {url = "git@github.com:unisonweb/base", branch = Just "v3"}, path = _releases.M3}))
|
||||
writeRemoteNamespace :: P (WriteRemoteNamespace (These ProjectName ProjectBranchName))
|
||||
writeRemoteNamespace =
|
||||
writeRemoteNamespaceWith projectAndBranchNamesParserInTheContextOfAlsoParsingLooseCodePaths
|
||||
writeRemoteNamespaceWith
|
||||
(projectAndBranchNamesParserInTheContextOfAlsoParsingLooseCodePaths ProjectBranchSpecifier'Name)
|
||||
|
||||
writeRemoteNamespaceWith :: P a -> P (WriteRemoteNamespace a)
|
||||
writeRemoteNamespaceWith projectBranchParser =
|
||||
|
@ -31,9 +31,9 @@ import Unison.Codebase.Editor.Input (DeleteOutput (..), DeleteTarget (..), Input
|
||||
import Unison.Codebase.Editor.Input qualified as Input
|
||||
import Unison.Codebase.Editor.Output.PushPull (PushPull (Pull, Push))
|
||||
import Unison.Codebase.Editor.Output.PushPull qualified as PushPull
|
||||
import Unison.Codebase.Editor.RemoteRepo (WriteGitRepo, WriteRemoteNamespace)
|
||||
import Unison.Codebase.Editor.RemoteRepo (ReadRemoteNamespace, WriteGitRepo, WriteRemoteNamespace)
|
||||
import Unison.Codebase.Editor.SlurpResult qualified as SR
|
||||
import Unison.Codebase.Editor.UriParser (parseReadRemoteNamespace)
|
||||
import Unison.Codebase.Editor.UriParser (readRemoteNamespaceParser)
|
||||
import Unison.Codebase.Editor.UriParser qualified as UriParser
|
||||
import Unison.Codebase.Path qualified as Path
|
||||
import Unison.Codebase.Path.Parse qualified as Path
|
||||
@ -51,7 +51,7 @@ import Unison.JitInfo qualified as JitInfo
|
||||
import Unison.Name (Name)
|
||||
import Unison.NameSegment qualified as NameSegment
|
||||
import Unison.Prelude
|
||||
import Unison.Project (ProjectAndBranch (..), ProjectAndBranchNames (..), ProjectBranchName, ProjectName, Semver)
|
||||
import Unison.Project (ProjectAndBranch (..), ProjectAndBranchNames (..), ProjectBranchName, ProjectBranchNameOrLatestRelease (..), ProjectBranchSpecifier (..), ProjectName, Semver)
|
||||
import Unison.Syntax.HashQualified qualified as HQ (fromString)
|
||||
import Unison.Syntax.Name qualified as Name (fromText, unsafeFromString)
|
||||
import Unison.Util.ColorText qualified as CT
|
||||
@ -1234,10 +1234,10 @@ pullImpl name aliases verbosity pullMode addendum = do
|
||||
maybeToEither (I.help self) . \case
|
||||
[] -> Just $ Input.PullRemoteBranchI Input.PullSourceTarget0 SyncMode.ShortCircuit pullMode verbosity
|
||||
[sourceString] -> do
|
||||
source <- eitherToMaybe (parseReadRemoteNamespace "remote-namespace" sourceString)
|
||||
source <- parsePullSource (Text.pack sourceString)
|
||||
Just $ Input.PullRemoteBranchI (Input.PullSourceTarget1 source) SyncMode.ShortCircuit pullMode verbosity
|
||||
[sourceString, targetString] -> do
|
||||
source <- eitherToMaybe (parseReadRemoteNamespace "remote-namespace" sourceString)
|
||||
source <- parsePullSource (Text.pack sourceString)
|
||||
target <- parseLooseCodeOrProject targetString
|
||||
Just $
|
||||
Input.PullRemoteBranchI
|
||||
@ -1275,7 +1275,7 @@ pullExhaustive =
|
||||
Input.PullWithHistory
|
||||
Verbosity.Verbose
|
||||
[sourceString] -> do
|
||||
source <- eitherToMaybe (parseReadRemoteNamespace "remote-namespace" sourceString)
|
||||
source <- parsePullSource (Text.pack sourceString)
|
||||
Just $
|
||||
Input.PullRemoteBranchI
|
||||
(Input.PullSourceTarget1 source)
|
||||
@ -1283,7 +1283,7 @@ pullExhaustive =
|
||||
Input.PullWithHistory
|
||||
Verbosity.Verbose
|
||||
[sourceString, targetString] -> do
|
||||
source <- eitherToMaybe (parseReadRemoteNamespace "remote-namespace" sourceString)
|
||||
source <- parsePullSource (Text.pack sourceString)
|
||||
target <- parseLooseCodeOrProject targetString
|
||||
Just $
|
||||
Input.PullRemoteBranchI
|
||||
@ -3253,6 +3253,10 @@ projectNameArg =
|
||||
isFinished = False
|
||||
}
|
||||
|
||||
parsePullSource :: Text -> Maybe (ReadRemoteNamespace (These ProjectName ProjectBranchNameOrLatestRelease))
|
||||
parsePullSource =
|
||||
P.parseMaybe (readRemoteNamespaceParser ProjectBranchSpecifier'NameOrLatestRelease)
|
||||
|
||||
-- | Parse a 'Input.PushSource'.
|
||||
parsePushSource :: String -> Either (P.Pretty CT.ColorText) Input.PushSource
|
||||
parsePushSource sourceStr =
|
||||
|
@ -2163,6 +2163,8 @@ notifyUser dir = \case
|
||||
<> P.newline
|
||||
<> P.newline
|
||||
<> P.wrap "🎉 🥳 Happy coding!"
|
||||
ProjectHasNoReleases projectName ->
|
||||
pure . P.wrap $ prettyProjectName projectName <> "has no releases."
|
||||
where
|
||||
_nameChange _cmd _pastTenseCmd _oldName _newName _r = error "todo"
|
||||
|
||||
@ -2781,7 +2783,7 @@ renderEditConflicts ppe Patch {..} = do
|
||||
then "deprecated and also replaced with"
|
||||
else "replaced with"
|
||||
)
|
||||
`P.hang` P.lines replacements
|
||||
`P.hang` P.lines replacements
|
||||
formatTermEdits ::
|
||||
(Reference.TermReference, Set TermEdit.TermEdit) ->
|
||||
Numbered Pretty
|
||||
@ -2796,7 +2798,7 @@ renderEditConflicts ppe Patch {..} = do
|
||||
then "deprecated and also replaced with"
|
||||
else "replaced with"
|
||||
)
|
||||
`P.hang` P.lines replacements
|
||||
`P.hang` P.lines replacements
|
||||
formatConflict ::
|
||||
Either
|
||||
(Reference, Set TypeEdit.TypeEdit)
|
||||
|
@ -12,13 +12,14 @@ import Unison.Codebase.Path qualified as Path
|
||||
import Unison.Codebase.ShortCausalHash (ShortCausalHash (..))
|
||||
import Unison.Core.Project (ProjectBranchName (..), ProjectName (..))
|
||||
import Unison.NameSegment (NameSegment (..))
|
||||
import Unison.Project (ProjectBranchSpecifier (..))
|
||||
|
||||
test :: Test ()
|
||||
test =
|
||||
scope "uriparser" . tests $
|
||||
[ parserTests
|
||||
"repoPath"
|
||||
(UriParser.repoPath <* P.eof)
|
||||
(UriParser.readRemoteNamespaceParser ProjectBranchSpecifier'Name <* P.eof)
|
||||
[ ("unisonweb.base._releases.M4", looseR "unisonweb" ["base", "_releases", "M4"]),
|
||||
("project", branchR (This "project")),
|
||||
("/branch", branchR (That "branch")),
|
||||
|
@ -136,6 +136,7 @@ library
|
||||
GeneralizedNewtypeDeriving
|
||||
ImportQualifiedPost
|
||||
InstanceSigs
|
||||
KindSignatures
|
||||
LambdaCase
|
||||
MultiParamTypeClasses
|
||||
MultiWayIf
|
||||
@ -208,6 +209,7 @@ library
|
||||
, text-builder
|
||||
, text-rope
|
||||
, these
|
||||
, these-lens
|
||||
, time
|
||||
, transformers
|
||||
, unison-codebase
|
||||
@ -266,6 +268,7 @@ executable cli-integration-tests
|
||||
GeneralizedNewtypeDeriving
|
||||
ImportQualifiedPost
|
||||
InstanceSigs
|
||||
KindSignatures
|
||||
LambdaCase
|
||||
MultiParamTypeClasses
|
||||
MultiWayIf
|
||||
@ -343,6 +346,7 @@ executable cli-integration-tests
|
||||
, text-builder
|
||||
, text-rope
|
||||
, these
|
||||
, these-lens
|
||||
, time
|
||||
, transformers
|
||||
, unison-codebase
|
||||
@ -396,6 +400,7 @@ executable transcripts
|
||||
GeneralizedNewtypeDeriving
|
||||
ImportQualifiedPost
|
||||
InstanceSigs
|
||||
KindSignatures
|
||||
LambdaCase
|
||||
MultiParamTypeClasses
|
||||
MultiWayIf
|
||||
@ -472,6 +477,7 @@ executable transcripts
|
||||
, text-builder
|
||||
, text-rope
|
||||
, these
|
||||
, these-lens
|
||||
, time
|
||||
, transformers
|
||||
, unison-cli
|
||||
@ -531,6 +537,7 @@ executable unison
|
||||
GeneralizedNewtypeDeriving
|
||||
ImportQualifiedPost
|
||||
InstanceSigs
|
||||
KindSignatures
|
||||
LambdaCase
|
||||
MultiParamTypeClasses
|
||||
MultiWayIf
|
||||
@ -608,6 +615,7 @@ executable unison
|
||||
, text-builder
|
||||
, text-rope
|
||||
, these
|
||||
, these-lens
|
||||
, time
|
||||
, transformers
|
||||
, unison-cli
|
||||
@ -670,6 +678,7 @@ test-suite cli-tests
|
||||
GeneralizedNewtypeDeriving
|
||||
ImportQualifiedPost
|
||||
InstanceSigs
|
||||
KindSignatures
|
||||
LambdaCase
|
||||
MultiParamTypeClasses
|
||||
MultiWayIf
|
||||
@ -747,6 +756,7 @@ test-suite cli-tests
|
||||
, text-builder
|
||||
, text-rope
|
||||
, these
|
||||
, these-lens
|
||||
, time
|
||||
, transformers
|
||||
, unison-cli
|
||||
|
@ -65,8 +65,10 @@ default-extensions:
|
||||
- DoAndIfThenElse
|
||||
- FlexibleContexts
|
||||
- FlexibleInstances
|
||||
- GADTs
|
||||
- GeneralizedNewtypeDeriving
|
||||
- ImportQualifiedPost
|
||||
- KindSignatures
|
||||
- LambdaCase
|
||||
- MultiParamTypeClasses
|
||||
- NamedFieldPuns
|
||||
|
@ -12,6 +12,8 @@ module Unison.Project
|
||||
projectBranchNameUserSlug,
|
||||
ProjectBranchNameKind (..),
|
||||
classifyProjectBranchName,
|
||||
ProjectBranchNameOrLatestRelease (..),
|
||||
ProjectBranchSpecifier (..),
|
||||
ProjectAndBranch (..),
|
||||
projectAndBranchNamesParser,
|
||||
ProjectAndBranchNames (..),
|
||||
@ -23,6 +25,7 @@ module Unison.Project
|
||||
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 (..))
|
||||
@ -271,6 +274,19 @@ projectBranchNameUserSlug (UnsafeProjectBranchName branchName) =
|
||||
then Just (Text.takeWhile (/= '/') (Text.drop 1 branchName))
|
||||
else Nothing
|
||||
|
||||
-- | A project branch name, or the latest release of its project.
|
||||
data ProjectBranchNameOrLatestRelease
|
||||
= ProjectBranchNameOrLatestRelease'LatestRelease
|
||||
| ProjectBranchNameOrLatestRelease'Name !ProjectBranchName
|
||||
deriving stock (Eq, 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
|
||||
|
||||
instance From (ProjectAndBranch ProjectName ProjectBranchName) Text where
|
||||
from (ProjectAndBranch project branch) =
|
||||
Text.Builder.run $
|
||||
@ -343,7 +359,7 @@ instance From (These ProjectName ProjectBranchName) Text where
|
||||
|
||||
instance TryFrom Text (These ProjectName ProjectBranchName) where
|
||||
tryFrom =
|
||||
maybeTryFrom (Megaparsec.parseMaybe projectAndBranchNamesParser)
|
||||
maybeTryFrom (Megaparsec.parseMaybe (projectAndBranchNamesParser ProjectBranchSpecifier'Name))
|
||||
|
||||
-- Valid things:
|
||||
--
|
||||
@ -351,20 +367,33 @@ instance TryFrom Text (These ProjectName ProjectBranchName) where
|
||||
-- 2. project/
|
||||
-- 3. project/branch
|
||||
-- 4. /branch
|
||||
projectAndBranchNamesParser :: Megaparsec.Parsec Void Text (These ProjectName ProjectBranchName)
|
||||
projectAndBranchNamesParser = do
|
||||
projectAndBranchNamesParser ::
|
||||
forall branch.
|
||||
ProjectBranchSpecifier branch ->
|
||||
Megaparsec.Parsec Void Text (These ProjectName branch)
|
||||
projectAndBranchNamesParser specifier = do
|
||||
optional projectNameParser >>= \case
|
||||
Nothing -> do
|
||||
_ <- Megaparsec.char '/'
|
||||
branch <- projectBranchNameParser False
|
||||
branch <- branchParser
|
||||
pure (That branch)
|
||||
Just (project, hasTrailingSlash) ->
|
||||
if hasTrailingSlash
|
||||
then do
|
||||
optional (projectBranchNameParser False) <&> \case
|
||||
optional branchParser <&> \case
|
||||
Nothing -> This project
|
||||
Just branch -> These project branch
|
||||
else pure (This project)
|
||||
where
|
||||
branchParser :: Megaparsec.Parsec Void Text branch
|
||||
branchParser =
|
||||
case specifier of
|
||||
ProjectBranchSpecifier'Name -> projectBranchNameParser False
|
||||
ProjectBranchSpecifier'NameOrLatestRelease ->
|
||||
asum
|
||||
[ ProjectBranchNameOrLatestRelease'LatestRelease <$ "releases/latest",
|
||||
ProjectBranchNameOrLatestRelease'Name <$> projectBranchNameParser False
|
||||
]
|
||||
|
||||
-- | @project/branch@ syntax, where the branch is optional.
|
||||
instance From (ProjectAndBranch ProjectName (Maybe ProjectBranchName)) Text where
|
||||
|
@ -71,8 +71,10 @@ library
|
||||
DoAndIfThenElse
|
||||
FlexibleContexts
|
||||
FlexibleInstances
|
||||
GADTs
|
||||
GeneralizedNewtypeDeriving
|
||||
ImportQualifiedPost
|
||||
KindSignatures
|
||||
LambdaCase
|
||||
MultiParamTypeClasses
|
||||
NamedFieldPuns
|
||||
@ -132,8 +134,10 @@ test-suite tests
|
||||
DoAndIfThenElse
|
||||
FlexibleContexts
|
||||
FlexibleInstances
|
||||
GADTs
|
||||
GeneralizedNewtypeDeriving
|
||||
ImportQualifiedPost
|
||||
KindSignatures
|
||||
LambdaCase
|
||||
MultiParamTypeClasses
|
||||
NamedFieldPuns
|
||||
|
Loading…
Reference in New Issue
Block a user