diff --git a/parser-typechecker/src/Unison/CommandLine/InputPatterns.hs b/parser-typechecker/src/Unison/CommandLine/InputPatterns.hs index 667feec3f..5ac8f7914 100644 --- a/parser-typechecker/src/Unison/CommandLine/InputPatterns.hs +++ b/parser-typechecker/src/Unison/CommandLine/InputPatterns.hs @@ -13,7 +13,6 @@ module Unison.CommandLine.InputPatterns where import Data.Foldable (toList) import Data.List (intercalate) -import qualified Data.Map as Map import qualified Data.Set as Set import Data.String (fromString) import qualified Data.Text as Text @@ -22,10 +21,10 @@ import qualified Unison.Codebase.Branch as Branch import Unison.Codebase.Editor (Input (..)) import qualified Unison.Codebase.Editor as E import Unison.CommandLine +import qualified Unison.CommandLine.InputPattern as I import Unison.CommandLine.InputPattern (ArgumentType (ArgumentType), InputPattern (InputPattern, aliases, - help, patternName), noSuggestions) import qualified Unison.HashQualified as HQ @@ -40,172 +39,143 @@ showPatternHelp i = P.lines [ (if not . null $ aliases i then " (or " <> intercalate ", " (aliases i) <> ")" else ""), - help i ] + P.wrap $ I.help i ] validInputs :: [InputPattern] -validInputs = validPatterns - where - commandNames = patternName <$> validPatterns - commandMap = Map.fromList (commandNames `zip` validPatterns) - helpPattern = InputPattern - "help" - ["?"] - [(True, commandName)] - "`help` shows general help and `help ` shows help for one command." - (\case - [] -> Left $ intercalateMap "\n\n" showPatternHelp validPatterns - [cmd] -> case Map.lookup cmd commandMap of - Nothing -> Left . warn $ "I don't know of that command. Try `help`." - Just pat -> Left $ help pat - _ -> Left $ warn "Use `help ` or `help`." - ) - commandName = - ArgumentType "command" $ \q _ _ -> pure $ autoComplete q commandNames - branchArg = ArgumentType "branch" $ \q codebase _b -> do - branches <- Codebase.branches codebase - let bs = Text.unpack <$> branches - pure $ autoComplete q bs - definitionQueryArg = - ArgumentType "definition query" $ \q _ (Branch.head -> b) -> do - let names = HQ.toString <$> toList (Branch.allNamesHashQualified b) - pure $ autoComplete q names - noCompletions = ArgumentType "a word" noSuggestions - quit = InputPattern - "quit" - ["exit"] - [] - "Exits the Unison command line interface." - (\case - [] -> pure QuitI - _ -> Left "Use `quit`, `exit`, or to quit." - ) - validPatterns - = [ helpPattern - , InputPattern "add" [] [] - (P.wrap $ "`add` adds to the codebase all the definitions from " - <> "the most recently typechecked file.") - (\ws -> if not $ null ws - then Left $ warn "`add` doesn't take any arguments." - else pure $ SlurpFileI False) - , InputPattern "branch" [] [(True, branchArg)] - (P.column2 - [ ("`branch`" - , P.wrap "lists all branches in the codebase.") - , ( "`branch foo`" - , P.wrap "switches to the branch named 'foo', creating it first if it doesn't exist.") - ] - ) - (\case - [] -> pure ListBranchesI - [b] -> pure . SwitchBranchI $ Text.pack b - _ -> Left . warn . P.wrap $ "Use `branch` to list all branches " - <> "or `branch foo` to switch to or create the branch 'foo'." - ) - , InputPattern "fork" [] [(False, branchArg)] - (P.wrap - "`fork foo` creates the branch 'foo' as a fork of the current branch.") - (\case - [b] -> pure . ForkBranchI $ Text.pack b - _ -> Left . warn . P.wrap $ "Use `fork foo` to create the branch 'foo'" - <> "from the current branch." - ) - , InputPattern "find" ["ls","list"] [(True, definitionQueryArg)] - (P.column2 - [ ("`find`" - , P.wrap "lists all definitions in the current branch.") - , ( "`find foo`" - , P.wrap "lists all definitions with a name similar to 'foo' in the current branch.") - , ( "`find foo bar`" - , P.wrap "lists all definitions with a name similar to 'foo' or 'bar' in the current branch.") - ] - ) - (pure . SearchByNameI) - , InputPattern "merge" [] [(False, branchArg)] - (P.wrap "`merge foo` merges the branch 'foo' into the current branch.") - (\case - [b] -> pure . MergeBranchI $ Text.pack b - _ -> Left . warn . P.wrap $ - "Use `merge foo` to merge the branch 'foo' into the current branch." - ) - , InputPattern "view" [] [(False, definitionQueryArg)] - (P.wrap "`view foo` prints the definition of `foo`.") - (pure . ShowDefinitionI E.ConsoleLocation) - , InputPattern "edit" [] [(False, definitionQueryArg)] - (P.wrap "`edit foo` prepends the definition of `foo` to the top of the most recently saved file.") - (pure . ShowDefinitionI E.LatestFileLocation) - , InputPattern "rename" ["mv"] - [(False, definitionQueryArg), (False, noCompletions)] - (P.wrap "`rename foo bar` renames `foo` to `bar`.") - (\case - [oldName, newName] -> - Right $ RenameUnconflictedI - allTargets - (fromString oldName) - (fromString newName) - _ -> Left . P.warnCallout $ P.wrap - "`rename` takes two arguments, like `rename oldname newname`." - ) - , InputPattern - "rename" - ["mv"] - [(False, definitionQueryArg), (False, noCompletions)] - (P.wrap "`rename foo bar` renames `foo` to `bar`.") - (\case - [oldName, newName] -> Right $ RenameUnconflictedI - allTargets - (fromString oldName) - (fromString newName) - _ -> Left . P.warnCallout $ P.wrap - "`rename` takes two arguments, like `rename oldname newname`.") - , InputPattern - "alias" - ["cp"] - [(False, definitionQueryArg), (False, noCompletions)] - (P.wrap - "`alias foo bar` introduces `bar` with the same definition as `foo`.") - (\case - [oldName, newName] -> Right $ AliasUnconflictedI - allTargets - (fromString oldName) - (fromString newName) - _ -> Left . warn $ P.wrap - "`alias` takes two arguments, like `alias oldname newname`." - ) - , InputPattern - "update" - [] - [] - ( P.wrap - $ "`update` works like `add`, except " - <> "if a definition in the file" - <> "has the same name as an existing definition, the name gets updated" - <> "to point to the new definition." - <> "If the old definition has any dependents, `update` will add" - <> "those dependents to a refactoring session." - ) - (\ws -> if not $ null ws - then Left $ warn "`update` doesn't take any arguments." - else pure $ SlurpFileI True - ) - , InputPattern - "propagate" - [] - [] - (P.wrap $ "`propagate` rewrites any definitions that" - <> "depend on definitions with type-preserving edits to use" - <> "the updated versions of these dependencies.") - (const $ pure PropagateI) - , InputPattern - "todo" - [] - [] - (P.wrap - $ "`todo` lists the work remaining in the current branch " <> - "to complete an ongoing refactoring." - ) - (\ws -> if not $ null ws - then Left $ warn "`todo` doesn't take any arguments." - else pure $ TodoI) - , quit +validInputs = + [ InputPattern + "help" ["?"] [(True, commandNameArg)] + "`help` shows general help and `help ` shows help for one command." + (\case + [] -> Left $ intercalateMap "\n\n" showPatternHelp validInputs + [cmd] -> case lookup cmd (commandNames `zip` validInputs) of + Nothing -> Left . warn $ "I don't know of that command. Try `help`." + Just pat -> Left $ I.help pat + _ -> Left $ warn "Use `help ` or `help`.") + , InputPattern "add" [] [] + "`add` adds to the codebase all the definitions from the most recently typechecked file." + (\ws -> if not $ null ws + then Left $ warn "`add` doesn't take any arguments." + else pure $ SlurpFileI False) + , InputPattern "branch" [] [(True, branchArg)] + (P.wrapColumn2 + [ ("`branch`", "lists all branches in the codebase.") + , ( "`branch foo`", "switches to the branch named 'foo', creating it first if it doesn't exist.") ] + ) + (\case + [] -> pure ListBranchesI + [b] -> pure . SwitchBranchI $ Text.pack b + _ -> Left . warn . P.wrap $ "Use `branch` to list all branches " + <> "or `branch foo` to switch to or create the branch 'foo'." + ) + , InputPattern "fork" [] [(False, branchArg)] + (P.wrap + "`fork foo` creates the branch 'foo' as a fork of the current branch.") + (\case + [b] -> pure . ForkBranchI $ Text.pack b + _ -> Left . warn . P.wrap $ "Use `fork foo` to create the branch 'foo'" + <> "from the current branch." + ) + , InputPattern "find" ["ls","list"] [(True, definitionQueryArg)] + (P.wrapColumn2 + [ ("`find`" + , "lists all definitions in the current branch.") + , ( "`find foo`" + , "lists all definitions with a name similar to 'foo' in the current branch.") + , ( "`find foo bar`" + , "lists all definitions with a name similar to 'foo' or 'bar' in the current branch.") + ] + ) + (pure . SearchByNameI) + , InputPattern "merge" [] [(False, branchArg)] + "`merge foo` merges the branch 'foo' into the current branch." + (\case + [b] -> pure . MergeBranchI $ Text.pack b + _ -> Left . warn . P.wrap $ + "Use `merge foo` to merge the branch 'foo' into the current branch." + ) + , InputPattern "view" [] [(False, definitionQueryArg)] + "`view foo` prints the definition of `foo`." + (pure . ShowDefinitionI E.ConsoleLocation) + , InputPattern "edit" [] [(False, definitionQueryArg)] + "`edit foo` prepends the definition of `foo` to the top of the most recently saved file." + (pure . ShowDefinitionI E.LatestFileLocation) + , InputPattern "rename" ["mv"] + [(False, definitionQueryArg), (False, noCompletions)] + (P.wrap "`rename foo bar` renames `foo` to `bar`.") + (\case + [oldName, newName] -> + Right $ RenameUnconflictedI + allTargets + (fromString oldName) + (fromString newName) + _ -> Left . P.warnCallout $ P.wrap + "`rename` takes two arguments, like `rename oldname newname`." + ) + , InputPattern "rename" ["mv"] + [(False, definitionQueryArg), (False, noCompletions)] + "`rename foo bar` renames `foo` to `bar`." + (\case + [oldName, newName] -> Right $ RenameUnconflictedI + allTargets + (fromString oldName) + (fromString newName) + _ -> Left . P.warnCallout $ P.wrap + "`rename` takes two arguments, like `rename oldname newname`.") + , InputPattern "alias" ["cp"] + [(False, definitionQueryArg), (False, noCompletions)] + "`alias foo bar` introduces `bar` with the same definition as `foo`." + (\case + [oldName, newName] -> Right $ AliasUnconflictedI + allTargets + (fromString oldName) + (fromString newName) + _ -> Left . warn $ P.wrap + "`alias` takes two arguments, like `alias oldname newname`." + ) + , InputPattern "update" [] [] + "`update` works like `add`, except if a definition in the file has the same name as an existing definition, the name gets updated to point to the new definition. If the old definition has any dependents, `update` will add those dependents to a refactoring session." + (\ws -> if not $ null ws + then Left $ warn "`update` doesn't take any arguments." + else pure $ SlurpFileI True + ) + , InputPattern "propagate" [] [] + "`propagate` rewrites any definitions that depend on definitions with type-preserving edits to use the updated versions of these dependencies." + (const $ pure PropagateI) + , InputPattern "todo" [] [] + "`todo` lists the work remaining in the current branch to complete an ongoing refactoring." + (\ws -> if not $ null ws + then Left $ warn "`todo` doesn't take any arguments." + else pure $ TodoI) + , InputPattern "quit" ["exit"] [] + "Exits the Unison command line interface." + (\case + [] -> pure QuitI + _ -> Left "Use `quit`, `exit`, or to quit." + ) + ] + where allTargets = Set.fromList [Names.TermName, Names.TypeName] + +commandNames :: [String] +commandNames = patternName <$> validInputs + +commandNameArg :: ArgumentType +commandNameArg = + ArgumentType "command" $ \q _ _ -> pure (autoComplete q commandNames) + +branchArg :: ArgumentType +branchArg = ArgumentType "branch" $ \q codebase _b -> do + branches <- Codebase.branches codebase + let bs = Text.unpack <$> branches + pure $ autoComplete q bs + +definitionQueryArg :: ArgumentType +definitionQueryArg = + ArgumentType "definition query" $ \q _ (Branch.head -> b) -> do + let names = HQ.toString <$> toList (Branch.allNamesHashQualified b) + pure $ autoComplete q names + +noCompletions :: ArgumentType +noCompletions = ArgumentType "a word" noSuggestions diff --git a/parser-typechecker/src/Unison/CommandLine/OutputMessages.hs b/parser-typechecker/src/Unison/CommandLine/OutputMessages.hs index d8d248018..ca04e5438 100644 --- a/parser-typechecker/src/Unison/CommandLine/OutputMessages.hs +++ b/parser-typechecker/src/Unison/CommandLine/OutputMessages.hs @@ -26,7 +26,7 @@ import Prelude hiding (readFile, writeFile) import qualified System.Console.ANSI as Console import System.Directory (canonicalizePath, doesFileExist) -import Unison.Codebase.Branch (Branch) +import Unison.Codebase.Branch (Branch, Branch0) import qualified Unison.Codebase.Branch as Branch import Unison.Codebase.Editor (DisplayThing (..), Input (..), Output (..)) @@ -52,6 +52,7 @@ import qualified Unison.Referent as Referent import qualified Unison.Result as Result import Unison.Term (AnnotatedTerm) import qualified Unison.TermPrinter as TermPrinter +import Unison.Type (AnnotatedType) import qualified Unison.TypePrinter as TypePrinter import qualified Unison.Typechecker.TypeLookup as TL import qualified Unison.UnisonFile as UF @@ -94,16 +95,12 @@ notifyUser dir o = case o of AliasOutput existingName newName r -> do nameChange "alias" "aliased" existingName newName r UnknownName branchName nameTarget name -> - putPrettyLn - . warn - . P.wrap - $ "I don't know of any " - <> fromString (Names.renderNameTarget nameTarget) - <> " named " - <> P.red (prettyName name) - <> " in the branch " - <> P.blue (P.text branchName) - <> "." + putPrettyLn . warn . P.wrap $ + "I don't know of any " <> targets <> " named " <> n <> " in the branch " <> b <> "." + where + targets = fromString (Names.renderNameTarget nameTarget) + n = P.red (prettyName name) + b = P.blue (P.text branchName) NameAlreadyExists branchName nameTarget name -> putPrettyLn . warn @@ -144,176 +141,8 @@ notifyUser dir o = case o of else " " <> P.text n in intercalateMap "\n" go (sort branches) ListOfDefinitions branch terms types -> - let ppe = Branch.prettyPrintEnv (Branch.head branch) - sigs0 = (\(name, _, typ) -> (name, typ)) <$> terms - sigs = [(name,t) | (name, Just t) <- sigs0 ] - impossible = terms >>= \case - (name, r, Nothing) -> case r of - Referent.Ref (Reference.Builtin _) -> [(name,r)] - _ -> [] - _ -> [] - termsWithMissingTypes = - [ (name, r) | (name, Referent.Ref (Reference.DerivedId r), Nothing) <- terms ] - missingTypes = nubOrdOn snd $ - [ (name, Reference.DerivedId r) | (name, _, MissingThing r) <- types ] <> - [ (name, r) | (name, Referent.toTypeReference -> Just r, Nothing) <- terms] - typeResults = map prettyDeclTriple types - in do - putPrettyLn . P.lines $ - typeResults ++ TypePrinter.prettySignatures' ppe sigs ++ - [formatMissingStuff termsWithMissingTypes missingTypes] - when (not $ null impossible) . error $ "Compiler bug, these referents are missing types: " <> show impossible - - SlurpOutput s -> - putPrettyLn . P.sep "\n" . P.nonEmpty $ [ - addMsg, updateMsg, dupeMsg, collMsg, - conflictMsg, aliasingMsg, termExistingCtorMsg, - ctorExistingTermMsg, blockedDependenciesMsg ] - where - -- todo: move this to a separate function - branch = E.updatedBranch s - file = E.originalFile s - E.SlurpComponent addedTypes addedTerms = E.adds s - E.SlurpComponent dupeTypes dupeTerms = E.duplicates s - E.SlurpComponent collidedTypes collidedTerms = E.collisions s - E.SlurpComponent conflictedTypes conflictedTerms = E.conflicts s - E.SlurpComponent updatedTypes updatedTerms = E.updates s - termTypesFromFile = - Map.fromList [ (v,t) | (v,_,t) <- join (UF.topLevelComponents file) ] - ppe = - Branch.prettyPrintEnv (Branch.head branch) `PPE.unionLeft` - Branch.prettyPrintEnv (Branch.fromTypecheckedFile file) - filterTermTypes vs = - [ (HQ.fromVar v,t) | v <- toList vs - , t <- maybe (error $ "There wasn't a type for " ++ show v ++ " in termTypesFromFile!") pure (Map.lookup v termTypesFromFile)] - prettyDeclHeader v = case UF.getDecl' file v of - Just (Left _) -> TypePrinter.prettyEffectHeader (HQ.fromVar v) - Just (Right _) -> TypePrinter.prettyDataHeader (HQ.fromVar v) - Nothing -> error "Wat." - addMsg = unlessM (null addedTypes && null addedTerms) . P.okCallout $ - P.wrap ("I" <> P.bold "added" <> "these definitions:") - <> "\n\n" <> P.indentN 2 - (P.lines ( - (prettyDeclHeader <$> toList addedTypes) ++ - TypePrinter.prettySignatures' ppe (filterTermTypes addedTerms)) - ) - updateMsg = unlessM (null updatedTypes && null updatedTerms) . P.okCallout $ - P.wrap ("I" <> P.bold "updated" <> "these definitions:") - -- todo: show the partial hash too? - <> "\n\n" - <> P.indentN 2 ( - P.lines ( - (prettyDeclHeader <$> toList updatedTypes) ++ - TypePrinter.prettySignatures' ppe (filterTermTypes updatedTerms)) - ) - -- todo "You probably have a bunch more work to do." - dupeMsg = unlessM (null dupeTypes && null dupeTerms) . P.callout "☑️" $ - P.wrap ("I skipped these definitions because they have" - <> P.bold "already been added:") - <> "\n\n" - <> P.indentN 2 ( - P.lines ( - (prettyDeclHeader <$> toList dupeTypes) ++ - TypePrinter.prettySignatures' ppe (filterTermTypes dupeTerms)) - ) - collMsg = unlessM (null collidedTypes && null collidedTerms) . P.warnCallout $ - P.wrap ("I skipped these definitions because the" <> P.bold "names already exist," <> "but with different definitions:") <> "\n\n" <> - P.indentN 2 ( - P.lines ( - (prettyDeclHeader <$> toList collidedTypes) ++ - TypePrinter.prettySignatures' ppe (filterTermTypes collidedTerms)) - ) - <> "\n\n" - <> tip ("You can use `update` if you're trying to replace the existing definitions and all their usages, or `rename` the existing definition to free up the name for the definitions in your .u file.") - conflictMsg = unlessM (null conflictedTypes && null conflictedTerms) . P.warnCallout $ - let sampleName = - P.text . head . fmap Var.name . toList $ - (conflictedTypes <> conflictedTerms) - sampleHash = "#abc" -- todo: get real hash prefix for sampleName - sampleNameHash = P.group (sampleName <> sampleHash) - sampleNameHash' = P.group (sampleNameHash <> "`") - sampleNameHash'' = P.group ("`" <> sampleNameHash <> "`") - -- todo: get real unused name from branch - sampleNewName = P.group (sampleName <> "2") - sampleNewName' = P.group (sampleNewName <> "`") - sampleName' = P.group (sampleName <>"`") - sampleName'' = P.group ("`" <> sampleName <>"`") in - P.wrap ("I didn't try to update these definitions because the names are" <> - P.bold "conflicted" <> - "(already associated with multiple definitions):") - <> P.newline - <> P.newline - <> P.indentN 2 ( - P.lines ( - (prettyDeclHeader <$> toList conflictedTypes) ++ - TypePrinter.prettySignatures' ppe (filterTermTypes conflictedTerms)) - ) <> "\n\n" - <> tip ("Use `view " <> sampleName' <> " to view the conflicting definitions and `rename " <> sampleNameHash <> " " <> sampleNewName' <> " to give each definition a distinct name. Alternatively, use `resolve " <> sampleNameHash' <> "to make" <> sampleNameHash'' <> " the canonical " <> sampleName'' <> "and remove the name from the other definitions.") - aliasingMsg = unlessM (R.null (Branch.termCollisions (E.needsAlias s)) - && R.null (Branch.typeCollisions (E.needsAlias s))) . P.warnCallout $ - let f = listToMaybe . Map.toList . R.domain - Just (sampleName0, sampleExistingName0) = - (f . Branch.typeCollisions) (E.needsAlias s) <|> - (f . Branch.termCollisions) (E.needsAlias s) - sampleNewName' = P.group (prettyName sampleName0 <> "`") - sampleOldName = prettyName . head . toList $ sampleExistingName0 in - - P.wrap ("I skipped these definitions because they already" <> P.bold "exist with other names:") <> "\n\n" <> - P.indentN 2 ( - P.lines . join $ [ - P.align - -- ("type Optional", "aka " ++ commas existingNames) - -- todo: something is wrong here: only one oldName is being shown, instead of all - [(prettyDeclHeader $ Name.toVar newName, - "aka " <> P.commas (prettyName <$> toList oldNames)) | - (newName, oldNames) <- - Map.toList . R.domain . Branch.typeCollisions $ (E.needsAlias s) ], - TypePrinter.prettySignaturesAlt' ppe - -- foo, foo2, fasdf : a -> b -> c - -- note: this shit vvvv is not a Name. - [ (name : fmap HQ.fromName (toList oldNames), typ) - | (newName, oldNames) <- - Map.toList . R.domain . Branch.termCollisions $ (E.needsAlias s) - , (name, typ) <- filterTermTypes [Name.toVar newName] - ] - ]) - <> "\n\n" - <> tip ("Use `alias" <> sampleOldName <> " " <> sampleNewName' <> "to create an additional name for this definition.") - termExistingCtorCollisions = E.termExistingConstructorCollisions s - termExistingCtorMsg = - unlessM (null termExistingCtorCollisions) . P.warnCallout $ - P.wrap ("I can't update these terms because the" <> P.bold "names are currently assigned to constructors:") <> "\n\n" <> - P.indentN 2 - (P.column2 - [ (P.text $ Var.name v, "is a constructor for " <> go r) - | (v, r) <- Map.toList termExistingCtorCollisions ] - ) - <> "\n\n" - <> tip "You can `rename` these constructors to free up the names for your new definitions." - where - go r = prettyHashQualified (PPE.typeName ppe (Referent.toReference r)) - ctorExistingTermCollisions = E.constructorExistingTermCollisions s - commaRefs rs = P.wrap $ P.commas (map go rs) where - go r = prettyHashQualified (PPE.termName ppe r) - ctorExistingTermMsg = unlessM (null ctorExistingTermCollisions) . P.warnCallout $ - P.wrap ("I can't update these types because one or more of the" <> P.bold "constructor names matches an existing term:") <> "\n\n" <> - P.indentN 2 ( - P.column2 [ - (P.text $ Var.name v, "has name collisions for: " <> commaRefs rs) - | (v, rs) <- Map.toList ctorExistingTermCollisions ] - ) - <> "\n\n" - <> tip "You can `rename` existing definitions to free up the names for your new definitions." - blockedTerms = Map.keys (E.termsWithBlockedDependencies s) - blockedTypes = Map.keys (E.typesWithBlockedDependencies s) - blockedDependenciesMsg = unlessM (null blockedTerms && null blockedTypes) . P.warnCallout $ - P.wrap ("I also skipped these definitions with a" <> P.bold "transitive dependency on a skipped definition" <> "mentioned above:") <> "\n\n" - <> P.indentN 2 ( - P.lines ( - (prettyDeclHeader <$> toList blockedTypes) ++ - TypePrinter.prettySignatures' ppe (filterTermTypes blockedTerms) - ) - ) + listOfDefinitions (Branch.head branch) terms types + SlurpOutput s -> slurpOutput s ParseErrors src es -> do Console.setTitle "Unison ☹︎" traverse_ (putStrLn . CT.toANSI . prettyParseError (Text.unpack src)) es @@ -349,24 +178,16 @@ notifyUser dir o = case o of Console.setTitle "Unison ☺︎" -- todo: we should just print this the same way as everything else let defs = prettyTypecheckedFile uf errorEnv - when (not $ null defs) . putPrettyLn' . ("\n" <>) $ - P.okCallout $ - P.lines [ - P.wrap ( - "I found and" <> P.bold "typechecked" <> "these definitions in " <> - P.group (P.text sourceName <> ":") - ), - "", - P.lit defs, - P.wrap $ - "Now evaluating any watch expressions (lines starting with `>`)" - <> "..." - ] + when (not $ null defs) . putPrettyLn' . ("\n" <>) . P.okCallout . P.lines$ + [ P.wrap $ "I found and" <> P.bold "typechecked" <> "these definitions in " <> P.group (P.text sourceName <> ":") + , "" + , P.lit defs + , P.wrap "Now evaluating any watch expressions (lines starting with `>`)..." + ] TodoOutput branch todo -> todoOutput branch todo where renderFileName = P.group . P.blue . fromString - nameChange cmd pastTenseCmd oldName newName r = do when (not . Set.null $ E.changedSuccessfully r) . putPrettyLn . P.okCallout $ P.wrap $ "I" <> pastTenseCmd <> "the" @@ -398,11 +219,11 @@ notifyUser dir o = case o of formatMissingStuff :: (Show tm, Show typ) => [(HQ.HashQualified, tm)] -> [(HQ.HashQualified, typ)] -> P.Pretty P.ColorText formatMissingStuff terms types = - (if null terms then mempty else P.fatalCallout $ + (unlessM (null terms) . P.fatalCallout $ P.wrap "The following terms have a missing or corrupted type signature:" <> "\n\n" <> P.column2 [ (prettyHashQualified name, fromString (show ref)) | (name, ref) <- terms ]) <> - (if null types then mempty else P.fatalCallout $ + (unlessM (null types) . P.fatalCallout $ P.wrap "The following types weren't found in the codebase:" <> "\n\n" <> P.column2 [ (prettyHashQualified name, fromString (show ref)) | (name, ref) <- types ]) @@ -499,15 +320,12 @@ renderNameConflicts conflictedTypeNames conflictedTermNames = renderEditConflicts :: PPE.PrettyPrintEnv -> Branch.Branch0 -> P.Pretty CT.ColorText renderEditConflicts ppe (Branch.editConflicts -> editConflicts) = - if null editConflicts then mempty else - P.callout "❓" . P.sep "\n\n" $ [ + unlessM (null editConflicts) . P.callout "❓" . P.sep "\n\n" $ [ P.wrap $ "These" <> P.bold "definitions were edited differently" <> "in branches that have been merged into this branch." <> "You'll have to tell me what to use as the new definition:", P.indentN 2 (P.lines (formatConflict <$> editConflicts)), - tip $ "Use" <> - P.group ("`resolve-edit " <> name (head editConflicts) <> " ") - <> "to pick a replacement." -- todo: eventually something with `edit` + tip $ "Use " <> backtick ("resolve-edit " <> name (head editConflicts) <> " ") <> " to pick a replacement." -- todo: eventually something with `edit` ] where name = either (typeName . fst) (termName . fst) @@ -567,3 +385,172 @@ todoOutput (Branch.head -> branch) todo = (goodTerms $ unscore <$> dirtyTerms)) , formatMissingStuff corruptTerms corruptTypes ] + +listOfDefinitions :: Var v => + Branch0 + -> [(HQ.HashQualified, Referent.Referent, Maybe (AnnotatedType v a1))] + -> [(HQ.HashQualified, Reference.Reference, DisplayThing (TL.Decl v2 a2))] + -> IO () +listOfDefinitions branch terms types = do + putPrettyLn . P.lines $ + typeResults ++ + TypePrinter.prettySignatures' ppe termsWithTypes ++ + [formatMissingStuff termsWithMissingTypes missingTypes] + unless (null impossible) . error $ "Compiler bug, these referents are missing types: " <> show impossible + where + ppe = Branch.prettyPrintEnv branch + typeResults = map prettyDeclTriple types + termsWithTypes = [(name,t) | (name, Just t) <- sigs0 ] + where sigs0 = (\(name, _, typ) -> (name, typ)) <$> terms + termsWithMissingTypes = + [ (name, r) | (name, Referent.Ref (Reference.DerivedId r), Nothing) <- terms ] + missingTypes = nubOrdOn snd $ + [ (name, Reference.DerivedId r) | (name, _, MissingThing r) <- types ] <> + [ (name, r) | (name, Referent.toTypeReference -> Just r, Nothing) <- terms] + impossible = terms >>= \case + (name, r@(Referent.Ref (Reference.Builtin _)), Nothing) -> [(name,r)] + _ -> [] + +-- todo: could probably use more cleanup +slurpOutput :: Var v => E.SlurpResult v -> IO () +slurpOutput s = + putPrettyLn . P.sep "\n" . P.nonEmpty $ [ + addedMsg, updatedMsg, alreadyAddedMsg, namesExistMsg, + namesConflictedMsg, aliasingMsg, termExistingCtorMsg, + ctorExistingTermMsg, blockedDependenciesMsg ] + where + -- todo: move this to a separate function + branch = E.updatedBranch s + file = E.originalFile s + E.SlurpComponent addedTypes addedTerms = E.adds s + E.SlurpComponent dupeTypes dupeTerms = E.duplicates s + E.SlurpComponent collidedTypes collidedTerms = E.collisions s + E.SlurpComponent conflictedTypes conflictedTerms = E.conflicts s + E.SlurpComponent updatedTypes updatedTerms = E.updates s + termTypesFromFile = + Map.fromList [ (v,t) | (v,_,t) <- join (UF.topLevelComponents file) ] + ppe = Branch.prettyPrintEnv (Branch.head branch) + <> Branch.prettyPrintEnv (Branch.fromTypecheckedFile file) + filterTermTypes vs = + [ (HQ.fromVar v,t) + | v <- toList vs + , t <- maybe (error $ "There wasn't a type for " ++ show v ++ " in termTypesFromFile!") pure (Map.lookup v termTypesFromFile)] + prettyDeclHeader v = case UF.getDecl' file v of + Just (Left _) -> TypePrinter.prettyEffectHeader (HQ.fromVar v) + Just (Right _) -> TypePrinter.prettyDataHeader (HQ.fromVar v) + Nothing -> error "Wat." + addedMsg = + unlessM (null addedTypes && null addedTerms) . P.okCallout $ + P.wrap ("I" <> P.bold "added" <> "these definitions:") + <> "\n\n" + <> (P.indentN 2 . P.lines $ + (prettyDeclHeader <$> toList addedTypes) ++ + TypePrinter.prettySignatures' ppe (filterTermTypes addedTerms)) + updatedMsg = + unlessM (null updatedTypes && null updatedTerms) . P.okCallout $ + P.wrap ("I" <> P.bold "updated" <> "these definitions:") + -- todo: show the partial hash too? + <> "\n\n" + <> (P.indentN 2 . P.lines $ + (prettyDeclHeader <$> toList updatedTypes) ++ + TypePrinter.prettySignatures' ppe (filterTermTypes updatedTerms)) + -- todo "You probably have a bunch more work to do." + alreadyAddedMsg = + unlessM (null dupeTypes && null dupeTerms) . P.callout "☑️" $ + P.wrap ("I skipped these definitions because they have" + <> P.bold "already been added:") + <> "\n\n" + <> (P.indentN 2 . P.lines $ + (prettyDeclHeader <$> toList dupeTypes) ++ + TypePrinter.prettySignatures' ppe (filterTermTypes dupeTerms)) + namesExistMsg = + unlessM (null collidedTypes && null collidedTerms) . P.warnCallout $ + P.wrap ("I skipped these definitions because the" <> P.bold "names already exist," <> "but with different definitions:") + <> "\n\n" + <> (P.indentN 2 . P.lines $ + (prettyDeclHeader <$> toList collidedTypes) ++ + TypePrinter.prettySignatures' ppe (filterTermTypes collidedTerms)) + <> "\n\n" + <> tip ("You can use `update` if you're trying to replace the existing definitions and all their usages, or `rename` the existing definition to free up the name for the definitions in your .u file.") + namesConflictedMsg = + unlessM (null conflictedTypes && null conflictedTerms) . P.warnCallout $ + P.wrap ("I didn't try to update these definitions because the names are" <> P.bold "conflicted" <> "(already associated with multiple definitions):") + <> "\n\n" + <> (P.indentN 2 . P.lines $ + (prettyDeclHeader <$> toList conflictedTypes) ++ + TypePrinter.prettySignatures' ppe (filterTermTypes conflictedTerms)) + <> "\n\n" + <> tip ("Use " <> backtick ("view " <> sampleName) <> " to view the conflicting definitions and " <> backtick ("rename " <> sampleNameHash <> " " <> sampleNewName) <> " to give each definition a distinct name. Alternatively, use " <> backtick ("resolve " <> sampleNameHash) <> "to make" <> backtick sampleNameHash <> " the canonical " <> backtick sampleName <> "and remove the name from the other definitions.") + where + sampleName = + P.text . head . fmap Var.name . toList $ (conflictedTypes <> conflictedTerms) + sampleHash = "#abc" -- todo: get real hash prefix for sampleName + sampleNameHash = P.group (sampleName <> sampleHash) + -- todo: get real unused name from branch + sampleNewName = P.group (sampleName <> "2") + aliasingMsg = + unlessM (R.null (Branch.termCollisions (E.needsAlias s)) + && R.null (Branch.typeCollisions (E.needsAlias s))) . P.warnCallout $ + P.wrap ("I skipped these definitions because they already" <> P.bold "exist with other names:") + <> "\n\n" + <> P.indentN 2 (P.lines . join $ [ + P.align + -- ("type Optional", "aka " ++ commas existingNames) + -- todo: something is wrong here: only one oldName is being shown, instead of all + [(prettyDeclHeader $ Name.toVar newName, + "aka " <> P.commas (prettyName <$> toList oldNames)) | + (newName, oldNames) <- + Map.toList . R.domain . Branch.typeCollisions $ (E.needsAlias s) ], + TypePrinter.prettySignaturesAlt' ppe + -- foo, foo2, fasdf : a -> b -> c + -- note: this shit vvvv is not a Name. + [ (name : fmap HQ.fromName (toList oldNames), typ) + | (newName, oldNames) <- + Map.toList . R.domain . Branch.termCollisions $ (E.needsAlias s) + , (name, typ) <- filterTermTypes [Name.toVar newName] + ] + ]) + <> "\n\n" + <> tip ("Use " <> backtick ("alias " <> sampleOldName <> " " <> sampleNewName) <> "to create an additional name for this definition.") + where + f = listToMaybe . Map.toList . R.domain + Just (prettyName -> sampleNewName, + prettyName . head . toList -> sampleOldName) = + (f . Branch.typeCollisions) (E.needsAlias s) <|> + (f . Branch.termCollisions) (E.needsAlias s) + termExistingCtorMsg = + unlessM (null ctorCollisions) . P.warnCallout $ + P.wrap ("I can't update these terms because the" <> P.bold "names are currently assigned to constructors:") + <> "\n\n" + <> (P.indentN 2 $ + (P.column2 [ (P.text $ Var.name v, "is a constructor for " <> go r) + | (v, r) <- Map.toList ctorCollisions ]) + <> "\n\n" + <> tip "You can `rename` these constructors to free up the names for your new definitions.") + where + ctorCollisions = E.termExistingConstructorCollisions s + go r = prettyHashQualified (PPE.typeName ppe (Referent.toReference r)) + ctorExistingTermMsg = + unlessM (null ctorExistingTermCollisions) . P.warnCallout $ + P.wrap ("I can't update these types because one or more of the" <> P.bold "constructor names matches an existing term:") <> "\n\n" <> + P.indentN 2 ( + P.column2 [ + (P.text $ Var.name v, "has name collisions for: " <> commaRefs rs) + | (v, rs) <- Map.toList ctorExistingTermCollisions ] + ) + <> "\n\n" + <> tip "You can `rename` existing definitions to free up the names for your new definitions." + where + ctorExistingTermCollisions = E.constructorExistingTermCollisions s + commaRefs rs = P.wrap $ P.commas (map go rs) + go r = prettyHashQualified (PPE.termName ppe r) + blockedDependenciesMsg = + unlessM (null blockedTerms && null blockedTypes) . P.warnCallout $ + P.wrap ("I also skipped these definitions with a" <> P.bold "transitive dependency on a skipped definition" <> "mentioned above:") + <> "\n\n" + <> (P.indentN 2 . P.lines $ + (prettyDeclHeader <$> toList blockedTypes) ++ + TypePrinter.prettySignatures' ppe (filterTermTypes blockedTerms)) + where + blockedTerms = Map.keys (E.termsWithBlockedDependencies s) + blockedTypes = Map.keys (E.typesWithBlockedDependencies s) diff --git a/parser-typechecker/src/Unison/Util/Pretty.hs b/parser-typechecker/src/Unison/Util/Pretty.hs index 562890080..e3add34d6 100644 --- a/parser-typechecker/src/Unison/Util/Pretty.hs +++ b/parser-typechecker/src/Unison/Util/Pretty.hs @@ -59,6 +59,7 @@ module Unison.Util.Pretty ( toANSI, toPlain, wrap, + wrapColumn2, wrapString, black, red, green, yellow, blue, purple, cyan, white, hiBlack, hiRed, hiGreen, hiYellow, hiBlue, hiPurple, hiCyan, hiWhite, bold, border @@ -177,7 +178,8 @@ render availableWidth p = go mempty [Right p] where in maxCol (cur' <> delta p) < availableWidth newline :: IsString s => Pretty s -newline = lit' (chDelta '\n') (fromString "\n") +newline = "\n" + spaceIfBreak :: IsString s => Pretty s spaceIfBreak = "" `orElse` " " @@ -279,6 +281,13 @@ column2 :: (LL.ListLike s Char, IsString s) => [(Pretty s, Pretty s)] -> Pretty s column2 rows = lines (group <$> align rows) +wrapColumn2 :: + (LL.ListLike s Char, IsString s) => [(Pretty s, Pretty s)] -> Pretty s +wrapColumn2 rows = lines (align rows) where + align rows = let lwidth = foldl' max 0 (preferredWidth . fst <$> rows) + 1 + in [ group (rightPad lwidth l <> indentNAfterNewline lwidth (wrap r)) + | (l, r) <- rows] + align :: (LL.ListLike s Char, IsString s) => [(Pretty s, Pretty s)] -> [Pretty s]