diff --git a/parser-typechecker/src/Unison/Codebase/Path.hs b/parser-typechecker/src/Unison/Codebase/Path.hs index f46934be2..47fc227da 100644 --- a/parser-typechecker/src/Unison/Codebase/Path.hs +++ b/parser-typechecker/src/Unison/Codebase/Path.hs @@ -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) = diff --git a/parser-typechecker/src/Unison/Codebase/Path/Parse.hs b/parser-typechecker/src/Unison/Codebase/Path/Parse.hs index 83782c568..1a88b95e5 100644 --- a/parser-typechecker/src/Unison/Codebase/Path/Parse.hs +++ b/parser-typechecker/src/Unison/Codebase/Path/Parse.hs @@ -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 = diff --git a/parser-typechecker/tests/Unison/Test/Codebase/Path.hs b/parser-typechecker/tests/Unison/Test/Codebase/Path.hs index fea1b787d..a79ceb2ae 100644 --- a/parser-typechecker/tests/Unison/Test/Codebase/Path.hs +++ b/parser-typechecker/tests/Unison/Test/Codebase/Path.hs @@ -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 diff --git a/unison-cli/src/Unison/Codebase/Editor/Input.hs b/unison-cli/src/Unison/Codebase/Editor/Input.hs index c851d20e3..4fc74cf42 100644 --- a/unison-cli/src/Unison/Codebase/Editor/Input.hs +++ b/unison-cli/src/Unison/Codebase/Editor/Input.hs @@ -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 diff --git a/unison-cli/src/Unison/CommandLine/BranchRelativePath.hs b/unison-cli/src/Unison/CommandLine/BranchRelativePath.hs index cbdfb3403..0bd113d29 100644 --- a/unison-cli/src/Unison/CommandLine/BranchRelativePath.hs +++ b/unison-cli/src/Unison/CommandLine/BranchRelativePath.hs @@ -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)))) diff --git a/unison-cli/src/Unison/CommandLine/InputPatterns.hs b/unison-cli/src/Unison/CommandLine/InputPatterns.hs index 8e55778ed..3b9d22d4b 100644 --- a/unison-cli/src/Unison/CommandLine/InputPatterns.hs +++ b/unison-cli/src/Unison/CommandLine/InputPatterns.hs @@ -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 ` 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) } diff --git a/unison-cli/unison/ArgParse.hs b/unison-cli/unison/ArgParse.hs index 971e289ec..43def809b 100644 --- a/unison-cli/unison/ArgParse.hs +++ b/unison-cli/unison/ArgParse.hs @@ -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 diff --git a/unison-share-api/src/Unison/Server/Orphans.hs b/unison-share-api/src/Unison/Server/Orphans.hs index 8455e265f..3478e650a 100644 --- a/unison-share-api/src/Unison/Server/Orphans.hs +++ b/unison-share-api/src/Unison/Server/Orphans.hs @@ -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." diff --git a/unison-syntax/src/Unison/Syntax/Lexer.hs b/unison-syntax/src/Unison/Syntax/Lexer.hs index 41ba07e50..b5646cb96 100644 --- a/unison-syntax/src/Unison/Syntax/Lexer.hs +++ b/unison-syntax/src/Unison/Syntax/Lexer.hs @@ -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). diff --git a/unison-syntax/src/Unison/Syntax/Name.hs b/unison-syntax/src/Unison/Syntax/Name.hs index ed17a9bc2..2d9742a78 100644 --- a/unison-syntax/src/Unison/Syntax/Name.hs +++ b/unison-syntax/src/Unison/Syntax/Name.hs @@ -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. -- diff --git a/unison-syntax/src/Unison/Syntax/NameSegment.hs b/unison-syntax/src/Unison/Syntax/NameSegment.hs index ad3641595..c0e419194 100644 --- a/unison-syntax/src/Unison/Syntax/NameSegment.hs +++ b/unison-syntax/src/Unison/Syntax/NameSegment.hs @@ -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