Merge pull request #4502 from unisonweb/travis/tdnr-bug

parser-typechecker/src/Unison/Typechecker.hs

@@ -32,8 +32,10 @@ import Control.Monad.State
     modify,
   )
 import Control.Monad.Writer
+import Data.Foldable
 import Data.Map qualified as Map
 import Data.Sequence.NonEmpty qualified as NESeq (toSeq)
+import Data.Set qualified as Set
 import Data.Text qualified as Text
 import Unison.ABT qualified as ABT
 import Unison.Blank qualified as B
@@ -229,17 +231,15 @@ typeDirectedNameResolution ppe oldNotes oldType env = do
   case catMaybes resolutions of
     [] -> pure oldType
     rs ->
-      let goAgain =
-            any ((== 1) . length . dedupe . filter Context.isExact . suggestions) rs
-       in if goAgain
-            then do
-              traverse_ substSuggestion rs
-              synthesizeAndResolve ppe tdnrEnv
-            else do
-              -- The type hasn't changed
-              liftResult $ suggest rs
-              pure oldType
+      applySuggestions rs >>= \case
+        True -> do
+          synthesizeAndResolve ppe tdnrEnv
+        False -> do
+          -- The type hasn't changed
+          liftResult $ suggest rs
+          pure oldType
   where
+
     addTypedComponent :: Context.InfoNote v loc -> State (Env v loc) ()
     addTypedComponent (Context.TopLevelComponent vtts) =
       for_ vtts $ \(v, typ, _) ->
@@ -268,23 +268,50 @@ typeDirectedNameResolution ppe oldNotes oldType env = do
         Var.MissingResult -> v
         _ -> Var.named name
 
-    substSuggestion :: Resolution v loc -> TDNR f v loc ()
+    extractSubstitution :: [Context.Suggestion v loc] -> Maybe (Either v Referent)
+    extractSubstitution suggestions =
+      let groupedByName :: [([Name.Name], Either v Referent)] =
+            map (\(a, b) -> (b, a))
+              . Map.toList
+              . fmap Set.toList
+              . foldl'
+                ( \b Context.Suggestion {suggestionName, suggestionReplacement} ->
+                    Map.insertWith
+                      Set.union
+                      suggestionReplacement
+                      (Set.singleton (Name.unsafeFromText suggestionName))
+                      b
+                )
+                Map.empty
+              $ filter Context.isExact suggestions
+          matches :: Set (Either v Referent) = Name.preferShallowLibDepth groupedByName
+       in case toList matches of
+            [x] -> Just x
+            _ -> Nothing
+
+    applySuggestions :: [Resolution v loc] -> TDNR f v loc Bool
+    applySuggestions = foldlM phi False
+      where
+        phi b a = do
+          didSub <- substSuggestion a
+          pure $! b || didSub
+
+    substSuggestion :: Resolution v loc -> TDNR f v loc Bool
     substSuggestion
       ( Resolution
           name
           _
           loc
           v
-          ( filter Context.isExact ->
-              [Context.Suggestion _ _ replacement Context.Exact]
-            )
+          (extractSubstitution -> Just replacement)
         ) =
         do
           modify (substBlank (Text.unpack name) loc solved)
           lift . btw $ Context.Decision (suggestedVar v name) loc solved
+          pure True
         where
           solved = either (Term.var loc) (Term.fromReferent loc) replacement
-    substSuggestion _ = pure ()
+    substSuggestion _ = pure False
 
     -- Resolve a `Blank` to a term
     substBlank :: String -> loc -> Term v loc -> Term v loc -> Term v loc

unison-core/src/Unison/Name.hs

@@ -35,16 +35,17 @@ module Unison.Name
     unqualified,
 
     -- * To organize later
+    commonPrefix,
     libSegment,
-    sortNames,
-    sortNamed,
-    sortByText,
-    searchBySuffix,
+    preferShallowLibDepth,
     searchByRankedSuffix,
-    suffixFrom,
+    searchBySuffix,
     shortestUniqueSuffix,
-    commonPrefix,
+    sortByText,
+    sortNamed,
+    sortNames,
     splits,
+    suffixFrom,
 
     -- * Re-exports
     module Unison.Util.Alphabetical,
@@ -333,23 +334,30 @@ searchBySuffix suffix rel =
 -- Example: foo.bar shadows lib.foo.bar
 -- Example: lib.foo.bar shadows lib.blah.lib.foo.bar
 searchByRankedSuffix :: (Ord r) => Name -> R.Relation Name r -> Set r
-searchByRankedSuffix suffix rel = case searchBySuffix suffix rel of
-  rs | Set.size rs <= 1 -> rs
-  rs -> case Map.lookup 0 byDepth <|> Map.lookup 1 byDepth of
-    -- anything with more than one lib in it is treated the same
-    Nothing -> rs
-    Just rs -> Set.fromList rs
-    where
-      byDepth =
-        List.multimap
-          [ (minLibs ns, r)
-            | r <- toList rs,
-              ns <- [filter ok (toList (R.lookupRan r rel))]
-          ]
+searchByRankedSuffix suffix rel =
+  let rs = searchBySuffix suffix rel
+  in case Set.size rs <= 1 of
+    True -> rs
+    False ->
+      let ok name = compareSuffix suffix name == EQ
+          withNames = map (\r -> (filter ok (toList (R.lookupRan r rel)), r)) (toList rs)
+      in preferShallowLibDepth withNames
+
+-- | precondition: input list is deduped, and so is the Name list in
+-- the tuple
+preferShallowLibDepth :: Ord r => [([Name], r)] -> Set r
+preferShallowLibDepth = \case
+  [] -> Set.empty
+  [x] -> Set.singleton (snd x)
+  rs ->
+    let 
+      byDepth = List.multimap (map (first minLibs) rs)
       libCount = length . filter (== libSegment) . toList . reverseSegments
       minLibs [] = 0
       minLibs ns = minimum (map libCount ns)
-      ok name = compareSuffix suffix name == EQ
+     in case Map.lookup 0 byDepth <|> Map.lookup 1 byDepth of
+          Nothing -> Set.fromList (map snd rs)
+          Just rs -> Set.fromList rs
 
 libSegment :: NameSegment
 libSegment = NameSegment "lib"

unison-src/transcripts/fix4498.md

@@ -0,0 +1,16 @@
+```ucm:hide
+.> builtins.merge
+```
+
+```unison
+lib.dep0.bonk.foo = 5
+lib.dep0.zonk.foo = "hi"
+lib.dep0.lib.dep1.foo = 6
+myterm = foo + 2
+```
+
+```ucm
+.> add
+.> view myterm
+```
+

unison-src/transcripts/fix4498.output.md

@@ -0,0 +1,39 @@
+```unison
+lib.dep0.bonk.foo = 5
+lib.dep0.zonk.foo = "hi"
+lib.dep0.lib.dep1.foo = 6
+myterm = foo + 2
+```
+
+```ucm
+
+  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`:
+    
+      lib.dep0.bonk.foo     : Nat
+      lib.dep0.lib.dep1.foo : Nat
+      lib.dep0.zonk.foo     : Text
+      myterm                : Nat
+
+```
+```ucm
+.> add
+
+  ⍟ I've added these definitions:
+  
+    lib.dep0.bonk.foo     : Nat
+    lib.dep0.lib.dep1.foo : Nat
+    lib.dep0.zonk.foo     : Text
+    myterm                : Nat
+
+.> view myterm
+
+  myterm : Nat
+  myterm =
+    use Nat +
+    bonk.foo + 2
+
+```