Merge pull request #5567 from unisonweb/share-3waydiff

Author: aryairani

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

Diff for: lib/unison-prelude/src/Unison/Util/Set.hs

@@ -5,6 +5,7 @@ module Unison.Util.Set
     mapMaybe,
     symmetricDifference,
     Unison.Util.Set.traverse,
+    Unison.Util.Set.for,
     flatMap,
     filterM,
     forMaybe,
@@ -51,6 +52,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
 

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

@@ -78,6 +78,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
@@ -241,6 +242,22 @@ doMerge info = do
 
         let blob0 = Merge.makeMergeblob0 nametrees3 libdeps3
 
+        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}
+
+        respondRegion (Output.Literal "Loading definitions...")
+
         -- Hydrate
         hydratedDefns ::
           Merge.ThreeWay
@@ -260,14 +277,14 @@ doMerge info = do
                  in bimap f g <$> blob0.defns
               )
 
-        respondRegion (Output.Literal "Computing diff between branches...")
+        respondRegion (Output.Literal "Computing diffs...")
 
         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)
 

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

Diff for: unison-core/src/Unison/Util/Defns.hs

@@ -4,6 +4,8 @@ module Unison.Util.Defns
     DefnsF2,
     DefnsF3,
     DefnsF4,
+    terms_,
+    types_,
     alignDefnsWith,
     defnsAreEmpty,
     fromTerms,
@@ -19,6 +21,7 @@ module Unison.Util.Defns
   )
 where
 
+import Control.Lens (Lens)
 import Data.Align (Semialign, alignWith)
 import Data.Bifoldable (Bifoldable, bifoldMap)
 import Data.Bitraversable (Bitraversable, bitraverse)
@@ -31,7 +34,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
@@ -46,6 +49,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)

Diff for: 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) =

Diff for: unison-merge/package.yaml

@@ -7,6 +7,7 @@ ghc-options: -Wall
 dependencies:
   - base
   - containers
+  - either
   - lens
   - mtl
   - nonempty-containers

Diff for: unison-merge/src/Unison/Merge/DeclCoherencyCheck.hs

@@ -132,7 +132,7 @@ data IncoherentDeclReason
     --   Foo.Bar#Foo
     IncoherentDeclReason'NestedDeclAlias !Name !Name -- shorter name, longer name
   | IncoherentDeclReason'StrayConstructor !TypeReferenceId !Name
-  deriving stock (Show)
+  deriving stock (Eq, Show)
 
 checkDeclCoherency ::
   (HasCallStack) =>