diff --git a/parser-typechecker/src/Unison/Codebase/ShortCausalHash.hs b/parser-typechecker/src/Unison/Codebase/ShortCausalHash.hs index 75335193379..7e8b40e75bd 100644 --- a/parser-typechecker/src/Unison/Codebase/ShortCausalHash.hs +++ b/parser-typechecker/src/Unison/Codebase/ShortCausalHash.hs @@ -2,6 +2,7 @@ module Unison.Codebase.ShortCausalHash ( toString, toHash, fromHash, + fromFullHash, fromText, ShortCausalHash (..), ) @@ -27,6 +28,14 @@ fromHash :: (Coercible h Hash.Hash) => Int -> h -> ShortCausalHash fromHash len = ShortCausalHash . Text.take len . Hash.toBase32HexText . coerce +-- | This allows a full hash to be preserved as a `ShortCausalHash`. +-- +-- `ShortCausalHash` is used for input when we expect a user to enter a hash on the command line, so they aren’t +-- required to enter the full hash. However, these inputs may also come from an internal source, and in such cases, +-- there is no reason to truncate the hash. +fromFullHash :: (Coercible h Hash.Hash) => h -> ShortCausalHash +fromFullHash = ShortCausalHash . Hash.toBase32HexText . coerce + -- abc -> SCH abc -- #abc -> SCH abc fromText :: Text -> Maybe ShortCausalHash diff --git a/unison-cli/src/Unison/Cli/Pretty.hs b/unison-cli/src/Unison/Cli/Pretty.hs index 75c4610567b..1495da6fbb2 100644 --- a/unison-cli/src/Unison/Cli/Pretty.hs +++ b/unison-cli/src/Unison/Cli/Pretty.hs @@ -350,8 +350,8 @@ prettyWhichBranchEmpty = \case WhichBranchEmptyPath path -> prettyPath' path -- | Displays a full, non-truncated Branch.CausalHash to a string, e.g. #abcdef -displayBranchHash :: CausalHash -> String -displayBranchHash = ("#" <>) . Text.unpack . Hash.toBase32HexText . unCausalHash +displayBranchHash :: CausalHash -> Text +displayBranchHash = ("#" <>) . Hash.toBase32HexText . unCausalHash prettyHumanReadableTime :: UTCTime -> UTCTime -> Pretty prettyHumanReadableTime now time = diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs index ee8c1507925..f5f06bde10d 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs @@ -5,6 +5,7 @@ module Unison.Codebase.Editor.HandleInput (loop) where -- TODO: Don't import backend +import Control.Arrow ((&&&)) import Control.Error.Util qualified as ErrorUtil import Control.Lens hiding (from) import Control.Monad.Reader (ask) @@ -97,6 +98,7 @@ import Unison.Codebase.Editor.Output.DumpNamespace qualified as Output.DN import Unison.Codebase.Editor.RemoteRepo qualified as RemoteRepo import Unison.Codebase.Editor.Slurp qualified as Slurp import Unison.Codebase.Editor.SlurpResult qualified as SlurpResult +import Unison.Codebase.Editor.StructuredArgument qualified as SA import Unison.Codebase.Editor.TodoOutput qualified as TO import Unison.Codebase.IntegrityCheck qualified as IntegrityCheck (integrityCheckFullCodebase) import Unison.Codebase.Metadata qualified as Metadata @@ -144,7 +146,6 @@ import Unison.Reference qualified as Reference import Unison.Referent (Referent) import Unison.Referent qualified as Referent import Unison.Runtime.IOSource qualified as IOSource -import Unison.Server.Backend (ShallowListEntry (..)) import Unison.Server.Backend qualified as Backend import Unison.Server.CodebaseServer qualified as Server import Unison.Server.Doc.Markdown.Render qualified as Md @@ -220,19 +221,22 @@ loop e = do Cli.respond $ PrintMessage pretty ShowReflogI -> do let numEntriesToShow = 500 - entries <- - Cli.runTransaction do - schLength <- Codebase.branchHashLength - Codebase.getReflog numEntriesToShow <&> fmap (first $ SCH.fromHash schLength) + (schLength, entries) <- + Cli.runTransaction $ + (,) <$> Codebase.branchHashLength <*> Codebase.getReflog numEntriesToShow let moreEntriesToLoad = length entries == numEntriesToShow let expandedEntries = List.unfoldr expandEntries (entries, Nothing, moreEntriesToLoad) - let numberedEntries = expandedEntries <&> \(_time, hash, _reason) -> "#" <> SCH.toString hash + let (shortEntries, numberedEntries) = + unzip $ + expandedEntries <&> \(time, hash, reason) -> + let (exp, sa) = (SCH.fromHash schLength &&& SA.Namespace) hash + in ((time, exp, reason), sa) Cli.setNumberedArgs numberedEntries - Cli.respond $ ShowReflog expandedEntries + Cli.respond $ ShowReflog shortEntries where expandEntries :: - ([Reflog.Entry SCH.ShortCausalHash Text], Maybe SCH.ShortCausalHash, Bool) -> - Maybe ((Maybe UTCTime, SCH.ShortCausalHash, Text), ([Reflog.Entry SCH.ShortCausalHash Text], Maybe SCH.ShortCausalHash, Bool)) + ([Reflog.Entry CausalHash Text], Maybe CausalHash, Bool) -> + Maybe ((Maybe UTCTime, CausalHash, Text), ([Reflog.Entry CausalHash Text], Maybe CausalHash, Bool)) expandEntries ([], Just expectedHash, moreEntriesToLoad) = if moreEntriesToLoad then Nothing @@ -690,7 +694,7 @@ loop e = do pathArgAbs <- Cli.resolvePath' pathArg entries <- liftIO (Backend.lsAtPath codebase Nothing pathArgAbs) - Cli.setNumberedArgs $ fmap entryToHQString entries + Cli.setNumberedArgs $ fmap (SA.ShallowListEntry pathArg) entries pped <- Cli.currentPrettyPrintEnvDecl let suffixifiedPPE = PPED.suffixifiedPPE pped -- This used to be a delayed action which only forced the loading of the root @@ -700,20 +704,6 @@ loop e = do -- in an improvement, so perhaps it's not worth the effort. let buildPPE = pure suffixifiedPPE Cli.respond $ ListShallow buildPPE entries - where - entryToHQString :: ShallowListEntry v Ann -> String - entryToHQString e = - fixup $ Text.unpack case e of - ShallowTypeEntry te -> Backend.typeEntryDisplayName te - ShallowTermEntry te -> Backend.termEntryDisplayName te - ShallowBranchEntry ns _ _ -> NameSegment.toEscapedText ns - ShallowPatchEntry ns -> NameSegment.toEscapedText ns - where - fixup s = case pathArgStr of - "" -> s - p | last p == '.' -> p ++ s - p -> p ++ "." ++ s - pathArgStr = show pathArg FindI isVerbose fscope ws -> handleFindI isVerbose fscope ws input StructuredFindI _fscope ws -> handleStructuredFindI ws StructuredFindReplaceI ws -> handleStructuredFindReplaceI ws @@ -822,8 +812,9 @@ loop e = do ListDependenciesI hq -> handleDependencies hq NamespaceDependenciesI path -> handleNamespaceDependencies path DebugNumberedArgsI -> do + schLength <- Cli.runTransaction Codebase.branchHashLength numArgs <- use #numberedArgs - Cli.respond (DumpNumberedArgs numArgs) + Cli.respond (DumpNumberedArgs schLength numArgs) DebugTypecheckedUnisonFileI -> do hqLength <- Cli.runTransaction Codebase.hashLength uf <- Cli.expectLatestTypecheckedFile @@ -1242,7 +1233,7 @@ handleFindI isVerbose fscope ws input = do (mapMaybe (HQ.parseTextWith anythingBeforeHash . Text.pack) qs) pure $ uniqueBy SR.toReferent srs let respondResults results = do - Cli.setNumberedArgs $ fmap (searchResultToHQString searchRoot) results + Cli.setNumberedArgs $ fmap (SA.SearchResult searchRoot) results results' <- Cli.runTransaction (Backend.loadSearchResults codebase results) Cli.respond $ ListOfDefinitions fscope suffixifiedPPE isVerbose results' results <- getResults names @@ -1297,8 +1288,8 @@ handleDependencies hq = do let types = nubOrdOn snd . Name.sortByText (HQ.toText . fst) $ (join $ fst <$> results) let terms = nubOrdOn snd . Name.sortByText (HQ.toText . fst) $ (join $ snd <$> results) Cli.setNumberedArgs $ - map (Text.unpack . Reference.toText . snd) types - <> map (Text.unpack . Reference.toText . Referent.toReference . snd) terms + map (SA.Ref . snd) types + <> map (SA.Ref . Referent.toReference . snd) terms Cli.respond $ ListDependencies suffixifiedPPE lds (fst <$> types) (fst <$> terms) handleDependents :: HQ.HashQualified Name -> Cli () @@ -1335,7 +1326,7 @@ handleDependents hq = do let sort = nubOrdOn snd . Name.sortByText (HQ.toText . fst) let types = sort [(n, r) | (False, n, r) <- join results] let terms = sort [(n, r) | (True, n, r) <- join results] - Cli.setNumberedArgs $ map (Text.unpack . Reference.toText . view _2) (types <> terms) + Cli.setNumberedArgs . map (SA.Ref . view _2) $ types <> terms Cli.respond (ListDependents ppe lds (fst <$> types) (fst <$> terms)) -- | Handle a @ShowDefinitionI@ input command, i.e. `view` or `edit`. @@ -1449,9 +1440,7 @@ doShowTodoOutput patch scopePath = do then Cli.respond NoConflictsOrEdits else do Cli.setNumberedArgs - ( Text.unpack . Reference.toText . view _2 - <$> fst (TO.todoFrontierDependents todo) - ) + (SA.Ref . view _2 <$> fst (TO.todoFrontierDependents todo)) pped <- Cli.currentPrettyPrintEnvDecl Cli.respondNumbered $ TodoOutput pped todo @@ -1497,16 +1486,6 @@ confirmedCommand i = do loopState <- State.get pure $ Just i == (loopState ^. #lastInput) --- | restores the full hash to these search results, for _numberedArgs purposes -searchResultToHQString :: Maybe Path -> SearchResult -> String -searchResultToHQString oprefix = \case - SR.Tm' n r _ -> Text.unpack $ HQ.toText $ HQ.requalify (addPrefix <$> n) r - SR.Tp' n r _ -> Text.unpack $ HQ.toText $ HQ.requalify (addPrefix <$> n) (Referent.Ref r) - _ -> error "impossible match failure" - where - addPrefix :: Name -> Name - addPrefix = maybe id Path.prefixName2 oprefix - -- return `name` and `name....` _searchBranchPrefix :: Branch m -> Name -> [SearchResult] _searchBranchPrefix b n = case Path.unsnoc (Path.fromName n) of diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/FindAndReplace.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/FindAndReplace.hs index 83cc5486ea1..f96ae85b217 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/FindAndReplace.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/FindAndReplace.hs @@ -18,6 +18,7 @@ import Unison.Cli.Pretty qualified as P import Unison.Codebase qualified as Codebase import Unison.Codebase.Branch.Names qualified as Branch import Unison.Codebase.Editor.Output +import Unison.Codebase.Editor.StructuredArgument qualified as SA import Unison.HashQualified qualified as HQ import Unison.HashQualified' qualified as HQ' import Unison.Name (Name) @@ -87,7 +88,7 @@ handleStructuredFindI rule = do ok t = pure (t, False) results0 <- traverse ok results let results = Alphabetical.sortAlphabeticallyOn fst [(hq, r) | ((hq, r), True) <- results0] - let toNumArgs = Text.unpack . Reference.toText . Referent.toReference . view _2 + let toNumArgs = SA.Ref . Referent.toReference . view _2 Cli.setNumberedArgs $ map toNumArgs results Cli.respond (ListStructuredFind (fst <$> results)) diff --git a/unison-cli/src/Unison/Codebase/Editor/Output.hs b/unison-cli/src/Unison/Codebase/Editor/Output.hs index 2d73f410797..3efdb8a71f6 100644 --- a/unison-cli/src/Unison/Codebase/Editor/Output.hs +++ b/unison-cli/src/Unison/Codebase/Editor/Output.hs @@ -36,6 +36,7 @@ import Unison.Codebase.Editor.Output.PushPull (PushPull) import Unison.Codebase.Editor.RemoteRepo import Unison.Codebase.Editor.SlurpResult (SlurpResult (..)) import Unison.Codebase.Editor.SlurpResult qualified as SR +import Unison.Codebase.Editor.StructuredArgument (StructuredArgument) import Unison.Codebase.Editor.TodoOutput qualified as TO import Unison.Codebase.IntegrityCheck (IntegrityResult (..)) import Unison.Codebase.Path (Path') @@ -82,7 +83,12 @@ type ListDetailed = Bool type SourceName = Text -type NumberedArgs = [String] +-- | +-- +-- __NB__: This only temporarily holds `Text`. Until all of the inputs are +-- updated to handle `StructuredArgument`s, we need to ensure that the +-- serialization remains unchanged. +type NumberedArgs = [StructuredArgument] type HashLength = Int @@ -294,7 +300,7 @@ data Output | ListDependencies PPE.PrettyPrintEnv (Set LabeledDependency) [HQ.HashQualified Name] [HQ.HashQualified Name] -- types, terms | -- | List dependents of a type or term. ListDependents PPE.PrettyPrintEnv (Set LabeledDependency) [HQ.HashQualified Name] [HQ.HashQualified Name] -- types, terms - | DumpNumberedArgs NumberedArgs + | DumpNumberedArgs HashLength NumberedArgs | DumpBitBooster CausalHash (Map CausalHash [CausalHash]) | DumpUnisonFileHashes Int [(Name, Reference.Id)] [(Name, Reference.Id)] [(Name, Reference.Id)] | BadName Text diff --git a/unison-cli/src/Unison/Codebase/Editor/StructuredArgument.hs b/unison-cli/src/Unison/Codebase/Editor/StructuredArgument.hs new file mode 100644 index 00000000000..935d6ccd27a --- /dev/null +++ b/unison-cli/src/Unison/Codebase/Editor/StructuredArgument.hs @@ -0,0 +1,31 @@ +module Unison.Codebase.Editor.StructuredArgument where + +import GHC.Generics (Generic) +import U.Codebase.HashTags (CausalHash) +import Unison.Codebase.Editor.Input +import Unison.Codebase.Path (Path, Path') +import Unison.Codebase.Path qualified as Path +import Unison.HashQualified qualified as HQ +import Unison.HashQualified' qualified as HQ' +import Unison.Name (Name) +import Unison.Parser.Ann (Ann) +import Unison.Project (ProjectAndBranch, ProjectBranchName, ProjectName) +import Unison.Reference (Reference) +import Unison.Server.Backend (ShallowListEntry) +import Unison.Server.SearchResult (SearchResult) +import Unison.Symbol (Symbol) + +-- | The types that can be referenced by a numeric command argument. +data StructuredArgument + = AbsolutePath Path.Absolute + | Name Name + | HashQualified (HQ.HashQualified Name) + | Project ProjectName + | ProjectBranch (ProjectAndBranch (Maybe ProjectName) ProjectBranchName) + | Ref Reference + | Namespace CausalHash + | NameWithBranchPrefix AbsBranchId Name + | HashQualifiedWithBranchPrefix AbsBranchId (HQ'.HashQualified Name) + | ShallowListEntry Path' (ShallowListEntry Symbol Ann) + | SearchResult (Maybe Path) SearchResult + deriving (Eq, Generic, Show) diff --git a/unison-cli/src/Unison/CommandLine.hs b/unison-cli/src/Unison/CommandLine.hs index f97a25e3311..2c8be9bf436 100644 --- a/unison-cli/src/Unison/CommandLine.hs +++ b/unison-cli/src/Unison/CommandLine.hs @@ -46,6 +46,7 @@ import Unison.Codebase qualified as Codebase import Unison.Codebase.Branch (Branch0) import Unison.Codebase.Branch qualified as Branch import Unison.Codebase.Editor.Input (Event (..), Input (..)) +import Unison.Codebase.Editor.Output (NumberedArgs) import Unison.Codebase.Path qualified as Path import Unison.Codebase.Watch qualified as Watch import Unison.CommandLine.FZFResolvers qualified as FZFResolvers @@ -123,14 +124,14 @@ parseInput :: -- | Current path from root Path.Absolute -> -- | Numbered arguments - [String] -> + NumberedArgs -> -- | Input Pattern Map Map String InputPattern -> -- | command:arguments [String] -> -- Returns either an error message or the fully expanded arguments list and parsed input. -- If the output is `Nothing`, the user cancelled the input (e.g. ctrl-c) - IO (Either (P.Pretty CT.ColorText) (Maybe ([String], Input))) + IO (Either (P.Pretty CT.ColorText) (Maybe (InputPattern.Arguments, Input))) parseInput codebase currentPath numberedArgs patterns segments = runExceptT do let getCurrentBranch0 :: IO (Branch0 IO) getCurrentBranch0 = Branch.head <$> Codebase.getBranchAtPath codebase currentPath @@ -140,16 +141,16 @@ parseInput codebase currentPath numberedArgs patterns segments = runExceptT do [] -> throwE "" command : args -> case Map.lookup command patterns of Just pat@(InputPattern {parse, help}) -> do - let expandedNumbers :: [String] + let expandedNumbers :: InputPattern.Arguments expandedNumbers = - foldMap (expandNumber numberedArgs) args + foldMap (\arg -> maybe [Left arg] (fmap pure) $ expandNumber numberedArgs arg) args lift (fzfResolve codebase projCtx getCurrentBranch0 pat expandedNumbers) >>= \case Left (NoFZFResolverForArgumentType _argDesc) -> throwError help Left (NoFZFOptions argDesc) -> throwError (noCompletionsMessage argDesc) Left FZFCancelled -> pure Nothing Right resolvedArgs -> do parsedInput <- except . parse $ resolvedArgs - pure $ Just (command : resolvedArgs, parsedInput) + pure $ Just (Left command : resolvedArgs, parsedInput) Nothing -> throwE . warn @@ -168,11 +169,9 @@ parseInput codebase currentPath numberedArgs patterns segments = runExceptT do ] -- Expand a numeric argument like `1` or a range like `3-9` -expandNumber :: [String] -> String -> [String] -expandNumber numberedArgs s = case expandedNumber of - Nothing -> [s] - Just nums -> - [s | i <- nums, Just s <- [vargs Vector.!? (i - 1)]] +expandNumber :: NumberedArgs -> String -> Maybe NumberedArgs +expandNumber numberedArgs s = + (\nums -> [arg | i <- nums, Just arg <- [vargs Vector.!? (i - 1)]]) <$> expandedNumber where vargs = Vector.fromList numberedArgs rangeRegex = "([0-9]+)-([0-9]+)" :: String @@ -193,13 +192,13 @@ data FZFResolveFailure | NoFZFOptions Text {- argument description -} | FZFCancelled -fzfResolve :: Codebase IO Symbol Ann -> ProjectContext -> (IO (Branch0 IO)) -> InputPattern -> [String] -> IO (Either FZFResolveFailure [String]) +fzfResolve :: Codebase IO Symbol Ann -> ProjectContext -> (IO (Branch0 IO)) -> InputPattern -> InputPattern.Arguments -> IO (Either FZFResolveFailure InputPattern.Arguments) fzfResolve codebase projCtx getCurrentBranch pat args = runExceptT do -- We resolve args in two steps, first we check that all arguments that will require a fzf -- resolver have one, and only if so do we prompt the user to actually do a fuzzy search. -- Otherwise, we might ask the user to perform a search only to realize we don't have a resolver -- for a later arg. - argumentResolvers :: [ExceptT FZFResolveFailure IO [String]] <- + argumentResolvers :: [ExceptT FZFResolveFailure IO InputPattern.Arguments] <- (Align.align (InputPattern.args pat) args) & traverse \case This (argName, opt, InputPattern.ArgumentType {fzfResolver}) @@ -212,7 +211,7 @@ fzfResolve codebase projCtx getCurrentBranch pat args = runExceptT do These _ arg -> pure $ pure [arg] argumentResolvers & foldMapM id where - fuzzyFillArg :: InputPattern.IsOptional -> Text -> InputPattern.FZFResolver -> ExceptT FZFResolveFailure IO [String] + fuzzyFillArg :: InputPattern.IsOptional -> Text -> InputPattern.FZFResolver -> ExceptT FZFResolveFailure IO InputPattern.Arguments fuzzyFillArg opt argDesc InputPattern.FZFResolver {getOptions} = do currentBranch <- Branch.withoutTransitiveLibs <$> liftIO getCurrentBranch options <- liftIO $ getOptions codebase projCtx currentBranch @@ -223,8 +222,9 @@ fzfResolve codebase projCtx getCurrentBranch pat args = runExceptT do `whenNothingM` throwError FZFCancelled -- If the user triggered the fuzzy finder, but selected nothing, abort the command rather than continuing execution -- with no arguments. - when (null results) $ throwError FZFCancelled - pure (Text.unpack <$> results) + if null results + then throwError FZFCancelled + else pure (Left . Text.unpack <$> results) multiSelectForOptional :: InputPattern.IsOptional -> Bool multiSelectForOptional = \case diff --git a/unison-cli/src/Unison/CommandLine/InputPattern.hs b/unison-cli/src/Unison/CommandLine/InputPattern.hs index f72506bab5f..4014bc1dc76 100644 --- a/unison-cli/src/Unison/CommandLine/InputPattern.hs +++ b/unison-cli/src/Unison/CommandLine/InputPattern.hs @@ -4,8 +4,10 @@ module Unison.CommandLine.InputPattern ( InputPattern (..), + Argument, ArgumentType (..), ArgumentDescription, + Arguments, argType, FZFResolver (..), IsOptional (..), @@ -25,6 +27,7 @@ import System.Console.Haskeline qualified as Line import Unison.Auth.HTTPClient (AuthenticatedHttpClient) import Unison.Codebase (Codebase) import Unison.Codebase.Editor.Input (Input (..)) +import Unison.Codebase.Editor.StructuredArgument (StructuredArgument) import Unison.Codebase.Path as Path import Unison.CommandLine.FZFResolvers (FZFResolver (..)) import Unison.Prelude @@ -44,6 +47,14 @@ data IsOptional data Visibility = Hidden | Visible deriving (Show, Eq, Ord) +-- | An argument to a command is either a string provided by the user which +-- needs to be parsed or a numbered argument that doesn’t need to be parsed, as +-- we’ve preserved its representation (although the numbered argument could +-- still be of the wrong type, which should result in an error). +type Argument = Either String StructuredArgument + +type Arguments = [Argument] + -- | Argument description -- It should fit grammatically into sentences like "I was expecting an argument for the " -- e.g. "namespace to merge", "definition to delete", "remote target to push to" etc. @@ -55,7 +66,7 @@ data InputPattern = InputPattern visibility :: Visibility, -- Allow hiding certain commands when debugging or work-in-progress args :: [(ArgumentDescription, IsOptional, ArgumentType)], help :: P.Pretty CT.ColorText, - parse :: [String] -> Either (P.Pretty CT.ColorText) Input + parse :: Arguments -> Either (P.Pretty CT.ColorText) Input } data ArgumentType = ArgumentType diff --git a/unison-cli/src/Unison/CommandLine/InputPatterns.hs b/unison-cli/src/Unison/CommandLine/InputPatterns.hs index 6335e2808d5..9a5d0a364c5 100644 --- a/unison-cli/src/Unison/CommandLine/InputPatterns.hs +++ b/unison-cli/src/Unison/CommandLine/InputPatterns.hs @@ -122,6 +122,7 @@ module Unison.CommandLine.InputPatterns viewReflog, -- * Misc + formatStructuredArgument, helpFor, makeExample', makeExample, @@ -130,6 +131,7 @@ module Unison.CommandLine.InputPatterns patternMap, patternName, showPatternHelp, + unifyArgument, validInputs, ) where @@ -149,7 +151,7 @@ import System.Console.Haskeline.Completion (Completion (Completion)) import System.Console.Haskeline.Completion qualified as Haskeline import System.Console.Haskeline.Completion qualified as Line import Text.Megaparsec qualified as Megaparsec -import Text.Megaparsec.Internal qualified as Megaparsec (withParsecT) +import U.Codebase.HashTags (CausalHash (..)) import U.Codebase.Sqlite.DbId (ProjectBranchId) import U.Codebase.Sqlite.Project qualified as Sqlite import U.Codebase.Sqlite.Queries qualified as Queries @@ -162,25 +164,33 @@ import Unison.Codebase.Branch.Merge qualified as Branch import Unison.Codebase.Editor.Input (DeleteOutput (..), DeleteTarget (..), Input) import Unison.Codebase.Editor.Input qualified as Input import Unison.Codebase.Editor.Output.PushPull (PushPull (Pull, Push)) -import Unison.Codebase.Editor.RemoteRepo (WriteRemoteNamespace) +import Unison.Codebase.Editor.RemoteRepo (ReadRemoteNamespace, WriteRemoteNamespace) +import Unison.Codebase.Editor.RemoteRepo qualified as RemoteRepo import Unison.Codebase.Editor.SlurpResult qualified as SR +import Unison.Codebase.Editor.StructuredArgument (StructuredArgument) +import Unison.Codebase.Editor.StructuredArgument qualified as SA import Unison.Codebase.Editor.UriParser (readRemoteNamespaceParser) import Unison.Codebase.Editor.UriParser qualified as UriParser +import Unison.Codebase.Path (Path, Path') import Unison.Codebase.Path qualified as Path import Unison.Codebase.Path.Parse qualified as Path import Unison.Codebase.PushBehavior qualified as PushBehavior +import Unison.Codebase.ShortCausalHash (ShortCausalHash) +import Unison.Codebase.ShortCausalHash qualified as SCH import Unison.CommandLine -import Unison.CommandLine.BranchRelativePath (parseBranchRelativePath, parseIncrementalBranchRelativePath) +import Unison.CommandLine.BranchRelativePath (BranchRelativePath (..), parseBranchRelativePath, parseIncrementalBranchRelativePath) import Unison.CommandLine.BranchRelativePath qualified as BranchRelativePath import Unison.CommandLine.Completion import Unison.CommandLine.FZFResolvers qualified as Resolvers import Unison.CommandLine.InputPattern (ArgumentType (..), InputPattern (InputPattern), IsOptional (..), unionSuggestions) import Unison.CommandLine.InputPattern qualified as I import Unison.HashQualified qualified as HQ +import Unison.HashQualified' qualified as HQ' import Unison.Name (Name) import Unison.Name qualified as Name import Unison.NameSegment (NameSegment) import Unison.NameSegment qualified as NameSegment +import Unison.Parser.Ann (Ann) import Unison.Prelude import Unison.Project ( ProjectAndBranch (..), @@ -193,15 +203,68 @@ import Unison.Project branchWithOptionalProjectParser, ) import Unison.Project.Util (ProjectContext (..), projectContextFromPath) -import Unison.Syntax.HashQualified qualified as HQ (parseText) -import Unison.Syntax.Name qualified as Name (parseText, unsafeParseText) -import Unison.Syntax.NameSegment qualified as NameSegment (renderParseErr, segmentP) +import Unison.Reference qualified as Reference +import Unison.Referent qualified as Referent +import Unison.Server.Backend (ShallowListEntry (..)) +import Unison.Server.Backend qualified as Backend +import Unison.Server.SearchResult (SearchResult) +import Unison.Server.SearchResult qualified as SR +import Unison.ShortHash (ShortHash) +import Unison.Syntax.HashQualified qualified as HQ (parseText, toText) +import Unison.Syntax.Name qualified as Name (parseTextEither, toText) +import Unison.Syntax.NameSegment qualified as NameSegment import Unison.Util.ColorText qualified as CT import Unison.Util.Monoid (intercalateMap) import Unison.Util.Monoid qualified as Monoid import Unison.Util.Pretty qualified as P import Unison.Util.Pretty.MegaParsec (prettyPrintParseError) +formatStructuredArgument :: Maybe Int -> StructuredArgument -> Text +formatStructuredArgument schLength = \case + SA.AbsolutePath path -> into @Text $ show path + SA.Name name -> Name.toText name + SA.HashQualified hqName -> HQ.toText hqName + SA.Project projectName -> into @Text projectName + SA.ProjectBranch (ProjectAndBranch mproj branch) -> + maybe (Text.cons '/' . into @Text) (\project -> into @Text . ProjectAndBranch project) mproj branch + -- also: ShortHash.toText . Reference.toShortHash + SA.Ref reference -> Reference.toText reference + -- also: ("#" <>) . Hash.toBase32HexText . unCausalHash + SA.Namespace causalHash -> ("#" <>) . SCH.toText $ maybe SCH.fromFullHash SCH.fromHash schLength causalHash + SA.NameWithBranchPrefix absBranchId name -> prefixBranchId absBranchId name + SA.HashQualifiedWithBranchPrefix absBranchId hq'Name -> HQ'.toTextWith (prefixBranchId absBranchId) hq'Name + SA.ShallowListEntry path entry -> entryToHQText path entry + SA.SearchResult searchRoot searchResult -> HQ.toText $ searchResultToHQ searchRoot searchResult + where + -- E.g. + -- prefixBranchId "#abcdef" "base.List.map" -> "#abcdef:.base.List.map" + -- prefixBranchId ".base" "List.map" -> ".base.List.map" + prefixBranchId :: Input.AbsBranchId -> Name -> Text + prefixBranchId branchId name = case branchId of + Left sch -> "#" <> SCH.toText sch <> ":" <> Name.toText (Name.makeAbsolute name) + Right pathPrefix -> Name.toText (Name.makeAbsolute . Path.prefixName pathPrefix $ name) + + entryToHQText :: Path' -> ShallowListEntry v Ann -> Text + entryToHQText pathArg = + fixup . \case + ShallowTypeEntry te -> Backend.typeEntryDisplayName te + ShallowTermEntry te -> Backend.termEntryDisplayName te + ShallowBranchEntry ns _ _ -> NameSegment.toEscapedText ns + ShallowPatchEntry ns -> NameSegment.toEscapedText ns + where + fixup s = + pathArgStr + <> if Text.null pathArgStr || Text.isSuffixOf "." pathArgStr + then s + else "." <> s + pathArgStr = Text.pack $ show pathArg + +-- | Converts an arbitrary argument to a `String`. This is for cases where the +-- command /should/ accept a structured argument of some type, but currently +-- wants a `String`. +unifyArgument :: I.Argument -> String +unifyArgument = either id (Text.unpack . formatStructuredArgument Nothing) + showPatternHelp :: InputPattern -> P.Pretty CT.ColorText showPatternHelp i = P.lines @@ -214,6 +277,42 @@ showPatternHelp i = I.help i ] +-- | restores the full hash to these search results, for _numberedArgs purposes +searchResultToHQ :: Maybe Path -> SearchResult -> HQ.HashQualified Name +searchResultToHQ oprefix = \case + SR.Tm' n r _ -> HQ.requalify (addPrefix <$> n) r + SR.Tp' n r _ -> HQ.requalify (addPrefix <$> n) (Referent.Ref r) + _ -> error "impossible match failure" + where + addPrefix :: Name -> Name + addPrefix = maybe id Path.prefixName2 oprefix + +unsupportedStructuredArgument :: Text -> I.Argument -> Either (P.Pretty CT.ColorText) String +unsupportedStructuredArgument expected = + either pure (const . Left . P.text $ "can’t use a numbered argument for " <> expected) + +expectedButActually :: Text -> Text -> Text -> Text +expectedButActually expected actualValue actualType = + "Expected " <> expected <> ", but the numbered arg resulted in " <> actualValue <> ", which is " <> actualType <> "." + +wrongStructuredArgument :: Text -> StructuredArgument -> P.Pretty CT.ColorText +wrongStructuredArgument expected actual = + P.text $ expectedButActually + expected + (formatStructuredArgument Nothing actual) + case actual of + SA.Ref _ -> "a reference" + SA.Name _ -> "a name" + SA.AbsolutePath _ -> "an absolute path" + SA.Namespace _ -> "a namespace" + SA.Project _ -> "a project" + SA.ProjectBranch _ -> "a branch" + SA.HashQualified _ -> "a hash-qualified name" + SA.NameWithBranchPrefix _ _ -> "a name" + SA.HashQualifiedWithBranchPrefix _ _ -> "a hash-qualified name" + SA.ShallowListEntry _ _ -> "an annotated symbol" + SA.SearchResult _ _ -> "a search result" + patternName :: InputPattern -> P.Pretty P.ColorText patternName = fromString . I.patternName @@ -232,7 +331,340 @@ makeExampleEOS p args = backtick (intercalateMap " " id (P.nonEmpty $ fromString (I.patternName p) : args)) <> "." helpFor :: InputPattern -> P.Pretty CT.ColorText -helpFor p = I.help p +helpFor = I.help + +handleProjectArg :: I.Argument -> Either (P.Pretty CT.ColorText) ProjectName +handleProjectArg = + either + ( \name -> + first (const . P.text $ "“" <> Text.pack name <> "” is an invalid project name") . tryInto @ProjectName $ + Text.pack name + ) + \case + SA.Project project -> pure project + otherArgType -> Left $ wrongStructuredArgument "a project" otherArgType + +handleLooseCodeOrProjectArg :: I.Argument -> Either (P.Pretty CT.ColorText) Input.LooseCodeOrProject +handleLooseCodeOrProjectArg = + either + (maybe (Left $ P.text "invalid path or project branch") pure . parseLooseCodeOrProject) + \case + SA.AbsolutePath path -> pure . This $ Path.absoluteToPath' path + SA.ProjectBranch pb -> pure $ That pb + otherArgType -> Left $ wrongStructuredArgument "a path or project branch" otherArgType + +handleMaybeProjectBranchArg :: + I.Argument -> Either (P.Pretty CT.ColorText) (ProjectAndBranch (Maybe ProjectName) ProjectBranchName) +handleMaybeProjectBranchArg = + either + (megaparse branchWithOptionalProjectParser . Text.pack) + \case + SA.ProjectBranch pb -> pure pb + otherArgType -> Left $ wrongStructuredArgument "a branch" otherArgType + +handleProjectMaybeBranchArg :: + I.Argument -> Either (P.Pretty CT.ColorText) (ProjectAndBranch ProjectName (Maybe ProjectBranchNameOrLatestRelease)) +handleProjectMaybeBranchArg = + either + (first (const $ P.text "The argument wasn’t a project") . tryInto . Text.pack) + \case + SA.Project proj -> pure $ ProjectAndBranch proj Nothing + SA.ProjectBranch (ProjectAndBranch (Just proj) branch) -> + pure . ProjectAndBranch proj . pure $ ProjectBranchNameOrLatestRelease'Name branch + otherArgType -> Left $ wrongStructuredArgument "a project" otherArgType + +handleHashQualifiedNameArg :: I.Argument -> Either (P.Pretty CT.ColorText) (HQ.HashQualified Name) +handleHashQualifiedNameArg = + either + parseHashQualifiedName + \case + SA.Name name -> pure $ HQ.NameOnly name + SA.NameWithBranchPrefix mprefix name -> + pure . HQ.NameOnly $ foldr (\prefix -> Name.makeAbsolute . Path.prefixName prefix) name mprefix + SA.Ref ref -> pure . HQ.HashOnly $ Reference.toShortHash ref + SA.HashQualified hqname -> pure hqname + SA.HashQualifiedWithBranchPrefix mprefix hqname -> + pure . HQ'.toHQ $ foldr (\prefix -> fmap $ Name.makeAbsolute . Path.prefixName prefix) hqname mprefix + SA.SearchResult mpath result -> pure $ searchResultToHQ mpath result + otherArgType -> Left $ wrongStructuredArgument "a hash-qualified name" otherArgType + +handlePathArg :: I.Argument -> Either (P.Pretty CT.ColorText) Path.Path +handlePathArg = + either + (first P.text . Path.parsePath) + \case + SA.Name name -> pure $ Path.fromName name + SA.NameWithBranchPrefix mprefix name -> pure . Path.fromName $ foldr Path.prefixName name mprefix + otherArgType -> Left $ wrongStructuredArgument "a relative path" otherArgType + +handlePath'Arg :: I.Argument -> Either (P.Pretty CT.ColorText) Path.Path' +handlePath'Arg = + either + (first P.text . Path.parsePath') + \case + SA.AbsolutePath path -> pure $ Path.absoluteToPath' path + SA.Name name -> pure $ Path.fromName' name + SA.NameWithBranchPrefix mprefix name -> + pure . Path.fromName' $ foldr (\prefix -> Name.makeAbsolute . Path.prefixName prefix) name mprefix + otherArgType -> Left $ wrongStructuredArgument "a namespace" otherArgType + +handleNewName :: I.Argument -> Either (P.Pretty CT.ColorText) Path.Split' +handleNewName = + either + (first P.text . Path.parseSplit') + (const . Left $ "can’t use a numbered argument for a new name") + +handleNewPath :: I.Argument -> Either (P.Pretty CT.ColorText) Path.Path' +handleNewPath = + either + (first P.text . Path.parsePath') + (const . Left $ "can’t use a numbered argument for a new namespace") + +-- | When only a relative name is allowed. +handleSplitArg :: I.Argument -> Either (P.Pretty CT.ColorText) Path.Split +handleSplitArg = + either + (first P.text . Path.parseSplit) + \case + SA.Name name | Name.isRelative name -> pure $ Path.splitFromName name + SA.NameWithBranchPrefix (Left _) name | Name.isRelative name -> pure $ Path.splitFromName name + SA.NameWithBranchPrefix (Right prefix) name + | Name.isRelative name -> pure . Path.splitFromName . Name.makeAbsolute $ Path.prefixName prefix name + otherNumArg -> Left $ wrongStructuredArgument "a relative name" otherNumArg + +handleSplit'Arg :: I.Argument -> Either (P.Pretty CT.ColorText) Path.Split' +handleSplit'Arg = + either + (first P.text . Path.parseSplit') + \case + SA.Name name -> pure $ Path.splitFromName' name + SA.NameWithBranchPrefix (Left _) name -> pure $ Path.splitFromName' name + SA.NameWithBranchPrefix (Right prefix) name -> + pure . Path.splitFromName' . Name.makeAbsolute $ Path.prefixName prefix name + otherNumArg -> Left $ wrongStructuredArgument "a name" otherNumArg + +handleProjectBranchNameArg :: I.Argument -> Either (P.Pretty CT.ColorText) ProjectBranchName +handleProjectBranchNameArg = + either + (first (const $ P.text "Wanted a branch name, but it wasn’t") . tryInto . Text.pack) + \case + SA.ProjectBranch (ProjectAndBranch _ branch) -> pure branch + otherNumArg -> Left $ wrongStructuredArgument "a branch name" otherNumArg + +handleBranchIdArg :: I.Argument -> Either (P.Pretty CT.ColorText) Input.BranchId +handleBranchIdArg = + either + (first P.text . Input.parseBranchId) + \case + SA.AbsolutePath path -> pure . pure $ Path.absoluteToPath' path + SA.Name name -> pure . pure $ Path.fromName' name + SA.NameWithBranchPrefix mprefix name -> + pure . pure . Path.fromName' $ either (const name) (Name.makeAbsolute . flip Path.prefixName name) mprefix + SA.Namespace hash -> pure . Left $ SCH.fromFullHash hash + otherNumArg -> Left $ wrongStructuredArgument "a branch id" otherNumArg + +handleBranchIdOrProjectArg :: + I.Argument -> + Either (P.Pretty CT.ColorText) (These Input.BranchId (ProjectAndBranch (Maybe ProjectName) ProjectBranchName)) +handleBranchIdOrProjectArg = + either + (maybe (Left $ P.text "Expected a branch or project, but it’s not") pure . branchIdOrProject) + \case + SA.Namespace hash -> pure . This . Left $ SCH.fromFullHash hash + SA.AbsolutePath path -> pure . This . pure $ Path.absoluteToPath' path + SA.Name name -> pure . This . pure $ Path.fromName' name + SA.NameWithBranchPrefix (Left _) name -> pure . This . pure $ Path.fromName' name + SA.NameWithBranchPrefix (Right prefix) name -> + pure . This . pure . Path.fromName' . Name.makeAbsolute $ Path.prefixName prefix name + SA.ProjectBranch pb -> pure $ pure pb + otherArgType -> Left $ wrongStructuredArgument "a branch" otherArgType + where + branchIdOrProject :: + String -> + Maybe + ( These + Input.BranchId + (ProjectAndBranch (Maybe ProjectName) ProjectBranchName) + ) + branchIdOrProject str = + let branchIdRes = Input.parseBranchId str + projectRes = + tryInto @(ProjectAndBranch (Maybe ProjectName) ProjectBranchName) + (Text.pack str) + in case (branchIdRes, projectRes) of + (Left _, Left _) -> Nothing + (Left _, Right pr) -> Just (That pr) + (Right bid, Left _) -> Just (This bid) + (Right bid, Right pr) -> Just (These bid pr) + +handleBranchId2Arg :: I.Argument -> Either (P.Pretty P.ColorText) (Either ShortCausalHash BranchRelativePath) +handleBranchId2Arg = + either + Input.parseBranchId2 + \case + SA.Namespace hash -> pure . Left $ SCH.fromFullHash hash + SA.AbsolutePath path -> pure . pure . LoosePath $ Path.absoluteToPath' path + SA.Name name -> pure . pure . LoosePath $ Path.fromName' name + SA.NameWithBranchPrefix (Left _) name -> pure . pure . LoosePath $ Path.fromName' name + SA.NameWithBranchPrefix (Right prefix) name -> + pure . pure . LoosePath . Path.fromName' . Name.makeAbsolute $ Path.prefixName prefix name + SA.ProjectBranch (ProjectAndBranch mproject branch) -> + pure . pure . BranchRelative . This $ maybe (Left branch) (pure . (,branch)) mproject + otherNumArg -> Left $ wrongStructuredArgument "a branch id" otherNumArg + +handleBranchRelativePathArg :: I.Argument -> Either (P.Pretty P.ColorText) BranchRelativePath +handleBranchRelativePathArg = + either + parseBranchRelativePath + \case + SA.AbsolutePath path -> pure . LoosePath $ Path.absoluteToPath' path + SA.Name name -> pure . LoosePath $ Path.fromName' name + SA.NameWithBranchPrefix (Left _) name -> pure . LoosePath $ Path.fromName' name + SA.NameWithBranchPrefix (Right prefix) name -> + pure . LoosePath . Path.fromName' . Name.makeAbsolute $ Path.prefixName prefix name + SA.ProjectBranch (ProjectAndBranch mproject branch) -> + pure . BranchRelative . This $ maybe (Left branch) (pure . (,branch)) mproject + otherNumArg -> Left $ wrongStructuredArgument "a branch id" otherNumArg + +hqNameToSplit' :: HQ.HashQualified Name -> Either (P.Pretty CT.ColorText) Path.HQSplit' +hqNameToSplit' = \case + HQ.HashOnly _ -> Left $ P.text "Only have a hash" + HQ.NameOnly name -> pure . fmap HQ'.NameOnly $ Path.splitFromName' name + HQ.HashQualified name hash -> pure . fmap (`HQ'.HashQualified` hash) $ Path.splitFromName' name + +hqNameToSplit :: HQ.HashQualified Name -> Either (P.Pretty CT.ColorText) Path.HQSplit +hqNameToSplit = \case + HQ.HashOnly _ -> Left $ P.text "Only have a hash" + HQ.NameOnly name -> pure . fmap HQ'.NameOnly $ Path.splitFromName name + HQ.HashQualified name hash -> pure . fmap (`HQ'.HashQualified` hash) $ Path.splitFromName name + +hq'NameToSplit' :: HQ'.HashQualified Name -> Path.HQSplit' +hq'NameToSplit' = \case + HQ'.NameOnly name -> HQ'.NameOnly <$> Path.splitFromName' name + HQ'.HashQualified name hash -> flip HQ'.HashQualified hash <$> Path.splitFromName' name + +hq'NameToSplit :: HQ'.HashQualified Name -> Path.HQSplit +hq'NameToSplit = \case + HQ'.NameOnly name -> HQ'.NameOnly <$> Path.splitFromName name + HQ'.HashQualified name hash -> flip HQ'.HashQualified hash <$> Path.splitFromName name + +handleHashQualifiedSplit'Arg :: I.Argument -> Either (P.Pretty CT.ColorText) Path.HQSplit' +handleHashQualifiedSplit'Arg = + either + (first P.text . Path.parseHQSplit') + \case + SA.HashQualified name -> hqNameToSplit' name + SA.HashQualifiedWithBranchPrefix (Left _) hqname -> pure $ hq'NameToSplit' hqname + SA.HashQualifiedWithBranchPrefix (Right prefix) hqname -> + pure . hq'NameToSplit' $ Name.makeAbsolute . Path.prefixName prefix <$> hqname + SA.SearchResult mpath result -> hqNameToSplit' $ searchResultToHQ mpath result + otherNumArg -> Left $ wrongStructuredArgument "a name" otherNumArg + +handleHashQualifiedSplitArg :: I.Argument -> Either (P.Pretty CT.ColorText) Path.HQSplit +handleHashQualifiedSplitArg = + either + (first P.text . Path.parseHQSplit) + \case + SA.HashQualified name -> hqNameToSplit name + SA.HashQualifiedWithBranchPrefix (Left _) hqname -> pure $ hq'NameToSplit hqname + SA.HashQualifiedWithBranchPrefix (Right prefix) hqname -> + pure . hq'NameToSplit $ Name.makeAbsolute . Path.prefixName prefix <$> hqname + SA.SearchResult mpath result -> hqNameToSplit $ searchResultToHQ mpath result + otherNumArg -> Left $ wrongStructuredArgument "a relative name" otherNumArg + +handleShortCausalHashArg :: I.Argument -> Either (P.Pretty CT.ColorText) ShortCausalHash +handleShortCausalHashArg = + either + (first (P.text . Text.pack) . Input.parseShortCausalHash) + \case + SA.Namespace hash -> pure $ SCH.fromFullHash hash + otherNumArg -> Left $ wrongStructuredArgument "a causal hash" otherNumArg + +handleShortHashOrHQSplit'Arg :: + I.Argument -> Either (P.Pretty CT.ColorText) (Either ShortHash Path.HQSplit') +handleShortHashOrHQSplit'Arg = + either + (first P.text . Path.parseShortHashOrHQSplit') + \case + SA.Ref ref -> pure $ Left $ Reference.toShortHash ref + SA.HashQualified name -> pure <$> hqNameToSplit' name + SA.HashQualifiedWithBranchPrefix (Left _) hqname -> pure . pure $ hq'NameToSplit' hqname + SA.HashQualifiedWithBranchPrefix (Right prefix) hqname -> + pure . pure $ hq'NameToSplit' (Name.makeAbsolute . Path.prefixName prefix <$> hqname) + SA.SearchResult mpath result -> fmap pure . hqNameToSplit' $ searchResultToHQ mpath result + otherNumArg -> Left $ wrongStructuredArgument "a hash or name" otherNumArg + +handleRelativeNameSegmentArg :: I.Argument -> Either (P.Pretty CT.ColorText) NameSegment +handleRelativeNameSegmentArg arg = do + name <- handleNameArg arg + let (segment NE.:| tail) = Name.reverseSegments name + if Name.isRelative name && null tail + then pure segment + else Left $ P.text "Wanted a single relative name segment, but it wasn’t." + +handleNameArg :: I.Argument -> Either (P.Pretty CT.ColorText) Name +handleNameArg = + either + (first P.text . Name.parseTextEither . Text.pack) + \case + SA.Name name -> pure name + SA.NameWithBranchPrefix (Left _) name -> pure name + SA.NameWithBranchPrefix (Right prefix) name -> pure . Name.makeAbsolute $ Path.prefixName prefix name + SA.HashQualified hqname -> maybe (Left "can’t find a name from the numbered arg") pure $ HQ.toName hqname + SA.HashQualifiedWithBranchPrefix (Left _) hqname -> pure $ HQ'.toName hqname + SA.HashQualifiedWithBranchPrefix (Right prefix) hqname -> + pure . Name.makeAbsolute . Path.prefixName prefix $ HQ'.toName hqname + SA.SearchResult mpath result -> + maybe (Left "can’t find a name from the numbered arg") pure . HQ.toName $ searchResultToHQ mpath result + otherNumArg -> Left $ wrongStructuredArgument "a name" otherNumArg + +handlePullSourceArg :: + I.Argument -> + Either + (P.Pretty CT.ColorText) + (ReadRemoteNamespace (These ProjectName ProjectBranchNameOrLatestRelease)) +handlePullSourceArg = + either + (megaparse (readRemoteNamespaceParser ProjectBranchSpecifier'NameOrLatestRelease) . Text.pack) + \case + SA.Project project -> pure . RemoteRepo.ReadShare'ProjectBranch $ This project + SA.ProjectBranch (ProjectAndBranch project branch) -> + pure . RemoteRepo.ReadShare'ProjectBranch . maybe That These project $ + ProjectBranchNameOrLatestRelease'Name branch + otherNumArg -> Left $ wrongStructuredArgument "a source to pull from" otherNumArg + +handlePushTargetArg :: + I.Argument -> Either (P.Pretty CT.ColorText) (WriteRemoteNamespace (These ProjectName ProjectBranchName)) +handlePushTargetArg = + either + (maybe (Left "Wanted a source to push from, but this ain’t it.") pure . parsePushTarget) + $ fmap RemoteRepo.WriteRemoteProjectBranch . \case + SA.Project project -> pure $ This project + SA.ProjectBranch (ProjectAndBranch project branch) -> pure $ maybe That These project branch + otherNumArg -> Left $ wrongStructuredArgument "a source to push from" otherNumArg + +handlePushSourceArg :: I.Argument -> Either (P.Pretty CT.ColorText) Input.PushSource +handlePushSourceArg = + either + (maybe (Left $ P.text "Wanted a source to push from, but this ain’t it.") pure . parsePushSource) + \case + SA.AbsolutePath path -> pure . Input.PathySource $ Path.absoluteToPath' path + SA.Name name -> pure . Input.PathySource $ Path.fromName' name + SA.NameWithBranchPrefix (Left _) name -> pure . Input.PathySource $ Path.fromName' name + SA.NameWithBranchPrefix (Right prefix) name -> + pure . Input.PathySource . Path.fromName' . Name.makeAbsolute $ Path.prefixName prefix name + SA.Project project -> pure . Input.ProjySource $ This project + SA.ProjectBranch (ProjectAndBranch project branch) -> pure . Input.ProjySource $ maybe That These project branch + otherNumArg -> Left $ wrongStructuredArgument "a source to push from" otherNumArg + +handleProjectAndBranchNamesArg :: I.Argument -> Either (P.Pretty CT.ColorText) ProjectAndBranchNames +handleProjectAndBranchNamesArg = + either + (first (const $ P.text "The argument wasn’t a project or branch") . tryInto @ProjectAndBranchNames . Text.pack) + $ fmap ProjectAndBranchNames'Unambiguous . \case + SA.Project project -> pure $ This project + SA.ProjectBranch (ProjectAndBranch mproj branch) -> pure $ maybe That These mproj branch + otherNumArg -> Left $ wrongStructuredArgument "a project or branch" otherNumArg mergeBuiltins :: InputPattern mergeBuiltins = @@ -244,9 +676,7 @@ mergeBuiltins = "Adds the builtins (excluding `io` and misc) to the specified namespace. Defaults to `builtin.`" \case [] -> pure . Input.MergeBuiltinsI $ Nothing - [p] -> first P.text do - p <- Path.parsePath p - pure . Input.MergeBuiltinsI $ Just p + [p] -> Input.MergeBuiltinsI . Just <$> handlePathArg p _ -> Left (I.help mergeBuiltins) mergeIOBuiltins :: InputPattern @@ -259,9 +689,7 @@ mergeIOBuiltins = "Adds all the builtins, including `io` and misc., to the specified namespace. Defaults to `builtin.`" \case [] -> pure . Input.MergeIOBuiltinsI $ Nothing - [p] -> first P.text do - p <- Path.parsePath p - pure . Input.MergeIOBuiltinsI $ Just p + [p] -> Input.MergeIOBuiltinsI . Just <$> handlePathArg p _ -> Left (I.help mergeBuiltins) updateBuiltins :: InputPattern @@ -297,16 +725,15 @@ todo = ) ] ) - ( \case - patchStr : ws -> mapLeft (warn . P.text) $ do - patch <- Path.parseSplit' patchStr - branch <- case ws of - [] -> pure Path.relativeEmpty' - [pathStr] -> Path.parsePath' pathStr - _ -> Left "`todo` just takes a patch and one optional namespace" - Right $ Input.TodoI (Just patch) branch - [] -> Right $ Input.TodoI Nothing Path.relativeEmpty' - ) + \case + patchStr : ws -> first warn $ do + patch <- handleSplit'Arg patchStr + branch <- case ws of + [] -> pure Path.relativeEmpty' + [pathStr] -> handlePath'Arg pathStr + _ -> Left "`todo` just takes a patch and one optional namespace" + Right $ Input.TodoI (Just patch) branch + [] -> Right $ Input.TodoI Nothing Path.relativeEmpty' load :: InputPattern load = @@ -324,11 +751,10 @@ load = ) ] ) - ( \case - [] -> pure $ Input.LoadI Nothing - [file] -> pure $ Input.LoadI . Just $ file - _ -> Left (I.help load) - ) + \case + [] -> pure $ Input.LoadI Nothing + [file] -> Input.LoadI . Just <$> unsupportedStructuredArgument "a file name" file + _ -> Left (I.help load) clear :: InputPattern clear = @@ -343,10 +769,9 @@ clear = ) ] ) - ( \case - [] -> pure $ Input.ClearI - _ -> Left (I.help clear) - ) + \case + [] -> pure Input.ClearI + _ -> Left (I.help clear) add :: InputPattern add = @@ -358,7 +783,7 @@ add = ( "`add` adds to the codebase all the definitions from the most recently " <> "typechecked file." ) - \ws -> pure $ Input.AddI (Set.fromList $ map (Name.unsafeParseText . Text.pack) ws) + $ fmap (Input.AddI . Set.fromList) . traverse handleNameArg previewAdd :: InputPattern previewAdd = @@ -372,7 +797,7 @@ previewAdd = <> "results. Use `load` to reparse & typecheck the file if the context " <> "has changed." ) - \ws -> pure $ Input.PreviewAddI (Set.fromList $ map (Name.unsafeParseText . Text.pack) ws) + $ fmap (Input.PreviewAddI . Set.fromList) . traverse handleNameArg update :: InputPattern update = @@ -387,10 +812,9 @@ update = <> "replacing existing definitions having the same name, and attempts to update all the existing dependents accordingly. If the process" <> "can't be completed automatically, the dependents will be added back to the scratch file" <> "for your review.", - parse = - maybeToEither (I.help update) . \case - [] -> Just Input.Update2I - _ -> Nothing + parse = \case + [] -> pure Input.Update2I + _ -> Left $ I.help update } updateOldNoPatch :: InputPattern @@ -419,13 +843,7 @@ updateOldNoPatch = ) ] ) - ( \case - ws -> do - pure $ - Input.UpdateI - Input.NoPatch - (Set.fromList $ map (Name.unsafeParseText . Text.pack) ws) - ) + $ fmap (Input.UpdateI Input.NoPatch . Set.fromList) . traverse handleNameArg updateOld :: InputPattern updateOld = @@ -460,12 +878,8 @@ updateOld = ] ) \case - patchStr : ws -> do - patch <- first P.text $ Path.parseSplit' patchStr - pure $ - Input.UpdateI - (Input.UsePatch patch) - (Set.fromList $ map (Name.unsafeParseText . Text.pack) ws) + patchStr : ws -> + Input.UpdateI . Input.UsePatch <$> handleSplit'Arg patchStr <*> fmap Set.fromList (traverse handleNameArg ws) [] -> Right $ Input.UpdateI Input.DefaultPatch mempty previewUpdate :: InputPattern @@ -480,7 +894,7 @@ previewUpdate = <> "typechecking results. Use `load` to reparse & typecheck the file if " <> "the context has changed." ) - \ws -> pure $ Input.PreviewUpdateI (Set.fromList $ map (Name.unsafeParseText . Text.pack) ws) + $ fmap (Input.PreviewUpdateI . Set.fromList) . traverse handleNameArg view :: InputPattern view = @@ -500,12 +914,12 @@ view = <> "not `List.map.doc` (since ? only matches 1 name segment)." ] ) - ( \case - (x : xs) -> - (x NE.:| xs) - & traverse parseHashQualifiedName - & fmap (Input.ShowDefinitionI Input.ConsoleLocation Input.ShowDefinitionLocal) - _ -> Left (I.help view) + ( maybe + (Left $ I.help view) + ( fmap (Input.ShowDefinitionI Input.ConsoleLocation Input.ShowDefinitionLocal) + . traverse handleHashQualifiedNameArg + ) + . NE.nonEmpty ) viewGlobal :: InputPattern @@ -520,12 +934,12 @@ viewGlobal = "`view.global` without arguments invokes a search to select definitions to view, which requires that `fzf` can be found within your PATH." ] ) - ( \case - (x : xs) -> - (x NE.:| xs) - & traverse parseHashQualifiedName - & fmap (Input.ShowDefinitionI Input.ConsoleLocation Input.ShowDefinitionGlobal) - _ -> Left (I.help viewGlobal) + ( maybe + (Left $ I.help viewGlobal) + ( fmap (Input.ShowDefinitionI Input.ConsoleLocation Input.ShowDefinitionGlobal) + . traverse handleHashQualifiedNameArg + ) + . NE.nonEmpty ) display :: InputPattern @@ -540,12 +954,8 @@ display = "`display` without arguments invokes a search to select a definition to display, which requires that `fzf` can be found within your PATH." ] ) - \case - (x : xs) -> - (x NE.:| xs) - & traverse parseHashQualifiedName - <&> Input.DisplayI Input.ConsoleLocation - _ -> Left (I.help display) + $ maybe (Left $ I.help display) (fmap (Input.DisplayI Input.ConsoleLocation) . traverse handleHashQualifiedNameArg) + . NE.nonEmpty displayTo :: InputPattern displayTo = @@ -558,11 +968,16 @@ displayTo = makeExample displayTo ["", "foo"] <> "prints a rendered version of the term `foo` to the given file." ) - \case - file : (x : xs) -> - (x NE.:| xs) - & traverse parseHashQualifiedName - <&> Input.DisplayI (Input.FileLocation file) + $ \case + file : defs -> + maybe + (Left $ I.help displayTo) + ( \defs -> + Input.DisplayI . Input.FileLocation + <$> unsupportedStructuredArgument "a file name" file + <*> traverse handleHashQualifiedNameArg defs + ) + $ NE.nonEmpty defs _ -> Left (I.help displayTo) docs :: InputPattern @@ -577,13 +992,7 @@ docs = "`docs` without arguments invokes a search to select which definition to view documentation for, which requires that `fzf` can be found within your PATH." ] ) - ( \case - x : xs -> - (x NE.:| xs) - & traverse Path.parseHQSplit' - & bimap P.text Input.DocsI - _ -> Left (I.help docs) - ) + $ maybe (Left $ I.help docs) (fmap Input.DocsI . traverse handleHashQualifiedSplit'Arg) . NE.nonEmpty api :: InputPattern api = @@ -605,9 +1014,7 @@ ui = help = P.wrap "`ui` opens the Local UI in the default browser.", parse = \case [] -> pure $ Input.UiI Path.relativeEmpty' - [path] -> first P.text $ do - p <- Path.parsePath' path - pure $ Input.UiI p + [path] -> Input.UiI <$> handlePath'Arg path _ -> Left (I.help ui) } @@ -625,7 +1032,9 @@ sfind :: InputPattern sfind = InputPattern "rewrite.find" ["sfind"] I.Visible [("rewrite-rule definition", Required, definitionQueryArg)] msg parse where - parse [q] = Input.StructuredFindI (Input.FindLocal Path.empty) <$> parseHashQualifiedName q + parse [q] = + Input.StructuredFindI (Input.FindLocal Path.empty) + <$> handleHashQualifiedNameArg q parse _ = Left "expected exactly one argument" msg = P.lines @@ -656,7 +1065,7 @@ sfindReplace :: InputPattern sfindReplace = InputPattern "rewrite" ["sfind.replace"] I.Visible [("rewrite-rule definition", Required, definitionQueryArg)] msg parse where - parse [q] = Input.StructuredFindReplaceI <$> parseHashQualifiedName q + parse [q] = Input.StructuredFindReplaceI <$> handleHashQualifiedNameArg q parse _ = Left "expected exactly one argument" msg :: P.Pretty CT.ColorText msg = @@ -704,9 +1113,7 @@ findIn' cmd mkfscope = [("namespace", Required, namespaceArg), ("query", ZeroPlus, exactDefinitionArg)] findHelp \case - p : args -> first P.text do - p <- Path.parsePath p - pure (Input.FindI False (mkfscope p) args) + p : args -> Input.FindI False . mkfscope <$> handlePathArg p <*> pure (unifyArgument <$> args) _ -> Left findHelp findHelp :: P.Pretty CT.ColorText @@ -753,7 +1160,7 @@ find' cmd fscope = I.Visible [("query", ZeroPlus, exactDefinitionArg)] findHelp - (pure . Input.FindI False fscope) + (pure . Input.FindI False fscope . fmap unifyArgument) findShallow :: InputPattern findShallow = @@ -768,11 +1175,9 @@ findShallow = ("`list .foo`", "lists the '.foo' namespace.") ] ) - ( \case - [] -> pure $ Input.FindShallowI Path.relativeEmpty' - [path] -> first P.text $ do - p <- Path.parsePath' path - pure $ Input.FindShallowI p + ( fmap Input.FindShallowI . \case + [] -> pure Path.relativeEmpty' + [path] -> handlePath'Arg path _ -> Left (I.help findShallow) ) @@ -786,7 +1191,7 @@ findVerbose = ( "`find.verbose` searches for definitions like `find`, but includes hashes " <> "and aliases in the results." ) - (pure . Input.FindI True (Input.FindLocal Path.empty)) + (pure . Input.FindI True (Input.FindLocal Path.empty) . fmap unifyArgument) findVerboseAll :: InputPattern findVerboseAll = @@ -798,7 +1203,7 @@ findVerboseAll = ( "`find.all.verbose` searches for definitions like `find.all`, but includes hashes " <> "and aliases in the results." ) - (pure . Input.FindI True (Input.FindLocalAndDeps Path.empty)) + (pure . Input.FindI True (Input.FindLocalAndDeps Path.empty) . fmap unifyArgument) renameTerm :: InputPattern renameTerm = @@ -810,16 +1215,9 @@ renameTerm = ("new location", Required, newNameArg) ] "`move.term foo bar` renames `foo` to `bar`." - ( \case - [oldName, newName] -> first P.text do - src <- Path.parseHQSplit' oldName - target <- Path.parseSplit' newName - pure $ Input.MoveTermI src target - _ -> - Left . P.warnCallout $ - P.wrap - "`rename.term` takes two arguments, like `rename.term oldname newname`." - ) + \case + [oldName, newName] -> Input.MoveTermI <$> handleHashQualifiedSplit'Arg oldName <*> handleNewName newName + _ -> Left . P.warnCallout $ P.wrap "`rename.term` takes two arguments, like `rename.term oldname newname`." moveAll :: InputPattern moveAll = @@ -831,16 +1229,9 @@ moveAll = ("new location", Required, newNameArg) ] "`move foo bar` renames the term, type, and namespace foo to bar." - ( \case - [oldName, newName] -> first P.text $ do - src <- Path.parsePath' oldName - target <- Path.parsePath' newName - pure $ Input.MoveAllI src target - _ -> - Left . P.warnCallout $ - P.wrap - "`move` takes two arguments, like `move oldname newname`." - ) + \case + [oldName, newName] -> Input.MoveAllI <$> handlePath'Arg oldName <*> handleNewPath newName + _ -> Left . P.warnCallout $ P.wrap "`move` takes two arguments, like `move oldname newname`." renameType :: InputPattern renameType = @@ -852,16 +1243,10 @@ renameType = ("new location", Required, newNameArg) ] "`move.type foo bar` renames `foo` to `bar`." - ( \case - [oldName, newName] -> first P.text do - src <- Path.parseHQSplit' oldName - target <- Path.parseSplit' newName - pure $ Input.MoveTypeI src target - _ -> - Left . P.warnCallout $ - P.wrap - "`rename.type` takes two arguments, like `rename.type oldname newname`." - ) + \case + [oldName, newName] -> Input.MoveTypeI <$> handleHashQualifiedSplit'Arg oldName <*> handleNewName newName + _ -> + Left . P.warnCallout $ P.wrap "`rename.type` takes two arguments, like `rename.type oldname newname`." deleteGen :: Maybe String -> ArgumentType -> String -> ([Path.HQSplit'] -> DeleteTarget) -> InputPattern deleteGen suffix queryCompletionArg target mkTarget = @@ -900,12 +1285,9 @@ deleteGen suffix queryCompletionArg target mkTarget = I.Visible [("definition to delete", OnePlus, queryCompletionArg)] info - ( \case - [] -> Left . P.warnCallout $ P.wrap warn - queries -> first P.text do - paths <- traverse Path.parseHQSplit' queries - pure $ Input.DeleteI (mkTarget paths) - ) + \case + [] -> Left . P.warnCallout $ P.wrap warn + queries -> Input.DeleteI . mkTarget <$> traverse handleHashQualifiedSplit'Arg queries delete :: InputPattern delete = deleteGen Nothing exactDefinitionTypeOrTermQueryArg "term or type" (DeleteTarget'TermOrType DeleteOutput'NoDiff) @@ -937,9 +1319,7 @@ deleteProject = [ ("`delete.project foo`", "deletes the local project `foo`") ], parse = \case - [name] - | Right project <- tryInto @ProjectName (Text.pack name) -> - Right (Input.DeleteI (DeleteTarget'Project project)) + [name] -> Input.DeleteI . DeleteTarget'Project <$> handleProjectArg name _ -> Left (showPatternHelp deleteProject) } @@ -956,10 +1336,7 @@ deleteBranch = ("`delete.branch /bar`", "deletes the branch `bar` in the current project") ], parse = \case - [name] -> - case tryInto @(ProjectAndBranch (Maybe ProjectName) ProjectBranchName) (Text.pack name) of - Left _ -> Left (showPatternHelp deleteBranch) - Right projectAndBranch -> Right (Input.DeleteI (DeleteTarget'ProjectBranch projectAndBranch)) + [name] -> Input.DeleteI . DeleteTarget'ProjectBranch <$> handleMaybeProjectBranchArg name _ -> Left (showPatternHelp deleteBranch) } where @@ -978,15 +1355,9 @@ aliasTerm = I.Visible [("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 P.text do - source <- Path.parseShortHashOrHQSplit' oldName - target <- Path.parseSplit' newName - pure $ Input.AliasTermI source target - _ -> - Left . warn $ - P.wrap - "`alias.term` takes two arguments, like `alias.term oldname newname`." + $ \case + [oldName, newName] -> Input.AliasTermI <$> handleShortHashOrHQSplit'Arg oldName <*> handleSplit'Arg newName + _ -> Left . warn $ P.wrap "`alias.term` takes two arguments, like `alias.term oldname newname`." aliasType :: InputPattern aliasType = @@ -997,14 +1368,8 @@ 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 P.text do - source <- Path.parseShortHashOrHQSplit' oldName - target <- Path.parseSplit' newName - pure $ Input.AliasTypeI source target - _ -> - Left . warn $ - P.wrap - "`alias.type` takes two arguments, like `alias.type oldname newname`." + [oldName, newName] -> Input.AliasTypeI <$> handleShortHashOrHQSplit'Arg oldName <*> handleSplit'Arg newName + _ -> Left . warn $ P.wrap "`alias.type` takes two arguments, like `alias.type oldname newname`." aliasMany :: InputPattern aliasMany = @@ -1023,10 +1388,8 @@ aliasMany = ] ) \case - srcs@(_ : _) Cons.:> dest -> first P.text do - sourceDefinitions <- traverse Path.parseHQSplit srcs - destNamespace <- Path.parsePath' dest - pure $ Input.AliasManyI sourceDefinitions destNamespace + srcs@(_ : _) Cons.:> dest -> + Input.AliasManyI <$> traverse handleHashQualifiedSplitArg srcs <*> handlePath'Arg dest _ -> Left (I.help aliasMany) up :: InputPattern @@ -1037,10 +1400,9 @@ up = I.Hidden [] (P.wrapColumn2 [(makeExample up [], "move current path up one level (deprecated)")]) - ( \case - [] -> Right Input.UpI - _ -> Left (I.help up) - ) + \case + [] -> Right Input.UpI + _ -> Left (I.help up) cd :: InputPattern cd = @@ -1069,10 +1431,8 @@ cd = ] ) \case - [".."] -> Right Input.UpI - [p] -> first P.text do - p <- Path.parsePath' p - pure . Input.SwitchBranchI $ p + [Left ".."] -> Right Input.UpI + [p] -> Input.SwitchBranchI <$> handlePath'Arg p _ -> Left (I.help cd) back :: InputPattern @@ -1114,15 +1474,10 @@ deleteNamespaceForce = ) (deleteNamespaceParser (I.help deleteNamespaceForce) Input.Force) -deleteNamespaceParser :: P.Pretty CT.ColorText -> Input.Insistence -> [String] -> Either (P.Pretty CT.ColorText) Input +deleteNamespaceParser :: P.Pretty CT.ColorText -> Input.Insistence -> I.Arguments -> Either (P.Pretty CT.ColorText) Input deleteNamespaceParser helpText insistence = \case - ["."] -> - first fromString - . pure - $ Input.DeleteI (DeleteTarget'Namespace insistence Nothing) - [p] -> first P.text do - p <- Path.parseSplit p - pure $ Input.DeleteI (DeleteTarget'Namespace insistence (Just p)) + [Left "."] -> first fromString . pure $ Input.DeleteI (DeleteTarget'Namespace insistence Nothing) + [p] -> Input.DeleteI . DeleteTarget'Namespace insistence . pure <$> handleSplitArg p _ -> Left helpText renameBranch :: InputPattern @@ -1134,10 +1489,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 P.text do - src <- Path.parsePath' src - dest <- Path.parsePath' dest - pure $ Input.MoveBranchI src dest + [src, dest] -> Input.MoveBranchI <$> handlePath'Arg src <*> handlePath'Arg dest _ -> Left (I.help renameBranch) history :: InputPattern @@ -1157,9 +1509,7 @@ history = ] ) \case - [src] -> first P.text do - p <- Input.parseBranchId src - pure $ Input.HistoryI (Just 10) (Just 10) p + [src] -> Input.HistoryI (Just 10) (Just 10) <$> handleBranchIdArg src [] -> pure $ Input.HistoryI (Just 10) (Just 10) (Right Path.currentPath) _ -> Left (I.help history) @@ -1185,10 +1535,7 @@ forkLocal = ] ) \case - [src, dest] -> do - src <- Input.parseBranchId2 src - dest <- parseBranchRelativePath dest - pure $ Input.ForkLocalBranchI src dest + [src, dest] -> Input.ForkLocalBranchI <$> handleBranchId2Arg src <*> handleBranchRelativePathArg dest _ -> Left (I.help forkLocal) libInstallInputPattern :: InputPattern @@ -1217,13 +1564,9 @@ libInstallInputPattern = ) ] ], - parse = \args -> - maybe (Left (I.help libInstallInputPattern)) Right do - [arg] <- Just args - libdep <- - eitherToMaybe $ - tryInto @(ProjectAndBranch ProjectName (Maybe ProjectBranchNameOrLatestRelease)) (Text.pack arg) - Just (Input.LibInstallI libdep) + parse = \case + [arg] -> Input.LibInstallI <$> handleProjectMaybeBranchArg arg + _ -> Left (I.help libInstallInputPattern) } reset :: InputPattern @@ -1242,32 +1585,11 @@ reset = ("`reset #pvfd222s8n /topic`", "reset the branch `topic` of the current project to the causal `#pvfd222s8n`.") ] ) - ( maybeToEither (I.help reset) . \case - arg0 : restArgs -> do - arg0 <- branchIdOrProject arg0 - arg1 <- case restArgs of - [] -> pure Nothing - arg1 : [] -> Just <$> parseLooseCodeOrProject arg1 - _ -> Nothing - Just (Input.ResetI arg0 arg1) - _ -> Nothing - ) + \case + [arg0] -> Input.ResetI <$> handleBranchIdOrProjectArg arg0 <*> pure Nothing + [arg0, arg1] -> Input.ResetI <$> handleBranchIdOrProjectArg arg0 <*> fmap pure (handleLooseCodeOrProjectArg arg1) + _ -> Left $ I.help reset where - branchIdOrProject :: - String -> - Maybe - ( These - Input.BranchId - (ProjectAndBranch (Maybe ProjectName) ProjectBranchName) - ) - branchIdOrProject str = - let branchIdRes = Input.parseBranchId str - projectRes = tryInto @(ProjectAndBranch (Maybe ProjectName) ProjectBranchName) (Text.pack str) - in case (branchIdRes, projectRes) of - (Left _, Left _) -> Nothing - (Left _, Right pr) -> Just (That pr) - (Right bid, Left _) -> Just (This bid) - (Right bid, Right pr) -> Just (These bid pr) config = ProjectBranchSuggestionsConfig { showProjectCompletions = False, @@ -1296,10 +1618,8 @@ resetRoot = ] ] ) - \case - [src] -> first P.text $ do - src <- Input.parseBranchId src - pure $ Input.ResetRootI src + $ \case + [src] -> Input.ResetRootI <$> handleBranchIdArg src _ -> Left (I.help resetRoot) pull :: InputPattern @@ -1358,57 +1678,49 @@ pullImpl name aliases pullMode addendum = do "", explainRemote Pull ], - parse = \case - -- maybeToEither (I.help self) . \case - [] -> Right $ Input.PullI Input.PullSourceTarget0 pullMode - [sourceString] -> do - source <- - sourceString - & Text.pack - & megaparse (readRemoteNamespaceParser ProjectBranchSpecifier'NameOrLatestRelease) - & mapLeft (\err -> I.help self <> P.newline <> err) - Right $ Input.PullI (Input.PullSourceTarget1 source) pullMode - [sourceString, targetString] -> do - source <- - sourceString - & Text.pack - & megaparse (readRemoteNamespaceParser ProjectBranchSpecifier'NameOrLatestRelease) - & mapLeft (\err -> I.help self <> P.newline <> err) - target <- - targetString - & Text.pack - & megaparse branchWithOptionalProjectParser - & mapLeft - ( \err -> - -- You used to be able to pull into a path. So if target parsing fails, but path parsing succeeds, - -- explain that the command has changed. Furthermore, in the special case that the user is trying to - -- pull into the `lib` namespace, suggest using `lib.install`. - case Path.parsePath' targetString of - Left _ -> I.help self <> P.newline <> err - Right path -> - I.help self - <> P.newline - <> P.newline - <> P.newline - <> let pullingIntoLib = - case path of - Path.RelativePath' - ( Path.Relative - (Path.toList -> lib : _) - ) -> lib == NameSegment.libSegment - _ -> False - in P.wrap $ - "You may only" - <> makeExample' pull - <> "into a branch." - <> if pullingIntoLib - then - "Did you mean to run" - <> P.group (makeExample libInstallInputPattern [P.string sourceString] <> "?") - else mempty - ) - Right $ Input.PullI (Input.PullSourceTarget2 source target) pullMode - _ -> Left (I.help self) + parse = + fmap + (flip Input.PullI pullMode) + . ( \case + [] -> pure $ Input.PullSourceTarget0 + [sourceString] -> + bimap (\err -> I.help self <> P.newline <> err) Input.PullSourceTarget1 $ + handlePullSourceArg sourceString + [sourceString, targetString] -> + Input.PullSourceTarget2 + <$> first (\err -> I.help self <> P.newline <> err) (handlePullSourceArg sourceString) + <*> first + ( \err -> + -- You used to be able to pull into a path. So if target parsing fails, but path parsing succeeds, + -- explain that the command has changed. Furthermore, in the special case that the user is trying to + -- pull into the `lib` namespace, suggest using `lib.install`. + case handlePath'Arg targetString of + Left _ -> I.help self <> P.newline <> err + Right path -> + I.help self + <> P.newline + <> P.newline + <> P.newline + <> let pullingIntoLib = + case path of + Path.RelativePath' + ( Path.Relative + (Path.toList -> lib : _) + ) -> lib == NameSegment.libSegment + _ -> False + in P.wrap $ + "You may only" + <> makeExample' pull + <> "into a branch." + <> if pullingIntoLib + then + "Did you mean to run" + <> P.group (makeExample libInstallInputPattern [P.string $ unifyArgument sourceString] <> "?") + else mempty + ) + (handleMaybeProjectBranchArg targetString) + _ -> Left $ I.help self + ) } debugTabCompletion :: InputPattern @@ -1423,9 +1735,7 @@ debugTabCompletion = P.wrap $ "Completions which are finished are prefixed with a * represent finished completions." ] ) - ( \inputs -> - Right $ Input.DebugTabCompletionI inputs - ) + (fmap Input.DebugTabCompletionI . traverse (unsupportedStructuredArgument "text")) debugFuzzyOptions :: InputPattern debugFuzzyOptions = @@ -1444,7 +1754,9 @@ debugFuzzyOptions = ) \case (cmd : args) -> - Right $ Input.DebugFuzzyOptionsI cmd args + Input.DebugFuzzyOptionsI + <$> unsupportedStructuredArgument "a command" cmd + <*> traverse (unsupportedStructuredArgument "text") args _ -> Left (I.help debugFuzzyOptions) debugFormat :: InputPattern @@ -1495,24 +1807,20 @@ push = explainRemote Push ] ) - \args -> do - sourceTarget <- - case args of - [] -> Right Input.PushSourceTarget0 - [targetStr] -> do - target <- parsePushTarget targetStr - Right (Input.PushSourceTarget1 target) - [targetStr, sourceStr] -> do - target <- parsePushTarget targetStr - source <- parsePushSource sourceStr - Right (Input.PushSourceTarget2 source target) - _ -> Left (I.help push) - Right $ - Input.PushRemoteBranchI - Input.PushRemoteBranchInput - { sourceTarget, - pushBehavior = PushBehavior.RequireNonEmpty - } + $ fmap + ( \sourceTarget -> + Input.PushRemoteBranchI + Input.PushRemoteBranchInput + { sourceTarget, + pushBehavior = PushBehavior.RequireNonEmpty + } + ) + . \case + [] -> pure Input.PushSourceTarget0 + [targetStr] -> Input.PushSourceTarget1 <$> handlePushTargetArg targetStr + [targetStr, sourceStr] -> + Input.PushSourceTarget2 <$> handlePushSourceArg sourceStr <*> handlePushTargetArg targetStr + _ -> Left (I.help push) where suggestionsConfig = ProjectBranchSuggestionsConfig @@ -1550,24 +1858,20 @@ pushCreate = explainRemote Push ] ) - \args -> do - sourceTarget <- - case args of - [] -> Right Input.PushSourceTarget0 - [targetStr] -> do - target <- parsePushTarget targetStr - Right (Input.PushSourceTarget1 target) - [targetStr, sourceStr] -> do - target <- parsePushTarget targetStr - source <- parsePushSource sourceStr - Right (Input.PushSourceTarget2 source target) - _ -> Left (I.help pushForce) - Right $ - Input.PushRemoteBranchI - Input.PushRemoteBranchInput - { sourceTarget, - pushBehavior = PushBehavior.RequireEmpty - } + $ fmap + ( \sourceTarget -> + Input.PushRemoteBranchI + Input.PushRemoteBranchInput + { sourceTarget, + pushBehavior = PushBehavior.RequireEmpty + } + ) + . \case + [] -> pure Input.PushSourceTarget0 + [targetStr] -> Input.PushSourceTarget1 <$> handlePushTargetArg targetStr + [targetStr, sourceStr] -> + Input.PushSourceTarget2 <$> handlePushSourceArg sourceStr <*> handlePushTargetArg targetStr + _ -> Left (I.help pushForce) where suggestionsConfig = ProjectBranchSuggestionsConfig @@ -1584,24 +1888,20 @@ pushForce = I.Hidden [("remote destination", Optional, remoteNamespaceArg), ("local source", Optional, namespaceOrProjectBranchArg suggestionsConfig)] (P.wrap "Like `push`, but overwrites any remote namespace.") - \args -> do - sourceTarget <- - case args of - [] -> Right Input.PushSourceTarget0 - [targetStr] -> do - target <- parsePushTarget targetStr - Right (Input.PushSourceTarget1 target) - [targetStr, sourceStr] -> do - target <- parsePushTarget targetStr - source <- parsePushSource sourceStr - Right (Input.PushSourceTarget2 source target) - _ -> Left (I.help pushForce) - Right $ - Input.PushRemoteBranchI - Input.PushRemoteBranchInput - { sourceTarget, - pushBehavior = PushBehavior.ForcePush - } + $ fmap + ( \sourceTarget -> + Input.PushRemoteBranchI + Input.PushRemoteBranchInput + { sourceTarget, + pushBehavior = PushBehavior.ForcePush + } + ) + . \case + [] -> pure Input.PushSourceTarget0 + [targetStr] -> Input.PushSourceTarget1 <$> handlePushTargetArg targetStr + [targetStr, sourceStr] -> + Input.PushSourceTarget2 <$> handlePushSourceArg sourceStr <*> handlePushTargetArg targetStr + _ -> Left (I.help pushForce) where suggestionsConfig = ProjectBranchSuggestionsConfig @@ -1628,24 +1928,20 @@ pushExhaustive = <> "versions M1l and earlier. It may be extra slow!" ] ) - \args -> do - sourceTarget <- - case args of - [] -> Right Input.PushSourceTarget0 - [targetStr] -> do - target <- parsePushTarget targetStr - Right (Input.PushSourceTarget1 target) - [targetStr, sourceStr] -> do - target <- parsePushTarget targetStr - source <- parsePushSource sourceStr - Right (Input.PushSourceTarget2 source target) - _ -> Left (I.help pushExhaustive) - Right $ - Input.PushRemoteBranchI - Input.PushRemoteBranchInput - { sourceTarget, - pushBehavior = PushBehavior.RequireNonEmpty - } + $ fmap + ( \sourceTarget -> + Input.PushRemoteBranchI + Input.PushRemoteBranchInput + { sourceTarget, + pushBehavior = PushBehavior.RequireNonEmpty + } + ) + . \case + [] -> pure Input.PushSourceTarget0 + [targetStr] -> Input.PushSourceTarget1 <$> handlePushTargetArg targetStr + [targetStr, sourceStr] -> + Input.PushSourceTarget2 <$> handlePushSourceArg sourceStr <*> handlePushTargetArg targetStr + _ -> Left (I.help pushExhaustive) where suggestionsConfig = ProjectBranchSuggestionsConfig @@ -1671,13 +1967,13 @@ mergeOldSquashInputPattern = <> "discarding the history of `src` in the process." <> "The resulting `dest` will have (at most) 1" <> "additional history entry.", - parse = - maybeToEither (I.help mergeOldSquashInputPattern) . \case - [src, dest] -> do - src <- parseLooseCodeOrProject src - dest <- parseLooseCodeOrProject dest - Just $ Input.MergeLocalBranchI src dest Branch.SquashMerge - _ -> Nothing + parse = \case + [src, dest] -> + Input.MergeLocalBranchI + <$> handleLooseCodeOrProjectArg src + <*> handleLooseCodeOrProjectArg dest + <*> pure Branch.SquashMerge + _ -> Left $ I.help mergeOldSquashInputPattern } where suggestionsConfig = @@ -1717,15 +2013,18 @@ mergeOldInputPattern = ) ] ) - ( maybeToEither (I.help mergeOldInputPattern) . \case - [src] -> do - src <- parseLooseCodeOrProject src - Just $ Input.MergeLocalBranchI src (This Path.relativeEmpty') Branch.RegularMerge - [src, dest] -> do - src <- parseLooseCodeOrProject src - dest <- parseLooseCodeOrProject dest - Just $ Input.MergeLocalBranchI src dest Branch.RegularMerge - _ -> Nothing + ( \case + [src] -> + Input.MergeLocalBranchI + <$> handleLooseCodeOrProjectArg src + <*> pure (This Path.relativeEmpty') + <*> pure Branch.RegularMerge + [src, dest] -> + Input.MergeLocalBranchI + <$> handleLooseCodeOrProjectArg src + <*> handleLooseCodeOrProjectArg dest + <*> pure Branch.RegularMerge + _ -> Left $ I.help mergeOldInputPattern ) where config = @@ -1754,15 +2053,10 @@ mergeInputPattern = ], help = P.wrap $ makeExample mergeInputPattern ["/branch"] <> "merges `branch` into the current branch", parse = - \args -> - maybeToEither (I.help mergeInputPattern) do - [branchString] <- Just args - branch <- - eitherToMaybe $ - tryInto - @(ProjectAndBranch (Maybe ProjectName) ProjectBranchName) - (Text.pack branchString) - pure (Input.MergeI branch) + \case + [branchString] -> + Input.MergeI <$> handleMaybeProjectBranchArg branchString + _ -> Left $ I.help mergeInputPattern } parseLooseCodeOrProject :: String -> Maybe Input.LooseCodeOrProject @@ -1793,13 +2087,8 @@ diffNamespace = ] ) ( \case - [before, after] -> first P.text do - before <- Input.parseBranchId before - after <- Input.parseBranchId after - pure $ Input.DiffNamespaceI before after - [before] -> first P.text do - before <- Input.parseBranchId before - pure $ Input.DiffNamespaceI before (Right Path.currentPath) + [before, after] -> Input.DiffNamespaceI <$> handleBranchIdArg before <*> handleBranchIdArg after + [before] -> Input.DiffNamespaceI <$> handleBranchIdArg before <*> pure (pure Path.currentPath) _ -> Left $ I.help diffNamespace ) where @@ -1826,15 +2115,11 @@ mergeOldPreviewInputPattern = ) ] ) - ( maybeToEither (I.help mergeOldPreviewInputPattern) . \case - [src] -> do - src <- parseLooseCodeOrProject src - pure $ Input.PreviewMergeLocalBranchI src (This Path.relativeEmpty') - [src, dest] -> do - src <- parseLooseCodeOrProject src - dest <- parseLooseCodeOrProject dest - pure $ Input.PreviewMergeLocalBranchI src dest - _ -> Nothing + ( \case + [src] -> Input.PreviewMergeLocalBranchI <$> handleLooseCodeOrProjectArg src <*> pure (This Path.relativeEmpty') + [src, dest] -> + Input.PreviewMergeLocalBranchI <$> handleLooseCodeOrProjectArg src <*> handleLooseCodeOrProjectArg dest + _ -> Left $ I.help mergeOldPreviewInputPattern ) where suggestionsConfig = @@ -1873,12 +2158,12 @@ edit = "`edit` without arguments invokes a search to select a definition for editing, which requires that `fzf` can be found within your PATH." ], parse = - \case - (x : xs) -> - (x NE.:| xs) - & traverse parseHashQualifiedName - <&> (Input.ShowDefinitionI Input.LatestFileLocation Input.ShowDefinitionLocal) - [] -> Left (I.help edit) + maybe + (Left $ I.help edit) + ( fmap (Input.ShowDefinitionI Input.LatestFileLocation Input.ShowDefinitionLocal) + . traverse handleHashQualifiedNameArg + ) + . NE.nonEmpty } editNamespace :: InputPattern @@ -1893,7 +2178,7 @@ editNamespace = [ "`edit.namespace` will load all terms and types contained within the current namespace into your scratch file. This includes definitions in namespaces, but excludes libraries.", "`edit.namespace ns1 ns2 ...` loads the terms and types contained within the provided namespaces." ], - parse = Right . Input.EditNamespaceI . fmap (Path.unsafeParseText . Text.pack) + parse = fmap Input.EditNamespaceI . traverse handlePathArg } topicNameArg :: ArgumentType @@ -1901,7 +2186,7 @@ topicNameArg = let topics = Map.keys helpTopicsMap in ArgumentType { typeName = "topic", - suggestions = \q _ _ _ -> pure (exactComplete q $ topics), + suggestions = \q _ _ _ -> pure (exactComplete q topics), fzfResolver = Just $ Resolvers.fuzzySelectFromList (Text.pack <$> topics) } @@ -1915,9 +2200,11 @@ helpTopics = ("`help-topics` lists all topics and `help-topics ` shows an explanation of that topic.") ( \case [] -> Left topics - [topic] -> case Map.lookup topic helpTopicsMap of - Nothing -> Left . warn $ "I don't know of that topic. Try `help-topics`." - Just t -> Left t + [topic] -> do + topic <- unsupportedStructuredArgument "a help topic" topic + case Map.lookup topic helpTopicsMap of + Nothing -> Left . warn $ "I don't know of that topic. Try `help-topics`." + Just t -> Left t _ -> Left $ warn "Use `help-topics ` or `help-topics`." ) where @@ -2095,14 +2382,15 @@ help = I.Visible [("command", Optional, commandNameArg)] "`help` shows general help and `help ` shows help for one command." - \case + $ \case [] -> Left $ intercalateMap "\n\n" showPatternHelp visibleInputs - [cmd] -> + [cmd] -> do + cmd <- unsupportedStructuredArgument "a command" cmd case (Map.lookup cmd commandsByName, isHelp cmd) of (Nothing, Just msg) -> Left msg (Nothing, Nothing) -> Left . warn $ "I don't know of that command. Try `help`." @@ -2149,13 +2437,8 @@ names isGlobal = I.Visible [("name or hash", Required, definitionQueryArg)] (P.wrap $ makeExample (names isGlobal) ["foo"] <> " shows the hash and all known names for `foo`.") - \case - [thing] -> case HQ.parseText (Text.pack thing) of - Just hq -> Right $ Input.NamesI isGlobal hq - Nothing -> - Left $ - "I was looking for one of these forms: " - <> P.blue "foo .foo.bar foo#abc #abcde .foo.bar#asdf" + $ \case + [thing] -> Input.NamesI isGlobal <$> handleHashQualifiedNameArg thing _ -> Left (I.help (names isGlobal)) where cmdName = if isGlobal then "names.global" else "names" @@ -2168,8 +2451,8 @@ dependents = I.Visible [("definition", Required, definitionQueryArg)] "List the named dependents of the specified definition." - \case - [thing] -> fmap Input.ListDependentsI $ parseHashQualifiedName thing + $ \case + [thing] -> Input.ListDependentsI <$> handleHashQualifiedNameArg thing _ -> Left (I.help dependents) dependencies = InputPattern @@ -2178,8 +2461,8 @@ dependencies = I.Visible [("definition", Required, definitionQueryArg)] "List the dependencies of the specified definition." - \case - [thing] -> fmap Input.ListDependenciesI $ parseHashQualifiedName thing + $ \case + [thing] -> Input.ListDependenciesI <$> handleHashQualifiedNameArg thing _ -> Left (I.help dependencies) namespaceDependencies :: InputPattern @@ -2190,10 +2473,8 @@ namespaceDependencies = I.Visible [("namespace", Optional, namespaceArg)] "List the external dependencies of the specified namespace." - \case - [p] -> first P.text do - p <- Path.parsePath' p - pure $ Input.NamespaceDependenciesI (Just p) + $ \case + [p] -> Input.NamespaceDependenciesI . pure <$> handlePath'Arg p [] -> pure (Input.NamespaceDependenciesI Nothing) _ -> Left (I.help namespaceDependencies) @@ -2246,7 +2527,7 @@ debugTerm = [("term", Required, exactDefinitionTermQueryArg)] "View debugging information for a given term." ( \case - [thing] -> fmap (Input.DebugTermI False) $ parseHashQualifiedName thing + [thing] -> Input.DebugTermI False <$> handleHashQualifiedNameArg thing _ -> Left (I.help debugTerm) ) @@ -2259,7 +2540,7 @@ debugTermVerbose = [("term", Required, exactDefinitionTermQueryArg)] "View verbose debugging information for a given term." ( \case - [thing] -> fmap (Input.DebugTermI True) $ parseHashQualifiedName thing + [thing] -> Input.DebugTermI True <$> handleHashQualifiedNameArg thing _ -> Left (I.help debugTermVerbose) ) @@ -2272,7 +2553,7 @@ debugType = [("type", Required, exactDefinitionTypeQueryArg)] "View debugging information for a given type." ( \case - [thing] -> fmap (Input.DebugTypeI) $ parseHashQualifiedName thing + [thing] -> Input.DebugTypeI <$> handleHashQualifiedNameArg thing _ -> Left (I.help debugType) ) @@ -2318,14 +2599,9 @@ debugNameDiff = visibility = I.Hidden, args = [("before namespace", Required, namespaceArg), ("after namespace", Required, namespaceArg)], help = P.wrap "List all name changes between two causal hashes. Does not detect patch changes.", - parse = - ( \case - [from, to] -> first fromString $ do - fromSCH <- Input.parseShortCausalHash from - toSCH <- Input.parseShortCausalHash to - pure $ Input.DebugNameDiffI fromSCH toSCH - _ -> Left (I.help debugNameDiff) - ) + parse = \case + [from, to] -> Input.DebugNameDiffI <$> handleShortCausalHashArg from <*> handleShortCausalHashArg to + _ -> Left (I.help debugNameDiff) } test :: InputPattern @@ -2340,21 +2616,21 @@ test = [ ("`test`", "runs unit tests for the current branch"), ("`test foo`", "runs unit tests for the current branch defined in namespace `foo`") ], - parse = \args -> - maybe (Left (I.help test)) Right do - path <- - case args of - [] -> Just Path.empty - [pathString] -> eitherToMaybe $ Path.parsePath pathString - _ -> Nothing - Just $ - Input.TestI - Input.TestInput - { includeLibNamespace = False, - path, - showFailures = True, - showSuccesses = True - } + parse = + fmap + ( \path -> + Input.TestI + Input.TestInput + { includeLibNamespace = False, + path, + showFailures = True, + showSuccesses = True + } + ) + . \case + [] -> pure Path.empty + [pathString] -> handlePathArg pathString + _ -> Left $ I.help test } testAll :: InputPattern @@ -2391,9 +2667,10 @@ docsToHtml = ] ) \case - [namespacePath, destinationFilePath] -> first P.text do - np <- Path.parsePath' namespacePath - pure $ Input.DocsToHtmlI np destinationFilePath + [namespacePath, destinationFilePath] -> + Input.DocsToHtmlI + <$> handlePath'Arg namespacePath + <*> unsupportedStructuredArgument "a file name" destinationFilePath _ -> Left $ showPatternHelp docsToHtml docToMarkdown :: InputPattern @@ -2410,9 +2687,7 @@ docToMarkdown = ] ) \case - [docNameText] -> first fromString $ do - docName <- maybeToEither "Invalid name" . Name.parseText . Text.pack $ docNameText - pure $ Input.DocToMarkdownI docName + [docNameText] -> Input.DocToMarkdownI <$> handleNameArg docNameText _ -> Left $ showPatternHelp docToMarkdown execute :: InputPattern @@ -2431,9 +2706,10 @@ execute = ) ] ) - \case - [w] -> pure $ Input.ExecuteI (Text.pack w) [] - w : ws -> pure $ Input.ExecuteI (Text.pack w) ws + $ \case + main : args -> + Input.ExecuteI (Text.pack $ unifyArgument main) + <$> traverse (unsupportedStructuredArgument "a command-line argument") args _ -> Left $ showPatternHelp execute saveExecuteResult :: InputPattern @@ -2446,8 +2722,8 @@ saveExecuteResult = ( "`add.run name` adds to the codebase the result of the most recent `run` command" <> "as `name`." ) - \case - [w] -> pure $ Input.SaveExecuteResultI (Name.unsafeParseText (Text.pack w)) + $ \case + [w] -> Input.SaveExecuteResultI <$> handleNameArg w _ -> Left $ showPatternHelp saveExecuteResult ioTest :: InputPattern @@ -2464,7 +2740,7 @@ ioTest = ) ], parse = \case - [thing] -> fmap Input.IOTestI $ parseHashQualifiedName thing + [thing] -> Input.IOTestI <$> handleHashQualifiedNameArg thing _ -> Left $ showPatternHelp ioTest } @@ -2501,9 +2777,11 @@ makeStandalone = ) ] ) - \case + $ \case [main, file] -> - Input.MakeStandaloneI file <$> parseHashQualifiedName main + Input.MakeStandaloneI + <$> unsupportedStructuredArgument "a file name" file + <*> handleHashQualifiedNameArg main _ -> Left $ showPatternHelp makeStandalone runScheme :: InputPattern @@ -2519,8 +2797,10 @@ runScheme = ) ] ) - \case - main : args -> Right $ Input.ExecuteSchemeI (Text.pack main) args + $ \case + main : args -> + Input.ExecuteSchemeI (Text.pack $ unifyArgument main) + <$> traverse (unsupportedStructuredArgument "a command-line argument") args _ -> Left $ showPatternHelp runScheme compileScheme :: InputPattern @@ -2538,9 +2818,11 @@ compileScheme = ) ] ) - \case + $ \case [main, file] -> - Input.CompileSchemeI (Text.pack file) <$> parseHashQualifiedName main + Input.CompileSchemeI . Text.pack + <$> unsupportedStructuredArgument "a file name" file + <*> handleHashQualifiedNameArg main _ -> Left $ showPatternHelp compileScheme createAuthor :: InputPattern @@ -2561,19 +2843,19 @@ createAuthor = <> backtick (P.group ("metadata.copyrightHolders" <> ".")) ) ) - ( \case - symbolStr : authorStr@(_ : _) -> first P.text do - symbol <- - Megaparsec.runParser (Megaparsec.withParsecT (fmap NameSegment.renderParseErr) NameSegment.segmentP <* Megaparsec.eof) "" symbolStr - & mapLeft (Text.pack . Megaparsec.errorBundlePretty) - -- let's have a real parser in not too long - let author :: Text - author = Text.pack $ case (unwords authorStr) of - quoted@('"' : _) -> (init . tail) quoted - bare -> bare - pure $ Input.CreateAuthorI symbol author - _ -> Left $ showPatternHelp createAuthor - ) + \case + symbolStr : authorStr@(_ : _) -> + Input.CreateAuthorI + <$> handleRelativeNameSegmentArg symbolStr + <*> fmap (parseAuthorName . unwords) (traverse (unsupportedStructuredArgument "text") authorStr) + _ -> Left $ showPatternHelp createAuthor + where + -- let's have a real parser in not too long + parseAuthorName :: String -> Text + parseAuthorName = + Text.pack . \case + ('"' : quoted) -> init quoted + bare -> bare authLogin :: InputPattern authLogin = @@ -2620,11 +2902,9 @@ projectCreate = ("`project.create foo`", "creates a project named `foo`") ], parse = \case - [name] -> - case tryInto @ProjectName (Text.pack name) of - Left _ -> Left "Invalid project name." - Right name1 -> Right (Input.ProjectCreateI True (Just name1)) - _ -> Right (Input.ProjectCreateI True Nothing) + [] -> pure $ Input.ProjectCreateI True Nothing + [name] -> Input.ProjectCreateI True . pure <$> handleProjectArg name + _ -> Left $ showPatternHelp projectCreate } projectCreateEmptyInputPattern :: InputPattern @@ -2640,11 +2920,9 @@ projectCreateEmptyInputPattern = ("`project.create-empty foo`", "creates an empty project named `foo`") ], parse = \case - [name] -> - case tryInto @ProjectName (Text.pack name) of - Left _ -> Left "Invalid project name." - Right name1 -> Right (Input.ProjectCreateI False (Just name1)) - _ -> Right (Input.ProjectCreateI False Nothing) + [] -> pure $ Input.ProjectCreateI False Nothing + [name] -> Input.ProjectCreateI False . pure <$> handleProjectArg name + _ -> Left $ showPatternHelp projectCreateEmptyInputPattern } projectRenameInputPattern :: InputPattern @@ -2659,7 +2937,7 @@ projectRenameInputPattern = [ ("`project.rename foo`", "renames the current project to `foo`") ], parse = \case - [nameString] | Right name <- tryInto (Text.pack nameString) -> Right (Input.ProjectRenameI name) + [nameString] -> Input.ProjectRenameI <$> handleProjectArg nameString _ -> Left (showPatternHelp projectRenameInputPattern) } @@ -2678,10 +2956,7 @@ projectSwitch = ("`switch /bar`", "switches to the branch `bar` in the current project") ], parse = \case - [name] -> - case tryInto @ProjectAndBranchNames (Text.pack name) of - Left _ -> Left (showPatternHelp projectSwitch) - Right projectAndBranch -> Right (Input.ProjectSwitchI projectAndBranch) + [name] -> Input.ProjectSwitchI <$> handleProjectAndBranchNamesArg name _ -> Left (showPatternHelp projectSwitch) } where @@ -2717,7 +2992,7 @@ branchesInputPattern = ], parse = \case [] -> Right (Input.BranchesI Nothing) - [nameString] | Right name <- tryFrom (Text.pack nameString) -> Right (Input.BranchesI (Just name)) + [nameString] -> Input.BranchesI . pure <$> handleProjectArg nameString _ -> Left (showPatternHelp branchesInputPattern) } @@ -2737,22 +3012,13 @@ branchInputPattern = ("`branch /bar foo`", "forks the branch `bar` of the current project to a new branch `foo`"), ("`branch .bar foo`", "forks the path `.bar` of the current project to a new branch `foo`") ], - parse = - maybeToEither (showPatternHelp branchInputPattern) . \case - [source0, name] -> do - source <- parseLooseCodeOrProject source0 - projectAndBranch <- - Text.pack name - & tryInto @(ProjectAndBranch (Maybe ProjectName) ProjectBranchName) - & eitherToMaybe - Just (Input.BranchI (Input.BranchSourceI'LooseCodeOrProject source) projectAndBranch) - [name] -> do - projectAndBranch <- - Text.pack name - & tryInto @(ProjectAndBranch (Maybe ProjectName) ProjectBranchName) - & eitherToMaybe - Just (Input.BranchI Input.BranchSourceI'CurrentContext projectAndBranch) - _ -> Nothing + parse = \case + [source0, name] -> + Input.BranchI . Input.BranchSourceI'LooseCodeOrProject + <$> handleLooseCodeOrProjectArg source0 + <*> handleMaybeProjectBranchArg name + [name] -> Input.BranchI Input.BranchSourceI'CurrentContext <$> handleMaybeProjectBranchArg name + _ -> Left $ showPatternHelp branchInputPattern } where newBranchNameArg = @@ -2778,9 +3044,8 @@ branchEmptyInputPattern = help = P.wrap "Create a new empty branch.", parse = \case [name] -> - first (\_ -> showPatternHelp branchEmptyInputPattern) do - projectAndBranch <- tryInto @(ProjectAndBranch (Maybe ProjectName) ProjectBranchName) (Text.pack name) - Right (Input.BranchI Input.BranchSourceI'Empty projectAndBranch) + Input.BranchI Input.BranchSourceI'Empty + <$> handleMaybeProjectBranchArg name _ -> Left (showPatternHelp branchEmptyInputPattern) } @@ -2793,10 +3058,9 @@ branchRenameInputPattern = args = [], help = P.wrapColumn2 - [ ("`branch.rename foo`", "renames the current branch to `foo`") - ], + [("`branch.rename foo`", "renames the current branch to `foo`")], parse = \case - [nameString] | Right name <- tryInto (Text.pack nameString) -> Right (Input.BranchRenameI name) + [name] -> Input.BranchRenameI <$> handleProjectBranchNameArg name _ -> Left (showPatternHelp branchRenameInputPattern) } @@ -2829,16 +3093,13 @@ clone = <> P.group (makeExample helpTopics ["remotes"] <> ")") ) ], - parse = - maybe (Left (showPatternHelp clone)) Right . \case - [remoteNamesString] -> do - remoteNames <- eitherToMaybe (tryInto @ProjectAndBranchNames (Text.pack remoteNamesString)) - Just (Input.CloneI remoteNames Nothing) - [remoteNamesString, localNamesString] -> do - remoteNames <- eitherToMaybe (tryInto @ProjectAndBranchNames (Text.pack remoteNamesString)) - localNames <- eitherToMaybe (tryInto @ProjectAndBranchNames (Text.pack localNamesString)) - Just (Input.CloneI remoteNames (Just localNames)) - _ -> Nothing + parse = \case + [remoteNames] -> Input.CloneI <$> handleProjectAndBranchNamesArg remoteNames <*> pure Nothing + [remoteNames, localNames] -> + Input.CloneI + <$> handleProjectAndBranchNamesArg remoteNames + <*> fmap pure (handleProjectAndBranchNamesArg localNames) + _ -> Left $ showPatternHelp clone } releaseDraft :: InputPattern @@ -2850,7 +3111,11 @@ releaseDraft = args = [], help = P.wrap "Draft a release.", parse = \case - [tryInto @Semver . Text.pack -> Right semver] -> Right (Input.ReleaseDraftI semver) + [semverString] -> + bimap (const "Couldn’t parse version number") Input.ReleaseDraftI + . tryInto @Semver + . Text.pack + =<< unsupportedStructuredArgument "a version number" semverString _ -> Left (showPatternHelp releaseDraft) } @@ -2864,20 +3129,11 @@ upgrade = help = P.wrap $ "`upgrade old new` upgrades library dependency `lib.old` to `lib.new`, and, if successful, deletes `lib.old`.", - parse = - maybeToEither (I.help upgrade) . \args -> do - [oldString, newString] <- Just args - old <- parseRelativeNameSegment oldString - new <- parseRelativeNameSegment newString - Just (Input.UpgradeI old new) + parse = \case + [oldString, newString] -> + Input.UpgradeI <$> handleRelativeNameSegmentArg oldString <*> handleRelativeNameSegmentArg newString + _ -> Left $ I.help upgrade } - where - parseRelativeNameSegment :: String -> Maybe NameSegment - parseRelativeNameSegment string = do - name <- Name.parseText (Text.pack string) - guard (Name.isRelative name) - segment NE.:| [] <- Just (Name.reverseSegments name) - Just segment validInputs :: [InputPattern] validInputs = @@ -3219,7 +3475,7 @@ projectAndOrBranchSuggestions config inputStr codebase _httpClient path = do ProjectBranchPath projectId branchId _ -> (Just projectId, Just branchId) handleAmbiguousComplete :: - MonadIO m => + (MonadIO m) => Text -> Codebase m v a -> m [Completion] @@ -3308,7 +3564,7 @@ projectAndOrBranchSuggestions config inputStr codebase _httpClient path = do then projectCompletions else branchCompletions ++ projectCompletions - handleBranchesComplete :: MonadIO m => Text -> Codebase m v a -> Path.Absolute -> m [Completion] + handleBranchesComplete :: (MonadIO m) => Text -> Codebase m v a -> Path.Absolute -> m [Completion] handleBranchesComplete branchName codebase path = do branches <- case preview ProjectUtils.projectBranchPathPrism path of @@ -3349,7 +3605,7 @@ projectBranchToCompletion projectName (_, branchName) = } handleBranchesComplete :: - MonadIO m => + (MonadIO m) => ProjectBranchSuggestionsConfig -> Text -> Codebase m v a -> @@ -3385,7 +3641,7 @@ currentProjectBranchToCompletion (_, branchName) = } branchRelativePathSuggestions :: - MonadIO m => + (MonadIO m) => ProjectBranchSuggestionsConfig -> String -> Codebase m v a -> @@ -3491,7 +3747,7 @@ branchRelativePathSuggestions config inputStr codebase _httpClient currentPath = branchPathSepPretty = P.hiBlack branchPathSep - branchPathSep :: IsString s => s + branchPathSep :: (IsString s) => s branchPathSep = ":" -- | A project name, branch name, or both. @@ -3541,7 +3797,7 @@ data OptionalSlash | NoSlash projectNameSuggestions :: - MonadIO m => + (MonadIO m) => OptionalSlash -> String -> Codebase m v a -> @@ -3568,21 +3824,16 @@ projectNameSuggestions slash (Text.strip . Text.pack -> input) codebase = do } -- | Parse a 'Input.PushSource'. -parsePushSource :: String -> Either (P.Pretty CT.ColorText) Input.PushSource +parsePushSource :: String -> Maybe Input.PushSource parsePushSource sourceStr = - case tryFrom (Text.pack sourceStr) of - Left _ -> - case Path.parsePath' sourceStr of - Left _ -> Left (I.help push) - Right path -> Right (Input.PathySource path) - Right branch -> Right (Input.ProjySource branch) + fixup Input.ProjySource (tryFrom $ Text.pack sourceStr) + <|> fixup Input.PathySource (Path.parsePath' sourceStr) + where + fixup = either (const Nothing) . (pure .) -- | Parse a push target. -parsePushTarget :: String -> Either (P.Pretty CT.ColorText) (WriteRemoteNamespace (These ProjectName ProjectBranchName)) -parsePushTarget target = - case Megaparsec.parseMaybe UriParser.writeRemoteNamespace (Text.pack target) of - Nothing -> Left (I.help push) - Just path -> Right path +parsePushTarget :: String -> Maybe (WriteRemoteNamespace (These ProjectName ProjectBranchName)) +parsePushTarget = Megaparsec.parseMaybe UriParser.writeRemoteNamespace . Text.pack parseHashQualifiedName :: String -> Either (P.Pretty CT.ColorText) (HQ.HashQualified Name) diff --git a/unison-cli/src/Unison/CommandLine/Main.hs b/unison-cli/src/Unison/CommandLine/Main.hs index de0d7e12fbb..f675f918967 100644 --- a/unison-cli/src/Unison/CommandLine/Main.hs +++ b/unison-cli/src/Unison/CommandLine/Main.hs @@ -33,7 +33,7 @@ import Unison.Codebase qualified as Codebase import Unison.Codebase.Branch qualified as Branch import Unison.Codebase.Editor.HandleInput qualified as HandleInput import Unison.Codebase.Editor.Input (Event, Input (..)) -import Unison.Codebase.Editor.Output (Output) +import Unison.Codebase.Editor.Output (NumberedArgs, Output) import Unison.Codebase.Editor.UCMVersion (UCMVersion) import Unison.Codebase.Path qualified as Path import Unison.Codebase.Runtime qualified as Runtime @@ -61,7 +61,7 @@ getUserInput :: Codebase IO Symbol Ann -> AuthenticatedHttpClient -> Path.Absolute -> - [String] -> + NumberedArgs -> IO Input getUserInput codebase authHTTPClient currentPath numberedArgs = Line.runInputT @@ -113,10 +113,11 @@ getUserInput codebase authHTTPClient currentPath numberedArgs = -- Ctrl-c or some input cancel, re-run the prompt go Right (Just (expandedArgs, i)) -> do - let expandedArgsStr = unwords expandedArgs - when (expandedArgs /= ws) $ do + let expandedArgs' = IP.unifyArgument <$> expandedArgs + expandedArgsStr = unwords expandedArgs' + when (expandedArgs' /= ws) $ do liftIO . putStrLn $ fullPrompt <> expandedArgsStr - Line.modifyHistory $ Line.addHistoryUnlessConsecutiveDupe $ unwords expandedArgs + Line.modifyHistory $ Line.addHistoryUnlessConsecutiveDupe $ expandedArgsStr pure i settings :: Line.Settings IO settings = diff --git a/unison-cli/src/Unison/CommandLine/OutputMessages.hs b/unison-cli/src/Unison/CommandLine/OutputMessages.hs index 4b284ef2ffe..6b142389b8c 100644 --- a/unison-cli/src/Unison/CommandLine/OutputMessages.hs +++ b/unison-cli/src/Unison/CommandLine/OutputMessages.hs @@ -61,6 +61,8 @@ import Unison.Codebase.Editor.Output.PushPull qualified as PushPull import Unison.Codebase.Editor.RemoteRepo (ShareUserHandle (..), WriteRemoteNamespace (..), WriteShareRemoteNamespace (..)) import Unison.Codebase.Editor.RemoteRepo qualified as RemoteRepo import Unison.Codebase.Editor.SlurpResult qualified as SlurpResult +import Unison.Codebase.Editor.StructuredArgument (StructuredArgument) +import Unison.Codebase.Editor.StructuredArgument qualified as SA import Unison.Codebase.Editor.TodoOutput qualified as TO import Unison.Codebase.IntegrityCheck (IntegrityResult (..), prettyPrintIntegrityErrors) import Unison.Codebase.Patch (Patch (..)) @@ -342,7 +344,7 @@ notifyNumbered = \case ] branchHashes :: [CausalHash] branchHashes = (fst <$> reversedHistory) <> tailHashes - in (msg, displayBranchHash <$> branchHashes) + in (msg, SA.Namespace <$> branchHashes) where toSCH :: CausalHash -> ShortCausalHash toSCH h = SCH.fromHash schLength h @@ -400,7 +402,7 @@ notifyNumbered = \case ) ListProjects projects -> ( P.numberedList (map (prettyProjectName . view #name) projects), - map (Text.unpack . into @Text . view #name) projects + map (SA.Project . view #name) projects ) ListBranches projectName branches -> ( P.columnNHeader @@ -416,7 +418,9 @@ notifyNumbered = \case ] : map (\branch -> ["", "", prettyRemoteBranchInfo branch]) remoteBranches ), - map (\(branchName, _) -> Text.unpack (into @Text (ProjectAndBranch projectName branchName))) branches + map + (SA.ProjectBranch . ProjectAndBranch (pure projectName) . fst) + branches ) AmbiguousSwitch project (ProjectAndBranch currentProject branch) -> ( P.wrap @@ -441,8 +445,9 @@ notifyNumbered = \case <> switch ["2"] <> " to pick one of these." ), - [ Text.unpack (Text.cons '/' (into @Text branch)), - Text.unpack (into @Text (ProjectAndBranch project (UnsafeProjectBranchName "main"))) + [ SA.ProjectBranch $ ProjectAndBranch Nothing branch, + SA.ProjectBranch . ProjectAndBranch (pure project) $ + UnsafeProjectBranchName "main" ] ) where @@ -471,8 +476,8 @@ notifyNumbered = \case <> reset (resetArgs ["2"]) <> " to pick one of these." ), - [ Text.unpack (Text.cons '/' (into @Text branch)), - Text.unpack (into @Text (show absPath0)) + [ SA.ProjectBranch $ ProjectAndBranch Nothing branch, + SA.AbsolutePath absPath0 ] ) where @@ -508,13 +513,13 @@ notifyNumbered = \case newNextNum = nextNum + length unnumberedNames in ( newNextNum, ( nameToNum <> (Map.fromList (zip unnumberedNames [nextNum ..])), - args <> fmap Name.toText unnumberedNames + args <> unnumberedNames ) ) ) (1, (mempty, mempty)) & snd - & over (_2 . mapped) Text.unpack + & over (_2 . mapped) SA.Name externalDepsTable :: Map LabeledDependency (Set Name) -> [(P.Pretty P.ColorText, P.Pretty P.ColorText)] externalDepsTable = ifoldMap $ \ld dependents -> [(prettyLD ld, prettyDependents dependents)] @@ -1401,7 +1406,8 @@ notifyUser dir = \case prettyNamespaceKey dest <> "is already up-to-date with" <> P.group (prettyNamespaceKey src <> ".") - DumpNumberedArgs args -> pure . P.numberedList $ fmap P.string args + DumpNumberedArgs schLength args -> + pure . P.numberedList $ fmap (P.text . IP.formatStructuredArgument (pure schLength)) args NoConflictsOrEdits -> pure (P.okCallout "No conflicts or edits in progress.") HelpMessage pat -> pure $ IP.showPatternHelp pat @@ -2493,7 +2499,7 @@ renderNameConflicts ppe conflictedNames = do P.lines <$> do for (Map.toList conflictedNames) $ \(name, hashes) -> do prettyConflicts <- for hashes \hash -> do - n <- addNumberedArg (Text.unpack (HQ.toText hash)) + n <- addNumberedArg $ SA.HashQualified hash pure $ formatNum n <> (P.blue . P.syntaxToColor . prettyHashQualified $ hash) pure . P.wrap $ ( "The " @@ -2525,7 +2531,7 @@ renderEditConflicts ppe Patch {..} = do <> (fmap Right . Map.toList . R.toMultimap . R.filterManyDom $ _termEdits) numberedHQName :: HQ.HashQualified Name -> Numbered Pretty numberedHQName hqName = do - n <- addNumberedArg (Text.unpack (HQ.toText hqName)) + n <- addNumberedArg $ SA.HashQualified hqName pure $ formatNum n <> styleHashQualified P.bold hqName formatTypeEdits :: (Reference, Set TypeEdit.TypeEdit) -> @@ -2564,9 +2570,9 @@ renderEditConflicts ppe Patch {..} = do Numbered Pretty formatConflict = either formatTypeEdits formatTermEdits -type Numbered = State.State (Int, Seq.Seq String) +type Numbered = State.State (Int, Seq.Seq StructuredArgument) -addNumberedArg :: String -> Numbered Int +addNumberedArg :: StructuredArgument -> Numbered Int addNumberedArg s = do (n, args) <- State.get State.put (n + 1, args Seq.|> s) @@ -2638,11 +2644,11 @@ todoOutput ppe todo = runNumbered do todoEdits :: Numbered Pretty todoEdits = do numberedTypes <- for (unscore <$> dirtyTypes) \(ref, displayObj) -> do - n <- addNumberedArg (Text.unpack (HQ.toText $ PPE.typeName ppeu ref)) + n <- addNumberedArg . SA.HashQualified $ PPE.typeName ppeu ref pure $ formatNum n <> prettyDeclPair ppeu (ref, displayObj) let filteredTerms = goodTerms (unscore <$> dirtyTerms) termNumbers <- for filteredTerms \(ref, _, _) -> do - n <- addNumberedArg (Text.unpack (HQ.toText $ PPE.termName ppeu ref)) + n <- addNumberedArg . SA.HashQualified $ PPE.termName ppeu ref pure $ formatNum n let formattedTerms = TypePrinter.prettySignaturesCT ppes filteredTerms numberedTerms = zipWith (<>) termNumbers formattedTerms @@ -2942,7 +2948,7 @@ showDiffNamespace sn ppe oldPath newPath OBD.BranchDiffOutput {..} = [] -> mempty x : ys -> " (" <> P.commas (x <> " updates" : ys) <> ")" pure $ n <> P.bold " patch " <> prettyName name <> message - -- 18. patch q + -- 18. patch q prettyNamePatch prefix (name, _patchDiff) = do n <- numPatch prefix name pure $ n <> P.bold " patch " <> prettyName name @@ -3047,21 +3053,13 @@ showDiffNamespace sn ppe oldPath newPath OBD.BranchDiffOutput {..} = -- DeclPrinter.prettyDeclHeader : HQ -> Either numPatch :: Input.AbsBranchId -> Name -> Numbered Pretty numPatch prefix name = - addNumberedArg' $ prefixBranchId prefix name + addNumberedArg' $ SA.NameWithBranchPrefix prefix name numHQ' :: Input.AbsBranchId -> HQ'.HashQualified Name -> Referent -> Numbered Pretty numHQ' prefix hq r = - addNumberedArg' . HQ'.toStringWith (prefixBranchId prefix) . HQ'.requalify hq $ r - - -- E.g. - -- prefixBranchId "#abcdef" "base.List.map" -> "#abcdef.base.List.map" - -- prefixBranchId ".base" "List.map" -> ".base.List.map" - prefixBranchId :: Input.AbsBranchId -> Name -> String - prefixBranchId branchId name = case branchId of - Left sch -> "#" <> SCH.toString sch <> ":" <> Text.unpack (Name.toText (Name.makeAbsolute name)) - Right pathPrefix -> Text.unpack (Name.toText (Name.makeAbsolute . Path.prefixName pathPrefix $ name)) + addNumberedArg' . SA.HashQualifiedWithBranchPrefix prefix $ HQ'.requalify hq r - addNumberedArg' :: String -> Numbered Pretty + addNumberedArg' :: StructuredArgument -> Numbered Pretty addNumberedArg' s = case sn of ShowNumbers -> do n <- addNumberedArg s @@ -3316,7 +3314,7 @@ numberedArgsForEndangerments (PPED.unsuffixifiedPPE -> ppe) m = m & Map.elems & concatMap toList - & fmap (Text.unpack . HQ.toText . PPE.labeledRefName ppe) + & fmap (SA.HashQualified . PPE.labeledRefName ppe) -- | Format and render all dependents which are endangered by references going extinct. endangeredDependentsTable :: diff --git a/unison-cli/tests/Unison/Test/Cli/Monad.hs b/unison-cli/tests/Unison/Test/Cli/Monad.hs index 3b9407da117..0edb1dc3de1 100644 --- a/unison-cli/tests/Unison/Test/Cli/Monad.hs +++ b/unison-cli/tests/Unison/Test/Cli/Monad.hs @@ -6,6 +6,8 @@ where import Control.Lens import EasyTest import Unison.Cli.Monad qualified as Cli +import Unison.Codebase.Editor.StructuredArgument qualified as SA +import Unison.Reference qualified as Reference test :: Test () test = @@ -16,13 +18,13 @@ test = Cli.runCli dummyEnv dummyLoopState do Cli.label \goto -> do Cli.label \_ -> do - Cli.setNumberedArgs ["foo"] + Cli.setNumberedArgs [SA.Ref $ Reference.ReferenceBuiltin "foo"] goto (1 :: Int) pure 2 -- test that 'goto' short-circuits, as expected expectEqual' (Cli.Success 1) r -- test that calling 'goto' doesn't lose state changes made along the way - expectEqual' ["foo"] (state ^. #numberedArgs) + expectEqual' [SA.Ref $ Reference.ReferenceBuiltin "foo"] (state ^. #numberedArgs) ok ] diff --git a/unison-cli/unison-cli.cabal b/unison-cli/unison-cli.cabal index d1ea32baa3a..79f8ada36de 100644 --- a/unison-cli/unison-cli.cabal +++ b/unison-cli/unison-cli.cabal @@ -97,6 +97,7 @@ library Unison.Codebase.Editor.Slurp Unison.Codebase.Editor.SlurpComponent Unison.Codebase.Editor.SlurpResult + Unison.Codebase.Editor.StructuredArgument Unison.Codebase.Editor.TodoOutput Unison.Codebase.Editor.UCMVersion Unison.Codebase.Editor.UriParser