Wrong type is reported in type mismatch error

src/Compiler/Checking/CheckExpressions.fs

@@ -590,8 +590,8 @@ let UnifyTupleTypeAndInferCharacteristics contextInfo (cenv: cenv) denv m knownT
         if isAnyTupleTy g knownTy then
             let tupInfo, ptys = destAnyTupleTy g knownTy
             let tupInfo = (if isExplicitStruct then tupInfoStruct else tupInfo)
-            let ptys = 
-                if List.length ps = List.length ptys then ptys 
+            let ptys =
+                if List.length ps = List.length ptys then ptys
                 else NewInferenceTypes g ps
             tupInfo, ptys
         else
@@ -5292,6 +5292,11 @@ and TcExprsWithFlexes (cenv: cenv) env m tpenv flexes argTys args =
     (tpenv, List.zip3 flexes argTys args) ||> List.mapFold (fun tpenv (flex, ty, e) ->
          TcExprFlex cenv flex false ty env tpenv e)
 
+and TcExprsNoFlexes (cenv: cenv) env m tpenv argTys args =
+    if List.length args <> List.length argTys then error(Error(FSComp.SR.tcExpressionCountMisMatch((List.length argTys), (List.length args)), m))
+    (tpenv, List.zip argTys args) ||> List.mapFold (fun tpenv (ty, e) ->
+         TcExprFlex2 cenv ty env false tpenv e)
+
 and CheckSuperInit (cenv: cenv) objTy m =
     let g = cenv.g
 
@@ -5798,30 +5803,27 @@ and TcExprLazy (cenv: cenv) overallTy env tpenv (synInnerExpr, m) =
     let expr = mkLazyDelayed g m innerTy (mkUnitDelayLambda g m innerExpr)
     expr, tpenv
 
+and CheckTupleIsCorrectLength g (env: TcEnv) m tupleTy args typeCheckArgs =
+    if isAnyTupleTy g tupleTy then
+        let tupInfo, ptys = destAnyTupleTy g tupleTy
+
+        if List.length args <> List.length ptys then
+            let argTys = NewInferenceTypes g args
+            suppressErrorReporting (fun () -> typeCheckArgs argTys)
+            let expectedTy = TType_tuple (tupInfo, argTys)
+
+            // We let error recovery handle this exception
+            error (ErrorFromAddingTypeEquation(g, env.DisplayEnv, tupleTy, expectedTy,
+                   (ConstraintSolverTupleDiffLengths(env.DisplayEnv, ptys, argTys, m, m)), m))
+
 and TcExprTuple (cenv: cenv) overallTy env tpenv (isExplicitStruct, args, m) =
     let g = cenv.g
     TcPossiblyPropagatingExprLeafThenConvert (fun ty -> isAnyTupleTy g ty || isTyparTy g ty) cenv overallTy env m (fun overallTy ->
 
-        // We preemptively check if the tuple has the correct length before submitting it to the
-        // constraint solver. If not we type check it against empty inference variables so that
-        // we can show the types in the error message if they are known.
-        if isAnyTupleTy g overallTy then
-            let tupInfo, ptys = destAnyTupleTy g overallTy
-
-            if List.length args <> List.length ptys then
-                let rhsTys = NewInferenceTypes g args
-                let flexes = rhsTys |> List.map (fun _ -> false)
-                suppressErrorReporting (fun () -> TcExprsWithFlexes cenv env m tpenv flexes rhsTys args) |> ignore
-                let expectedTy = TType_tuple (tupInfo, rhsTys)
-
-                // We let error recovery handle this exception
-                error (ErrorFromAddingTypeEquation(g, env.DisplayEnv, overallTy, expectedTy,
-                       (ConstraintSolverTupleDiffLengths(env.DisplayEnv, ptys, rhsTys, m, m)), m))
+        CheckTupleIsCorrectLength g env m overallTy args (fun argTys -> TcExprsNoFlexes cenv env m tpenv argTys args |> ignore)
 
         let tupInfo, argTys = UnifyTupleTypeAndInferCharacteristics env.eContextInfo cenv env.DisplayEnv m overallTy isExplicitStruct args
-
-        let flexes = argTys |> List.map (fun _ -> false)
-        let argsR, tpenv = TcExprsWithFlexes cenv env m tpenv flexes argTys args
+        let argsR, tpenv = TcExprsNoFlexes cenv env m tpenv argTys args
         let expr = mkAnyTupled g m tupInfo argsR argTys
         expr, tpenv
     )
@@ -6101,8 +6103,7 @@ and TcExprILAssembly (cenv: cenv) overallTy env tpenv (ilInstrs, synTyArgs, synA
     let argTys = NewInferenceTypes g synArgs
     let tyargs, tpenv = TcTypes cenv NewTyparsOK CheckCxs ItemOccurence.UseInType WarnOnIWSAM.Yes env tpenv synTyArgs
     // No subsumption at uses of IL assembly code
-    let flexes = argTys |> List.map (fun _ -> false)
-    let args, tpenv = TcExprsWithFlexes cenv env m tpenv flexes argTys synArgs
+    let args, tpenv = TcExprsNoFlexes cenv env m tpenv argTys synArgs
     let retTys, tpenv = TcTypes cenv NewTyparsOK CheckCxs ItemOccurence.UseInType WarnOnIWSAM.Yes env tpenv synRetTys
     let returnTy =
         match retTys with
@@ -7166,8 +7167,7 @@ and TcInterpolatedStringExpr cenv (overallTy: OverallTy) env m tpenv (parts: Syn
                 mkCallNewFormat g m printerTy printerArgTy printerResidueTy printerResultTy printerTupleTy str, tpenv
         else
             // Type check the expressions filling the holes
-            let flexes = argTys |> List.map (fun _ -> false)
-            let fillExprs, tpenv = TcExprsWithFlexes cenv env m tpenv flexes argTys synFillExprs
+            let fillExprs, tpenv = TcExprsNoFlexes cenv env m tpenv argTys synFillExprs
 
             let fillExprsBoxed = (argTys, fillExprs) ||> List.map2 (mkCallBox g m)
 
@@ -7193,8 +7193,7 @@ and TcInterpolatedStringExpr cenv (overallTy: OverallTy) env m tpenv (parts: Syn
     | Choice2Of2 createFormattableStringMethod ->
 
         // Type check the expressions filling the holes
-        let flexes = argTys |> List.map (fun _ -> false)
-        let fillExprs, tpenv = TcExprsWithFlexes cenv env m tpenv flexes argTys synFillExprs
+        let fillExprs, tpenv = TcExprsNoFlexes cenv env m tpenv argTys synFillExprs
 
         let fillExprsBoxed = (argTys, fillExprs) ||> List.map2 (mkCallBox g m)
 

src/Compiler/Checking/CheckExpressions.fsi

@@ -623,6 +623,18 @@ val TcExpr:
     synExpr: SynExpr ->
         Expr * UnscopedTyparEnv
 
+/// Check that 'args' have the correct number of elements for a tuple expression.
+/// If not, use 'typeCheckArgs' to type check the given elements to show
+/// their correct types (if known) in the error message and raise the error
+val CheckTupleIsCorrectLength:
+    g: TcGlobals ->
+    env: TcEnv ->
+    m: range ->
+    tupleTy: TType ->
+    args: 'a list ->
+    typeCheckArgs: (TType list -> unit) ->
+        unit
+
 /// Converts 'a..b' to a call to the '(..)' operator in FSharp.Core
 /// Converts 'a..b..c' to a call to the '(.. ..)' operator in FSharp.Core
 val RewriteRangeExpr: synExpr: SynExpr -> SynExpr option

src/Compiler/Checking/CheckPatterns.fs

@@ -423,6 +423,8 @@ and TcPatAnds warnOnUpper cenv env vFlags patEnv ty pats m =
 and TcPatTuple warnOnUpper cenv env vFlags patEnv ty isExplicitStruct args m =
     let g = cenv.g
     try
+        CheckTupleIsCorrectLength g env m ty args (fun argTys -> TcPatterns warnOnUpper cenv env vFlags patEnv argTys args |> ignore)
+
         let tupInfo, argTys = UnifyTupleTypeAndInferCharacteristics env.eContextInfo cenv env.DisplayEnv m ty isExplicitStruct args
         let argsR, acc = TcPatterns warnOnUpper cenv env vFlags patEnv argTys args
         let phase2 values = TPat_tuple(tupInfo, List.map (fun f -> f values) argsR, argTys, m)

src/Compiler/Driver/CompilerDiagnostics.fs

@@ -740,6 +740,7 @@ type Exception with
 
         | ErrorFromAddingTypeEquation (_g, denv, ty1, ty2, ConstraintSolverTupleDiffLengths (_, tl1, tl2, _, _), _) ->
             let ty1, ty2, tpcs = NicePrint.minimalStringsOfTwoTypes denv ty1 ty2
+
             if ty1 <> ty2 + tpcs then
                 os.AppendString(ErrorFromAddingTypeEquationTuplesE().Format tl1.Length ty1 tl2.Length ty2 tpcs)
 

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

@@ -21,6 +21,21 @@ let x a b c : int * int = a, b, c
                  "Type mismatch. Expecting a tuple of length 2 of type\n    int * int    \nbut given a tuple of length 3 of type\n    'a * 'b * 'c    \n")
             ]
 
+        [<Fact>]
+        let ``Type annotation propagates to the error message``() =
+            FSharp """
+let x a b (c: string) : int * int = a, b, c
+let y a (b: string) c : int * int = a, b, c
+            """
+            |> typecheck
+            |> shouldFail
+            |> withDiagnostics [
+                (Error 1, Line 2, Col 37, Line 2, Col 44,
+                 "Type mismatch. Expecting a tuple of length 2 of type\n    int * int    \nbut given a tuple of length 3 of type\n    'a * 'b * string    \n")
+                (Error 1, Line 3, Col 37, Line 3, Col 44,
+                 "Type mismatch. Expecting a tuple of length 2 of type\n    int * int    \nbut given a tuple of length 3 of type\n    'a * string * 'b    \n")
+            ]
+
         [<Fact>]
         let ``Known type on the right``() =
             FSharp """
@@ -52,6 +67,43 @@ let x: int * int = "", "", 1
                  "Type mismatch. Expecting a tuple of length 2 of type\n    int * int    \nbut given a tuple of length 3 of type\n    string * string * int    \n")
             ]
 
+        [<Fact>]
+        let ``Patterns minimal`` () =
+            FSharp """
+let test (x : int * string * char) =
+    match x with
+    | 10, "20"      -> true
+    | _ -> false
+            """
+            |> typecheck
+            |> shouldFail
+            |> withDiagnostics [
+                (Error 1, Line 4, Col 7, Line 4, Col 15,
+                 "Type mismatch. Expecting a tuple of length 3 of type\n    int * string * char    \nbut given a tuple of length 2 of type\n    int * string    \n")
+            ]
+
+        [<Fact>]
+        let ``Patterns with inference`` () =
+            FSharp """
+let test x =
+    match x with
+    |  0,  "1", '2' -> true
+    | 10, "20"      -> true
+    |     "-1", '0' -> true
+    | 99,       '9' -> true
+    | _ -> false
+            """
+            |> typecheck
+            |> shouldFail
+            |> withDiagnostics [
+                (Error 1, Line 5, Col 7, Line 5, Col 15,
+                 "Type mismatch. Expecting a tuple of length 3 of type\n    int * string * char    \nbut given a tuple of length 2 of type\n    int * string    \n")
+                (Error 1, Line 6, Col 11, Line 6, Col 20,
+                 "Type mismatch. Expecting a tuple of length 3 of type\n    int * string * char    \nbut given a tuple of length 2 of type\n    string * char    \n")
+                (Error 1, Line 7, Col 7, Line 7, Col 20,
+                 "Type mismatch. Expecting a tuple of length 3 of type\n    int * string * char    \nbut given a tuple of length 2 of type\n    int * char    \n")
+            ]
+
     [<Fact>]
     let ``return Instead Of return!``() =
         FSharp """

tests/fsharp/typecheck/sigs/neg04.bsl

@@ -14,31 +14,31 @@ neg04.fs(26,8,26,17): typecheck error FS0912: This declaration element is not pe
 neg04.fs(32,8,32,11): typecheck error FS0039: The type 'Double' does not define the field, constructor or member 'Nan'. Maybe you want one of the following:
    IsNaN
 
-neg04.fs(46,69,46,94): typecheck error FS0001: Type mismatch. Expecting a
-    ''a * 'b * 'c * 'e'    
-but given a
-    ''a * 'b * 'c'    
-The tuples have differing lengths of 4 and 3
+neg04.fs(46,69,46,94): typecheck error FS0001: Type mismatch. Expecting a tuple of length 4 of type
+    'a * 'g * 'f * 'i    
+but given a tuple of length 3 of type
+    'c * 'l * 'm    
+
+
+neg04.fs(46,99,46,107): typecheck error FS0001: Type mismatch. Expecting a tuple of length 4 of type
+    'a * 'g * 'f * 'i    
+but given a tuple of length 3 of type
+    'n * 'o * 'p    
 
-neg04.fs(46,99,46,107): typecheck error FS0001: Type mismatch. Expecting a
-    ''a * 'b * 'c * 'e'    
-but given a
-    ''a * 'b * 'c'    
-The tuples have differing lengths of 4 and 3
 
 neg04.fs(47,30,47,51): typecheck error FS0001: Type mismatch. Expecting a
-    'seq<'a> -> 'f'    
+    'seq<'a> -> 'n'    
 but given a
-    ''g list -> 'h'    
-The type 'seq<'a>' does not match the type ''f list'
+    ''o list -> 'p'    
+The type 'seq<'a>' does not match the type ''n list'
 
 neg04.fs(47,49,47,51): typecheck error FS0784: This numeric literal requires that a module 'NumericLiteralN' defining functions FromZero, FromOne, FromInt32, FromInt64 and FromString be in scope
 
 neg04.fs(47,30,47,51): typecheck error FS0001: Type mismatch. Expecting a
-    'seq<'a> -> 'f'    
+    'seq<'a> -> 'n'    
 but given a
-    ''g list -> 'h'    
-The type 'seq<'a>' does not match the type ''f list'
+    ''o list -> 'p'    
+The type 'seq<'a>' does not match the type ''n list'
 
 neg04.fs(61,25,61,40): typecheck error FS0001: This expression was expected to have type
     'ClassType1'    

tests/fsharpqa/Source/Conformance/PatternMatching/Tuple/env.lst

@@ -3,5 +3,3 @@
 	SOURCE=W_IncompleteMatches01.fs	# W_IncompleteMatches01.fs
 	SOURCE=W_RedundantPattern01.fs	# W_RedundantPattern01.fs
 	SOURCE=W_RedundantPattern02.fs	# W_RedundantPattern02.fs
-
-	SOURCE=E_TupleMismatch01.fs SCFLAGS="--test:ErrorRanges --flaterrors"	# E_TupleMismatch01.fs