FCS: capture additional types during analysis

Author: auduchinok

src/Compiler/Checking/CheckPatterns.fs

@@ -103,6 +103,7 @@ and TcSimplePat optionalArgsOK checkConstraints (cenv: cenv) ty env patEnv p (at
 
     | SynSimplePat.Typed (p, cty, m) ->
         let ctyR, tpenv = TcTypeAndRecover cenv NewTyparsOK checkConstraints ItemOccurrence.UseInType WarnOnIWSAM.Yes env tpenv cty
+        CallExprHasTypeSinkSynthetic cenv.tcSink (p.Range, env.NameEnv, ctyR, env.AccessRights)
 
         match p with
         // Optional arguments on members
@@ -293,6 +294,7 @@ and TcPat warnOnUpper (cenv: cenv) env valReprInfo vFlags (patEnv: TcPatLinearEn
         TcConstPat warnOnUpper cenv env vFlags patEnv ty synConst m
 
     | SynPat.Wild m ->
+        CallExprHasTypeSinkSynthetic cenv.tcSink (m, env.NameEnv, ty, env.AccessRights)
         (fun _ -> TPat_wild m), patEnv
 
     | SynPat.IsInst (synTargetTy, m)
@@ -675,6 +677,7 @@ and TcPatLongIdentUnionCaseOrExnCase warnOnUpper cenv env ad vFlags patEnv ty (m
 
     // Report information about the case occurrence to IDE
     CallNameResolutionSink cenv.tcSink (mLongId, env.NameEnv, item, emptyTyparInst, ItemOccurrence.Pattern, env.eAccessRights)
+    CallExprHasTypeSinkSynthetic cenv.tcSink (m, env.NameEnv, ty, env.AccessRights)
 
     let mkf, argTys, argNames = ApplyUnionCaseOrExn m cenv env ty item
     let numArgTys = argTys.Length

src/Compiler/Checking/Expressions/CheckExpressions.fs

@@ -1822,6 +1822,7 @@ let MakeAndPublishSimpleValsForMergedScope (cenv: cenv) env m (names: NameMap<_>
                             notifyNameResolution (pos, item, itemGroup, itemTyparInst, occurrence, nenv, ad, m, replacing)
 
                         member _.NotifyExprHasType(_, _, _, _) = assert false // no expr typings in MakeAndPublishSimpleVals
+                        member _.NotifyExprHasTypeSynthetic(_, _, _, _) =  assert false // no expr typings in MakeAndPublishSimpleVals
 
                         member _.NotifyFormatSpecifierLocation(_, _) = ()
 
@@ -5844,13 +5845,13 @@ and TcExprUndelayed (cenv: cenv) (overallTy: OverallTy) env tpenv (synExpr: SynE
         TcNonControlFlowExpr env <| fun env ->
         CallExprHasTypeSink cenv.tcSink (m, env.NameEnv, overallTy.Commit, env.AccessRights)
         TcConstExpr cenv overallTy env m tpenv synConst
+
     | SynExpr.DotLambda (synExpr, m, trivia) ->
         match env.NameEnv.eUnqualifiedItems |> Map.tryFind "_arg1" with
         // Compiler-generated _arg items can have more forms, the real underscore will be 1-character wide
         | Some (Item.Value(valRef)) when valRef.Range.StartColumn+1 = valRef.Range.EndColumn ->
             warning(Error(FSComp.SR.tcAmbiguousDiscardDotLambda(), trivia.UnderscoreRange))
-        | Some _ -> ()
-        | None -> ()
+        | _ -> ()
 
         let unaryArg = mkSynId trivia.UnderscoreRange (cenv.synArgNameGenerator.New())
         let svar = mkSynCompGenSimplePatVar unaryArg
@@ -6131,6 +6132,7 @@ and TcExprMatchLambda (cenv: cenv) overallTy env tpenv (isExnMatch, mFunction, c
     let domainTy, resultTy = UnifyFunctionType None cenv env.DisplayEnv m overallTy.Commit
     let idv1, idve1 = mkCompGenLocal mFunction (cenv.synArgNameGenerator.New()) domainTy
     CallExprHasTypeSink cenv.tcSink (mFunction.StartRange, env.NameEnv, domainTy, env.AccessRights)
+    CallExprHasTypeSink cenv.tcSink (m, env.NameEnv, overallTy.Commit, env.AccessRights)
     let envinner = ExitFamilyRegion env
     let envinner = { envinner with eIsControlFlow = true }
     let idv2, matchExpr, tpenv = TcAndPatternCompileMatchClauses m mFunction (if isExnMatch then Throw else ThrowIncompleteMatchException) cenv None domainTy (MustConvertTo (false, resultTy)) envinner tpenv clauses
@@ -6534,6 +6536,7 @@ and TcIteratedLambdas (cenv: cenv) isFirst (env: TcEnv) overallTy takenNames tpe
             | [] -> envinner
 
         let bodyExpr, tpenv = TcIteratedLambdas cenv false envinner (MustConvertTo (false, resultTy)) takenNames tpenv bodyExpr
+        CallExprHasTypeSink cenv.tcSink (m, env.NameEnv, overallTy.Commit, env.AccessRights)
 
         // See bug 5758: Non-monotonicity in inference: need to ensure that parameters are never inferred to have byref type, instead it is always declared
         byrefs |> Map.iter (fun _ (orig, v) ->
@@ -7779,6 +7782,7 @@ and TcAssertExpr cenv overallTy env (m: range) tpenv x =
     TcExpr cenv overallTy env tpenv callDiagnosticsExpr
 
 and TcRecdExpr cenv overallTy env tpenv (inherits, withExprOpt, synRecdFields, mWholeExpr) =
+    CallExprHasTypeSink cenv.tcSink (mWholeExpr, env.NameEnv, overallTy, env.eAccessRights)
     let g = cenv.g
 
     let requiresCtor = (GetCtorShapeCounter env = 1) // Get special expression forms for constructors
@@ -8404,6 +8408,8 @@ and TcDelayed cenv (overallTy: OverallTy) env tpenv mExpr expr exprTy (atomicFla
     // We can now record for posterity the type of this expression and the location of the expression.
     if (atomicFlag = ExprAtomicFlag.Atomic) then
         CallExprHasTypeSink cenv.tcSink (mExpr, env.NameEnv, exprTy, env.eAccessRights)
+    else
+        CallExprHasTypeSinkSynthetic cenv.tcSink (mExpr, env.NameEnv, exprTy, env.eAccessRights)
 
     match delayed with
     | []

src/Compiler/Checking/NameResolution.fs

@@ -1787,6 +1787,8 @@ type ITypecheckResultsSink =
 
     abstract NotifyExprHasType: TType * NameResolutionEnv * AccessorDomain * range -> unit
 
+    abstract NotifyExprHasTypeSynthetic: TType * NameResolutionEnv * AccessorDomain * range -> unit
+
     abstract NotifyNameResolution: pos * item: Item * TyparInstantiation * ItemOccurrence * NameResolutionEnv * AccessorDomain * range * replace: bool -> unit
 
     abstract NotifyMethodGroupNameResolution : pos * item: Item * itemMethodGroup: Item * TyparInstantiation * ItemOccurrence * NameResolutionEnv * AccessorDomain * range * replace: bool -> unit
@@ -2188,6 +2190,10 @@ type TcResultsSinkImpl(tcGlobals, ?sourceText: ISourceText) =
             if allowedRange m then
                 capturedExprTypings.Add((ty, nenv, ad, m))
 
+        member sink.NotifyExprHasTypeSynthetic(ty, nenv, ad, m) =
+            if allowedRange m then
+                capturedExprTypings.Add((ty, nenv, ad, m.MakeSynthetic()))
+
         member sink.NotifyNameResolution(endPos, item, tpinst, occurrenceType, nenv, ad, m, replace) =
             if allowedRange m then
                 if replace then
@@ -2305,6 +2311,11 @@ let CallExprHasTypeSink (sink: TcResultsSink) (m: range, nenv, ty, ad) =
     | None -> ()
     | Some sink -> sink.NotifyExprHasType(ty, nenv, ad, m)
 
+let CallExprHasTypeSinkSynthetic (sink: TcResultsSink) (m: range, nenv, ty, ad) =
+    match sink.CurrentSink with
+    | None -> ()
+    | Some sink -> sink.NotifyExprHasTypeSynthetic(ty, nenv, ad, m)
+
 let CallOpenDeclarationSink (sink: TcResultsSink) (openDeclaration: OpenDeclaration) =
     match sink.CurrentSink with
     | None -> ()

src/Compiler/Checking/NameResolution.fsi

@@ -482,6 +482,8 @@ type ITypecheckResultsSink =
     /// Record that an expression has a specific type at the given range.
     abstract NotifyExprHasType: TType * NameResolutionEnv * AccessorDomain * range -> unit
 
+    abstract NotifyExprHasTypeSynthetic: TType * NameResolutionEnv * AccessorDomain * range -> unit
+
     /// Record that a name resolution occurred at a specific location in the source
     abstract NotifyNameResolution:
         pos * Item * TyparInstantiation * ItemOccurrence * NameResolutionEnv * AccessorDomain * range * bool -> unit
@@ -635,6 +637,9 @@ val internal RegisterUnionCaseTesterForProperty:
 /// Report a specific name resolution at a source range
 val internal CallExprHasTypeSink: TcResultsSink -> range * NameResolutionEnv * TType * AccessorDomain -> unit
 
+/// Report a captured type at a range, but don't use it in features like code completion, only in TryGetCapturedType
+val internal CallExprHasTypeSinkSynthetic: TcResultsSink -> range * NameResolutionEnv * TType * AccessorDomain -> unit
+
 /// Report an open declaration
 val internal CallOpenDeclarationSink: TcResultsSink -> OpenDeclaration -> unit
 

src/Compiler/Service/FSharpCheckerResults.fs

@@ -729,6 +729,8 @@ type internal TypeCheckInfo
         let quals =
             sResolutions.CapturedExpressionTypings
             |> Seq.filter (fun (ty, nenv, _, m) ->
+                not m.IsSynthetic &&
+
                 // We only want expression types that end at the particular position in the file we are looking at.
                 posEq m.End endOfExprPos
                 &&
@@ -2098,9 +2100,9 @@ type internal TypeCheckInfo
     member scope.IsRelativeNameResolvableFromSymbol(cursorPos: pos, plid: string list, symbol: FSharpSymbol) : bool =
         scope.IsRelativeNameResolvable(cursorPos, plid, symbol.Item)
 
-    member scope.TryGetCapturedType(range) =
+    member scope.TryGetCapturedType(range: range) =
         sResolutions.CapturedExpressionTypings
-        |> Seq.tryFindBack (fun (_, _, _, m) -> equals m range)
+        |> Seq.tryFindBack (fun (_, _, _, m) -> equals (m.MakeSynthetic()) (range.MakeSynthetic()))
         |> Option.map (fun (ty, _, _, _) -> FSharpType(cenv, ty))
 
     member scope.TryGetCapturedDisplayContext(range) =

tests/FSharp.Compiler.Service.Tests/CapturedTypes.fs

@@ -15,22 +15,64 @@ let assertCapturedType expectedTypeString markedSource =
     let capturedType = tryGetCapturedType markedSource
     capturedType.Value.Format displayContext |> shouldEqual expectedTypeString
 
-[<Fact>]
-let ``Expr - If 01`` () =
-    assertCapturedType "int * int" "{selstart}if true then 1, 2 else 1, true{selend}"
+module Expr =
+    [<Fact>]
+    let ``Function 01`` () =
+        assertCapturedType "string -> int" "[\"\"] |> List.map ({selstart}function s -> s.Length{selend})"
 
-[<Fact>]
-let ``Expr - Literal 01`` () =
-    assertCapturedType "int" "{selstart}1{selend}"
+    [<Fact>]
+    let ``Function 02`` () =
+        assertCapturedType "string" "[\"\"] |> List.map ({selstart}{selend}function s -> s.Length)"
 
-[<Fact>]
-let ``Expr - Literal 02`` () =
-    assertCapturedType "string" "{selstart}\"\"{selend}"
+    [<Fact>]
+    let ``Function 03`` () =
+        assertCapturedType "string" "[\"\"] |> List.map ({selstart}{selend}function)"
 
-[<Fact>]
-let ``Expr - Tuple 01`` () =
-    assertCapturedType "int * int" "{selstart}1, 2{selend}"
+    [<Fact(Skip = "Implement parser recovery")>]
+    let ``Function 04`` () =
+        assertCapturedType "string" "[\"\"] |> List.map {selstart}{selend}function"
 
-[<Fact>]
-let ``Expr - Tuple 02`` () =
-    assertCapturedType "int * int" "if true then {selstart}1, 2{selend} else 1, true"
+    [<Fact>]
+    let ``If 01`` () =
+        assertCapturedType "int * int" "{selstart}if true then 1, 2 else 1, true{selend}"
+
+    [<Fact>]
+    let ``Lambda 01`` () =
+        assertCapturedType "string -> int" "[\"\"] |> List.map ({selstart}fun s -> s.Length{selend})"
+
+    [<Fact>]
+    let ``Literal 01`` () =
+        assertCapturedType "int" "{selstart}1{selend}"
+
+    [<Fact>]
+    let ``Literal 02`` () =
+        assertCapturedType "string" "{selstart}\"\"{selend}"
+
+    [<Fact>]
+    let ``Paren 01`` () =
+        assertCapturedType "string -> int" "[\"\"] |> List.map {selstart}(fun s -> s.Length){selend}"
+
+    [<Fact>]
+    let ``Short lambda 01`` () =
+        assertCapturedType "string" "[\"\"] |> List.map {selstart}_{selend}.Length"
+
+    [<Fact>]
+    let ``Short lambda 02`` () =
+        assertCapturedType "string -> int" "[\"\"] |> List.map {selstart}_.Length{selend}"
+
+    [<Fact>]
+    let ``Tuple 01`` () =
+        assertCapturedType "int * int" "{selstart}1, 2{selend}"
+
+    [<Fact>]
+    let ``Tuple 02`` () =
+        assertCapturedType "int * int" "if true then {selstart}1, 2{selend} else 1, true"
+
+module Pattern =
+    [<Fact>]
+    let ``Literal 01`` () =
+        assertCapturedType "int" "let {selstart}i{selend} = 1"
+
+    [<Fact>]
+    let ``Wild 01`` () =
+        assertCapturedType "int" "let {selstart}_{selend} = 1"