Merge pull request #5343 from unisonweb/fix-5340

unison-core/src/Unison/Names.hs

@@ -50,9 +50,12 @@ module Unison.Names
     hashQualifyTermsRelation,
     fromTermsAndTypes,
     lenientToNametree,
+    resolveName,
   )
 where
 
+import Control.Lens (_2)
+import Data.List qualified as List
 import Data.Map qualified as Map
 import Data.Semialign (alignWith)
 import Data.Set qualified as Set
@@ -68,6 +71,7 @@ import Unison.LabeledDependency qualified as LD
 import Unison.Name (Name)
 import Unison.Name qualified as Name
 import Unison.NameSegment (NameSegment)
+import Unison.Names.ResolvesTo (ResolvesTo (..))
 import Unison.Prelude
 import Unison.Reference (Reference, TermReference, TermReferenceId, TypeReference, TypeReferenceId)
 import Unison.Reference qualified as Reference
@@ -208,10 +212,11 @@ restrictReferences refs Names {..} = Names terms' types'
 -- e.g. @shadowing scratchFileNames codebaseNames@
 shadowing :: Names -> Names -> Names
 shadowing a b =
-  Names (shadowing a.terms b.terms) (shadowing a.types b.types)
-  where
-    shadowing xs ys =
-      Relation.fromMultimap (Map.unionWith (\x _ -> x) (Relation.domain xs) (Relation.domain ys))
+  Names (shadowing1 a.terms b.terms) (shadowing1 a.types b.types)
+
+shadowing1 :: (Ord a, Ord b) => Relation a b -> Relation a b -> Relation a b
+shadowing1 xs ys =
+  Relation.fromMultimap (Map.unionWith (\x _ -> x) (Relation.domain xs) (Relation.domain ys))
 
 -- | TODO: get this from database. For now it's a constant.
 numHashChars :: Int
@@ -497,3 +502,32 @@ lenientToNametree names =
       -- The partial `Set.findMin` is fine here because Relation.domain only has non-empty Set values. A NESet would be
       -- better.
       unflattenNametree . Map.map Set.findMin . Relation.domain
+
+-- Given a namespace and locally-bound names that shadow it (i.e. from a Unison file that hasn't been typechecked yet),
+-- determine what the name resolves to, per the usual suffix-matching rules (where local defnintions and direct
+-- dependencies are preferred to indirect dependencies).
+resolveName :: forall ref. (Ord ref) => Relation Name ref -> Set Name -> Name -> Set (ResolvesTo ref)
+resolveName namespace locals name
+  | Set.member name locals = Set.singleton (ResolvesToLocal name)
+  | Set.size exactNamespaceMatches == 1 = Set.mapMonotonic ResolvesToNamespace exactNamespaceMatches
+  | otherwise = localsPlusNamespaceSuffixMatches
+  where
+    exactNamespaceMatches :: Set ref
+    exactNamespaceMatches =
+      Relation.lookupDom name namespace
+
+    localsPlusNamespaceSuffixMatches :: Set (ResolvesTo ref)
+    localsPlusNamespaceSuffixMatches =
+      Name.searchByRankedSuffix
+        name
+        ( shadowing1
+            ( List.foldl'
+                (\acc name -> Relation.insert name (ResolvesToLocal name) acc)
+                Relation.empty
+                (Set.toList locals)
+            )
+            ( Relation.map
+                (over _2 ResolvesToNamespace)
+                namespace
+            )
+        )

unison-core/src/Unison/Term.hs

@@ -41,7 +41,6 @@ import Unison.Type (Type)
 import Unison.Type qualified as Type
 import Unison.Util.Defns (Defns (..), DefnsF)
 import Unison.Util.List (multimap, validate)
-import Unison.Util.Relation qualified as Relation
 import Unison.Var (Var)
 import Unison.Var qualified as Var
 import Unsafe.Coerce (unsafeCoerce)
@@ -157,43 +156,37 @@ bindNames ::
   Names ->
   Term v a ->
   Names.ResolutionResult a (Term v a)
-bindNames unsafeVarToName nameToVar localVars ns term = do
+bindNames unsafeVarToName nameToVar localVars namespace term = do
   let freeTmVars = ABT.freeVarOccurrences localVars term
       freeTyVars =
         [ (v, a) | (v, as) <- Map.toList (freeTypeVarAnnotations term), a <- as
         ]
-      localNames = map unsafeVarToName (Set.toList localVars)
 
-      okTm :: (v, a) -> Names.ResolutionResult a (Maybe (v, ResolvesTo Referent))
+      okTm :: (v, a) -> Maybe (v, ResolvesTo Referent)
       okTm (v, _) =
-        let exactNamespaceMatches = Names.lookupHQTerm Names.ExactName (HQ.NameOnly name) ns
-            suffixNamespaceMatches = Name.searchByRankedSuffix name (Names.terms ns)
-            localMatches =
-              Name.searchBySuffix name (Relation.fromList (map (\name -> (name, name)) localNames))
-         in case (Set.size exactNamespaceMatches, Set.size suffixNamespaceMatches, Set.size localMatches) of
-              (1, _, _) -> good (ResolvesToNamespace (Set.findMin exactNamespaceMatches))
-              (n, _, _) | n > 1 -> leaveFreeForTdnr
-              (_, 0, 0) -> leaveFreeForTellingUserAboutExpectedType
-              (_, 1, 0) -> good (ResolvesToNamespace (Set.findMin suffixNamespaceMatches))
-              (_, 0, 1) -> good (ResolvesToLocal (Set.findMin localMatches))
-              _ -> leaveFreeForTdnr
+        case Set.size matches of
+          1 -> Just (v, Set.findMin matches)
+          0 -> Nothing -- not found: leave free for telling user about expected type
+          _ -> Nothing -- ambiguous: leave free for TDNR
         where
-          name = unsafeVarToName v
-          good = Right . Just . (v,)
-          leaveFreeForTdnr = Right Nothing
-          leaveFreeForTellingUserAboutExpectedType = Right Nothing
+          matches :: Set (ResolvesTo Referent)
+          matches =
+            Names.resolveName (Names.terms namespace) (Set.map unsafeVarToName localVars) (unsafeVarToName v)
 
       okTy :: (v, a) -> Names.ResolutionResult a (v, Type v a)
-      okTy (v, a) = case Names.lookupHQType Names.IncludeSuffixes hqName ns of
-        rs
-          | Set.size rs == 1 -> pure (v, Type.ref a $ Set.findMin rs)
-          | Set.size rs == 0 -> Left (Seq.singleton (Names.TypeResolutionFailure hqName a Names.NotFound))
-          | otherwise -> Left (Seq.singleton (Names.TypeResolutionFailure hqName a (Names.Ambiguous ns rs Set.empty)))
+      okTy (v, a) =
+        case Names.lookupHQType Names.IncludeSuffixes hqName namespace of
+          rs
+            | Set.size rs == 1 -> pure (v, Type.ref a $ Set.findMin rs)
+            | Set.size rs == 0 -> Left (Seq.singleton (Names.TypeResolutionFailure hqName a Names.NotFound))
+            | otherwise -> Left (Seq.singleton (Names.TypeResolutionFailure hqName a (Names.Ambiguous namespace rs Set.empty)))
         where
           hqName = HQ.NameOnly (unsafeVarToName v)
-  (namespaceTermResolutions, localTermResolutions) <-
-    partitionResolutions . catMaybes <$> validate okTm freeTmVars
-  let termSubsts =
+
+  let (namespaceTermResolutions, localTermResolutions) =
+        partitionResolutions (mapMaybe okTm freeTmVars)
+
+      termSubsts =
         [(v, fromReferent () ref) | (v, ref) <- namespaceTermResolutions]
           ++ [(v, var () (nameToVar name)) | (v, name) <- localTermResolutions]
   typeSubsts <- validate okTy freeTyVars

unison-core/src/Unison/Type/Names.hs

@@ -8,17 +8,15 @@ import Data.Set qualified as Set
 import Unison.ABT qualified as ABT
 import Unison.HashQualified qualified as HQ
 import Unison.Name (Name)
-import Unison.Name qualified as Name
 import Unison.Names (Names)
+import Unison.Names qualified as Names
 import Unison.Names.ResolutionResult qualified as Names
 import Unison.Names.ResolvesTo (ResolvesTo (..), partitionResolutions)
-import Unison.NamesWithHistory qualified as Names
 import Unison.Prelude
 import Unison.Reference (TypeReference)
 import Unison.Type
 import Unison.Type qualified as Type
 import Unison.Util.List qualified as List
-import Unison.Util.Relation qualified as Relation
 import Unison.Var (Var)
 
 bindNames ::
@@ -30,7 +28,7 @@ bindNames ::
   Names ->
   Type v a ->
   Names.ResolutionResult a (Type v a)
-bindNames unsafeVarToName nameToVar localVars namespaceNames ty =
+bindNames unsafeVarToName nameToVar localVars namespace ty =
   let -- Identify the unresolved variables in the type: those whose names aren't an *exact* match for some locally-bound
       -- type.
       --
@@ -47,55 +45,32 @@ bindNames unsafeVarToName nameToVar localVars namespaceNames ty =
       unresolvedVars =
         ABT.freeVarOccurrences localVars ty
 
-      -- For each unresolved variable, look up what it might refer to:
-      --
-      --   1. An exact match in the namespace.
-      --   2. A suffix match in the namespace.
-      --   3. A suffix match in the local names.
-      resolvedVars :: [(v, a, (Set TypeReference, Set TypeReference), Set Name)]
-      resolvedVars =
-        map
-          ( \(v, a) ->
-              let name = unsafeVarToName v
-               in (v, a, getNamespaceMatches name, getLocalMatches name)
-          )
-          unresolvedVars
-
-      checkAmbiguity ::
-        (v, a, (Set TypeReference, Set TypeReference), Set Name) ->
-        Either (Seq (Names.ResolutionFailure a)) (v, ResolvesTo TypeReference)
-      checkAmbiguity (v, a, (exactNamespaceMatches, suffixNamespaceMatches), localMatches) =
-        case (Set.size exactNamespaceMatches, Set.size suffixNamespaceMatches, Set.size localMatches) of
-          (1, _, _) -> good (ResolvesToNamespace (Set.findMin exactNamespaceMatches))
-          (n, _, _) | n > 1 -> bad (Names.Ambiguous namespaceNames exactNamespaceMatches Set.empty)
-          (_, 0, 0) -> bad Names.NotFound
-          (_, 1, 0) -> good (ResolvesToNamespace (Set.findMin suffixNamespaceMatches))
-          (_, 0, 1) -> good (ResolvesToLocal (Set.findMin localMatches))
-          _ -> bad (Names.Ambiguous namespaceNames suffixNamespaceMatches localMatches)
+      okTy :: (v, a) -> Names.ResolutionResult a (v, ResolvesTo TypeReference)
+      okTy (v, a) =
+        case Set.size matches of
+          1 -> good (Set.findMin matches)
+          0 -> bad Names.NotFound
+          _ ->
+            let (namespaceMatches, localMatches) =
+                  matches
+                    & Set.toList
+                    & map \case
+                      ResolvesToNamespace ref -> Left ref
+                      ResolvesToLocal name -> Right name
+                    & partitionEithers
+                    & bimap Set.fromList Set.fromList
+             in bad (Names.Ambiguous namespace namespaceMatches localMatches)
         where
+          matches :: Set (ResolvesTo TypeReference)
+          matches =
+            Names.resolveName (Names.types namespace) (Set.map unsafeVarToName localVars) (unsafeVarToName v)
+
           bad = Left . Seq.singleton . Names.TypeResolutionFailure (HQ.NameOnly (unsafeVarToName v)) a
           good = Right . (v,)
-   in List.validate checkAmbiguity resolvedVars <&> \resolutions ->
+   in List.validate okTy unresolvedVars <&> \resolutions ->
         let (namespaceResolutions, localResolutions) = partitionResolutions resolutions
          in ty
               -- Apply namespace resolutions (replacing "Foo" with #Foo where "Foo" refers to namespace)
               & bindExternal namespaceResolutions
               -- Apply local resolutions (replacing "Foo" with "Full.Name.Foo" where "Full.Name.Foo" is in local vars)
               & ABT.substsInheritAnnotation [(v, Type.var () (nameToVar name)) | (v, name) <- localResolutions]
-  where
-    localNames :: Set Name
-    localNames =
-      Set.map unsafeVarToName localVars
-
-    getNamespaceMatches :: Name -> (Set TypeReference, Set TypeReference)
-    getNamespaceMatches name =
-      ( Names.lookupHQType Names.ExactName (HQ.NameOnly name) namespaceNamesLessLocalNames,
-        Names.lookupHQType Names.IncludeSuffixes (HQ.NameOnly name) namespaceNamesLessLocalNames
-      )
-      where
-        namespaceNamesLessLocalNames =
-          over #types (Relation.subtractDom localNames) namespaceNames
-
-    getLocalMatches :: Name -> Set Name
-    getLocalMatches =
-      (`Name.searchBySuffix` Relation.fromList (map (\name -> (name, name)) (Set.toList localNames)))

unison-src/transcripts/fix-5340.md

@@ -0,0 +1,28 @@
+```ucm:hide
+scratch/main> builtins.merge lib.builtin
+```
+
+```unison
+type my.Foo = MkFoo
+type lib.dep.lib.dep.Foo = MkFoo
+
+my.foo = 17
+lib.dep.lib.dep.foo = 18
+```
+
+```ucm
+scratch/main> add
+```
+
+These references to type `Foo` and term `foo` are unambiguous (resolving to the `my.Foo` and `my.foo` in the
+file), even though indirect dependencies `lib.dep.lib.dep.Foo` and `lib.dep.lib.dep.foo` match by suffix.
+
+```unison
+type my.Foo = MkFoo
+type Bar = MkBar Foo
+```
+
+```unison
+my.foo = 17
+bar = foo Nat.+ foo
+```

unison-src/transcripts/fix-5340.output.md

@@ -0,0 +1,78 @@
+``` unison
+type my.Foo = MkFoo
+type lib.dep.lib.dep.Foo = MkFoo
+
+my.foo = 17
+lib.dep.lib.dep.foo = 18
+```
+
+``` ucm
+
+  Loading changes detected in scratch.u.
+
+  I found and typechecked these definitions in scratch.u. If you
+  do an `add` or `update`, here's how your codebase would
+  change:
+  
+    ⍟ These new definitions are ok to `add`:
+    
+      type lib.dep.lib.dep.Foo
+      type my.Foo
+      lib.dep.lib.dep.foo : Nat
+      my.foo              : Nat
+
+```
+``` ucm
+scratch/main> add
+
+  ⍟ I've added these definitions:
+  
+    type lib.dep.lib.dep.Foo
+    type my.Foo
+    lib.dep.lib.dep.foo : Nat
+    my.foo              : Nat
+
+```
+These references to type `Foo` and term `foo` are unambiguous (resolving to the `my.Foo` and `my.foo` in the
+file), even though indirect dependencies `lib.dep.lib.dep.Foo` and `lib.dep.lib.dep.foo` match by suffix.
+
+``` unison
+type my.Foo = MkFoo
+type Bar = MkBar Foo
+```
+
+``` ucm
+
+  Loading changes detected in scratch.u.
+
+  I found and typechecked these definitions in scratch.u. If you
+  do an `add` or `update`, here's how your codebase would
+  change:
+  
+    ⊡ Previously added definitions will be ignored: my.Foo
+    
+    ⍟ These new definitions are ok to `add`:
+    
+      type Bar
+
+```
+``` unison
+my.foo = 17
+bar = foo Nat.+ foo
+```
+
+``` ucm
+
+  Loading changes detected in scratch.u.
+
+  I found and typechecked these definitions in scratch.u. If you
+  do an `add` or `update`, here's how your codebase would
+  change:
+  
+    ⊡ Previously added definitions will be ignored: my.foo
+    
+    ⍟ These new definitions are ok to `add`:
+    
+      bar : Nat
+
+```