use name parser in parseSplit'

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) =

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
+parsePath' :: String -> Either Text Path'
--- libs.blah.poo is Relative
--- Left is some parse error tbd
-parsePath' :: String -> Either String Path'
 parsePath' = \case
   "." -> Right absoluteEmpty'
-  path ->
+  path -> unsplit' <$> parseSplit' 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
 
 -- 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' :: String -> Either Text Split'
--- parseSplit' wordyNameSegment "foo.bar.+" returns Left err
+parseSplit' path = do
--- parseSplit' definitionNameSegment "foo.bar.+" returns Right (foo.bar, +)
+  case P.runParser (Name.nameP <* P.eof) "" path of
-parseSplit' ::
+    Left err -> Left (NameSegment.renderParseErr err)
-  (String -> Either String NameSegment) ->
+    Right name -> Right (splitFromName' name)
-  String ->
-  Either String Split'
-parseSplit' lastSegment p = do
-  (p', rem) <- parsePathImpl' p
-  seg <- lastSegment rem
-  pure (p', seg)
 
 parseShortHashOrHQSplit' :: String -> Either String (Either ShortHash HQSplit')
 parseShortHashOrHQSplit' s =

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 (Path (..), Path' (..), Relative (..))
-import Unison.Codebase.Path.Parse
+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 "parseShortHashOrHQSplit'" . 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 $
         [ let s = "foo.bar#34"
            in scope s . expect $
                 parseShortHashOrHQSplit' s

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.Codebase.Verbosity (Verbosity)
-import Unison.CommandLine.BranchRelativePath
+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

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 :: forall a. Int -> Text -> Megaparsec.Parsec Void Text a
-    failureAt offset str = Megaparsec.parseError (Megaparsec.FancyError offset (Set.singleton (Megaparsec.ErrorFail str)))
+    failureAt offset str =
+      Megaparsec.parseError (Megaparsec.FancyError offset (Set.singleton (Megaparsec.ErrorFail (Text.unpack str))))

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
+        patchStr : ws -> mapLeft (warn . P.text) $ do
-          patch <- Path.parseSplit' Path.definitionNameSegment patchStr
+          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 <-
+        patch <- first P.text $ Path.parseSplit' patchStr
-          first fromString $
-            Path.parseSplit' Path.definitionNameSegment patchStr
         pure $
           Input.UpdateI
             (Input.UsePatch patch)
@@ -365,8 +364,8 @@ patch =
         ]
     )
     \case
-      patchStr : ws -> first fromString $ do
+      patchStr : ws -> first P.text do
-        patch <- Path.parseSplit' Path.definitionNameSegment patchStr
+        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
+        [oldName, newName] -> first P.text do
-          src <- Path.parseHQSplit' oldName
+          src <- mapLeft Text.pack (Path.parseHQSplit' oldName)
-          target <- Path.parseSplit' Path.definitionNameSegment newName
+          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
+        [oldName, newName] -> first P.text do
-          src <- Path.parseHQSplit' oldName
+          src <- mapLeft Text.pack (Path.parseHQSplit' oldName)
-          target <- Path.parseSplit' Path.definitionNameSegment newName
+          target <- Path.parseSplit' newName
           pure $ Input.MoveTypeI src target
         _ ->
           Left . P.warnCallout $
@@ -833,10 +832,7 @@ deleteReplacement isTerm =
     )
     ( \case
         query : patch -> do
-          patch <-
+          patch <- first P.text . traverse Path.parseSplit' $ listToMaybe patch
-            first fromString
-              . traverse (Path.parseSplit' Path.definitionNameSegment)
-              $ 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
+        [oldName, newName] -> first P.text do
-          source <- Path.parseShortHashOrHQSplit' oldName
+          source <- mapLeft Text.pack (Path.parseShortHashOrHQSplit' oldName)
-          target <- Path.parseSplit' Path.definitionNameSegment newName
+          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
+        [oldName, newName] -> first P.text do
-          source <- Path.parseShortHashOrHQSplit' oldName
+          source <- mapLeft Text.pack (Path.parseShortHashOrHQSplit' oldName)
-          target <- Path.parseSplit' Path.definitionNameSegment newName
+          target <- Path.parseSplit' newName
           pure $ Input.AliasTypeI source target
         _ ->
           Left . warn $
@@ -965,8 +961,8 @@ aliasMany =
         ]
     )
     ( \case
-        srcs@(_ : _) Cons.:> dest -> first fromString $ do
+        srcs@(_ : _) Cons.:> dest -> first P.text do
-          sourceDefinitions <- traverse Path.parseHQSplit srcs
+          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] -> first P.text do
-        p <- Path.parseSplit' Path.definitionNameSegment p
+        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] -> first P.text do
-          p <- Path.parseSplit' Path.definitionNameSegment p
+          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
+movePatch src dest = first P.text do
-  src <- Path.parseSplit' Path.definitionNameSegment src
+  src <- Path.parseSplit' src
-  dest <- Path.parseSplit' Path.definitionNameSegment dest
+  dest <- Path.parseSplit' dest
   pure $ Input.MovePatchI src dest
 
 copyPatch' :: String -> String -> Either (P.Pretty CT.ColorText) Input
-copyPatch' src dest = first fromString $ do
+copyPatch' src dest = first P.text do
-  src <- Path.parseSplit' Path.definitionNameSegment src
+  src <- Path.parseSplit' src
-  dest <- Path.parseSplit' Path.definitionNameSegment dest
+  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 <-
+              patch <- first P.text <$> traverse Path.parseSplit' $ listToMaybe patch
-                first fromString
-                  <$> traverse (Path.parseSplit' Path.definitionNameSegment)
-                  $ 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
+        [patchStr] -> mapLeft P.text do
-          patch <- Path.parseSplit' Path.definitionNameSegment patchStr
+          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
+    \case
-        [namespacePath, destinationFilePath] -> first fromString $ do
+      [namespacePath, destinationFilePath] -> first P.text do
-          np <- Path.parsePath' namespacePath
+        np <- Path.parsePath' namespacePath
-          pure $ Input.DocsToHtmlI np destinationFilePath
+        pure $ Input.DocsToHtmlI np destinationFilePath
-        _ -> Left $ showPatternHelp docsToHtml
+      _ -> Left $ showPatternHelp docsToHtml
-    )
 
 docToMarkdown :: InputPattern
 docToMarkdown =
@@ -2354,12 +2346,11 @@ docToMarkdown =
           )
         ]
     )
-    ( \case
+    \case
-        [docNameText] -> first fromString $ do
+      [docNameText] -> first fromString $ do
-          docName <- maybeToEither "Invalid name" . Name.fromText . Text.pack $ docNameText
+        docName <- maybeToEither "Invalid name" . Name.fromText . Text.pack $ docNameText
-          pure $ Input.DocToMarkdownI docName
+        pure $ Input.DocToMarkdownI docName
-        _ -> Left $ showPatternHelp docToMarkdown
+      _ -> Left $ showPatternHelp docToMarkdown
-    )
 
 execute :: InputPattern
 execute =
@@ -2377,11 +2368,10 @@ execute =
           )
         ]
     )
-    ( \case
+    \case
-        [w] -> pure $ Input.ExecuteI w []
+      [w] -> pure $ Input.ExecuteI w []
-        (w : ws) -> pure $ Input.ExecuteI w ws
+      (w : ws) -> pure $ Input.ExecuteI w ws
-        _ -> Left $ showPatternHelp execute
+      _ -> 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
+    \case
-        [w] -> pure $ Input.SaveExecuteResultI (Name.unsafeFromString w)
+      [w] -> pure $ Input.SaveExecuteResultI (Name.unsafeFromString w)
-        _ -> Left $ showPatternHelp saveExecuteResult
+      _ -> Left $ showPatternHelp saveExecuteResult
-    )
 
 ioTest :: InputPattern
 ioTest =
@@ -2449,11 +2438,10 @@ makeStandalone =
           )
         ]
     )
-    ( \case
+    \case
-        [main, file] ->
+      [main, file] ->
-          Input.MakeStandaloneI file <$> parseHashQualifiedName main
+        Input.MakeStandaloneI file <$> parseHashQualifiedName main
-        _ -> Left $ showPatternHelp makeStandalone
+      _ -> Left $ showPatternHelp makeStandalone
-    )
 
 runScheme :: InputPattern
 runScheme =
@@ -2468,10 +2456,9 @@ runScheme =
           )
         ]
     )
-    ( \case
+    \case
-        (main : args) -> Right $ Input.ExecuteSchemeI main args
+      (main : args) -> Right $ Input.ExecuteSchemeI main args
-        _ -> Left $ showPatternHelp runScheme
+      _ -> Left $ showPatternHelp runScheme
-    )
 
 compileScheme :: InputPattern
 compileScheme =
@@ -2488,11 +2475,10 @@ compileScheme =
           )
         ]
     )
-    ( \case
+    \case
-        [main, file] ->
+      [main, file] ->
-          Input.CompileSchemeI file <$> parseHashQualifiedName main
+        Input.CompileSchemeI file <$> parseHashQualifiedName main
-        _ -> Left $ showPatternHelp compileScheme
+      _ -> Left $ showPatternHelp compileScheme
-    )
 
 schemeLibgen :: InputPattern
 schemeLibgen =
@@ -2515,11 +2501,10 @@ schemeLibgen =
           )
         ]
     )
-    ( \case
+    \case
-        [] -> pure $ Input.GenSchemeLibsI Nothing
+      [] -> pure $ Input.GenSchemeLibsI Nothing
-        [dir] -> pure . Input.GenSchemeLibsI $ Just dir
+      [dir] -> pure . Input.GenSchemeLibsI $ Just dir
-        _ -> Left $ showPatternHelp schemeLibgen
+      _ -> Left $ showPatternHelp schemeLibgen
-    )
 
 fetchScheme :: InputPattern
 fetchScheme =
@@ -2552,16 +2537,15 @@ fetchScheme =
           )
         ]
     )
-    ( \case
+    \case
-        [] -> pure (Input.FetchSchemeCompilerI "unison" JitInfo.currentRelease)
+      [] -> pure (Input.FetchSchemeCompilerI "unison" JitInfo.currentRelease)
-        [name] -> pure (Input.FetchSchemeCompilerI name branch)
+      [name] -> pure (Input.FetchSchemeCompilerI name branch)
-          where
+        where
-            branch
+          branch
-              | name == "unison" = JitInfo.currentRelease
+            | name == "unison" = JitInfo.currentRelease
-              | otherwise = "main"
+            | otherwise = "main"
-        [name, branch] -> pure (Input.FetchSchemeCompilerI name branch)
+      [name, branch] -> pure (Input.FetchSchemeCompilerI name branch)
-        _ -> Left $ showPatternHelp fetchScheme
+      _ -> Left $ showPatternHelp fetchScheme
-    )
 
 createAuthor :: InputPattern
 createAuthor =
@@ -2582,8 +2566,10 @@ createAuthor =
           )
     )
     ( \case
-        symbolStr : authorStr@(_ : _) -> first fromString $ do
+        symbolStr : authorStr@(_ : _) -> first fromString do
-          symbol <- Path.definitionNameSegment symbolStr
+          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)
     }

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

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."
 

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
+    nameSegmentParseErrToErr :: NameSegment.ParseErr -> Err
-    nameParseErrToErr = \case
+    nameSegmentParseErrToErr = \case
-      Name.ReservedOperator s -> ReservedSymbolyId (Text.unpack s)
+      NameSegment.ReservedOperator s -> ReservedSymbolyId (Text.unpack s)
-      Name.ReservedWord s -> ReservedWordyId (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).

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
+nameP :: forall m. Monad m => ParsecT (Token NameSegment.ParseErr) [Char] m Name
-  = 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 =
   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.
     --

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