fix 13607 (#13648)

Co-authored-by: Vlad Zarytovskii <[email protected]>

Author: dsyme

src/Compiler/Checking/PatternMatchCompilation.fs

@@ -418,17 +418,17 @@ type Implication =
     /// Indicates nothing in particular
     | Nothing
 
-/// Work out what one successful type test implies about a null test
+/// Work out what a successful type test (against tgtTy1) implies about a null test for the same input value.
 ///
 /// Example:
 ///     match x with 
-///     | :? string -> ...
+///     | :? string when false -> ... // note: "when false" used so type test succeeds but proceed to next type test
 ///     | null -> ...
 /// For any inputs where ':? string' succeeds, 'null' will fail
 ///
 /// Example:
 ///     match x with 
-///     | :? (int option) -> ...
+///     | :? (int option) when false -> ... // note: "when false" used so type test succeeds but proceed to next type test
 ///     | null -> ...
 /// Nothing can be learned.  If ':? (int option)' succeeds, 'null' may still have to be run.
 let computeWhatSuccessfulTypeTestImpliesAboutNullTest g tgtTy1 =
@@ -437,7 +437,7 @@ let computeWhatSuccessfulTypeTestImpliesAboutNullTest g tgtTy1 =
     else
         Implication.Fails
 
-/// Work out what a failing type test implies about a null test.
+/// Work out what a failing type test (against tgtTy1) implies about a null test for the same input value.
 ///
 /// Example:
 ///     match x with 
@@ -450,17 +450,17 @@ let computeWhatFailingTypeTestImpliesAboutNullTest g tgtTy1 =
     else
         Implication.Nothing
 
-/// Work out what one successful null test implies about a type test.
+/// Work out what one successful null test implies about a type test (against tgtTy2) for the same input value.
 ///
 /// Example:
 ///     match x with 
-///     | null -> ...
+///     | null when false -> ...  // note: "when false" used so null test succeeds but proceed to next type test
 ///     | :? string -> ...
 /// For any inputs where 'null' succeeds, ':? string' will fail
 ///
 /// Example:
 ///     match x with 
-///     | null -> ...
+///     | null when false -> ... // note: "when false" used so null test succeeds but proceed to next type test
 ///     | :? (int option) -> ...
 /// For any inputs where 'null' succeeds, ':? (int option)' will succeed
 let computeWhatSuccessfulNullTestImpliesAboutTypeTest g tgtTy2 =
@@ -469,67 +469,79 @@ let computeWhatSuccessfulNullTestImpliesAboutTypeTest g tgtTy2 =
     else
         Implication.Fails
 
-/// Work out what a failing null test implies about a type test. The answer is "nothing" but it's included for symmetry.
+/// Work out what a failing null test implies about a type test (against tgtTy2) for the same
+/// input balue. The answer is "nothing" but it's included for symmetry.
 let computeWhatFailingNullTestImpliesAboutTypeTest _g _tgtTy2 =
     Implication.Nothing
 
-/// Work out what one successful type test implies about another type test
+/// Work out what one successful type test (against tgtTy1) implies about another type test (against tgtTy2)
+/// for the same input value.
 let computeWhatSuccessfulTypeTestImpliesAboutTypeTest g amap m tgtTy1 tgtTy2 =
     let tgtTy1 = stripTyEqnsWrtErasure EraseAll g tgtTy1
     let tgtTy2 = stripTyEqnsWrtErasure EraseAll g tgtTy2
 
-    //  A successful type test on any type implies all supertypes always succeed
+    // A successful type test of an input value against a type (tgtTy1)
+    // implies all type tests of the same input value on equivalent or
+    // supertypes (tgtTy2) always succeed.
     //
     // Example:
     //     match x with 
-    //     | :? string -> ...
+    //     | :? string when false -> ... // note: "when false" used so type test succeeds but proceed to next type test
     //     | :? IComparable -> ...
     //
     // Example:
     //     match x with 
-    //     | :? string -> ...
+    //     | :? string when false -> ... // note: "when false" used so type test succeeds but proceed to next type test
     //     | :? string -> ...
     //
     if TypeDefinitelySubsumesTypeNoCoercion 0 g amap m tgtTy2 tgtTy1 then
         Implication.Succeeds
 
-    //  A successful type test on a sealed type implies all non-related types fail
+    // A successful type test of an input value against a sealed target type (tgtTy1) implies all
+    // type tests of the same object against a unrelated target type (tgtTy2) fails.
     //
     // Example:
     //     match x with 
-    //     | :? int -> ...
+    //     | :? int when false -> ... // note: "when false" used so type test succeeds but proceed to next type test
     //     | :? string -> ...
     //
     // For any inputs where ':? int' succeeds, ':? string' will fail
     //
-    // This doesn't apply to related types:
+    //
+    // This only applies if tgtTy2 is not potetnially related to the sealed type tgtTy1:
     //     match x with 
-    //     | :? int -> ...
+    //     | :? int when false -> ... // note: "when false" used so type test succeeds but proceed to next type test
     //     | :? IComparable -> ...
     //
-    // Here IComparable neither fails nor is redundant
+    // Here IComparable is not known to fail (NOTE: indeed it is actually known to succeed,
+    // give ":? int" succeeded, however this is not utilised in the analysis, because it involves coercion).
+    //
     //
-    // This doesn't apply to unsealed types:
+    // This rule also doesn't apply to unsealed types:
     //     match x with 
-    //     | :? SomeClass -> ...
+    //     | :? SomeUnsealedClass when false -> ... // note: "when false" used so type test succeeds but proceed to next type test
     //     | :? SomeInterface -> ...
+    // because the input may be some subtype of SomeUnsealedClass and that type could implement SomeInterface even if
+    // SomeUnsealedClass doesnt.
+    //
     //
-    // This doesn't apply to types with null as true value:
+    // This rule also doesn't apply to types with null as true value:
     //     match x with 
-    //     | :? (int option) -> ...
+    //     | :? (int option) when false -> ... // "when false" means type test succeeds but proceed to next type test
     //     | :? (string option) -> ...
     //
     // Here on 'null' input the first pattern succeeds, and the second pattern will also succeed
     elif isSealedTy g tgtTy1 &&
          not (TypeNullIsTrueValue g tgtTy1) &&
-         not (TypeDefinitelySubsumesTypeNoCoercion 0 g amap m tgtTy2 tgtTy1) then
+         not (TypeFeasiblySubsumesType 0 g amap m tgtTy2 CanCoerce tgtTy1) then
         Implication.Fails
 
-    //  A successful type test on an unsealed class type implies type tests on unrelated non-interface types always fail
+    // A successful type test of an input value against an unsealed class type (tgtTy1) implies
+    // a type test of the same input value against an unrelated non-interface type (tgtTy2) always fails
     //
     // Example:
     //     match x with 
-    //     | :? SomeUnsealedClass -> ...
+    //     | :? SomeUnsealedClass when false -> ... // "when false" used so type test succeeds but proceed to next type test
     //     | :? SomeUnrelatedClass -> ...
     //
     // For any inputs where ':? SomeUnsealedClass' succeeds, ':? SomeUnrelatedClass' will fail
@@ -543,11 +555,13 @@ let computeWhatSuccessfulTypeTestImpliesAboutTypeTest g amap m tgtTy1 tgtTy2 =
          not (TypeFeasiblySubsumesType 0 g amap m tgtTy2 CanCoerce tgtTy1) then
         Implication.Fails
 
-    //  A successful type test on an interface type refutes sealed types that do not support that interface
+    // A successful type test of an input value against an interface type (tgtTy1) implies
+    // a type test of the same object against a sealed types (tgtTy2) that does not support that interface
+    // always fails.
     //
     // Example:
     //     match x with 
-    //     | :? IComparable -> ...
+    //     | :? IComparable when false -> ... // "when false" used so type test succeeds but proceed to next type test
     //     | :? SomeOtherSealedClass -> ...
     //
     // For any inputs where ':? IComparable' succeeds, ':? SomeOtherSealedClass' will fail
@@ -561,12 +575,13 @@ let computeWhatSuccessfulTypeTestImpliesAboutTypeTest g amap m tgtTy1 tgtTy2 =
     else
         Implication.Nothing
 
-/// Work out what one successful type test implies about another type test
+/// Work out what one failing type test (tgtTy1) implies about another type test (tgtTy2)
 let computeWhatFailingTypeTestImpliesAboutTypeTest g amap m tgtTy1 tgtTy2 =
     let tgtTy1 = stripTyEqnsWrtErasure EraseAll g tgtTy1
     let tgtTy2 = stripTyEqnsWrtErasure EraseAll g tgtTy2
 
-    //  A failing type test on any type implies all subtypes fail
+    // If testing an input value against a target type (tgtTy1) fails then
+    // testing the same input value against an equivalent or subtype type (tgtTy2) always fails.
     //
     // Example:
     //     match x with 

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

@@ -59,4 +59,28 @@ module Simple =
         |> asExe
         |> withLangVersionPreview
         |> compileExeAndRun
-        |> shouldSucceed
+        |> shouldSucceed
+
+
+    [<Theory>]
+    [<InlineData("DateTime", "DateTime.Now")>]
+    [<InlineData("int", "1")>]
+    [<InlineData("Guid", "(Guid.NewGuid())")>]
+    [<InlineData("Byte", "0x1")>]
+    [<InlineData("Decimal", "1m")>]
+    let ``Test type matching for subtypes and interfaces`` typ value =
+        Fsx $"""
+open System
+let classify (o: obj) =
+    match o with
+    | :? {typ} as d when d = Unchecked.defaultof<_> -> "default"
+    | :? IFormattable -> "formattable"
+    | _ -> "not a {typ}"
+
+let res = classify {value}
+if res <> "formattable" then
+    failwith $"Unexpected result: {{res}}"
+         """
+         |> asExe
+         |> compileAndRun
+         |> shouldSucceed

tests/fsharp/core/subtype/test.fsx

@@ -2458,6 +2458,72 @@ module TestSubtypeMatching13 =
     check "cnwcki4d3" (toName (C())) "IA"
     check "cnwcki4d4" (toName (obj())) "other"
 
+module TestStructMatching1 =
+
+    let toName (x: obj) =
+        match x with
+        | :? int when false -> "A" // note: "when false" used so type test succeeds but proceed to next type test
+        | :? IComparable -> "B"
+        | _ -> "other"
+
+    check "cnwcki4cewweq1" (toName 1) "B"
+    check "cnwcki4cewweq2" (toName "a") "B"
+    check "cnwcki4cewweq3" (toName System.DateTime.Now) "B"
+    check "cnwcki4cewweq4" (toName (obj())) "other"
+
+module TestStructMatching2 =
+
+    let toName (x: obj) =
+        match x with
+        | :? DateTime when false -> "A" // note: "when false" used so type test succeeds but proceed to next type test
+        | :? IComparable -> "B"
+        | _ -> "other"
+
+    check "cnwcki4cewweq1" (toName 1) "B"
+    check "cnwcki4cewweq2" (toName "a") "B"
+    check "cnwcki4cewweq3" (toName System.DateTime.Now) "B"
+    check "cnwcki4cewweq4" (toName (obj())) "other"
+
+module TestStructMatching3 =
+
+    let toName (x: obj) =
+        match x with
+        | :? IComparable when false -> "A" // note: "when false" used so type test succeeds but proceed to next type test
+        | :? DateTime -> "B"
+        | _ -> "other"
+
+    check "cnwcki4cewweq1" (toName 1) "other"
+    check "cnwcki4cewweq2" (toName "a") "other"
+    check "cnwcki4cewweq3" (toName System.DateTime.Now) "B"
+    check "cnwcki4cewweq4" (toName (obj())) "other"
+
+module TestStructMatching4 =
+
+    let toName (x: obj) =
+        match x with
+        | :? IFormattable when false -> "A" // note: "when false" used so type test succeeds but proceed to next type test
+        | :? DateTime -> "B"
+        | _ -> "other"
+
+    check "cnwcki4cewweq1" (toName 1) "other"
+    check "cnwcki4cewweq2" (toName "a") "other"
+    check "cnwcki4cewweq3" (toName System.DateTime.Now) "B"
+    check "cnwcki4cewweq4" (toName (obj())) "other"
+
+module TestStructMatching5 =
+
+    let toName (x: obj) =
+        match x with
+        | :? IFormattable when false -> "A" // note: "when false" used so type test succeeds but proceed to next type test
+        | :? Guid -> "B"
+        | _ -> "other"
+
+    check "cnwcki4cewweq11" (toName 1) "other"
+    check "cnwcki4cewweq22" (toName "a") "other"
+    check "cnwcki4cewweq33" (toName System.DateTime.Now) "other"
+    check "cnwcki4cewweq34" (toName (System.Guid())) "B"
+    check "cnwcki4cewweq45" (toName (obj())) "other"
+
 #if !NETCOREAPP
 module TestConverter =
     open System