Merge pull request #5177 from unisonweb/24-07-01-todo-merge-precondit…

…ion-violations

lib/unison-util-relation/src/Unison/Util/BiMultimap.hs

@@ -178,6 +178,7 @@ invertDomain =
     g x acc y =
       Map.insert y x acc
 
+-- | Construct a left-unique relation from a mapping from its right-elements to its left-elements.
 fromRange :: (Ord a, Ord b) => Map b a -> BiMultimap a b
 fromRange m =
   BiMultimap (Map.foldlWithKey' f Map.empty m) m

parser-typechecker/src/Unison/Codebase/Branch.hs

@@ -139,6 +139,7 @@ import Unison.NameSegment (NameSegment)
 import Unison.NameSegment qualified as NameSegment
 import Unison.Prelude hiding (empty)
 import Unison.Reference (TermReference, TermReferenceId, TypeReference, TypeReferenceId)
+import Unison.Reference qualified as Reference
 import Unison.Referent (Referent)
 import Unison.Referent qualified as Referent
 import Unison.Util.List qualified as List
@@ -148,7 +149,6 @@ import Unison.Util.Set qualified as Set
 import Unison.Util.Star2 qualified as Star2
 import Witherable (FilterableWithIndex (imapMaybe))
 import Prelude hiding (head, read, subtract)
-import qualified Unison.Reference as Reference
 
 instance AsEmpty (Branch m) where
   _Empty = prism' (const empty) matchEmpty
@@ -215,7 +215,6 @@ deepTypeReferenceIds :: Branch0 m -> Set TypeReferenceId
 deepTypeReferenceIds =
   Set.mapMaybe Reference.toId . deepTypeReferences
 
-
 namespaceStats :: Branch0 m -> NamespaceStats
 namespaceStats b =
   NamespaceStats

parser-typechecker/src/Unison/Codebase/Causal.hs

@@ -1,7 +1,7 @@
 {-# LANGUAGE TemplateHaskell #-}
 
 module Unison.Codebase.Causal
-  ( Causal (currentHash, head, tail, tails),
+  ( Causal (currentHash, valueHash, head, tail, tails),
     pattern One,
     pattern Cons,
     pattern Merge,
@@ -40,7 +40,8 @@ import Unison.Codebase.Causal.Type
         currentHash,
         head,
         tail,
-        tails
+        tails,
+        valueHash
       ),
     before,
     lca,

unison-cli/src/Unison/Codebase/Editor/HandleInput/Merge2.hs

@@ -9,6 +9,9 @@ module Unison.Codebase.Editor.HandleInput.Merge2
     LcaMergeInfo (..),
     doMerge,
     doMergeLocalBranch,
+
+    -- * API exported for @todo@
+    hasDefnsInLib,
   )
 where
 
@@ -86,6 +89,7 @@ import Unison.Merge.EitherWay (EitherWay (..))
 import Unison.Merge.EitherWayI (EitherWayI (..))
 import Unison.Merge.EitherWayI qualified as EitherWayI
 import Unison.Merge.Libdeps qualified as Merge
+import Unison.Merge.PartialDeclNameLookup (PartialDeclNameLookup)
 import Unison.Merge.PartitionCombinedDiffs (partitionCombinedDiffs)
 import Unison.Merge.Synhashed (Synhashed (..))
 import Unison.Merge.Synhashed qualified as Synhashed
@@ -139,7 +143,6 @@ import Unison.Util.SyntaxText (SyntaxText')
 import Unison.Var (Var)
 import Witch (unsafeFrom)
 import Prelude hiding (unzip, zip, zipWith)
-import Unison.Merge.PartialDeclNameLookup (PartialDeclNameLookup)
 
 handleMerge :: ProjectAndBranch (Maybe ProjectName) ProjectBranchName -> Cli ()
 handleMerge (ProjectAndBranch maybeBobProjectName bobBranchName) = do
@@ -239,11 +242,7 @@ doMerge info = do
 
       -- Assert that neither Alice nor Bob have defns in lib
       for_ [(mergeTarget, branches.alice), (mergeSource, branches.bob)] \(who, branch) -> do
-        libdeps <-
-          case Map.lookup NameSegment.libSegment branch.children of
-            Nothing -> pure V2.Branch.empty
-            Just libdeps -> Cli.runTransaction libdeps.value
-        when (not (Map.null libdeps.terms) || not (Map.null libdeps.types)) do
+        whenM (Cli.runTransaction (hasDefnsInLib branch)) do
           done (Output.MergeDefnsInLib who)
 
       -- Load Alice/Bob/LCA definitions and decl name lookups
@@ -486,6 +485,17 @@ loadLibdeps branches = do
           libdepsBranch <- libdepsCausal.value
           pure libdepsBranch.children
 
+------------------------------------------------------------------------------------------------------------------------
+-- Merge precondition violation checks
+
+hasDefnsInLib :: Applicative m => V2.Branch m -> m Bool
+hasDefnsInLib branch = do
+  libdeps <-
+    case Map.lookup NameSegment.libSegment branch.children of
+      Nothing -> pure V2.Branch.empty
+      Just libdeps -> libdeps.value
+  pure (not (Map.null libdeps.terms) || not (Map.null libdeps.types))
+
 ------------------------------------------------------------------------------------------------------------------------
 -- Creating Unison files
 

unison-cli/src/Unison/Codebase/Editor/HandleInput/Todo.hs

@@ -4,7 +4,9 @@ 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
 import Unison.Builtin qualified as Builtin
 import Unison.Cli.Monad (Cli)
@@ -14,7 +16,11 @@ import Unison.Cli.PrettyPrintUtils qualified as Cli
 import Unison.Codebase qualified as Codebase
 import Unison.Codebase.Branch qualified as Branch
 import Unison.Codebase.Branch.Names qualified as Branch
+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)
@@ -26,11 +32,22 @@ handleTodo :: Cli ()
 handleTodo = do
   -- For now, we don't go through any great trouble to seek out the root of the project branch. Just assume the current
   -- namespace is the root, which will be the case unless the user uses `deprecated.cd`.
-  currentNamespace <- Cli.getCurrentBranch0
+  currentCausal <- Cli.getCurrentBranch
+  let currentNamespace = Branch.head currentCausal
   let currentNamespaceWithoutLibdeps = Branch.deleteLibdeps currentNamespace
 
-  (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
+        branch <-
+          currentCausal
+            & Branch._history
+            & Causal.valueHash
+            & coerce @_ @BranchHash
+            & Operations.expectBranchByBranchHash
+        hasDefnsInLib branch
+
       let todoReference :: TermReference
           todoReference =
             Set.asSingleton (Names.refTermsNamed Builtin.names (Name.unsafeParseText "todo"))
@@ -51,20 +68,28 @@ handleTodo = do
 
       hashLen <- Codebase.hashLength
 
-      pure (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,
           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

@@ -54,6 +54,7 @@ import Unison.Hash (Hash)
 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)
@@ -154,9 +155,11 @@ data NumberedOutput
       (Map LabeledDependency (Set Name)) -- Mapping of external dependencies to their local dependents.
 
 data TodoOutput = TodoOutput
-  { dependentsOfTodo :: !(Set TermReferenceId),
+  { defnsInLib :: !Bool,
+    dependentsOfTodo :: !(Set TermReferenceId),
     directDependenciesWithoutNames :: !(DefnsF Set TermReference TypeReference),
     hashLen :: !Int,
+    incoherentDeclReasons :: !IncoherentDeclReasons,
     nameConflicts :: !Names,
     ppe :: !PrettyPrintEnvDecl
   }
@@ -166,6 +169,8 @@ todoOutputIsEmpty todo =
   Set.null todo.dependentsOfTodo
     && defnsAreEmpty todo.directDependenciesWithoutNames
     && Names.isEmpty todo.nameConflicts
+    && not todo.defnsInLib
+    && todo.incoherentDeclReasons == IncoherentDeclReasons [] [] [] []
 
 data AmbiguousReset'Argument
   = AmbiguousReset'Hash