compute alice's unconflicted names

unisonweb · Oct 10, 2023 · fda0267 · fda0267
1 parent 8ff6ce3
commit fda0267
Show file tree

Hide file tree

Showing 2 changed files with 66 additions and 12 deletions.
diff --git a/lib/unison-util-bimultimap/src/Unison/Util/BiMultimap.hs b/lib/unison-util-bimultimap/src/Unison/Util/BiMultimap.hs
@@ -11,9 +11,15 @@ module Unison.Util.BiMultimap
     -- ** Mapping / traversing
     unsafeTraverseDom,
 
+    -- ** Filtering
+    filterDom,
+    restrictDom,
+    withoutDom,
+
     -- ** Maps
     domain,
     range,
+    unsafeFromDomain,
     fromRange,
 
     -- ** Sets
@@ -90,12 +96,45 @@ unsafeTraverseDom f m =
       !b <- f a
       acc $! BiMultimap (Map.insert b xs domain0) (deriveRangeFromDomain b xs range0)
 
+-- | Restrict a left-unique relation to only those @(a, b)@ members whose @a@ is in the given set.
+filterDom :: (Ord a, Ord b) => (a -> Bool) -> BiMultimap a b -> BiMultimap a b
+filterDom f m =
+  unsafeFromDomain (Map.filterWithKey (\x _ -> f x) (domain m))
+
+-- | Restrict a left-unique relation to only those @(a, b)@ members whose @a@ is in the given set.
+restrictDom :: (Ord a, Ord b) => Set a -> BiMultimap a b -> BiMultimap a b
+restrictDom xs m =
+  unsafeFromDomain (Map.restrictKeys (domain m) xs)
+
+-- | Restrict a left-unique relation to only those @(a, b)@ members whose @a@ is not in the given set.
+withoutDom :: (Ord a, Ord b) => Set a -> BiMultimap a b -> BiMultimap a b
+withoutDom xs m =
+  unsafeFromDomain (Map.withoutKeys (domain m) xs)
+
 domain :: BiMultimap a b -> Map a (NESet b)
 domain = toMultimap
 
 range :: BiMultimap a b -> Map b a
 range = toMapR
 
+-- | Construct a left-unique relation from a mapping from its left-elements to set-of-right-elements. The caller is
+-- responsible for ensuring that no right-element is mapped to by two different left-elements.
+unsafeFromDomain :: Ord b => Map a (NESet b) -> BiMultimap a b
+unsafeFromDomain domain =
+  BiMultimap domain (invertDomain domain)
+
+invertDomain :: forall a b. Ord b => Map a (NESet b) -> Map b a
+invertDomain =
+  Map.foldlWithKey' f Map.empty
+  where
+    f :: Map b a -> a -> NESet b -> Map b a
+    f acc x ys =
+      Set.NonEmpty.foldl' (g x) acc ys
+
+    g :: a -> Map b a -> b -> Map b a
+    g x acc y =
+      Map.insert y x acc
+
 fromRange :: (Ord a, Ord b) => Map b a -> BiMultimap a b
 fromRange m =
   BiMultimap (Map.foldlWithKey' f Map.empty m) m

diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Merge2.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Merge2.hs
@@ -188,6 +188,13 @@ handleMerge alicePath0 bobPath0 _resultPath = do
             aliceLibdeps
             bobLibdeps
 
+      -- For some things below we only care about the `Map Name ref` direction of our `BiMultimap ref Name` definitions
+      let aliceNames :: Merge.Defns (Map Name Referent) (Map Name TypeReference)
+          aliceNames = aliceDefns & over #terms BiMultimap.range & over #types BiMultimap.range
+
+      let bobNames :: Merge.Defns (Map Name Referent) (Map Name TypeReference)
+          bobNames = bobDefns & over #terms BiMultimap.range & over #types BiMultimap.range
+
       -- If there are no conflicts, then proceed to typechecking
       if null conflictedTerms && null conflictedTypes
         then do
@@ -198,18 +205,6 @@ handleMerge alicePath0 bobPath0 _resultPath = do
 
               namelookup :: Merge.RefToName = wundefined
 
-              aliceNames :: Merge.Defns (Map Name Referent) (Map Name TypeReference)
-              aliceNames =
-                aliceDefns
-                  & over #terms BiMultimap.range
-                  & over #types BiMultimap.range
-
-              bobNames :: Merge.Defns (Map Name Referent) (Map Name TypeReference)
-              bobNames =
-                bobDefns
-                  & over #terms BiMultimap.range
-                  & over #types BiMultimap.range
-
               aliceUpdates :: Merge.Defns (Map Name Referent) (Map Name TypeReference)
               aliceUpdates =
                 filterUpdates aliceNames (diffs ^. #alice)
@@ -284,6 +279,26 @@ handleMerge alicePath0 bobPath0 _resultPath = do
                     types = Set.union (bobConflicts ^. #types) (bobDependentsOfConflicts ^. #types)
                   }
 
+          -- All of Alice's definitions, minus those that are conflicted
+          let aliceUnconflicted :: Merge.Defns (BiMultimap Referent Name) (BiMultimap TypeReference Name)
+              aliceUnconflicted =
+                Merge.Defns
+                  { terms =
+                      (aliceDefns ^. #terms) & BiMultimap.filterDom \case
+                        -- Consider a constructor term "unconflicted" if its decl is unconflicted.
+                        Referent.Con (ReferenceDerived typeRef) _conId -> not (Set.member typeRef (aliceConflicted ^. #types))
+                        -- Keep builtin terms (since they can't be conflicted, per a precondition)
+                        Referent.Ref (ReferenceDerived termRef) -> not (Set.member termRef (aliceConflicted ^. #terms))
+                        -- Keep builtin constructors (which don't even exist) and builtin terms (since they can't be
+                        -- conflicted, per a precondition)
+                        Referent.Con (ReferenceBuiltin _) _ -> True
+                        Referent.Ref (ReferenceBuiltin _) -> True,
+                    types =
+                      BiMultimap.withoutDom
+                        (Set.map ReferenceDerived (aliceConflicted ^. #types))
+                        (aliceDefns ^. #types)
+                  }
+
           mergeOutput <- wundefined "create MergeOutput"
           wundefined "dump MergeOutput to scratchfile" mergeOutput