Updates to Merge2 for Share

lib/unison-prelude/src/Unison/Prelude.hs

@@ -25,6 +25,7 @@ module Unison.Prelude
     whenJustM,
     eitherToMaybe,
     maybeToEither,
+    eitherToThese,
     altSum,
     altMap,
     hoistMaybe,
@@ -82,6 +83,7 @@ import Data.Text as X (Text)
 import Data.Text qualified as Text
 import Data.Text.Encoding as X (decodeUtf8, encodeUtf8)
 import Data.Text.IO qualified as Text
+import Data.These (These (..))
 import Data.Traversable as X (for)
 import Data.Typeable as X (Typeable)
 import Data.Void as X (Void)
@@ -205,6 +207,9 @@ throwEitherM = throwEitherMWith id
 throwEitherMWith :: forall e e' m a. (MonadIO m, Exception e') => (e -> e') -> m (Either e a) -> m a
 throwEitherMWith f action = throwExceptT . withExceptT f $ (ExceptT action)
 
+eitherToThese :: Either a b -> These a b
+eitherToThese = either This That
+
 tShow :: (Show a) => a -> Text
 tShow = Text.pack . show
 

lib/unison-prelude/src/Unison/Util/Set.hs

@@ -4,6 +4,7 @@ module Unison.Util.Set
     mapMaybe,
     symmetricDifference,
     Unison.Util.Set.traverse,
+    Unison.Util.Set.for,
     flatMap,
     filterM,
     forMaybe,
@@ -45,6 +46,9 @@ forMaybe xs f =
 traverse :: (Applicative f, Ord b) => (a -> f b) -> Set a -> f (Set b)
 traverse f = fmap Set.fromList . Prelude.traverse f . Set.toList
 
+for :: (Ord b, Applicative f) => Set a -> (a -> f b) -> f (Set b)
+for = flip Unison.Util.Set.traverse
+
 flatMap :: (Ord b) => (a -> Set b) -> Set a -> Set b
 flatMap f = Set.unions . fmap f . Set.toList
 

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

@@ -72,6 +72,7 @@ import Unison.Merge.ThreeWay qualified as ThreeWay
 import Unison.Name (Name)
 import Unison.NameSegment (NameSegment)
 import Unison.NameSegment qualified as NameSegment
+import Unison.Names (Names)
 import Unison.Parser.Ann (Ann)
 import Unison.Prelude
 import Unison.Project
@@ -228,6 +229,15 @@ doMerge info = do
         Cli.runTransactionWithRollback2 (\rollback -> Right <$> action (rollback . Left))
           & onLeftM (done . Output.ConflictedDefn "merge")
 
+      names3 :: Merge.ThreeWay Names <- do
+        let causalHashes = Merge.TwoOrThreeWay {alice = info.alice.causalHash, bob = info.bob.causalHash, lca = info.lca.causalHash}
+        branches <- for causalHashes \ch -> do
+          liftIO (Codebase.getBranchForHash env.codebase ch) >>= \case
+            Nothing -> done (Output.CouldntLoadBranch ch)
+            Just b -> pure b
+        let names = fmap (Branch.toNames . Branch.head) branches
+        pure Merge.ThreeWay {alice = names.alice, bob = names.bob, lca = fromMaybe mempty names.lca}
+
       libdeps3 <- Cli.runTransaction (loadLibdeps branches)
 
       let blob0 = Merge.makeMergeblob0 nametrees3 libdeps3
@@ -252,11 +262,11 @@ doMerge info = do
             )
 
       blob1 <-
-        Merge.makeMergeblob1 blob0 hydratedDefns & onLeft \case
+        Merge.makeMergeblob1 blob0 names3 hydratedDefns & onLeft \case
           Merge.Alice reason -> done (Output.IncoherentDeclDuringMerge mergeTarget reason)
           Merge.Bob reason -> done (Output.IncoherentDeclDuringMerge mergeSource reason)
 
-      liftIO (debugFunctions.debugDiffs blob1.diffs)
+      liftIO (debugFunctions.debugDiffs blob1.diffsFromLCA)
 
       liftIO (debugFunctions.debugCombinedDiff blob1.diff)
 

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

@@ -3,7 +3,28 @@ module Unison.Util.Defn
   )
 where
 
+import Data.Bifoldable (Bifoldable (..))
+import Data.Bifunctor (Bifunctor (..))
+import Data.Bitraversable (Bitraversable (..))
+import GHC.Generics (Generic)
+
 -- | A "definition" is either a term or a type.
 data Defn term typ
   = TermDefn term
   | TypeDefn typ
+  deriving stock (Generic, Functor, Foldable, Traversable, Show, Eq, Ord)
+
+instance Bifunctor Defn where
+  bimap f g = \case
+    TermDefn x -> TermDefn (f x)
+    TypeDefn y -> TypeDefn (g y)
+
+instance Bifoldable Defn where
+  bifoldMap f g = \case
+    TermDefn x -> f x
+    TypeDefn y -> g y
+
+instance Bitraversable Defn where
+  bitraverse f g = \case
+    TermDefn x -> TermDefn <$> f x
+    TypeDefn y -> TypeDefn <$> g y

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

@@ -4,6 +4,8 @@ module Unison.Util.Defns
     DefnsF2,
     DefnsF3,
     DefnsF4,
+    terms_,
+    types_,
     alignDefnsWith,
     defnsAreEmpty,
     hoistDefnsF,
@@ -13,9 +15,11 @@ module Unison.Util.Defns
     zipDefns,
     zipDefnsWith,
     zipDefnsWith3,
+    zipDefnsWith4,
   )
 where
 
+import Control.Lens (Lens)
 import Data.Align (Semialign, alignWith)
 import Data.Bifoldable (Bifoldable, bifoldMap)
 import Data.Bitraversable (Bitraversable, bitraverse)
@@ -28,7 +32,7 @@ data Defns terms types = Defns
   { terms :: terms,
     types :: types
   }
-  deriving stock (Generic, Functor, Show)
+  deriving stock (Generic, Functor, Show, Eq, Ord)
   deriving (Monoid, Semigroup) via GenericSemigroupMonoid (Defns terms types)
 
 instance Bifoldable Defns where
@@ -43,6 +47,12 @@ instance Bitraversable Defns where
   bitraverse f g (Defns x y) =
     Defns <$> f x <*> g y
 
+terms_ :: Lens (Defns terms types) (Defns terms' types) terms terms'
+terms_ f (Defns x y) = (\x' -> Defns x' y) <$> f x
+
+types_ :: Lens (Defns terms types) (Defns terms types') types types'
+types_ f (Defns x y) = (\y' -> Defns x y') <$> f y
+
 -- | A common shape of definitions - terms and types are stored in the same structure.
 type DefnsF f terms types =
   Defns (f terms) (f types)
@@ -99,3 +109,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-core/src/Unison/Util/Nametree.hs

@@ -3,6 +3,7 @@ module Unison.Util.Nametree
     Nametree (..),
     traverseNametreeWithName,
     unfoldNametree,
+    unionWith,
 
     -- ** Flattening and unflattening
     flattenNametree,
@@ -33,6 +34,16 @@ data Nametree a = Nametree
   }
   deriving stock (Functor, Foldable, Traversable, Generic, Show)
 
+unionWith :: (a -> a -> a) -> Nametree a -> Nametree a -> Nametree a
+unionWith f (Nametree x xs) (Nametree y ys) =
+  Nametree (f x y) (Map.unionWith (unionWith f) xs ys)
+
+instance (Semigroup a) => Semigroup (Nametree a) where
+  (<>) = unionWith (<>)
+
+instance (Monoid a) => Monoid (Nametree a) where
+  mempty = Nametree mempty mempty
+
 instance Semialign Nametree where
   alignWith :: (These a b -> c) -> Nametree a -> Nametree b -> Nametree c
   alignWith f (Nametree x xs) (Nametree y ys) =