Merge pull request #4962 from sellout/structured-numbered-args

Avoid printing/parsing numbered args

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

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 =

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.<everything>...`
 _searchBranchPrefix :: Branch m -> Name -> [SearchResult]
 _searchBranchPrefix b n = case Path.unsnoc (Path.fromName n) of

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

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

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)

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