fix(codegen): test nested constructor patterns — three backends emitted the same guard

lib/codegen_deno.ml

@@ -1256,7 +1256,30 @@ and gen_pattern_test scrut pat =
   match pat with
   | PatWildcard _ | PatVar _ -> "true"
   | PatLit lit -> scrut ^ " === " ^ gen_literal lit
-  | PatCon (id, _) -> scrut ^ ".tag === " ^ Printf.sprintf "%S" id.name
+  (* Descend into the sub-patterns. This used to be [PatCon (id, _)], testing
+     only the OUTERMOST tag and discarding the arguments -- so [Some(Circle(n))]
+     and [Some(Square(n))] emitted the SAME guard, the second arm was
+     unreachable, and the first arm's body ran for both. It type-checked; only
+     the emitted JavaScript was wrong, which is the worst place for it to be.
+
+     The paths mirror gen_pattern_bindings below, which was already descending
+     correctly -- that asymmetry is why the bug was invisible: bindings landed
+     on the right values, so the output looked plausible. *)
+  | PatCon (id, args) ->
+      let tag_test = scrut ^ ".tag === " ^ Printf.sprintf "%S" id.name in
+      let sub_tests =
+        match args with
+        | []       -> []
+        | [single] -> [gen_pattern_test (scrut ^ ".value") single]
+        | many     ->
+            List.mapi (fun i p ->
+              gen_pattern_test
+                (scrut ^ ".values[" ^ string_of_int i ^ "]") p) many
+      in
+      (* A variable or wildcard sub-pattern tests "true"; dropping those keeps
+         the guard readable rather than "tag === X && true && true". *)
+      let meaningful = List.filter (fun s -> s <> "true") sub_tests in
+      String.concat " && " (tag_test :: meaningful)
   | PatTuple pats ->
       let conds = List.mapi (fun i p ->
         gen_pattern_test (scrut ^ "[" ^ string_of_int i ^ "]") p) pats in

lib/js_codegen.ml

@@ -376,9 +376,24 @@ and gen_pattern_test scrut pat =
   match pat with
   | PatWildcard _ | PatVar _ -> "true"
   | PatLit lit -> scrut ^ " === " ^ gen_literal lit
-  | PatCon (id, _) ->
-      (* Tagged-union variant: { tag: "Some", value: ... } *)
-      scrut ^ ".tag === " ^ Printf.sprintf "%S" id.name
+  (* Tagged-union variant: { tag: "Some", value: ... }
+     Sub-patterns MUST be tested too. This used to discard [args], so
+     [Some(Circle(n))] and [Some(Square(n))] produced the same guard and the
+     second arm was unreachable -- the first arm's body ran for both. Paths
+     mirror gen_pattern_bindings: .value for arity 1, .values[i] otherwise. *)
+  | PatCon (id, args) ->
+      let tag_test = scrut ^ ".tag === " ^ Printf.sprintf "%S" id.name in
+      let sub_tests =
+        match args with
+        | []       -> []
+        | [single] -> [gen_pattern_test (scrut ^ ".value") single]
+        | many     ->
+            List.mapi (fun i p ->
+              gen_pattern_test
+                (scrut ^ ".values[" ^ string_of_int i ^ "]") p) many
+      in
+      String.concat " && "
+        (tag_test :: List.filter (fun s -> s <> "true") sub_tests)
   | PatTuple pats ->
       let conds = List.mapi (fun i p ->
         gen_pattern_test (scrut ^ "[" ^ string_of_int i ^ "]") p

lib/lua_codegen.ml

@@ -99,7 +99,23 @@ and gen_pattern_test scrut pat =
   match pat with
   | PatWildcard _ | PatVar _ -> "true"
   | PatLit lit -> Printf.sprintf "%s == %s" scrut (gen_lit lit)
-  | PatCon (id, _) -> Printf.sprintf "%s.tag == %S" scrut id.name
+  (* Sub-patterns must be tested, not discarded -- see codegen_deno.ml. Paths
+     mirror gen_pattern_bindings below: .value for arity 1, .values[i] else.
+     Lua indexes from 1, and the bindings walker uses the same expression, so
+     the two stay in step. *)
+  | PatCon (id, args) ->
+      let tag_test = Printf.sprintf "%s.tag == %S" scrut id.name in
+      let sub_tests =
+        match args with
+        | []       -> []
+        | [single] -> [gen_pattern_test (scrut ^ ".value") single]
+        | many     ->
+            List.mapi (fun i p ->
+              gen_pattern_test
+                (Printf.sprintf "%s.values[%d]" scrut i) p) many
+      in
+      String.concat " and "
+        (tag_test :: List.filter (fun s -> s <> "true") sub_tests)
   | PatTuple _ -> "true"  (* arity match by structure, not tag *)
   | PatRecord _ -> "true"
   | PatAs (_, p) -> gen_pattern_test scrut p

test/test_stdlib_aot.ml

@@ -340,9 +340,77 @@ let tuple_pattern_tests =
   [ Alcotest.test_case "nested (literal/var) tuple patterns -> Wasm" `Quick
       test_nested_tuple_patterns_wasm ]
 
+(* ---- Nested CONSTRUCTOR patterns must be discriminated (#731) -------------
+
+   Regression guard. gen_pattern_test discarded PatCon's sub-patterns, so arms
+   differing only in a NESTED constructor emitted IDENTICAL guards:
+
+       if (__scrut.tag === "Some")     <- Some(Circle(n))
+       if (__scrut.tag === "Some")     <- Some(Square(n))   unreachable
+
+   Every arm after the first was dead and the first arm's body ran for all of
+   them. It type-checked; only the emitted code was wrong, so nothing in the
+   compiler caught it -- and neither did this file, which had a nested-TUPLE
+   pattern test but none for nested CONSTRUCTORS on the JS-family backends.
+
+   Verified to fail without the fix: reverting the PatCon arm in
+   codegen_deno.ml turns exactly this test red. *)
+let nested_ctor_src = {|
+module nestedctor;
+use prelude::{ Option, Some, None };
+
+pub type Shape = Circle(Int) | Square(Int)
+
+pub fn describe(s: Option<Shape>) -> Int {
+  match s {
+    Some(Circle(n)) => n,
+    Some(Square(n)) => n + 1000,
+    None => -1,
+  }
+}
+|}
+
+let check_nested_ctor_guards (backend : string) (js : string) =
+  (* The inner constructor must appear in a GUARD, not merely in a binding --
+     bindings were already descending correctly, which is what made the bug
+     invisible. *)
+  Alcotest.(check bool)
+    (backend ^ ": guard discriminates the inner Circle")
+    true (count_substr "tag === \"Circle\"" js > 0
+          || count_substr "tag == \"Circle\"" js > 0);
+  Alcotest.(check bool)
+    (backend ^ ": guard discriminates the inner Square")
+    true (count_substr "tag === \"Square\"" js > 0
+          || count_substr "tag == \"Square\"" js > 0)
+
+let test_deno_nested_ctor_guards () =
+  match Parse_driver.parse_string ~file:"<nestedctor>" nested_ctor_src with
+  | exception e ->
+    Alcotest.failf "nested-ctor parse raised: %s" (Printexc.to_string e)
+  | prog ->
+    (match pipeline_to_deno prog with
+     | Error m -> Alcotest.failf "deno codegen failed: %s" m
+     | Ok js -> check_nested_ctor_guards "Deno-ESM" js)
+
+let test_js_nested_ctor_guards () =
+  match Parse_driver.parse_string ~file:"<nestedctor>" nested_ctor_src with
+  | exception e ->
+    Alcotest.failf "nested-ctor parse raised: %s" (Printexc.to_string e)
+  | prog ->
+    (match pipeline_to_js prog with
+     | Error m -> Alcotest.failf "js codegen failed: %s" m
+     | Ok js -> check_nested_ctor_guards "JS" js)
+
+let nested_ctor_tests =
+  [ Alcotest.test_case "nested constructor patterns are discriminated (Deno)"
+      `Quick test_deno_nested_ctor_guards;
+    Alcotest.test_case "nested constructor patterns are discriminated (JS)"
+      `Quick test_js_nested_ctor_guards ]
+
 let tests =
   [ ("STAGE-A AOT smoke (#136)", aot_smoke_tests);
     ("STAGE-A multi-module integration (#137)", integration_tests);
     ("cross-module constructor linking, Wasm (#138)", xmod_constructor_tests);
     ("Deno-ESM / JS no duplicate Option/Result constructor", dup_ctor_tests);
-    ("Wasm nested tuple patterns", tuple_pattern_tests) ]
+    ("Wasm nested tuple patterns", tuple_pattern_tests);
+    ("Nested constructor patterns discriminated (#731)", nested_ctor_tests) ]