Improve error LSP ranges on type mismatches

parser-typechecker/src/Unison/PrintError.hs

@@ -369,7 +369,7 @@ renderTypeError e env src = case e of
   Mismatch {..} ->
     mconcat
       [ Pr.lines
-          [ "I found a value  of type:  " <> style Type1 (renderType' env foundLeaf),
+          [ "I found a value of type:  " <> style Type1 (renderType' env foundLeaf),
             "where I expected to find:  " <> style Type2 (renderType' env expectedLeaf)
           ],
         "\n\n",

unison-cli/src/Unison/LSP/FileAnalysis.hs

@@ -216,7 +216,10 @@ analyseNotes fileUri ppe src notes = do
     Result.TypeError errNote@(Context.ErrorNote {cause}) -> do
       let typeErr = TypeError.typeErrorFromNote errNote
           ranges = case typeErr of
-            TypeError.Mismatch {mismatchSite} -> singleRange $ ABT.annotation mismatchSite
+            TypeError.Mismatch {mismatchSite} -> do
+              let locs = ABT.annotation <$> expressionLeafNodes mismatchSite
+              (r, rs) <- withNeighbours (locs >>= aToR)
+              pure (r, ("mismatch",) <$> rs)
             TypeError.BooleanMismatch {mismatchSite} -> singleRange $ ABT.annotation mismatchSite
             TypeError.ExistentialMismatch {mismatchSite} -> singleRange $ ABT.annotation mismatchSite
             TypeError.FunctionApplication {f} -> singleRange $ ABT.annotation f
@@ -471,3 +474,38 @@ mkTypeSignatureHints parsedFile typecheckedFile = do
                 pure $ TypeSignatureHint name (Referent.fromTermReferenceId ref) newRange typ
             )
    in typeHints
+
+-- | Crawl a term and find the nodes which actually influence its return type. This is useful for narrowing down a giant
+-- "This let/do block has the wrong type" into "This specific line returns the wrong type"
+-- This is just a heuristic.
+expressionLeafNodes :: Term.Term2 vt at ap v a -> [Term.Term2 vt at ap v a]
+expressionLeafNodes abt =
+  case ABT.out abt of
+    ABT.Var {} -> [abt]
+    ABT.Cycle r -> expressionLeafNodes r
+    ABT.Abs _ r -> expressionLeafNodes r
+    ABT.Tm f -> case f of
+      Term.Int {} -> [abt]
+      Term.Nat {} -> [abt]
+      Term.Float {} -> [abt]
+      Term.Boolean {} -> [abt]
+      Term.Text {} -> [abt]
+      Term.Char {} -> [abt]
+      Term.Blank {} -> [abt]
+      Term.Ref {} -> [abt]
+      Term.Constructor {} -> [abt]
+      Term.Request {} -> [abt]
+      -- Not 100% sure whether the error should appear on the handler or action, maybe both?
+      Term.Handle handler _action -> expressionLeafNodes handler
+      Term.App _a _b -> [abt]
+      Term.Ann a _ -> expressionLeafNodes a
+      Term.List {} -> [abt]
+      Term.If _cond a b -> expressionLeafNodes a <> expressionLeafNodes b
+      Term.And {} -> [abt]
+      Term.Or {} -> [abt]
+      Term.Lam a -> expressionLeafNodes a
+      Term.LetRec _isTop _bindings body -> expressionLeafNodes body
+      Term.Let _isTop _bindings body -> expressionLeafNodes body
+      Term.Match _a cases -> cases & foldMap \(Term.MatchCase {matchBody}) -> expressionLeafNodes matchBody
+      Term.TermLink {} -> [abt]
+      Term.TypeLink {} -> [abt]

unison-core/src/Unison/Term.hs

@@ -72,21 +72,21 @@ data F typeVar typeAnn patternAnn a
   | Ref Reference
   | Constructor ConstructorReference
   | Request ConstructorReference
-  | Handle a a
+  | Handle a {- <- the handler -} a {- <- the action to run -}
-  | App a a
+  | App a {- <- func -} a {- <- arg -}
   | Ann a (Type typeVar typeAnn)
   | List (Seq a)
-  | If a a a
+  | If a {- <- cond -} a {- <- then -} a {- <- else -}
   | And a a
   | Or a a
   | Lam a
   | -- Note: let rec blocks have an outer ABT.Cycle which introduces as many
     -- variables as there are bindings
-    LetRec IsTop [a] a
+    LetRec IsTop [a {- <- bindings -}] a {- <- body -}
-  | -- Note: first parameter is the binding, second is the expression which may refer
+    -- Note: first parameter is the binding, second is the expression which may refer
-    -- to this let bound variable. Constructed as `Let b (abs v e)`
+  | -- to this let bound variable. Constructed as `Let b (abs v e)`
-    Let IsTop a a
+    Let IsTop a {- <- binding -} a {- <- body -}
-  | -- Pattern matching / eliminating data types, example:
+    -- Pattern matching / eliminating data types, example:
     --  case x of
     --    Just n -> rhs1
     --    Nothing -> rhs2
@@ -94,7 +94,7 @@ data F typeVar typeAnn patternAnn a
     -- translates to
     --
     --   Match x
-    --     [ (Constructor 0 [Var], ABT.abs n rhs1)
+  | --     [ (Constructor 0 [Var], ABT.abs n rhs1)
     --     , (Constructor 1 [], rhs2) ]
     Match a [MatchCase patternAnn a]
   | TermLink Referent