remove "old style" merge functions that take merge database as argument

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

@@ -170,6 +170,7 @@ withoutRan ys m =
 domain :: BiMultimap a b -> Map a (NESet b)
 domain = toMultimap
 
+-- | /O(1)/.
 range :: BiMultimap a b -> Map b a
 range = toMapR
 

unison-cli/src/Unison/Cli/Monad.hs

@@ -47,6 +47,7 @@ module Unison.Cli.Monad
     -- * Running transactions
     runTransaction,
     runTransactionWithRollback,
+    runTransactionWithRollback2,
 
     -- * Internal
     setMostRecentProjectPath,
@@ -444,3 +445,10 @@ runTransactionWithRollback action = do
   Env {codebase} <- ask
   liftIO (Codebase.runTransactionWithRollback codebase \rollback -> Right <$> action (\output -> rollback (Left output)))
     & onLeftM returnEarly
+
+-- | Run a transaction that can abort early.
+-- todo: rename to runTransactionWithRollback
+runTransactionWithRollback2 :: ((forall void. a -> Sqlite.Transaction void) -> Sqlite.Transaction a) -> Cli a
+runTransactionWithRollback2 action = do
+  env <- ask
+  liftIO (Codebase.runTransactionWithRollback env.codebase action)

unison-cli/src/Unison/Cli/UpdateUtils.hs

@@ -235,13 +235,13 @@ hydrateDefns ::
   (Hash -> m [term]) ->
   (Hash -> m [typ]) ->
   DefnsF (Map name) TermReferenceId TypeReferenceId ->
-  m (DefnsF (Map name) term (TypeReferenceId, typ))
+  m (DefnsF (Map name) (TermReferenceId, term) (TypeReferenceId, typ))
 hydrateDefns getTermComponent getTypeComponent = do
   bitraverse hydrateTerms hydrateTypes
   where
-    hydrateTerms :: Map name TermReferenceId -> m (Map name term)
+    hydrateTerms :: Map name TermReferenceId -> m (Map name (TermReferenceId, term))
     hydrateTerms terms =
-      hydrateDefns_ getTermComponent terms \_ _ -> id
+      hydrateDefns_ getTermComponent terms \_ -> (,)
 
     hydrateTypes :: Map name TypeReferenceId -> m (Map name (TypeReferenceId, typ))
     hydrateTypes types =

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

@@ -15,6 +15,7 @@ module Unison.Codebase.Editor.HandleInput.Merge2
   )
 where
 
+import Control.Lens (mapped)
 import Control.Monad.Reader (ask)
 import Data.Bifoldable (bifoldMap)
 import Data.Bitraversable (bitraverse)
@@ -106,10 +107,14 @@ import Unison.Sqlite (Transaction)
 import Unison.Sqlite qualified as Sqlite
 import Unison.Symbol (Symbol)
 import Unison.Syntax.Name qualified as Name
+import Unison.Term (Term)
+import Unison.Type (Type)
 import Unison.UnisonFile (TypecheckedUnisonFile)
 import Unison.UnisonFile qualified as UnisonFile
 import Unison.Util.BiMultimap (BiMultimap)
 import Unison.Util.BiMultimap qualified as BiMultimap
+import Unison.Util.Conflicted (Conflicted)
+import Unison.Util.Defn (Defn)
 import Unison.Util.Defns (Defns (..), DefnsF, DefnsF2, DefnsF3, alignDefnsWith, defnsAreEmpty, zipDefnsWith, zipDefnsWith3)
 import Unison.Util.Monoid qualified as Monoid
 import Unison.Util.Nametree (Nametree (..), flattenNametrees, unflattenNametree)
@@ -224,37 +229,102 @@ doMerge info = do
         whenM (Cli.runTransaction (hasDefnsInLib branch)) do
           done (Output.MergeDefnsInLib who)
 
-      -- Load Alice/Bob/LCA definitions and decl name lookups
-      (defns3, declNameLookups, lcaDeclNameLookup) <- do
-        let emptyNametree = Nametree {value = Defns Map.empty Map.empty, children = Map.empty}
-        let loadDefns branch =
-              Cli.runTransaction (loadNamespaceDefinitions (referent2to1 db) branch)
-                & onLeftM (done . Output.ConflictedDefn "merge")
-        let load = \case
-              Nothing -> pure (emptyNametree, Merge.DeclNameLookup Map.empty Map.empty)
-              Just (who, branch) -> do
-                defns <- loadDefns branch
-                declNameLookup <-
-                  Cli.runTransaction (Merge.oldCheckDeclCoherency db.loadDeclNumConstructors defns)
-                    & onLeftM (done . Output.IncoherentDeclDuringMerge who)
-                pure (defns, declNameLookup)
-
-        (aliceDefns0, aliceDeclNameLookup) <- load (Just (mergeTarget, branches.alice))
-        (bobDefns0, bobDeclNameLookup) <- load (Just (mergeSource, branches.bob))
-        lcaDefns0 <- maybe (pure emptyNametree) loadDefns branches.lca
-        lcaDeclNameLookup <- Cli.runTransaction (Merge.oldLenientCheckDeclCoherency db.loadDeclNumConstructors lcaDefns0)
-
-        let defns3 = flattenNametrees <$> Merge.ThreeWay {alice = aliceDefns0, bob = bobDefns0, lca = lcaDefns0}
-        let declNameLookups = Merge.TwoWay {alice = aliceDeclNameLookup, bob = bobDeclNameLookup}
-
-        pure (defns3, declNameLookups, lcaDeclNameLookup)
-
-      let defns = ThreeWay.forgetLca defns3
+      -- Load Alice/Bob/LCA definitions
+      --
+      -- FIXME: Oops, if this fails due to a conflicted name, we don't actually say where the conflicted name came from.
+      -- We should have a better error message (even though you can't do anything about conflicted names in the LCA).
+      nametrees3 :: Merge.ThreeWay (Nametree (DefnsF (Map NameSegment) Referent TypeReference)) <- do
+        let action ::
+              (forall a. Defn (Conflicted Name Referent) (Conflicted Name TypeReference) -> Transaction a) ->
+              Transaction (Merge.ThreeWay (Nametree (DefnsF (Map NameSegment) Referent TypeReference)))
+            action rollback = do
+              alice <- loadNamespaceDefinitions (referent2to1 db) branches.alice & onLeftM rollback
+              bob <- loadNamespaceDefinitions (referent2to1 db) branches.bob & onLeftM rollback
+              lca <-
+                case branches.lca of
+                  Nothing -> pure Nametree {value = Defns Map.empty Map.empty, children = Map.empty}
+                  Just lca -> loadNamespaceDefinitions (referent2to1 db) lca & onLeftM rollback
+              pure Merge.ThreeWay {alice, bob, lca}
+        Cli.runTransactionWithRollback2 (\rollback -> Right <$> action (rollback . Left))
+          & onLeftM (done . Output.ConflictedDefn "merge")
+
+      -- Flatten nametrees
+      let defns3 :: Merge.ThreeWay (Defns (BiMultimap Referent Name) (BiMultimap TypeReference Name))
+          defns3 =
+            flattenNametrees <$> nametrees3
+
+      let defns2 :: Merge.TwoWay (Defns (BiMultimap Referent Name) (BiMultimap TypeReference Name))
+          defns2 =
+            ThreeWay.forgetLca defns3
+
+      -- Hydrate
+      hydratedDefns2 ::
+        Merge.TwoWay
+          ( DefnsF
+              (Map Name)
+              (TermReferenceId, (Term Symbol Ann, Type Symbol Ann))
+              (TypeReferenceId, Decl Symbol Ann)
+          ) <-
+        Cli.runTransaction $
+          traverse
+            ( hydrateDefns
+                (Codebase.unsafeGetTermComponent codebase)
+                Operations.expectDeclComponent
+            )
+            ( let f = Map.mapMaybe Referent.toTermReferenceId . BiMultimap.range
+                  g = Map.mapMaybe Reference.toId . BiMultimap.range
+               in bimap f g <$> ThreeWay.forgetLca defns3
+            )
+
+      -- Make one big constructor count lookup for Alice+Bob's type decls
+      let numConstructors :: Map TypeReferenceId Int
+          numConstructors =
+            Map.empty
+              & f (Map.elems hydratedDefns2.alice.types)
+              & f (Map.elems hydratedDefns2.bob.types)
+            where
+              f :: [(TypeReferenceId, Decl Symbol Ann)] -> Map TypeReferenceId Int -> Map TypeReferenceId Int
+              f types acc =
+                List.foldl'
+                  ( \acc (ref, decl) ->
+                      Map.insert ref (DataDeclaration.constructorCount (DataDeclaration.asDataDecl decl)) acc
+                  )
+                  acc
+                  types
+
+      -- Make Alice/Bob decl name lookups
+      declNameLookups <- do
+        alice <-
+          Merge.checkDeclCoherency nametrees3.alice numConstructors
+            & onLeft (done . Output.IncoherentDeclDuringMerge mergeTarget)
+        bob <-
+          Merge.checkDeclCoherency nametrees3.bob numConstructors
+            & onLeft (done . Output.IncoherentDeclDuringMerge mergeSource)
+        pure Merge.TwoWay {alice, bob}
+
+      -- Make LCA decl name lookup
+      let lcaDeclNameLookup =
+            Merge.lenientCheckDeclCoherency nametrees3.lca numConstructors
 
       liftIO (debugFunctions.debugDefns defns3 declNameLookups lcaDeclNameLookup)
 
       -- Diff LCA->Alice and LCA->Bob
-      diffs <- Cli.runTransaction (Merge.oldNameBasedNamespaceDiff db declNameLookups lcaDeclNameLookup defns3)
+      let diffs :: Merge.TwoWay (DefnsF3 (Map Name) Merge.DiffOp Merge.Synhashed Referent TypeReference)
+          diffs =
+            Merge.nameBasedNamespaceDiff
+              declNameLookups
+              lcaDeclNameLookup
+              defns3
+              Defns
+                { terms =
+                    foldMap
+                      (List.foldl' (\acc (ref, (term, _)) -> Map.insert ref term acc) Map.empty . Map.elems . (.terms))
+                      hydratedDefns2,
+                  types =
+                    foldMap
+                      (List.foldl' (\acc (ref, typ) -> Map.insert ref typ acc) Map.empty . Map.elems . (.types))
+                      hydratedDefns2
+                }
 
       liftIO (debugFunctions.debugDiffs diffs)
 
@@ -270,14 +340,14 @@ doMerge info = do
 
       -- Partition the combined diff into the conflicted things and the unconflicted things
       (conflicts, unconflicts) <-
-        Merge.partitionCombinedDiffs defns declNameLookups diff & onLeft \name ->
+        Merge.partitionCombinedDiffs (ThreeWay.forgetLca defns3) declNameLookups diff & onLeft \name ->
           done (Output.MergeConflictInvolvingBuiltin name)
 
       liftIO (debugFunctions.debugPartitionedDiff conflicts unconflicts)
 
       -- 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 <- Cli.runTransaction (identifyDependents defns conflicts unconflicts)
+      dependents <- Cli.runTransaction (identifyDependents defns2 conflicts unconflicts)
 
       liftIO (debugFunctions.debugDependents dependents)
 
@@ -304,7 +374,7 @@ doMerge info = do
             defnsNames <&> \names -> PPED.makePPED (PPE.namer (names <> libdepsNames)) suffixifier
             where
               suffixifier = PPE.suffixifyByName (fold defnsNames <> libdepsNames)
-      let ppes = mkPpes (defnsToNames <$> defns) (Branch.toNames mergedLibdeps)
+      let ppes = mkPpes (defnsToNames <$> defns2) (Branch.toNames mergedLibdeps)
 
       hydratedThings <- do
         Cli.runTransaction do
@@ -315,8 +385,8 @@ doMerge info = do
       let (renderedConflicts, renderedDependents) =
             unzip $
               ( \declNameLookup (conflicts, dependents) ppe ->
-                  let honk1 = renderDefnsForUnisonFile declNameLookup ppe
-                   in (honk1 conflicts, honk1 dependents)
+                  let render = renderDefnsForUnisonFile declNameLookup ppe . over (#terms . mapped) snd
+                   in (render conflicts, render dependents)
               )
                 <$> declNameLookups
                 <*> hydratedThings

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

@@ -7,13 +7,15 @@ module Unison.Codebase.Editor.HandleInput.Update2
   )
 where
 
-import Control.Monad.RWS (ask)
+import Control.Lens (mapped)
+import Control.Monad.Reader.Class (ask)
 import Data.Bifoldable (bifoldMap)
+import Data.Foldable qualified as Foldable
 import Data.List qualified as List
 import Data.Map qualified as Map
 import Data.Set qualified as Set
 import Data.Text qualified as Text
-import U.Codebase.Reference (Reference, TermReferenceId)
+import U.Codebase.Reference (Reference, Reference' (..), TermReferenceId)
 import U.Codebase.Sqlite.Operations qualified as Operations
 import Unison.Cli.Monad (Cli, Env (..))
 import Unison.Cli.Monad qualified as Cli
@@ -38,8 +40,7 @@ import Unison.Codebase.Path qualified as Path
 import Unison.Codebase.SqliteCodebase.Operations qualified as Operations
 import Unison.DataDeclaration (Decl)
 import Unison.DataDeclaration qualified as Decl
-import Unison.Merge.DeclCoherencyCheck (oldCheckDeclCoherency)
-import Unison.Merge.DeclNameLookup (DeclNameLookup (..))
+import Unison.Merge qualified as Merge
 import Unison.Name (Name)
 import Unison.Names (Names)
 import Unison.Names qualified as Names
@@ -51,13 +52,16 @@ import Unison.PrettyPrintEnvDecl qualified as PPED
 import Unison.PrettyPrintEnvDecl.Names qualified as PPED
 import Unison.Reference (TypeReference, TypeReferenceId)
 import Unison.Reference qualified as Reference (fromId)
+import Unison.Referent (Referent)
 import Unison.Referent qualified as Referent
 import Unison.Sqlite (Transaction)
 import Unison.Symbol (Symbol)
 import Unison.Syntax.Name qualified as Name
 import Unison.UnisonFile qualified as UF
 import Unison.UnisonFile.Names qualified as UF
 import Unison.UnisonFile.Type (TypecheckedUnisonFile)
+import Unison.Util.BiMultimap (BiMultimap)
+import Unison.Util.BiMultimap qualified as BiMultimap
 import Unison.Util.Defns (Defns (..), DefnsF, defnsAreEmpty)
 import Unison.Util.Monoid qualified as Monoid
 import Unison.Util.Nametree (flattenNametrees)
@@ -78,14 +82,33 @@ handleUpdate2 = do
   let namesIncludingLibdeps = Branch.toNames currentBranch0
 
   -- Assert that the namespace doesn't have any conflicted names
-  defns <-
+  nametree <-
     narrowDefns (Branch.deepDefns currentBranch0ExcludingLibdeps)
       & onLeft (Cli.returnEarly . Output.ConflictedDefn "update")
 
+  let defns :: Defns (BiMultimap Referent Name) (BiMultimap TypeReference Name)
+      defns =
+        flattenNametrees nametree
+
+  -- Get the number of constructors for every type declaration
+  numConstructors <-
+    Cli.runTransaction do
+      defns.types
+        & BiMultimap.dom
+        & Set.toList
+        & Foldable.foldlM
+          ( \acc -> \case
+              ReferenceBuiltin _ -> pure acc
+              ReferenceDerived ref -> do
+                num <- Operations.expectDeclNumConstructors ref
+                pure $! Map.insert ref num acc
+          )
+          Map.empty
+
   -- Assert that the namespace doesn't have any incoherent decls
   declNameLookup <-
-    Cli.runTransaction (oldCheckDeclCoherency Operations.expectDeclNumConstructors defns)
-      & onLeftM (Cli.returnEarly . Output.IncoherentDeclDuringUpdate)
+    Merge.checkDeclCoherency nametree numConstructors
+      & onLeft (Cli.returnEarly . Output.IncoherentDeclDuringUpdate)
 
   Cli.respond Output.UpdateLookingForDependents
 
@@ -94,7 +117,7 @@ handleUpdate2 = do
       -- Get all dependents of things being updated
       dependents0 <-
         getNamespaceDependentsOf2
-          (flattenNametrees defns)
+          (flattenNametrees nametree)
           (getExistingReferencesNamed termAndDeclNames (Branch.toNames currentBranch0ExcludingLibdeps))
 
       -- Throw away the dependents that are shadowed by the file itself
@@ -125,7 +148,7 @@ handleUpdate2 = do
               let ppe = makePPE 10 namesIncludingLibdeps (UF.typecheckedToNames tuf) dependents
                in makePrettyUnisonFile
                     (Pretty.prettyUnisonFile ppe (UF.discardTypes tuf))
-                    (renderDefnsForUnisonFile declNameLookup ppe hydratedDependents)
+                    (renderDefnsForUnisonFile declNameLookup ppe (over (#terms . mapped) snd hydratedDependents))
 
         parsingEnv <- Cli.makeParsingEnv pp namesIncludingLibdeps
 

unison-merge/src/Unison/Merge.hs

@@ -3,16 +3,13 @@ module Unison.Merge
     DeclNameLookup (..),
     PartialDeclNameLookup (..),
     IncoherentDeclReason (..),
-    oldCheckDeclCoherency,
     checkDeclCoherency,
-    oldLenientCheckDeclCoherency,
     lenientCheckDeclCoherency,
     IncoherentDeclReasons (..),
     checkAllDeclCoherency,
 
     -- * 3-way namespace diff
     DiffOp (..),
-    oldNameBasedNamespaceDiff,
     nameBasedNamespaceDiff,
 
     -- * Combining namespace diffs
@@ -47,11 +44,9 @@ import Unison.Merge.DeclCoherencyCheck
     checkAllDeclCoherency,
     checkDeclCoherency,
     lenientCheckDeclCoherency,
-    oldCheckDeclCoherency,
-    oldLenientCheckDeclCoherency,
   )
 import Unison.Merge.DeclNameLookup (DeclNameLookup (..))
-import Unison.Merge.Diff (nameBasedNamespaceDiff, oldNameBasedNamespaceDiff)
+import Unison.Merge.Diff (nameBasedNamespaceDiff)
 import Unison.Merge.DiffOp (DiffOp (..))
 import Unison.Merge.EitherWay (EitherWay (..))
 import Unison.Merge.EitherWayI (EitherWayI (..))