Type checker: recover on adding constraints

docs/release-notes/.FSharp.Compiler.Service/11.0.0.md

@@ -9,6 +9,8 @@
 
 ### Added
 
+* Type checker: recover on adding constraints ([#19034](https://github.com/dotnet/fsharp/pull/19034))
+
 ### Changed
 
 * Parallel compilation stabilised and enabled by default ([PR #18998](https://github.com/dotnet/fsharp/pull/18998))

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,13 @@ 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

src/Compiler/TypedTree/TypedTreeOps.fs

@@ -5715,8 +5715,8 @@ let InferValReprInfoOfExpr g allowTypeDirectedDetupling ty partialArgAttribsL re
     let fun_arity = vsl.Length
     let dtys, _ = stripFunTyN g fun_arity (snd (tryDestForallTy g ty))
     let partialArgAttribsL = Array.ofList partialArgAttribsL
-    assert (List.length vsl = List.length dtys)
-        
+    if List.length vsl <> List.length dtys then ValReprInfo.emptyValData else
+
     let curriedArgInfos =
         (vsl, dtys) ||> List.mapi2 (fun i vs ty ->
             let partialAttribs = if i < partialArgAttribsL.Length then partialArgAttribsL[i] else []

tests/FSharp.Compiler.ComponentTests/Conformance/BasicGrammarElements/MemberDefinitions/MethodsAndProperties/MethodsAndProperties.fs

@@ -121,7 +121,9 @@ module MemberDefinitions_MethodsAndProperties =
             (Error 1, Line 11, Col 24, Line 11, Col 33, "This expression was expected to have type\n    ''a array2d'    \nbut here has type\n    'int array'    ")
             (Error 1, Line 12, Col 25, Line 12, Col 32, "This expression was expected to have type\n    ''a array'    \nbut here has type\n    'int array2d'    ")
             (Error 1, Line 13, Col 26, Line 13, Col 37, "This expression was expected to have type\n    ''a array'    \nbut here has type\n    'int array3d'    ")
+            (Error 1, Line 13, Col 32, Line 13, Col 35, "This expression was expected to have type\n    'int'    \nbut here has type\n    'int * int'    ")
             (Error 1, Line 14, Col 27, Line 14, Col 38, "This expression was expected to have type\n    ''a array'    \nbut here has type\n    'int array4d'    ")
+            (Error 1, Line 14, Col 33, Line 14, Col 36, "This expression was expected to have type\n    'int'    \nbut here has type\n    'int * int'    ")
         ]
 
     // SOURCE=E_IndexerArityMismatch02.fs     SCFLAGS="--test:ErrorRanges --flaterrors"	# E_IndexerArityMismatch02.fs

tests/FSharp.Compiler.ComponentTests/Conformance/BasicGrammarElements/TypeAbbreviations/TypeAbbreviations.fs

@@ -85,7 +85,6 @@ module TypeAbbreviations =
         |> shouldFail
         |> withDiagnostics [
             (Error 1, Line 16, Col 14, Line 16, Col 19, "A type parameter is missing a constraint 'when 'b :> IB'")
-            (Error 35, Line 16, Col 6, Line 16, Col 7, "This construct is deprecated: This type abbreviation has one or more declared type parameters that do not appear in the type being abbreviated. Type abbreviations must use all declared type parameters in the type being abbreviated. Consider removing one or more type parameters, or use a concrete type definition that wraps an underlying type, such as 'type C<'a> = C of ...'.")
         ]
 
     //SOURCE=E_DroppedTypeVariable01.fsx SCFLAGS="--test:ErrorRanges -a"                                        # E_DroppedTypeVariable01.fsx

tests/FSharp.Compiler.ComponentTests/Conformance/Constraints/Unmanaged.fs

@@ -69,7 +69,9 @@ let _ = Test<DoubleType<DoubleType<int option>>>()
         |> shouldFail
         |> withDiagnostics [
                    Error 1, Line 10, Col 9, Line 10, Col 33, "A generic construct requires that the type 'DoubleType<string>' is an unmanaged type"
-                   Error 1, Line 11, Col 9, Line 11, Col 49, "A generic construct requires that the type 'DoubleType<DoubleType<int option>>' is an unmanaged type" ]
+                   Error 1, Line 11, Col 9, Line 11, Col 49, "A generic construct requires that the type 'DoubleType<DoubleType<int option>>' is an unmanaged type"
+                   Error 688, Line 11, Col 9, Line 11, Col 51, "The default, zero-initializing constructor of a struct type may only be used if all the fields of the struct type admit default initialization"
+        ]
 
     [<Fact>]
     let ``voption considered unmanaged when inner type is unmanaged`` () = 
@@ -348,7 +350,9 @@ let _ = Test<MyDu<int,MyDu<int,string voption>>>()
                        Error 193, Line 26, Col 24, Line 26, Col 36, "A generic construct requires that the type 'A<'T,obj>' is an unmanaged type"
                        Error 1, Line 27, Col 9, Line 27, Col 18, "A generic construct requires that the type 'obj' is an unmanaged type"
                        Error 1, Line 28, Col 9, Line 28, Col 28, "A generic construct requires that the type 'NonStructRecd' is an unmanaged type"
-                       Error 1, Line 29, Col 9, Line 29, Col 49, "A generic construct requires that the type 'string' is an unmanaged type" ]
+                       Error 688, Line 28, Col 9, Line 28, Col 30, "The default, zero-initializing constructor of a struct type may only be used if all the fields of the struct type admit default initialization"
+                       Error 1, Line 29, Col 9, Line 29, Col 49, "A generic construct requires that the type 'string' is an unmanaged type"
+         ]
 
     [<Fact>]
     let ``Disallow both 'unmanaged' and 'not struct' constraints`` () =

tests/FSharp.Compiler.ComponentTests/Conformance/Expressions/ObjectExpressions/ObjectExpressions.fs

@@ -520,7 +520,7 @@ but here has type
     'AsString'    
 but here has type
     'SomeDu'    "
-            Warning 25, Line 30, Col 19, Line 30, Col 23, "Incomplete pattern matches on this expression."]
+         ]
 
     [<Fact>]
     let ``Object expression implementing multiple interfaces`` () =

tests/FSharp.Compiler.ComponentTests/Conformance/PatternMatching/ConsList/ConsList.fs

@@ -46,10 +46,13 @@ but here has type
         |> withOptions ["--test:ErrorRanges"]
         |> typecheck
         |> shouldFail
-        |> withSingleDiagnostic (Error 1, Line 15, Col 22, Line 15, Col 24, "This expression was expected to have type
-    'int'    
-but here has type
-    ''a list'    ")
+        |> withDiagnostics [
+            (Error 1, Line 15, Col 22, Line 15, Col 24, "This expression was expected to have type\n    'int'    \nbut here has type\n    ''a list'    ")
+            (Error 1, Line 16, Col 14, Line 16, Col 16, "This expression was expected to have type\n    'int'    \nbut here has type\n    ''a list'    ")
+            (Warning 25, Line 13, Col 11, Line 13, Col 12, "Incomplete pattern matches on this expression. For example, the value '[_]' may indicate a case not covered by the pattern(s).")
+            (Warning 26, Line 15, Col 7, Line 15, Col 18, "This rule will never be matched")
+            (Warning 26, Line 16, Col 7, Line 16, Col 24, "This rule will never be matched")
+        ]
 
     // This test was automatically generated (moved from FSharpQA suite - Conformance/PatternMatching/ConsList)
     [<Theory; FileInlineData("OutsideMatch01.fs")>]

tests/FSharp.Compiler.ComponentTests/Conformance/Types/RecordTypes/AnonymousRecords.fs

@@ -238,6 +238,7 @@ let x() = ({| b = 2; c = 3 |} = {| a = 2; d = "" |} )
         |> shouldFail
         |> withDiagnostics [
             (Error 1, Line 2, Col 33, Line 2, Col 52, "This anonymous record should have fields 'b', 'c'; but here has fields 'a', 'd'.")
+            (Error 1, Line 2, Col 47, Line 2, Col 49, "This expression was expected to have type\n    'int'    \nbut here has type\n    'string'    ")
         ]
 
     [<Fact>]

tests/FSharp.Compiler.ComponentTests/Conformance/Types/RecordTypes/RecordTypes.fs

@@ -130,6 +130,9 @@ module RecordTypes =
         |> shouldFail
         |> withDiagnostics [
             (Error 1, Line 7, Col 17, Line 7, Col 47, "This expression was expected to have type\n    'int array'    \nbut here has type\n    'RecType'    ")
+            (Error 786, Line 7, Col 17, Line 7, Col 47, "The expression form { expr with ... } may only be used with record types. To build object types use { new Type(...) with ... }");
+            (Error 791, Line 7, Col 17, Line 7, Col 47, "This type is not a record type");
+            (Error 763, Line 7, Col 17, Line 7, Col 47, "The field 'B' has been given a value, but is not present in the type 'int array'")
         ]
 
     // SOURCE=E_RecordsNotNull01.fs                                                             # E_RecordsNotNull01.fs

tests/FSharp.Compiler.ComponentTests/ErrorMessages/ConstructorTests.fs

@@ -31,6 +31,8 @@ let x = { Name = "Isaac", Age = 21, City = "London" }
         |> shouldFail
         |> withDiagnostics [
             (Error 1,   Line 3, Col 18, Line 3, Col 52, "This expression was expected to have type\n    'string'    \nbut here has type\n    ''a * 'b * 'c'    " + System.Environment.NewLine + "A ';' is used to separate field values in records. Consider replacing ',' with ';'.")
+            (Error 39,  Line 3, Col 27, Line 3, Col 30, "The value or constructor 'Age' is not defined.")
+            (Error 39,  Line 3, Col 37, Line 3, Col 41, "The value or constructor 'City' is not defined.")
             (Error 764, Line 3, Col 9,  Line 3, Col 54, "No assignment given for field 'Age' of type 'Test.Person'")]
 
     [<Fact>]

tests/FSharp.Compiler.ComponentTests/ErrorMessages/ElseBranchHasWrongTypeTests.fs

@@ -119,8 +119,10 @@ let y =
         """
         |> typecheck
         |> shouldFail
-        |> withSingleDiagnostic (Error 1, Line 7, Col 14, Line 7, Col 22,
-                                 "This expression was expected to have type\n    'int'    \nbut here has type\n    'string'    ")
+        |> withDiagnostics [
+            (Error 1, Line 7, Col 14, Line 7, Col 22, "This expression was expected to have type\n    'int'    \nbut here has type\n    'string'    ")
+            (Error 1, Line 8, Col 26, Line 8, Col 27, "This expression was expected to have type\n    'string'    \nbut here has type\n    'int'    ")
+        ]
 
     [<Fact>]
     let ``Else branch context doesn't propagate to lines before last line``() =

tests/FSharp.Compiler.ComponentTests/ErrorMessages/TypeMismatchTests.fs

@@ -292,7 +292,10 @@ type Derived3() =
         |> withDiagnostics [
                 (Error 856, Line 8,  Col 16, Line 8,  Col 22, "This override takes a different number of arguments to the corresponding abstract member. The following abstract members were found:" + System.Environment.NewLine + "   abstract Base.Member: int * string -> string")
                 (Error 856, Line 12, Col 16, Line 12, Col 22, "This override takes a different number of arguments to the corresponding abstract member. The following abstract members were found:" + System.Environment.NewLine + "   abstract Base.Member: int * string -> string")
-                (Error 1,   Line 16, Col 24, Line 16, Col 34, "This expression was expected to have type\n    'int'    \nbut here has type\n    'string'    ")]
+                (Error 1,   Line 16, Col 24, Line 16, Col 34, "This expression was expected to have type\n    'int'    \nbut here has type\n    'string'    ")
+                (Error 1, Line 16, Col 36, Line 16, Col 43, "This expression was expected to have type\n    'string'    \nbut here has type\n    'int'    ");
+                (Error 1, Line 16, Col 66, Line 16, Col 67, "This expression was expected to have type\n    'string'    \nbut here has type\n    'int'    ")
+        ]
 
     [<Fact>]
     let ``Interface member with tuple argument should give error message with better solution``() =

tests/FSharp.Compiler.ComponentTests/Language/FixedBindings/FixedBindings.fs

@@ -47,6 +47,7 @@ module Legacy =
 but given a
     'nativeptr<byte>'    
 The type 'int' does not match the type 'byte'""")
+            (Warning 9, Line 6, Col 5, Line 6, Col 18, """Uses of this construct may result in the generation of unverifiable .NET IL code. This warning can be disabled using '--nowarn:9' or '#nowarn "9"'.""")
         ]
 
     [<Theory>]
@@ -64,6 +65,7 @@ The type 'int' does not match the type 'byte'""")
 but given a
     'nativeptr<byte>'    
 The type 'char' does not match the type 'byte'""")
+            (Warning 9, Line 6, Col 5, Line 6, Col 18, """Uses of this construct may result in the generation of unverifiable .NET IL code. This warning can be disabled using '--nowarn:9' or '#nowarn "9"'.""")
         ]
 
     [<Theory>]
@@ -437,6 +439,7 @@ The type 'char' does not match the type 'byte'""")
 but given a
     'nativeptr<char>'    
 The type 'int' does not match the type 'char'")
+            (Warning 9, Line 10, Col 5, Line 10, Col 18, """Uses of this construct may result in the generation of unverifiable .NET IL code. This warning can be disabled using '--nowarn:9' or '#nowarn "9"'.""")
         ]
 
     [<Theory>]
@@ -667,6 +670,7 @@ module ExtendedFixedBindings =
 but given a
     'nativeptr<char>'    
 The type 'int' does not match the type 'char'")
+            (Warning 9, Line 10, Col 5, Line 10, Col 18, """Uses of this construct may result in the generation of unverifiable .NET IL code. This warning can be disabled using '--nowarn:9' or '#nowarn "9"'.""")
         ]
 
     [<Theory>]