mirror of
https://github.com/unisonweb/unison.git
synced 2024-09-20 06:47:15 +03:00
use name parser in parseSplit'
This commit is contained in:
Mitchell Rosen
parent
81e4ebe013
commit
3677c6bfbb
@ -65,6 +65,7 @@ module Unison.Codebase.Path
|
||||
|
||||
-- * things that could be replaced with `Parse` instances
|
||||
splitFromName,
|
||||
splitFromName',
|
||||
hqSplitFromName',
|
||||
|
||||
-- * things that could be replaced with `Cons` instances
|
||||
@ -256,9 +257,19 @@ hqSplitFromName' = fmap (fmap HQ'.fromName) . Lens.unsnoc . fromName'
|
||||
-- >>> splitFromName "foo"
|
||||
-- (,foo)
|
||||
splitFromName :: Name -> Split
|
||||
splitFromName name =
|
||||
splitFromName =
|
||||
over _1 fromPath' . splitFromName'
|
||||
|
||||
splitFromName' :: Name -> Split'
|
||||
splitFromName' name =
|
||||
case Name.reverseSegments name of
|
||||
(seg :| pathSegments) -> (fromList $ reverse pathSegments, seg)
|
||||
(seg :| pathSegments) ->
|
||||
let path = fromList (reverse pathSegments)
|
||||
in ( if Name.isAbsolute name
|
||||
then AbsolutePath' (Absolute path)
|
||||
else RelativePath' (Relative path),
|
||||
seg
|
||||
)
|
||||
|
||||
-- | Remove a path prefix from a name.
|
||||
-- Returns 'Nothing' if there are no remaining segments to construct the name from.
|
||||
@ -522,7 +533,8 @@ instance Convert HQSplit (HQ'.HashQualified Path) where convert = unsplitHQ
|
||||
|
||||
instance Convert HQSplit' (HQ'.HashQualified Path') where convert = unsplitHQ'
|
||||
|
||||
instance Convert Name Split where convert = splitFromName
|
||||
instance Convert Name Split where
|
||||
convert = splitFromName
|
||||
|
||||
instance Convert (path, NameSegment) (path, HQ'.HQSegment) where
|
||||
convert (path, name) =
|
||||
|
||||
@ -3,18 +3,15 @@
|
||||
module Unison.Codebase.Path.Parse
|
||||
( parsePath',
|
||||
parseSplit',
|
||||
definitionNameSegment,
|
||||
parseHQSplit,
|
||||
parseHQSplit',
|
||||
parseShortHashOrHQSplit',
|
||||
wordyNameSegment,
|
||||
)
|
||||
where
|
||||
|
||||
import Control.Lens (over, _1)
|
||||
import Control.Lens qualified as Lens
|
||||
import Data.List.Extra (stripPrefix)
|
||||
import Data.List.NonEmpty qualified as List.NonEmpty
|
||||
import Data.Text qualified as Text
|
||||
import Text.Megaparsec qualified as P
|
||||
import Unison.Codebase.Path
|
||||
@ -26,20 +23,12 @@ import Unison.ShortHash (ShortHash)
|
||||
import Unison.ShortHash qualified as SH
|
||||
import Unison.Syntax.Lexer qualified as Lexer
|
||||
import Unison.Syntax.Name qualified as Name
|
||||
import Unison.Syntax.NameSegment qualified as NameSegment (renderParseErr)
|
||||
|
||||
-- .libs.blah.poo is Absolute
|
||||
-- libs.blah.poo is Relative
|
||||
-- Left is some parse error tbd
|
||||
parsePath' :: String -> Either String Path'
|
||||
parsePath' :: String -> Either Text Path'
|
||||
parsePath' = \case
|
||||
"." -> Right absoluteEmpty'
|
||||
path ->
|
||||
case P.runParser (Name.nameP <* P.eof) "" path of
|
||||
Left err -> Left (renderErr err)
|
||||
Right name -> Right (fromName' name)
|
||||
where
|
||||
renderErr =
|
||||
P.parseErrorTextPretty . P.mapParseError Lexer.payload . List.NonEmpty.head . P.bundleErrors
|
||||
path -> unsplit' <$> parseSplit' path
|
||||
|
||||
-- implementation detail of parsePath' and parseSplit'
|
||||
-- foo.bar.baz.34 becomes `Right (foo.bar.baz, "34")
|
||||
@ -100,17 +89,11 @@ definitionNameSegment s = wordyNameSegment s <> symbolyNameSegment s <> unit s
|
||||
Right (a, rem) ->
|
||||
Left $ "trailing characters after " <> show a <> ": " <> show rem
|
||||
|
||||
-- parseSplit' wordyNameSegment "foo.bar.baz" returns Right (foo.bar, baz)
|
||||
-- parseSplit' wordyNameSegment "foo.bar.+" returns Left err
|
||||
-- parseSplit' definitionNameSegment "foo.bar.+" returns Right (foo.bar, +)
|
||||
parseSplit' ::
|
||||
(String -> Either String NameSegment) ->
|
||||
String ->
|
||||
Either String Split'
|
||||
parseSplit' lastSegment p = do
|
||||
(p', rem) <- parsePathImpl' p
|
||||
seg <- lastSegment rem
|
||||
pure (p', seg)
|
||||
parseSplit' :: String -> Either Text Split'
|
||||
parseSplit' path = do
|
||||
case P.runParser (Name.nameP <* P.eof) "" path of
|
||||
Left err -> Left (NameSegment.renderParseErr err)
|
||||
Right name -> Right (splitFromName' name)
|
||||
|
||||
parseShortHashOrHQSplit' :: String -> Either String (Either ShortHash HQSplit')
|
||||
parseShortHashOrHQSplit' s =
|
||||
|
||||
@ -4,34 +4,17 @@ module Unison.Test.Codebase.Path where
|
||||
|
||||
import Data.Maybe (fromJust)
|
||||
import EasyTest
|
||||
import Unison.Codebase.Path
|
||||
import Unison.Codebase.Path.Parse
|
||||
import Unison.Codebase.Path (Path (..), Path' (..), Relative (..))
|
||||
import Unison.Codebase.Path.Parse (parseHQSplit', parseShortHashOrHQSplit')
|
||||
import Unison.HashQualified' qualified as HQ'
|
||||
import Unison.NameSegment
|
||||
import Unison.NameSegment (NameSegment (..))
|
||||
import Unison.Prelude
|
||||
import Unison.ShortHash qualified as SH
|
||||
|
||||
test :: Test ()
|
||||
test =
|
||||
scope "path" . tests $
|
||||
[ scope "parseSplit'" . tests $
|
||||
[ scope "wordyNameSegment" . tests $
|
||||
[ let s = "foo.bar.baz"
|
||||
in scope s . expect $
|
||||
parseSplit' wordyNameSegment s == Right (relative ["foo", "bar"], NameSegment "baz"),
|
||||
let s = "foo.bar.baz#abc" in scope s . expect $ isLeft $ parseSplit' wordyNameSegment s,
|
||||
let s = "foo.bar.+"
|
||||
in scope s . expect $
|
||||
isLeft $
|
||||
parseSplit' wordyNameSegment s
|
||||
],
|
||||
scope "definitionNameSegment" . tests $
|
||||
[ let s = "foo.bar.+"
|
||||
in scope s . expect $
|
||||
parseSplit' definitionNameSegment s == Right (relative ["foo", "bar"], NameSegment "+")
|
||||
]
|
||||
],
|
||||
scope "parseShortHashOrHQSplit'" . tests $
|
||||
[ scope "parseShortHashOrHQSplit'" . tests $
|
||||
[ let s = "foo.bar#34"
|
||||
in scope s . expect $
|
||||
parseShortHashOrHQSplit' s
|
||||
|
||||
@ -34,7 +34,7 @@ import Data.Text qualified as Text
|
||||
import Data.These (These)
|
||||
import U.Codebase.HashTags (CausalHash)
|
||||
import Unison.Codebase.Branch.Merge qualified as Branch
|
||||
import Unison.Codebase.Editor.RemoteRepo
|
||||
import Unison.Codebase.Editor.RemoteRepo (ReadRemoteNamespace, WriteGitRepo, WriteRemoteNamespace)
|
||||
import Unison.Codebase.Path (Path')
|
||||
import Unison.Codebase.Path qualified as Path
|
||||
import Unison.Codebase.Path.Parse qualified as Path
|
||||
@ -42,8 +42,8 @@ import Unison.Codebase.PushBehavior (PushBehavior)
|
||||
import Unison.Codebase.ShortCausalHash (ShortCausalHash)
|
||||
import Unison.Codebase.ShortCausalHash qualified as SCH
|
||||
import Unison.Codebase.SyncMode (SyncMode)
|
||||
import Unison.Codebase.Verbosity
|
||||
import Unison.CommandLine.BranchRelativePath
|
||||
import Unison.Codebase.Verbosity (Verbosity)
|
||||
import Unison.CommandLine.BranchRelativePath (BranchRelativePath, parseBranchRelativePath)
|
||||
import Unison.HashQualified qualified as HQ
|
||||
import Unison.Name (Name)
|
||||
import Unison.NameSegment (NameSegment)
|
||||
@ -82,7 +82,7 @@ type HashOrHQSplit' = Either ShortHash Path.HQSplit'
|
||||
data Insistence = Force | Try
|
||||
deriving (Show, Eq)
|
||||
|
||||
parseBranchId :: String -> Either String BranchId
|
||||
parseBranchId :: String -> Either Text BranchId
|
||||
parseBranchId ('#' : s) = case SCH.fromText (Text.pack s) of
|
||||
Nothing -> Left "Invalid hash, expected a base32hex string."
|
||||
Just h -> pure $ Left h
|
||||
|
||||
@ -131,5 +131,6 @@ branchRelativePathParser =
|
||||
_ <- Megaparsec.char ':'
|
||||
That <$> relPath
|
||||
|
||||
failureAt :: forall a. Int -> String -> Megaparsec.Parsec Void Text a
|
||||
failureAt offset str = Megaparsec.parseError (Megaparsec.FancyError offset (Set.singleton (Megaparsec.ErrorFail str)))
|
||||
failureAt :: forall a. Int -> Text -> Megaparsec.Parsec Void Text a
|
||||
failureAt offset str =
|
||||
Megaparsec.parseError (Megaparsec.FancyError offset (Set.singleton (Megaparsec.ErrorFail (Text.unpack str))))
|
||||
|
||||
@ -61,6 +61,7 @@ import Unison.Project (ProjectAndBranch (..), ProjectAndBranchNames (..), Projec
|
||||
import Unison.Project.Util (ProjectContext (..), projectContextFromPath)
|
||||
import Unison.Syntax.HashQualified qualified as HQ (fromString)
|
||||
import Unison.Syntax.Name qualified as Name (fromText, unsafeFromString)
|
||||
import Unison.Syntax.NameSegment qualified as NameSegment (renderParseErr, segmentP)
|
||||
import Unison.Util.ColorText qualified as CT
|
||||
import Unison.Util.Monoid (intercalateMap)
|
||||
import Unison.Util.Pretty qualified as P
|
||||
@ -152,8 +153,8 @@ todo =
|
||||
]
|
||||
)
|
||||
( \case
|
||||
patchStr : ws -> mapLeft (warn . fromString) $ do
|
||||
patch <- Path.parseSplit' Path.definitionNameSegment patchStr
|
||||
patchStr : ws -> mapLeft (warn . P.text) $ do
|
||||
patch <- Path.parseSplit' patchStr
|
||||
branch <- case ws of
|
||||
[] -> pure Path.relativeEmpty'
|
||||
[pathStr] -> Path.parsePath' pathStr
|
||||
@ -315,9 +316,7 @@ updateOld =
|
||||
)
|
||||
\case
|
||||
patchStr : ws -> do
|
||||
patch <-
|
||||
first fromString $
|
||||
Path.parseSplit' Path.definitionNameSegment patchStr
|
||||
patch <- first P.text $ Path.parseSplit' patchStr
|
||||
pure $
|
||||
Input.UpdateI
|
||||
(Input.UsePatch patch)
|
||||
@ -365,8 +364,8 @@ patch =
|
||||
]
|
||||
)
|
||||
\case
|
||||
patchStr : ws -> first fromString $ do
|
||||
patch <- Path.parseSplit' Path.definitionNameSegment patchStr
|
||||
patchStr : ws -> first P.text do
|
||||
patch <- Path.parseSplit' patchStr
|
||||
branch <- case ws of
|
||||
[pathStr] -> Path.parsePath' pathStr
|
||||
_ -> pure Path.relativeEmpty'
|
||||
@ -500,7 +499,7 @@ ui =
|
||||
help = P.wrap "`ui` opens the Local UI in the default browser.",
|
||||
parse = \case
|
||||
[] -> pure $ Input.UiI Path.relativeEmpty'
|
||||
[path] -> first fromString $ do
|
||||
[path] -> first P.text $ do
|
||||
p <- Path.parsePath' path
|
||||
pure $ Input.UiI p
|
||||
_ -> Left (I.help ui)
|
||||
@ -641,7 +640,7 @@ findShallow =
|
||||
)
|
||||
( \case
|
||||
[] -> pure $ Input.FindShallowI Path.relativeEmpty'
|
||||
[path] -> first fromString $ do
|
||||
[path] -> first P.text $ do
|
||||
p <- Path.parsePath' path
|
||||
pure $ Input.FindShallowI p
|
||||
_ -> Left (I.help findShallow)
|
||||
@ -694,9 +693,9 @@ renameTerm =
|
||||
]
|
||||
"`move.term foo bar` renames `foo` to `bar`."
|
||||
( \case
|
||||
[oldName, newName] -> first fromString $ do
|
||||
src <- Path.parseHQSplit' oldName
|
||||
target <- Path.parseSplit' Path.definitionNameSegment newName
|
||||
[oldName, newName] -> first P.text do
|
||||
src <- mapLeft Text.pack (Path.parseHQSplit' oldName)
|
||||
target <- Path.parseSplit' newName
|
||||
pure $ Input.MoveTermI src target
|
||||
_ ->
|
||||
Left . P.warnCallout $
|
||||
@ -715,7 +714,7 @@ moveAll =
|
||||
]
|
||||
"`move foo bar` renames the term, type, and namespace foo to bar."
|
||||
( \case
|
||||
[oldName, newName] -> first fromString $ do
|
||||
[oldName, newName] -> first P.text $ do
|
||||
src <- Path.parsePath' oldName
|
||||
target <- Path.parsePath' newName
|
||||
pure $ Input.MoveAllI src target
|
||||
@ -736,9 +735,9 @@ renameType =
|
||||
]
|
||||
"`move.type foo bar` renames `foo` to `bar`."
|
||||
( \case
|
||||
[oldName, newName] -> first fromString $ do
|
||||
src <- Path.parseHQSplit' oldName
|
||||
target <- Path.parseSplit' Path.definitionNameSegment newName
|
||||
[oldName, newName] -> first P.text do
|
||||
src <- mapLeft Text.pack (Path.parseHQSplit' oldName)
|
||||
target <- Path.parseSplit' newName
|
||||
pure $ Input.MoveTypeI src target
|
||||
_ ->
|
||||
Left . P.warnCallout $
|
||||
@ -833,10 +832,7 @@ deleteReplacement isTerm =
|
||||
)
|
||||
( \case
|
||||
query : patch -> do
|
||||
patch <-
|
||||
first fromString
|
||||
. traverse (Path.parseSplit' Path.definitionNameSegment)
|
||||
$ listToMaybe patch
|
||||
patch <- first P.text . traverse Path.parseSplit' $ listToMaybe patch
|
||||
q <- parseHashQualifiedName query
|
||||
pure $ input q patch
|
||||
_ ->
|
||||
@ -919,9 +915,9 @@ aliasTerm =
|
||||
[("term to alias", Required, exactDefinitionTermQueryArg), ("alias name", Required, newNameArg)]
|
||||
"`alias.term foo bar` introduces `bar` with the same definition as `foo`."
|
||||
( \case
|
||||
[oldName, newName] -> first fromString $ do
|
||||
source <- Path.parseShortHashOrHQSplit' oldName
|
||||
target <- Path.parseSplit' Path.definitionNameSegment newName
|
||||
[oldName, newName] -> first P.text do
|
||||
source <- mapLeft Text.pack (Path.parseShortHashOrHQSplit' oldName)
|
||||
target <- Path.parseSplit' newName
|
||||
pure $ Input.AliasTermI source target
|
||||
_ ->
|
||||
Left . warn $
|
||||
@ -938,9 +934,9 @@ aliasType =
|
||||
[("type to alias", Required, exactDefinitionTypeQueryArg), ("alias name", Required, newNameArg)]
|
||||
"`alias.type Foo Bar` introduces `Bar` with the same definition as `Foo`."
|
||||
( \case
|
||||
[oldName, newName] -> first fromString $ do
|
||||
source <- Path.parseShortHashOrHQSplit' oldName
|
||||
target <- Path.parseSplit' Path.definitionNameSegment newName
|
||||
[oldName, newName] -> first P.text do
|
||||
source <- mapLeft Text.pack (Path.parseShortHashOrHQSplit' oldName)
|
||||
target <- Path.parseSplit' newName
|
||||
pure $ Input.AliasTypeI source target
|
||||
_ ->
|
||||
Left . warn $
|
||||
@ -965,8 +961,8 @@ aliasMany =
|
||||
]
|
||||
)
|
||||
( \case
|
||||
srcs@(_ : _) Cons.:> dest -> first fromString $ do
|
||||
sourceDefinitions <- traverse Path.parseHQSplit srcs
|
||||
srcs@(_ : _) Cons.:> dest -> first P.text do
|
||||
sourceDefinitions <- mapLeft Text.pack (traverse Path.parseHQSplit srcs)
|
||||
destNamespace <- Path.parsePath' dest
|
||||
pure $ Input.AliasManyI sourceDefinitions destNamespace
|
||||
_ -> Left (I.help aliasMany)
|
||||
@ -1013,7 +1009,7 @@ cd =
|
||||
)
|
||||
( \case
|
||||
[".."] -> Right Input.UpI
|
||||
[p] -> first fromString $ do
|
||||
[p] -> first P.text do
|
||||
p <- Path.parsePath' p
|
||||
pure . Input.SwitchBranchI $ p
|
||||
_ -> Left (I.help cd)
|
||||
@ -1066,8 +1062,8 @@ deleteNamespaceParser helpText insistence =
|
||||
first fromString
|
||||
. pure
|
||||
$ Input.DeleteI (DeleteTarget'Namespace insistence Nothing)
|
||||
[p] -> first fromString $ do
|
||||
p <- Path.parseSplit' Path.definitionNameSegment p
|
||||
[p] -> first P.text do
|
||||
p <- Path.parseSplit' p
|
||||
pure $ Input.DeleteI (DeleteTarget'Namespace insistence (Just p))
|
||||
_ -> Left helpText
|
||||
)
|
||||
@ -1081,22 +1077,22 @@ deletePatch =
|
||||
[("patch to delete", Required, patchArg)]
|
||||
"`delete.patch <foo>` deletes the patch `foo`"
|
||||
( \case
|
||||
[p] -> first fromString $ do
|
||||
p <- Path.parseSplit' Path.definitionNameSegment p
|
||||
[p] -> first P.text do
|
||||
p <- Path.parseSplit' p
|
||||
pure . Input.DeleteI $ DeleteTarget'Patch p
|
||||
_ -> Left (I.help deletePatch)
|
||||
)
|
||||
|
||||
movePatch :: String -> String -> Either (P.Pretty CT.ColorText) Input
|
||||
movePatch src dest = first fromString $ do
|
||||
src <- Path.parseSplit' Path.definitionNameSegment src
|
||||
dest <- Path.parseSplit' Path.definitionNameSegment dest
|
||||
movePatch src dest = first P.text do
|
||||
src <- Path.parseSplit' src
|
||||
dest <- Path.parseSplit' dest
|
||||
pure $ Input.MovePatchI src dest
|
||||
|
||||
copyPatch' :: String -> String -> Either (P.Pretty CT.ColorText) Input
|
||||
copyPatch' src dest = first fromString $ do
|
||||
src <- Path.parseSplit' Path.definitionNameSegment src
|
||||
dest <- Path.parseSplit' Path.definitionNameSegment dest
|
||||
copyPatch' src dest = first P.text do
|
||||
src <- Path.parseSplit' src
|
||||
dest <- Path.parseSplit' dest
|
||||
pure $ Input.CopyPatchI src dest
|
||||
|
||||
copyPatch :: InputPattern
|
||||
@ -1134,7 +1130,7 @@ renameBranch =
|
||||
[("namespace to move", Required, namespaceArg), ("new location", Required, newNameArg)]
|
||||
"`move.namespace foo bar` renames the path `foo` to `bar`."
|
||||
( \case
|
||||
[src, dest] -> first fromString $ do
|
||||
[src, dest] -> first P.text do
|
||||
src <- Path.parsePath' src
|
||||
dest <- Path.parsePath' dest
|
||||
pure $ Input.MoveBranchI src dest
|
||||
@ -1158,7 +1154,7 @@ history =
|
||||
]
|
||||
)
|
||||
( \case
|
||||
[src] -> first fromString $ do
|
||||
[src] -> first P.text do
|
||||
p <- Input.parseBranchId src
|
||||
pure $ Input.HistoryI (Just 10) (Just 10) p
|
||||
[] -> pure $ Input.HistoryI (Just 10) (Just 10) (Right Path.currentPath)
|
||||
@ -1262,7 +1258,7 @@ resetRoot =
|
||||
]
|
||||
)
|
||||
( \case
|
||||
[src] -> first fromString $ do
|
||||
[src] -> first P.text $ do
|
||||
src <- Input.parseBranchId src
|
||||
pure $ Input.ResetRootI src
|
||||
_ -> Left (I.help resetRoot)
|
||||
@ -1732,11 +1728,11 @@ diffNamespace =
|
||||
]
|
||||
)
|
||||
( \case
|
||||
[before, after] -> first fromString $ do
|
||||
[before, after] -> first P.text do
|
||||
before <- Input.parseBranchId before
|
||||
after <- Input.parseBranchId after
|
||||
pure $ Input.DiffNamespaceI before after
|
||||
[before] -> first fromString $ do
|
||||
[before] -> first P.text do
|
||||
before <- Input.parseBranchId before
|
||||
pure $ Input.DiffNamespaceI before (Right Path.currentPath)
|
||||
_ -> Left $ I.help diffNamespace
|
||||
@ -1812,10 +1808,7 @@ replaceEdit f = self
|
||||
)
|
||||
( \case
|
||||
source : target : patch -> do
|
||||
patch <-
|
||||
first fromString
|
||||
<$> traverse (Path.parseSplit' Path.definitionNameSegment)
|
||||
$ listToMaybe patch
|
||||
patch <- first P.text <$> traverse Path.parseSplit' $ listToMaybe patch
|
||||
sourcehq <- parseHashQualifiedName source
|
||||
targethq <- parseHashQualifiedName target
|
||||
pure $ f sourcehq targethq patch
|
||||
@ -2136,8 +2129,8 @@ viewPatch =
|
||||
)
|
||||
( \case
|
||||
[] -> Right $ Input.ListEditsI Nothing
|
||||
[patchStr] -> mapLeft fromString $ do
|
||||
patch <- Path.parseSplit' Path.definitionNameSegment patchStr
|
||||
[patchStr] -> mapLeft P.text do
|
||||
patch <- Path.parseSplit' patchStr
|
||||
Right $ Input.ListEditsI (Just patch)
|
||||
_ -> Left $ warn "`view.patch` takes a patch and that's it."
|
||||
)
|
||||
@ -2195,7 +2188,7 @@ namespaceDependencies =
|
||||
[("namespace", Optional, namespaceArg)]
|
||||
"List the external dependencies of the specified namespace."
|
||||
( \case
|
||||
[p] -> first fromString $ do
|
||||
[p] -> first P.text do
|
||||
p <- Path.parsePath' p
|
||||
pure $ Input.NamespaceDependenciesI (Just p)
|
||||
[] -> pure (Input.NamespaceDependenciesI Nothing)
|
||||
@ -2334,12 +2327,11 @@ docsToHtml =
|
||||
)
|
||||
]
|
||||
)
|
||||
( \case
|
||||
[namespacePath, destinationFilePath] -> first fromString $ do
|
||||
np <- Path.parsePath' namespacePath
|
||||
pure $ Input.DocsToHtmlI np destinationFilePath
|
||||
_ -> Left $ showPatternHelp docsToHtml
|
||||
)
|
||||
\case
|
||||
[namespacePath, destinationFilePath] -> first P.text do
|
||||
np <- Path.parsePath' namespacePath
|
||||
pure $ Input.DocsToHtmlI np destinationFilePath
|
||||
_ -> Left $ showPatternHelp docsToHtml
|
||||
|
||||
docToMarkdown :: InputPattern
|
||||
docToMarkdown =
|
||||
@ -2354,12 +2346,11 @@ docToMarkdown =
|
||||
)
|
||||
]
|
||||
)
|
||||
( \case
|
||||
[docNameText] -> first fromString $ do
|
||||
docName <- maybeToEither "Invalid name" . Name.fromText . Text.pack $ docNameText
|
||||
pure $ Input.DocToMarkdownI docName
|
||||
_ -> Left $ showPatternHelp docToMarkdown
|
||||
)
|
||||
\case
|
||||
[docNameText] -> first fromString $ do
|
||||
docName <- maybeToEither "Invalid name" . Name.fromText . Text.pack $ docNameText
|
||||
pure $ Input.DocToMarkdownI docName
|
||||
_ -> Left $ showPatternHelp docToMarkdown
|
||||
|
||||
execute :: InputPattern
|
||||
execute =
|
||||
@ -2377,11 +2368,10 @@ execute =
|
||||
)
|
||||
]
|
||||
)
|
||||
( \case
|
||||
[w] -> pure $ Input.ExecuteI w []
|
||||
(w : ws) -> pure $ Input.ExecuteI w ws
|
||||
_ -> Left $ showPatternHelp execute
|
||||
)
|
||||
\case
|
||||
[w] -> pure $ Input.ExecuteI w []
|
||||
(w : ws) -> pure $ Input.ExecuteI w ws
|
||||
_ -> Left $ showPatternHelp execute
|
||||
|
||||
saveExecuteResult :: InputPattern
|
||||
saveExecuteResult =
|
||||
@ -2393,10 +2383,9 @@ saveExecuteResult =
|
||||
( "`add.run name` adds to the codebase the result of the most recent `run` command"
|
||||
<> "as `name`."
|
||||
)
|
||||
( \case
|
||||
[w] -> pure $ Input.SaveExecuteResultI (Name.unsafeFromString w)
|
||||
_ -> Left $ showPatternHelp saveExecuteResult
|
||||
)
|
||||
\case
|
||||
[w] -> pure $ Input.SaveExecuteResultI (Name.unsafeFromString w)
|
||||
_ -> Left $ showPatternHelp saveExecuteResult
|
||||
|
||||
ioTest :: InputPattern
|
||||
ioTest =
|
||||
@ -2449,11 +2438,10 @@ makeStandalone =
|
||||
)
|
||||
]
|
||||
)
|
||||
( \case
|
||||
[main, file] ->
|
||||
Input.MakeStandaloneI file <$> parseHashQualifiedName main
|
||||
_ -> Left $ showPatternHelp makeStandalone
|
||||
)
|
||||
\case
|
||||
[main, file] ->
|
||||
Input.MakeStandaloneI file <$> parseHashQualifiedName main
|
||||
_ -> Left $ showPatternHelp makeStandalone
|
||||
|
||||
runScheme :: InputPattern
|
||||
runScheme =
|
||||
@ -2468,10 +2456,9 @@ runScheme =
|
||||
)
|
||||
]
|
||||
)
|
||||
( \case
|
||||
(main : args) -> Right $ Input.ExecuteSchemeI main args
|
||||
_ -> Left $ showPatternHelp runScheme
|
||||
)
|
||||
\case
|
||||
(main : args) -> Right $ Input.ExecuteSchemeI main args
|
||||
_ -> Left $ showPatternHelp runScheme
|
||||
|
||||
compileScheme :: InputPattern
|
||||
compileScheme =
|
||||
@ -2488,11 +2475,10 @@ compileScheme =
|
||||
)
|
||||
]
|
||||
)
|
||||
( \case
|
||||
[main, file] ->
|
||||
Input.CompileSchemeI file <$> parseHashQualifiedName main
|
||||
_ -> Left $ showPatternHelp compileScheme
|
||||
)
|
||||
\case
|
||||
[main, file] ->
|
||||
Input.CompileSchemeI file <$> parseHashQualifiedName main
|
||||
_ -> Left $ showPatternHelp compileScheme
|
||||
|
||||
schemeLibgen :: InputPattern
|
||||
schemeLibgen =
|
||||
@ -2515,11 +2501,10 @@ schemeLibgen =
|
||||
)
|
||||
]
|
||||
)
|
||||
( \case
|
||||
[] -> pure $ Input.GenSchemeLibsI Nothing
|
||||
[dir] -> pure . Input.GenSchemeLibsI $ Just dir
|
||||
_ -> Left $ showPatternHelp schemeLibgen
|
||||
)
|
||||
\case
|
||||
[] -> pure $ Input.GenSchemeLibsI Nothing
|
||||
[dir] -> pure . Input.GenSchemeLibsI $ Just dir
|
||||
_ -> Left $ showPatternHelp schemeLibgen
|
||||
|
||||
fetchScheme :: InputPattern
|
||||
fetchScheme =
|
||||
@ -2552,16 +2537,15 @@ fetchScheme =
|
||||
)
|
||||
]
|
||||
)
|
||||
( \case
|
||||
[] -> pure (Input.FetchSchemeCompilerI "unison" JitInfo.currentRelease)
|
||||
[name] -> pure (Input.FetchSchemeCompilerI name branch)
|
||||
where
|
||||
branch
|
||||
| name == "unison" = JitInfo.currentRelease
|
||||
| otherwise = "main"
|
||||
[name, branch] -> pure (Input.FetchSchemeCompilerI name branch)
|
||||
_ -> Left $ showPatternHelp fetchScheme
|
||||
)
|
||||
\case
|
||||
[] -> pure (Input.FetchSchemeCompilerI "unison" JitInfo.currentRelease)
|
||||
[name] -> pure (Input.FetchSchemeCompilerI name branch)
|
||||
where
|
||||
branch
|
||||
| name == "unison" = JitInfo.currentRelease
|
||||
| otherwise = "main"
|
||||
[name, branch] -> pure (Input.FetchSchemeCompilerI name branch)
|
||||
_ -> Left $ showPatternHelp fetchScheme
|
||||
|
||||
createAuthor :: InputPattern
|
||||
createAuthor =
|
||||
@ -2582,8 +2566,10 @@ createAuthor =
|
||||
)
|
||||
)
|
||||
( \case
|
||||
symbolStr : authorStr@(_ : _) -> first fromString $ do
|
||||
symbol <- Path.definitionNameSegment symbolStr
|
||||
symbolStr : authorStr@(_ : _) -> first fromString do
|
||||
symbol <-
|
||||
Megaparsec.runParser (NameSegment.segmentP <* Megaparsec.eof) "" symbolStr
|
||||
& mapLeft (Text.unpack . NameSegment.renderParseErr)
|
||||
-- let's have a real parser in not too long
|
||||
let author :: Text
|
||||
author = Text.pack $ case (unwords authorStr) of
|
||||
@ -2663,10 +2649,10 @@ diffNamespaceToPatch =
|
||||
help = P.wrap "Create a patch from a namespace diff.",
|
||||
parse = \case
|
||||
[branchId1, branchId2, patch] ->
|
||||
mapLeft fromString do
|
||||
mapLeft P.text do
|
||||
branchId1 <- Input.parseBranchId branchId1
|
||||
branchId2 <- Input.parseBranchId branchId2
|
||||
patch <- Path.parseSplit' Path.definitionNameSegment patch
|
||||
patch <- Path.parseSplit' patch
|
||||
pure (Input.DiffNamespaceToPatchI Input.DiffNamespaceToPatchInput {branchId1, branchId2, patch})
|
||||
_ -> Left (showPatternHelp diffNamespaceToPatch)
|
||||
}
|
||||
|
||||
@ -1,7 +1,4 @@
|
||||
{-# LANGUAGE ApplicativeDo #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE ViewPatterns #-}
|
||||
|
||||
-- | This module handles parsing CLI arguments into 'Command's.
|
||||
-- See the excellent documentation at https://hackage.haskell.org/package/optparse-applicative
|
||||
@ -13,6 +10,7 @@ import Data.Functor ((<&>))
|
||||
import Data.List qualified as List
|
||||
import Data.List.NonEmpty (NonEmpty)
|
||||
import Data.List.NonEmpty qualified as NE
|
||||
import Data.Text qualified as Text
|
||||
import Options.Applicative
|
||||
( CommandFields,
|
||||
Mod,
|
||||
@ -450,7 +448,7 @@ readPath' :: ReadM Path.Path'
|
||||
readPath' = do
|
||||
strPath <- OptParse.str
|
||||
case Path.parsePath' strPath of
|
||||
Left err -> OptParse.readerError err
|
||||
Left err -> OptParse.readerError (Text.unpack err)
|
||||
Right path' -> pure path'
|
||||
|
||||
fileArgument :: String -> Parser FilePath
|
||||
|
||||
@ -234,7 +234,7 @@ instance ToJSON ConstructorType where
|
||||
|
||||
instance FromHttpApiData Path.Relative where
|
||||
parseUrlPiece txt = case Path.parsePath' (Text.unpack txt) of
|
||||
Left s -> Left (Text.pack s)
|
||||
Left s -> Left s
|
||||
Right (Path.RelativePath' p) -> Right p
|
||||
Right (Path.AbsolutePath' _) -> Left $ "Expected relative path, but " <> txt <> " was absolute."
|
||||
|
||||
@ -243,7 +243,7 @@ instance ToHttpApiData Path.Relative where
|
||||
|
||||
instance FromHttpApiData Path.Absolute where
|
||||
parseUrlPiece txt = case Path.parsePath' (Text.unpack txt) of
|
||||
Left s -> Left (Text.pack s)
|
||||
Left s -> Left s
|
||||
Right (Path.RelativePath' _) -> Left $ "Expected absolute path, but " <> txt <> " was relative."
|
||||
Right (Path.AbsolutePath' p) -> Right p
|
||||
|
||||
@ -251,14 +251,14 @@ instance ToHttpApiData Path.Absolute where
|
||||
toUrlPiece = tShow
|
||||
|
||||
instance FromHttpApiData Path.Path' where
|
||||
parseUrlPiece txt = mapLeft Text.pack $ Path.parsePath' (Text.unpack txt)
|
||||
parseUrlPiece txt = Path.parsePath' (Text.unpack txt)
|
||||
|
||||
instance ToHttpApiData Path.Path' where
|
||||
toUrlPiece = tShow
|
||||
|
||||
instance FromHttpApiData Path.Path where
|
||||
parseUrlPiece txt = case Path.parsePath' (Text.unpack txt) of
|
||||
Left s -> Left (Text.pack s)
|
||||
Left s -> Left s
|
||||
Right (Path.RelativePath' p) -> Right (Path.unrelative p)
|
||||
Right (Path.AbsolutePath' _) -> Left $ "Expected relative path, but " <> txt <> " was absolute."
|
||||
|
||||
|
||||
@ -55,9 +55,9 @@ import Unison.ShortHash (ShortHash)
|
||||
import Unison.ShortHash qualified as SH
|
||||
import Unison.Syntax.HashQualified' qualified as HQ' (toString)
|
||||
import Unison.Syntax.Lexer.Token (Token (..), posP, tokenP)
|
||||
import Unison.Syntax.Name qualified as Name (ParseErr (..), isSymboly, nameP, toText, unsafeFromString)
|
||||
import Unison.Syntax.Name qualified as Name (isSymboly, nameP, toText, unsafeFromString)
|
||||
import Unison.Syntax.NameSegment (symbolyIdChar, wordyIdChar, wordyIdStartChar)
|
||||
import Unison.Syntax.NameSegment qualified as NameSegment (wordyP)
|
||||
import Unison.Syntax.NameSegment qualified as NameSegment (ParseErr(..), wordyP)
|
||||
import Unison.Syntax.ReservedWords (keywords, reservedOperators, typeModifiers, typeOrAbility)
|
||||
import Unison.Util.Bytes qualified as Bytes
|
||||
import Unison.Util.Monoid (intercalateMap)
|
||||
@ -1042,15 +1042,15 @@ tok p = do
|
||||
identifierP :: P (HQ'.HashQualified Name)
|
||||
identifierP = do
|
||||
P.label "identifier (ex: abba1, snake_case, .foo.++#xyz, or 🌻)" do
|
||||
name <- PI.withParsecT (fmap nameParseErrToErr) Name.nameP
|
||||
name <- PI.withParsecT (fmap nameSegmentParseErrToErr) Name.nameP
|
||||
P.optional shorthashP <&> \case
|
||||
Nothing -> HQ'.fromName name
|
||||
Just shorthash -> HQ'.HashQualified name shorthash
|
||||
where
|
||||
nameParseErrToErr :: Name.ParseErr -> Err
|
||||
nameParseErrToErr = \case
|
||||
Name.ReservedOperator s -> ReservedSymbolyId (Text.unpack s)
|
||||
Name.ReservedWord s -> ReservedWordyId (Text.unpack s)
|
||||
nameSegmentParseErrToErr :: NameSegment.ParseErr -> Err
|
||||
nameSegmentParseErrToErr = \case
|
||||
NameSegment.ReservedOperator s -> ReservedSymbolyId (Text.unpack s)
|
||||
NameSegment.ReservedWord s -> ReservedWordyId (Text.unpack s)
|
||||
|
||||
-- An identifier is a non-empty dot-delimited list of segments, with an optional leading dot, where each segment is
|
||||
-- symboly (comprised of only symbols) or wordy (comprised of only alphanums).
|
||||
|
||||
@ -13,7 +13,6 @@ module Unison.Syntax.Name
|
||||
toVar,
|
||||
|
||||
-- * Name parsers
|
||||
ParseErr (..),
|
||||
nameP,
|
||||
|
||||
-- * Name classifiers
|
||||
@ -31,7 +30,6 @@ import Data.Text.Lazy.Builder qualified as Text.Builder
|
||||
import Text.Megaparsec (ParsecT)
|
||||
import Text.Megaparsec qualified as P
|
||||
import Text.Megaparsec.Char qualified as P
|
||||
import Text.Megaparsec.Internal qualified as P (withParsecT)
|
||||
import Unison.Name qualified as Name (fromSegments, lastSegment, makeAbsolute)
|
||||
import Unison.Name.Internal (Name (Name))
|
||||
import Unison.NameSegment (NameSegment (NameSegment))
|
||||
@ -40,7 +38,7 @@ import Unison.Position (Position (..))
|
||||
import Unison.Prelude
|
||||
import Unison.Syntax.Lexer.Token (Token)
|
||||
import Unison.Syntax.NameSegment (segmentStartChar)
|
||||
import Unison.Syntax.NameSegment qualified as NameSegment (isSymboly, symbolyP, wordyP)
|
||||
import Unison.Syntax.NameSegment qualified as NameSegment (ParseErr, isSymboly, segmentP)
|
||||
import Unison.Var (Var)
|
||||
import Unison.Var qualified as Var
|
||||
|
||||
@ -137,31 +135,13 @@ unsafeFromVar =
|
||||
------------------------------------------------------------------------------------------------------------------------
|
||||
-- Name parsers
|
||||
|
||||
data ParseErr
|
||||
= ReservedOperator !Text
|
||||
| ReservedWord !Text
|
||||
deriving stock (Eq, Ord)
|
||||
|
||||
instance P.ShowErrorComponent ParseErr where
|
||||
showErrorComponent = \case
|
||||
ReservedOperator s -> Text.unpack ("reserved operator: " <> s)
|
||||
ReservedWord s -> Text.unpack ("reserved word: " <> s)
|
||||
errorComponentLen = \case
|
||||
ReservedOperator s -> Text.length s
|
||||
ReservedWord s -> Text.length s
|
||||
|
||||
nameP :: forall m. Monad m => ParsecT (Token ParseErr) [Char] m Name
|
||||
nameP :: forall m. Monad m => ParsecT (Token NameSegment.ParseErr) [Char] m Name
|
||||
nameP =
|
||||
P.try do
|
||||
leadingDot <- isJust <$> P.optional (P.char '.')
|
||||
name <- Name.fromSegments <$> Monad.sepBy1 segmentP separatorP
|
||||
name <- Name.fromSegments <$> Monad.sepBy1 NameSegment.segmentP separatorP
|
||||
pure (if leadingDot then Name.makeAbsolute name else name)
|
||||
where
|
||||
segmentP :: ParsecT (Token ParseErr) [Char] m NameSegment
|
||||
segmentP =
|
||||
P.withParsecT (fmap ReservedOperator) NameSegment.symbolyP
|
||||
<|> P.withParsecT (fmap ReservedWord) NameSegment.wordyP
|
||||
|
||||
-- The separator between segments is just a dot, but we don't want to commit to parsing another segment unless the
|
||||
-- character after the dot can begin a segment.
|
||||
--
|
||||
|
||||
@ -7,8 +7,11 @@ module Unison.Syntax.NameSegment
|
||||
isSymboly,
|
||||
|
||||
-- * Name segment classifiers
|
||||
segmentP,
|
||||
symbolyP,
|
||||
wordyP,
|
||||
ParseErr (..),
|
||||
renderParseErr,
|
||||
|
||||
-- * Character classifiers
|
||||
segmentStartChar,
|
||||
@ -19,11 +22,13 @@ module Unison.Syntax.NameSegment
|
||||
where
|
||||
|
||||
import Data.Char qualified as Char
|
||||
import Data.List.NonEmpty qualified as List.NonEmpty
|
||||
import Data.Set qualified as Set
|
||||
import Data.Text qualified as Text
|
||||
import Text.Megaparsec (ParsecT)
|
||||
import Text.Megaparsec qualified as P
|
||||
import Text.Megaparsec.Char qualified as P
|
||||
import Text.Megaparsec.Internal qualified as P (withParsecT)
|
||||
import Unison.NameSegment (NameSegment (..))
|
||||
import Unison.Prelude
|
||||
import Unison.Syntax.Lexer.Token (Token (..), posP)
|
||||
@ -40,6 +45,11 @@ unsafeFromText =
|
||||
------------------------------------------------------------------------------------------------------------------------
|
||||
-- Name segment parsers
|
||||
|
||||
segmentP :: Monad m => ParsecT (Token ParseErr) [Char] m NameSegment
|
||||
segmentP =
|
||||
P.withParsecT (fmap ReservedOperator) symbolyP
|
||||
<|> P.withParsecT (fmap ReservedWord) wordyP
|
||||
|
||||
-- | A symboly name segment parser, which consists only of symboly characters.
|
||||
--
|
||||
-- A symboly name segment can optionally be escaped by surrounding it with backticks. Thus, there are two different
|
||||
@ -97,6 +107,24 @@ wordyP = do
|
||||
where
|
||||
wordyMsg = "identifier (ex: abba1, snake_case, .foo.bar#xyz, or 🌻)"
|
||||
|
||||
data ParseErr
|
||||
= ReservedOperator !Text
|
||||
| ReservedWord !Text
|
||||
deriving stock (Eq, Ord)
|
||||
|
||||
instance P.ShowErrorComponent ParseErr where
|
||||
showErrorComponent = \case
|
||||
ReservedOperator s -> Text.unpack ("reserved operator: " <> s)
|
||||
ReservedWord s -> Text.unpack ("reserved word: " <> s)
|
||||
errorComponentLen = \case
|
||||
ReservedOperator s -> Text.length s
|
||||
ReservedWord s -> Text.length s
|
||||
|
||||
-- | A convenience function for rendering a name segment parse error, because it's so weird and verbose to do so.
|
||||
renderParseErr :: P.ParseErrorBundle [Char] (Token ParseErr) -> Text
|
||||
renderParseErr =
|
||||
Text.pack . P.parseErrorTextPretty . P.mapParseError payload . List.NonEmpty.head . P.bundleErrors
|
||||
|
||||
------------------------------------------------------------------------------------------------------------------------
|
||||
-- Character classifiers
|
||||
|
||||
|
||||
Loading…
Reference in New Issue
Block a user