Merge pull request #5332 from unisonweb/24-09-05-merge-branch-dependents

bugfix: reuse unique type guids on merge conflicts

Author: aryairani

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

@@ -313,8 +313,6 @@ doMerge info = do
                 Left _typecheckErr -> Nothing
                 Right blob5 -> Just blob5
 
-      let stageOneBranch = defnsAndLibdepsToBranch0 env.codebase blob3.stageOne mergedLibdeps
-
       let parents =
             causals <&> \causal -> (causal.causalHash, Codebase.expectBranchForHash env.codebase causal.causalHash)
 
@@ -326,7 +324,11 @@ doMerge info = do
               info.description
               ( HandleInput.Branch.CreateFrom'NamespaceWithParent
                   info.alice.projectAndBranch.branch
-                  (Branch.mergeNode stageOneBranch parents.alice parents.bob)
+                  ( Branch.mergeNode
+                      (defnsAndLibdepsToBranch0 env.codebase blob3.stageTwo mergedLibdeps)
+                      parents.alice
+                      parents.bob
+                  )
               )
               info.alice.projectAndBranch.project
               (findTemporaryBranchName info.alice.projectAndBranch.project.projectId mergeSourceAndTarget)
@@ -338,11 +340,18 @@ doMerge info = do
           done (Output.MergeFailure scratchFilePath mergeSourceAndTarget temporaryBranchName)
 
       Cli.runTransaction (Codebase.addDefsToCodebase env.codebase blob5.file)
-      let stageTwoBranch = Branch.batchUpdates (typecheckedUnisonFileToBranchAdds blob5.file) stageOneBranch
       Cli.updateProjectBranchRoot_
         info.alice.projectAndBranch.branch
         info.description
-        (\_aliceBranch -> Branch.mergeNode stageTwoBranch parents.alice parents.bob)
+        ( \_aliceBranch ->
+            Branch.mergeNode
+              ( Branch.batchUpdates
+                  (typecheckedUnisonFileToBranchAdds blob5.file)
+                  (defnsAndLibdepsToBranch0 env.codebase blob3.stageOne mergedLibdeps)
+              )
+              parents.alice
+              parents.bob
+        )
       pure (Output.MergeSuccess mergeSourceAndTarget)
 
   Cli.respond finalOutput

unison-core/src/Unison/Util/Defns.hs

@@ -13,6 +13,7 @@ module Unison.Util.Defns
     zipDefns,
     zipDefnsWith,
     zipDefnsWith3,
+    zipDefnsWith4,
   )
 where
 
@@ -99,3 +100,14 @@ zipDefnsWith3 ::
   Defns tm4 ty4
 zipDefnsWith3 f g (Defns terms1 types1) (Defns terms2 types2) (Defns terms3 types3) =
   Defns (f terms1 terms2 terms3) (g types1 types2 types3)
+
+zipDefnsWith4 ::
+  (tm1 -> tm2 -> tm3 -> tm4 -> tm5) ->
+  (ty1 -> ty2 -> ty3 -> ty4 -> ty5) ->
+  Defns tm1 ty1 ->
+  Defns tm2 ty2 ->
+  Defns tm3 ty3 ->
+  Defns tm4 ty4 ->
+  Defns tm5 ty5
+zipDefnsWith4 f g (Defns terms1 types1) (Defns terms2 types2) (Defns terms3 types3) (Defns terms4 types4) =
+  Defns (f terms1 terms2 terms3 terms4) (g types1 types2 types3 types4)

unison-merge/src/Unison/Merge/Mergeblob3.hs

@@ -17,8 +17,10 @@ import Data.Zip (unzip)
 import Unison.DataDeclaration (Decl)
 import Unison.DataDeclaration qualified as DataDeclaration
 import Unison.DeclNameLookup (DeclNameLookup, expectConstructorNames)
+import Unison.DeclNameLookup qualified as DeclNameLookup
 import Unison.Merge.Mergeblob2 (Mergeblob2 (..))
 import Unison.Merge.PrettyPrintEnv (makePrettyPrintEnvs)
+import Unison.Merge.ThreeWay (ThreeWay)
 import Unison.Merge.ThreeWay qualified as ThreeWay
 import Unison.Merge.TwoWay (TwoWay)
 import Unison.Merge.TwoWay qualified as TwoWay
@@ -38,7 +40,7 @@ import Unison.Term (Term)
 import Unison.Type (Type)
 import Unison.Util.BiMultimap (BiMultimap)
 import Unison.Util.BiMultimap qualified as BiMultimap
-import Unison.Util.Defns (Defns (..), DefnsF, defnsAreEmpty, zipDefnsWith, zipDefnsWith3)
+import Unison.Util.Defns (Defns (..), DefnsF, defnsAreEmpty, zipDefnsWith, zipDefnsWith3, zipDefnsWith4)
 import Unison.Util.Pretty (ColorText, Pretty)
 import Unison.Util.Pretty qualified as Pretty
 import Unison.Util.Relation qualified as Relation
@@ -47,6 +49,7 @@ import Prelude hiding (unzip)
 data Mergeblob3 = Mergeblob3
   { libdeps :: Names,
     stageOne :: DefnsF (Map Name) Referent TypeReference,
+    stageTwo :: DefnsF (Map Name) Referent TypeReference,
     uniqueTypeGuids :: Map Name Text,
     unparsedFile :: Pretty ColorText
   }
@@ -64,6 +67,7 @@ makeMergeblob3 blob dependents0 libdeps authors =
 
       -- Identify the unconflicted dependents we need to pull into the Unison file (either first for typechecking, if
       -- there aren't conflicts, or else for manual conflict resolution without a typechecking step, if there are)
+      dependents :: TwoWay (DefnsF Set Name Name)
       dependents =
         filterDependents
           conflictsNames
@@ -105,6 +109,13 @@ makeMergeblob3 blob dependents0 libdeps authors =
               dependents
               (bimap BiMultimap.range BiMultimap.range blob.defns.lca),
           uniqueTypeGuids = makeUniqueTypeGuids blob.hydratedDefns,
+          stageTwo =
+            makeStageTwo
+              blob.declNameLookups
+              conflictsNames
+              blob.unconflicts
+              dependents
+              (bimap BiMultimap.range BiMultimap.range <$> blob.defns),
           unparsedFile = makePrettyUnisonFile authors renderedConflicts renderedDependents
         }
 
@@ -164,6 +175,41 @@ makeStageOneV :: Unconflicts v -> Set Name -> Map Name v -> Map Name v
 makeStageOneV unconflicts namesToDelete =
   (`Map.withoutKeys` namesToDelete) . Unconflicts.apply unconflicts
 
+makeStageTwo ::
+  forall term typ.
+  TwoWay DeclNameLookup ->
+  TwoWay (DefnsF Set Name Name) ->
+  DefnsF Unconflicts term typ ->
+  TwoWay (DefnsF Set Name Name) ->
+  ThreeWay (DefnsF (Map Name) term typ) ->
+  DefnsF (Map Name) term typ
+makeStageTwo declNameLookups conflicts unconflicts dependents defns =
+  zipDefnsWith4 makeStageTwoV makeStageTwoV defns.lca aliceBiasedDependents unconflicts aliceConflicts
+  where
+    aliceConflicts :: DefnsF (Map Name) term typ
+    aliceConflicts =
+      zipDefnsWith
+        (\defns conflicts -> Map.restrictKeys defns (conflicts <> aliceConstructorsOfTypeConflicts))
+        Map.restrictKeys
+        defns.alice
+        conflicts.alice
+
+    aliceConstructorsOfTypeConflicts :: Set Name
+    aliceConstructorsOfTypeConflicts =
+      foldMap
+        (Set.fromList . DeclNameLookup.expectConstructorNames declNameLookups.alice)
+        conflicts.alice.types
+
+    aliceBiasedDependents :: DefnsF (Map Name) term typ
+    aliceBiasedDependents =
+      TwoWay.twoWay
+        (zipDefnsWith (Map.unionWith const) (Map.unionWith const))
+        (zipDefnsWith Map.restrictKeys Map.restrictKeys <$> ThreeWay.forgetLca defns <*> dependents)
+
+makeStageTwoV :: Map Name v -> Map Name v -> Unconflicts v -> Map Name v -> Map Name v
+makeStageTwoV lca dependents unconflicts conflicts =
+  Map.unionWith const conflicts (Unconflicts.apply unconflicts (Map.unionWith const dependents lca))
+
 -- Given just named term/type reference ids, fill out all names that occupy the term and type namespaces. This is simply
 -- the given names plus all of the types' constructors.
 --