From 386e04eeef93cb7506c26b5cecd5d998347229f3 Mon Sep 17 00:00:00 2001 From: Kevin Ransom Date: Wed, 10 Jun 2020 15:43:36 -0700 Subject: [PATCH 1/3] fix pattern match recovery --- src/fsharp/TypeChecker.fs | 16 +++++++--------- 1 file changed, 7 insertions(+), 9 deletions(-) diff --git a/src/fsharp/TypeChecker.fs b/src/fsharp/TypeChecker.fs index 0cb1515cbfe..9a5fd294d4a 100755 --- a/src/fsharp/TypeChecker.fs +++ b/src/fsharp/TypeChecker.fs @@ -5551,16 +5551,14 @@ and TcPat warnOnUpper cenv env topValInfo vFlags (tpenv, names, takenNames) ty p let numArgs = args.Length if numArgs = numArgTys then args, extraPatterns + elif numArgs < numArgTys then + errorR (UnionCaseWrongArguments (env.DisplayEnv, numArgTys, numArgs, m)) + args @ (List.init (numArgTys - numArgs) (fun _ -> SynPat.Wild (m.MakeSynthetic()))), extraPatterns else - if numArgs < numArgTys then - if numArgs <> 0 && numArgTys <> 0 then - errorR (UnionCaseWrongArguments (env.DisplayEnv, numArgTys, numArgs, m)) - args @ (List.init (numArgTys - numArgs) (fun _ -> SynPat.Wild (m.MakeSynthetic()))), extraPatterns - else - let args, remaining = args |> List.splitAt numArgTys - for remainingArg in remaining do - errorR (UnionCaseWrongArguments (env.DisplayEnv, numArgTys, numArgs, remainingArg.Range)) - args, extraPatterns @ remaining + let args, remaining = args |> List.splitAt numArgTys + for remainingArg in remaining do + errorR (UnionCaseWrongArguments (env.DisplayEnv, numArgTys, numArgs, remainingArg.Range)) + args, extraPatterns @ remaining let extraPatterns = extraPatterns @ extraPatternsFromNames let args', acc = TcPatterns warnOnUpper cenv env vFlags (tpenv, names, takenNames) argTys args From 0d3548a8e60f9b2eead8c837d84fd96b3d97bb05 Mon Sep 17 00:00:00 2001 From: Kevin Ransom Date: Wed, 10 Jun 2020 21:25:11 -0700 Subject: [PATCH 2/3] add testcase and fixup --- src/fsharp/TypeChecker.fs | 9 ++++++--- tests/service/PatternMatchCompilationTests.fs | 19 ++++++++++++++++++- 2 files changed, 24 insertions(+), 4 deletions(-) diff --git a/src/fsharp/TypeChecker.fs b/src/fsharp/TypeChecker.fs index 9a5fd294d4a..71712d566e2 100755 --- a/src/fsharp/TypeChecker.fs +++ b/src/fsharp/TypeChecker.fs @@ -5464,6 +5464,7 @@ and TcPat warnOnUpper cenv env topValInfo vFlags (tpenv, names, takenNames) ty p TPat_query((activePatExpr, activePatResTys, activePatIdentity, idx, apinfo), arg' values, m)), acc | (Item.UnionCase _ | Item.ExnCase _) as item -> + // Report information about the case occurrence to IDE CallNameResolutionSink cenv.tcSink (lidRange, env.NameEnv, item, emptyTyparInst, ItemOccurence.Pattern, env.eAccessRights) @@ -5535,7 +5536,6 @@ and TcPat warnOnUpper cenv env topValInfo vFlags (tpenv, names, takenNames) ty p errorR (Error (FSComp.SR.tcUnionCaseDoesNotTakeArguments (), m)) [], args - | arg :: rest when numArgTys = 1 -> if numArgTys = 1 && not (List.isEmpty rest) then errorR (Error (FSComp.SR.tcUnionCaseRequiresOneArgument (), m)) @@ -5544,7 +5544,6 @@ and TcPat warnOnUpper cenv env topValInfo vFlags (tpenv, names, takenNames) ty p | [arg] -> [arg], [] | args -> - errorR (Error (FSComp.SR.tcUnionCaseExpectsTupledArguments numArgTys, m)) [], args let args, extraPatterns = @@ -5552,7 +5551,11 @@ and TcPat warnOnUpper cenv env topValInfo vFlags (tpenv, names, takenNames) ty p if numArgs = numArgTys then args, extraPatterns elif numArgs < numArgTys then - errorR (UnionCaseWrongArguments (env.DisplayEnv, numArgTys, numArgs, m)) + if numArgTys > 1 then + // Expects tuple without enough args + errorR (Error (FSComp.SR.tcUnionCaseExpectsTupledArguments numArgTys, m)) + else + errorR (UnionCaseWrongArguments (env.DisplayEnv, numArgTys, numArgs, m)) args @ (List.init (numArgTys - numArgs) (fun _ -> SynPat.Wild (m.MakeSynthetic()))), extraPatterns else let args, remaining = args |> List.splitAt numArgTys diff --git a/tests/service/PatternMatchCompilationTests.fs b/tests/service/PatternMatchCompilationTests.fs index 60f6327d3ca..b4261473935 100644 --- a/tests/service/PatternMatchCompilationTests.fs +++ b/tests/service/PatternMatchCompilationTests.fs @@ -80,7 +80,7 @@ match A with """ assertHasSymbolUsages ["x"; "y"] checkResults dumpErrors checkResults |> shouldEqual [ - "(7,2--7,10): This constructor is applied to 2 argument(s) but expects 3" + "(7,2--7,10): This union case expects 3 arguments in tupled form" "(6,6--6,7): Incomplete pattern matches on this expression. For example, the value 'A' may indicate a case not covered by the pattern(s)." ] @@ -257,6 +257,23 @@ match TraceLevel.Off with ] +[] +let ``Caseless DU`` () = + let _, checkResults = getParseAndCheckResults """ +type DU = Case of int + +let f du = + match du with + | Case -> () + +let dowork () = + f (Case 1) + 0 // return an integer exit code""" + assertHasSymbolUsages ["DU"; "dowork"; "du"; "f"] checkResults + dumpErrors checkResults |> shouldEqual [ + "(6,6--6,10): This constructor is applied to 0 argument(s) but expects 1" + ] + [] let ``Or 01 - No errors`` () = let _, checkResults = getParseAndCheckResults """ From 60c668f4f767b7adc9d9f5937fab8d39bb4496b2 Mon Sep 17 00:00:00 2001 From: "Kevin Ransom (msft)" Date: Wed, 10 Jun 2020 21:52:52 -0700 Subject: [PATCH 3/3] Update TypeChecker.fs --- src/fsharp/TypeChecker.fs | 1 - 1 file changed, 1 deletion(-) diff --git a/src/fsharp/TypeChecker.fs b/src/fsharp/TypeChecker.fs index 71712d566e2..6f94be6fcea 100755 --- a/src/fsharp/TypeChecker.fs +++ b/src/fsharp/TypeChecker.fs @@ -5464,7 +5464,6 @@ and TcPat warnOnUpper cenv env topValInfo vFlags (tpenv, names, takenNames) ty p TPat_query((activePatExpr, activePatResTys, activePatIdentity, idx, apinfo), arg' values, m)), acc | (Item.UnionCase _ | Item.ExnCase _) as item -> - // Report information about the case occurrence to IDE CallNameResolutionSink cenv.tcSink (lidRange, env.NameEnv, item, emptyTyparInst, ItemOccurence.Pattern, env.eAccessRights)