Type checker: recover on adding constraints

Author: auduchinok

src/Compiler/Checking/ConstraintSolver.fs

@@ -3939,7 +3939,7 @@ let AddCxTypeEqualsType contextInfo denv css m expected actual =
     PostponeOnFailedMemberConstraintResolution csenv NoTrace
         (fun csenv -> SolveTypeEqualsTypeWithReport csenv 0 m NoTrace None expected actual)
         ErrorD
-    |> RaiseOperationResult
+    |> ReportOperationResultAndRecover
 
 let UndoIfFailed f =
     let trace = Trace.New()
@@ -4005,7 +4005,7 @@ let AddCxTypeMustSubsumeTypeMatchingOnlyUndoIfFailed denv css m extraRigidTypars
 let AddCxTypeMustSubsumeType contextInfo denv css m trace ty1 ty2 = 
     let csenv = MakeConstraintSolverEnv contextInfo css m denv
     SolveTypeSubsumesTypeWithReport csenv 0 m trace None None ty1 ty2
-    |> RaiseOperationResult
+    |> ReportOperationResultAndRecover
 
 let AddCxMethodConstraint denv css m trace traitInfo  =
     let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m denv
@@ -4017,25 +4017,25 @@ let AddCxMethodConstraint denv css m trace traitInfo  =
                     |> OperationResult.ignore
             })
         (fun res -> ErrorD (ErrorFromAddingConstraint(denv, res, m)))
-    |> RaiseOperationResult
+    |> ReportOperationResultAndRecover
 
 let AddCxTypeDefnNotSupportsNull denv css m trace ty =
     let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m denv
     PostponeOnFailedMemberConstraintResolution csenv trace
         (fun csenv -> SolveTypeUseNotSupportsNull csenv 0 m trace ty)
         (fun res -> ErrorD (ErrorFromAddingConstraint(denv, res, m)))
-    |> RaiseOperationResult
+    |> ReportOperationResultAndRecover
 
 let AddCxTypeUseSupportsNull denv css m trace ty =
     let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m denv
     PostponeOnFailedMemberConstraintResolution csenv trace
         (fun csenv -> SolveTypeUseSupportsNull csenv 0 m trace ty)
         (fun res -> ErrorD (ErrorFromAddingConstraint(denv, res, m)))
-    |> RaiseOperationResult
+    |> ReportOperationResultAndRecover
 
 let AddCxTypeCanCarryNullnessInfo denv css m ty nullness =
     let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m denv
-    let canCarryNullnessCheck() = SolveTypeCanCarryNullness csenv ty nullness |> RaiseOperationResult
+    let canCarryNullnessCheck() = SolveTypeCanCarryNullness csenv ty nullness |> ReportOperationResultAndRecover
     csenv.SolverState.PushPostInferenceCheck (preDefaults=false, check = canCarryNullnessCheck)
 
 
@@ -4044,63 +4044,63 @@ let AddCxTypeMustSupportComparison denv css m trace ty =
     PostponeOnFailedMemberConstraintResolution csenv trace
         (fun csenv -> SolveTypeSupportsComparison csenv 0 m trace ty)
         (fun res -> ErrorD (ErrorFromAddingConstraint(denv, res, m)))
-    |> RaiseOperationResult
+    |> ReportOperationResultAndRecover
 
 let AddCxTypeMustSupportEquality denv css m trace ty =
     let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m denv
     PostponeOnFailedMemberConstraintResolution csenv trace
         (fun csenv -> SolveTypeSupportsEquality csenv 0 m trace ty)
         (fun res -> ErrorD (ErrorFromAddingConstraint(denv, res, m)))
-    |> RaiseOperationResult
+    |> ReportOperationResultAndRecover
 
 let AddCxTypeMustSupportDefaultCtor denv css m trace ty =
     let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m denv
     PostponeOnFailedMemberConstraintResolution csenv trace
         (fun csenv -> SolveTypeRequiresDefaultConstructor csenv 0 m trace ty)
         (fun res -> ErrorD (ErrorFromAddingConstraint(denv, res, m)))
-    |> RaiseOperationResult
+    |> ReportOperationResultAndRecover
 
 let AddCxTypeIsReferenceType denv css m trace ty =
     let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m denv
     PostponeOnFailedMemberConstraintResolution csenv trace
         (fun csenv -> SolveTypeIsReferenceType csenv 0 m trace ty)
         (fun res -> ErrorD (ErrorFromAddingConstraint(denv, res, m)))
-    |> RaiseOperationResult
+    |> ReportOperationResultAndRecover
 
 let AddCxTypeIsValueType denv css m trace ty =
     let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m denv
     PostponeOnFailedMemberConstraintResolution csenv trace
         (fun csenv -> SolveTypeIsNonNullableValueType csenv 0 m trace ty)
         (fun res -> ErrorD (ErrorFromAddingConstraint(denv, res, m)))
-    |> RaiseOperationResult
+    |> ReportOperationResultAndRecover
 
 let AddCxTypeIsUnmanaged denv css m trace ty =
     let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m denv
     PostponeOnFailedMemberConstraintResolution csenv trace
         (fun csenv -> SolveTypeIsUnmanaged csenv 0 m trace ty)
         (fun res -> ErrorD (ErrorFromAddingConstraint(denv, res, m)))
-    |> RaiseOperationResult
+    |> ReportOperationResultAndRecover
 
 let AddCxTypeIsEnum denv css m trace ty underlying =
     let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m denv
     PostponeOnFailedMemberConstraintResolution csenv trace
         (fun csenv -> SolveTypeIsEnum csenv 0 m trace ty underlying)
         (fun res -> ErrorD (ErrorFromAddingConstraint(denv, res, m)))
-    |> RaiseOperationResult
+    |> ReportOperationResultAndRecover
 
 let AddCxTypeIsDelegate denv css m trace ty aty bty =
     let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m denv
     PostponeOnFailedMemberConstraintResolution csenv trace
         (fun csenv -> SolveTypeIsDelegate csenv 0 m trace ty aty bty)
         (fun res -> ErrorD (ErrorFromAddingConstraint(denv, res, m)))
-    |> RaiseOperationResult
+    |> ReportOperationResultAndRecover
 
 let AddCxTyparDefaultsTo denv css m ctxtInfo tp ridx ty =
     let csenv = MakeConstraintSolverEnv ctxtInfo css m denv
     PostponeOnFailedMemberConstraintResolution csenv NoTrace
         (fun csenv -> AddConstraint csenv 0 m NoTrace tp (TyparConstraint.DefaultsTo(ridx, ty, m)))
         (fun res -> ErrorD (ErrorFromAddingConstraint(denv, res, m)))
-    |> RaiseOperationResult
+    |> ReportOperationResultAndRecover
 
 let SolveTypeAsError denv css m ty =
     let ty2 = NewErrorType ()
@@ -4204,14 +4204,14 @@ let CheckDeclaredTypars denv css m typars1 typars2 =
             ErrorD (ErrorFromAddingConstraint(denv, res, m)))
     |> RaiseOperationResult
 
-let CanonicalizePartialInferenceProblem css denv m tps =
+let CanonicalizePartialInferenceProblem (css: ConstraintSolverState) (denv: DisplayEnv) (m: range) (tps: Typar list) : unit =
     // Canonicalize constraints prior to generalization 
     let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m denv
     let csenv = { csenv with ErrorOnFailedMemberConstraintResolution = true }
     IgnoreFailedMemberConstraintResolution
         (fun () -> CanonicalizeRelevantMemberConstraints csenv 0 NoTrace tps)
         (fun res -> ErrorD (ErrorFromAddingConstraint(denv, res, m))) 
-    |> RaiseOperationResult
+    |> ReportOperationResultAndRecover
 
 /// An approximation used during name resolution for intellisense to eliminate extension members which will not
 /// apply to a particular object argument. This is given as the isApplicableMeth argument to the partial name resolution

src/Compiler/Facilities/DiagnosticsLogger.fs

@@ -665,6 +665,14 @@ let CommitOperationResult res =
 
 let RaiseOperationResult res : unit = CommitOperationResult res
 
+let ReportOperationResultAndRecover (res: OperationResult<unit>) : unit =
+    match res with
+    | OkResult(warns, _) ->
+        ReportWarnings warns
+    | ErrorResult(warns, err) ->
+        ReportWarnings warns
+        errorR err
+
 let inline ErrorD err = ErrorResult([], err)
 
 let inline WarnD err = OkResult([ err ], ())

src/Compiler/Facilities/DiagnosticsLogger.fsi

@@ -351,6 +351,8 @@ type ImperativeOperationResult = OperationResult<unit>
 
 val ReportWarnings: warns: #exn list -> unit
 
+val ReportOperationResultAndRecover: res: OperationResult<unit> -> unit
+
 val CommitOperationResult: res: OperationResult<'T> -> 'T
 
 val RaiseOperationResult: res: OperationResult<unit> -> unit

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

@@ -442,14 +442,16 @@ let assertContainsSymbolsWithNames (names: string list) source =
         |> Seq.contains name
         |> shouldEqual true
 
-let assertHasSymbolUsages (names: string list) (results: FSharpCheckFileResults) =
+let assertHasSymbolUsages (expectedNames: string list) (results: FSharpCheckFileResults) =
+    let symbols =
+        getSymbolUses results |> getSymbols |> List.ofSeq
+
     let symbolNames =
-        getSymbolUses results
-        |> getSymbols
+        symbols
         |> Seq.choose getSymbolName
         |> set
 
-    for name in names do
+    for name in expectedNames do
         Assert.True(Set.contains name symbolNames, name)
 
 let findSymbolUseByName (name: string) (results: FSharpCheckFileResults) =

tests/FSharp.Compiler.Service.Tests/TypeChecker/TypeCheckerRecoveryTests.fs

@@ -49,4 +49,83 @@ Math.Max(a,b,)
         "(4,0--4,14)", 503
     ]
 
-    assertHasSymbolUsages ["Max"] checkResults
+    assertHasSymbolUsages ["Max"] checkResults
+
+module Constraints =
+    [<Fact>]
+    let ``Type 01`` () =
+        let _, checkResults = getParseAndCheckResults """
+let f (x: unit) =
+    x + 1
+
+f ()
+"""
+        assertHasSymbolUsages ["f"; "x"] checkResults
+
+    [<Fact>]
+    let ``Reference 01`` () =
+        let _, checkResults = getParseAndCheckResults """
+let f<'T when 'T : not struct> (x: 'T) =
+    x
+
+let (i: int) = f<int> 1
+"""
+        assertHasSymbolUsages ["f"; "x"; "i"] checkResults
+
+    [<Fact>]
+    let ``Struct 01`` () =
+        let _, checkResults = getParseAndCheckResults """
+let f<'T when 'T : struct> (x: 'T) =
+    x
+
+let i = f<obj> 1
+"""
+        assertHasSymbolUsages ["f"; "x"; "i"] checkResults
+
+    [<Fact>]
+    let ``Struct 02`` () =
+        let _, checkResults = getParseAndCheckResults """
+let f<'T when 'T : struct> (x: 'T) =
+    x
+
+let i = f<obj> Unchecked.defaultof<obj>
+"""
+        assertHasSymbolUsages ["f"; "x"; "defaultof"; "i"] checkResults
+
+    [<Fact>]
+    let ``Struct 03`` () =
+        let _, checkResults = getParseAndCheckResults """
+let f<'T when 'T : struct> (x: 'T) =
+    x
+
+let i = f Unchecked.defaultof<obj>
+"""
+        assertHasSymbolUsages ["f"; "x"; "defaultof"; "i"] checkResults
+
+    [<Fact>]
+    let ``Equality 01`` () =
+        let _, checkResults = getParseAndCheckResults """
+let f<'T when 'T : equality> (x: 'T) =
+    x
+
+[<NoEquality>]
+type T() =
+    class end
+
+let i = f<T> Unchecked.defaultof<T>
+"""
+        assertHasSymbolUsages ["f"; "x"; "defaultof"; "i"] checkResults
+
+    [<Fact>]
+    let ``Equality 02`` () =
+        let _, checkResults = getParseAndCheckResults """
+let f<'T when 'T : equality> (x: 'T) =
+    x
+
+[<NoEquality>]
+type T() =
+    class end
+
+let i = f Unchecked.defaultof<T>
+"""
+        assertHasSymbolUsages ["f"; "x"; "defaultof"; "i"] checkResults