From 06b731b7749c5a1aa8223d2fd15bbe13a68ebd5b Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Wed, 3 Jul 2024 11:19:18 -0400 Subject: [PATCH] report constructor aliases in `todo` --- .../Codebase/Editor/HandleInput/Todo.hs | 17 +++-- .../src/Unison/Codebase/Editor/Output.hs | 5 +- .../src/Unison/CommandLine/OutputMessages.hs | 31 ++++++++- .../src/Unison/Merge/DeclCoherencyCheck.hs | 63 +++++++++++++++++-- unison-src/transcripts/todo.md | 22 +++++++ unison-src/transcripts/todo.output.md | 41 ++++++++++++ 6 files changed, 167 insertions(+), 12 deletions(-) diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Todo.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Todo.hs index ef58f044b..108ceee2a 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Todo.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Todo.hs @@ -4,6 +4,7 @@ module Unison.Codebase.Editor.HandleInput.Todo ) where +import Data.Either qualified as Either import Data.Set qualified as Set import U.Codebase.HashTags (BranchHash (..)) import U.Codebase.Sqlite.Operations qualified as Operations @@ -19,6 +20,7 @@ import Unison.Codebase.Causal qualified as Causal import Unison.Codebase.Editor.HandleInput.Merge2 (hasDefnsInLib) import Unison.Codebase.Editor.Output import Unison.Hash (HashFor (..)) +import Unison.Merge.DeclCoherencyCheck (IncoherentDeclReasons (..), checkAllDeclCoherency) import Unison.Names qualified as Names import Unison.Prelude import Unison.Reference (TermReference) @@ -34,7 +36,7 @@ handleTodo = do let currentNamespace = Branch.head currentCausal let currentNamespaceWithoutLibdeps = Branch.deleteLibdeps currentNamespace - (defnsInLib, dependentsOfTodo, directDependencies, hashLen) <- + (defnsInLib, dependentsOfTodo, directDependencies, hashLen, incoherentDeclReasons) <- Cli.runTransaction do -- We call a shared `hasDefnsLib` helper even though we could easily duplicate the logic with the branch in hand defnsInLib <- do @@ -66,21 +68,28 @@ handleTodo = do hashLen <- Codebase.hashLength - pure (defnsInLib, dependentsOfTodo.terms, directDependencies, hashLen) + incoherentDeclReasons <- + fmap (Either.fromLeft (IncoherentDeclReasons [] [] [] [])) $ + checkAllDeclCoherency + Operations.expectDeclNumConstructors + (Names.lenientToNametree (Branch.toNames currentNamespaceWithoutLibdeps)) + + pure (defnsInLib, dependentsOfTodo.terms, directDependencies, hashLen, incoherentDeclReasons) ppe <- Cli.currentPrettyPrintEnvDecl Cli.respondNumbered $ Output'Todo TodoOutput - { hashLen, - defnsInLib, + { defnsInLib, dependentsOfTodo, directDependenciesWithoutNames = Defns { terms = Set.difference directDependencies.terms (Branch.deepTermReferences currentNamespace), types = Set.difference directDependencies.types (Branch.deepTypeReferences currentNamespace) }, + hashLen, + incoherentDeclReasons, nameConflicts = Names.conflicts (Branch.toNames currentNamespaceWithoutLibdeps), ppe } diff --git a/unison-cli/src/Unison/Codebase/Editor/Output.hs b/unison-cli/src/Unison/Codebase/Editor/Output.hs index 7ee842a07..c85f88410 100644 --- a/unison-cli/src/Unison/Codebase/Editor/Output.hs +++ b/unison-cli/src/Unison/Codebase/Editor/Output.hs @@ -53,9 +53,11 @@ import Unison.DataDeclaration.ConstructorId (ConstructorId) import Unison.HashQualified qualified as HQ import Unison.HashQualified' qualified as HQ' import Unison.LabeledDependency (LabeledDependency) +import Unison.Merge.DeclCoherencyCheck (IncoherentDeclReasons (..)) import Unison.Name (Name) import Unison.NameSegment (NameSegment) import Unison.Names (Names) +import Unison.Names qualified as Names import Unison.Names.ResolutionResult qualified as Names import Unison.NamesWithHistory qualified as Names import Unison.Parser.Ann (Ann) @@ -82,7 +84,6 @@ import Unison.Util.Defns (DefnsF, defnsAreEmpty) import Unison.Util.Pretty qualified as P import Unison.Util.Relation (Relation) import Unison.WatchKind qualified as WK -import qualified Unison.Names as Names type ListDetailed = Bool @@ -157,6 +158,7 @@ data TodoOutput = TodoOutput dependentsOfTodo :: !(Set TermReferenceId), directDependenciesWithoutNames :: !(DefnsF Set TermReference TypeReference), hashLen :: !Int, + incoherentDeclReasons :: !IncoherentDeclReasons, nameConflicts :: !Names, ppe :: !PrettyPrintEnvDecl } @@ -167,6 +169,7 @@ todoOutputIsEmpty todo = && defnsAreEmpty todo.directDependenciesWithoutNames && Names.isEmpty todo.nameConflicts && not todo.defnsInLib + && todo.incoherentDeclReasons == IncoherentDeclReasons [] [] [] [] data AmbiguousReset'Argument = AmbiguousReset'Hash diff --git a/unison-cli/src/Unison/CommandLine/OutputMessages.hs b/unison-cli/src/Unison/CommandLine/OutputMessages.hs index 0e3b93e5c..470d6f88a 100644 --- a/unison-cli/src/Unison/CommandLine/OutputMessages.hs +++ b/unison-cli/src/Unison/CommandLine/OutputMessages.hs @@ -87,6 +87,7 @@ import Unison.Hash32 (Hash32) import Unison.HashQualified qualified as HQ import Unison.HashQualified' qualified as HQ' import Unison.LabeledDependency as LD +import Unison.Merge.DeclCoherencyCheck (IncoherentDeclReasons (..)) import Unison.Name (Name) import Unison.Name qualified as Name import Unison.NameSegment qualified as NameSegment @@ -1405,6 +1406,7 @@ notifyUser dir = \case pure . P.lines $ [ P.wrap "Sorry, I wasn't able to perform the merge:", "", + -- Note [ConstructorAliasMessage] If you change this, also change the other similar one P.wrap $ "On" <> P.group (prettyMergeSourceOrTarget aliceOrBob <> ",") @@ -2728,12 +2730,39 @@ handleTodoOutput todo <> "subnamespaces representing library dependencies. Please move or remove it." else mempty + prettyConstructorAliases <- + if null todo.incoherentDeclReasons.constructorAliases + then pure mempty + else do + things <- + for todo.incoherentDeclReasons.constructorAliases \(typeName, conName1, conName2) -> do + n1 <- addNumberedArg (SA.Name conName1) + n2 <- addNumberedArg (SA.Name conName2) + pure (typeName, formatNum n1 <> prettyName conName1, formatNum n2 <> prettyName conName2) + pure $ + things + & map + ( \(typeName, prettyCon1, prettyCon2) -> + -- Note [ConstructorAliasMessage] If you change this, also change the other similar one + P.wrap + ( "The type" + <> prettyName typeName + <> "has a constructor with multiple names. Please delete all but one name for each" + <> "constructor." + ) + <> P.newline + <> P.newline + <> P.indentN 2 (P.lines [prettyCon1, prettyCon2]) + ) + & P.sep "\n\n" + (pure . P.sep "\n\n" . P.nonEmpty) [ prettyDependentsOfTodo, prettyDirectTermDependenciesWithoutNames, prettyDirectTypeDependenciesWithoutNames, prettyConflicts, - prettyDefnsInLib + prettyDefnsInLib, + prettyConstructorAliases ] listOfDefinitions :: diff --git a/unison-merge/src/Unison/Merge/DeclCoherencyCheck.hs b/unison-merge/src/Unison/Merge/DeclCoherencyCheck.hs index 907c453e2..302e46a29 100644 --- a/unison-merge/src/Unison/Merge/DeclCoherencyCheck.hs +++ b/unison-merge/src/Unison/Merge/DeclCoherencyCheck.hs @@ -83,6 +83,10 @@ module Unison.Merge.DeclCoherencyCheck ( IncoherentDeclReason (..), checkDeclCoherency, lenientCheckDeclCoherency, + + -- * Getting all failures rather than just the first + IncoherentDeclReasons (..), + checkAllDeclCoherency, ) where @@ -147,6 +151,53 @@ checkDeclCoherency loadDeclNumConstructors nametree = nametree ) +data IncoherentDeclReasons = IncoherentDeclReasons + { constructorAliases :: ![(Name, Name, Name)], + missingConstructorNames :: ![Name], + nestedDeclAliases :: ![(Name, Name)], + strayConstructors :: ![Name] + } + deriving stock (Eq, Generic) + +-- | Like 'checkDeclCoherency', but returns info about all of the incoherent decls found, not just the first. +checkAllDeclCoherency :: + forall m. + Monad m => + (TypeReferenceId -> m Int) -> + Nametree (DefnsF (Map NameSegment) Referent TypeReference) -> + m (Either IncoherentDeclReasons DeclNameLookup) +checkAllDeclCoherency loadDeclNumConstructors nametree = do + State.runStateT doCheck emptyReasons <&> \(declNameLookup, reasons) -> + if reasons == emptyReasons + then Right declNameLookup + else Left (reverseReasons reasons) + where + doCheck :: StateT IncoherentDeclReasons m DeclNameLookup + doCheck = + checkDeclCoherencyWith + (lift . loadDeclNumConstructors) + ( OnIncoherentDeclReasons + { onConstructorAlias = \x y z -> #constructorAliases %= ((x, y, z) :), + onMissingConstructorName = \x -> #missingConstructorNames %= (x :), + onNestedDeclAlias = \x y -> #nestedDeclAliases %= ((x, y) :), + onStrayConstructor = \x -> #strayConstructors %= (x :) + } + ) + nametree + + emptyReasons :: IncoherentDeclReasons + emptyReasons = + IncoherentDeclReasons [] [] [] [] + + reverseReasons :: IncoherentDeclReasons -> IncoherentDeclReasons + reverseReasons reasons = + IncoherentDeclReasons + { constructorAliases = reverse reasons.constructorAliases, + missingConstructorNames = reverse reasons.missingConstructorNames, + nestedDeclAliases = reverse reasons.nestedDeclAliases, + strayConstructors = reverse reasons.strayConstructors + } + data OnIncoherentDeclReasons m = OnIncoherentDeclReasons { onConstructorAlias :: Name -> Name -> Name -> m (), onMissingConstructorName :: Name -> m (), @@ -171,22 +222,22 @@ checkDeclCoherencyWith loadDeclNumConstructors callbacks = (Nametree (DefnsF (Map NameSegment) Referent TypeReference)) -> StateT DeclCoherencyCheckState m () go prefix (Nametree defns children) = do - for_ (Map.toList defns.terms) (checkDeclCoherency_terms callbacks prefix) + for_ (Map.toList defns.terms) (checkDeclCoherencyWith_DoTerms callbacks prefix) childrenWeWentInto <- forMaybe (Map.toList defns.types) - (checkDeclCoherency_types loadDeclNumConstructors callbacks go prefix children) + (checkDeclCoherencyWith_DoTypes loadDeclNumConstructors callbacks go prefix children) let childrenWeHaventGoneInto = children `Map.withoutKeys` Set.fromList childrenWeWentInto for_ (Map.toList childrenWeHaventGoneInto) \(name, child) -> go (name : prefix) child -checkDeclCoherency_terms :: +checkDeclCoherencyWith_DoTerms :: forall m. Monad m => OnIncoherentDeclReasons m -> [NameSegment] -> (NameSegment, Referent) -> StateT DeclCoherencyCheckState m () -checkDeclCoherency_terms callbacks prefix = \case +checkDeclCoherencyWith_DoTerms callbacks prefix = \case (_, Referent.Ref _) -> pure () (_, Referent.Con (ConstructorReference (ReferenceBuiltin _) _) _) -> pure () (name, Referent.Con (ConstructorReference (ReferenceDerived typeRef) conId) _) -> do @@ -209,7 +260,7 @@ checkDeclCoherency_terms callbacks prefix = \case name1 = Name.fromReverseSegments (name :| prefix) -checkDeclCoherency_types :: +checkDeclCoherencyWith_DoTypes :: forall m. Monad m => (TypeReferenceId -> m Int) -> @@ -222,7 +273,7 @@ checkDeclCoherency_types :: Map NameSegment (Nametree (DefnsF (Map NameSegment) Referent TypeReference)) -> (NameSegment, TypeReference) -> StateT DeclCoherencyCheckState m (Maybe NameSegment) -checkDeclCoherency_types loadDeclNumConstructors callbacks go prefix children = \case +checkDeclCoherencyWith_DoTypes loadDeclNumConstructors callbacks go prefix children = \case (_, ReferenceBuiltin _) -> pure Nothing (name, ReferenceDerived typeRef) -> do state <- State.get diff --git a/unison-src/transcripts/todo.md b/unison-src/transcripts/todo.md index 25f99aa40..5b4a40dec 100644 --- a/unison-src/transcripts/todo.md +++ b/unison-src/transcripts/todo.md @@ -98,3 +98,25 @@ scratch/main> todo ```ucm:hide scratch/main> delete.project scratch ``` + +# Constructor aliases + +The `todo` command complains about constructor aliases. + +```ucm:hide +scratch/main> builtins.mergeio lib.builtins +``` + +```unison +type Foo = One +``` + +```ucm +scratch/main> add +scratch/main> alias.term Foo.One Foo.Two +scratch/main> todo +``` + +```ucm:hide +scratch/main> delete.project scratch +``` diff --git a/unison-src/transcripts/todo.output.md b/unison-src/transcripts/todo.output.md index 07f0b03c3..0de57bd2c 100644 --- a/unison-src/transcripts/todo.output.md +++ b/unison-src/transcripts/todo.output.md @@ -181,3 +181,44 @@ scratch/main> todo representing library dependencies. Please move or remove it. ``` +# Constructor aliases + +The `todo` command complains about constructor aliases. + +```unison +type Foo = One +``` + +```ucm + + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + type Foo + +``` +```ucm +scratch/main> add + + ⍟ I've added these definitions: + + type Foo + +scratch/main> alias.term Foo.One Foo.Two + + Done. + +scratch/main> todo + + The type Foo has a constructor with multiple names. Please + delete all but one name for each constructor. + + 1. Foo.One + 2. Foo.Two + +```