report constructor aliases in todo

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
         }

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

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

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

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
+```

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
+
+```