diff --git a/compiler/core/js_dump.ml b/compiler/core/js_dump.ml index ea1c3d5fda..4e15a94482 100644 --- a/compiler/core/js_dump.ml +++ b/compiler/core/js_dump.ml @@ -922,6 +922,9 @@ and expression_desc cxt ~(level : int) f x : cxt = | None -> L.tag | Some s -> s in + let is_primitive_catch_all = + Ast_untagged_variants.has_primitive_catchall p.attrs + in let tails = Ext_list.filter_map tails (fun ((f, optional), x) -> match x.expression_desc with @@ -929,6 +932,7 @@ and expression_desc cxt ~(level : int) f x : cxt = | _ -> Some (f, x)) in if untagged then tails + else if is_primitive_catch_all then tails else ( Js_op.Lit tag_name, (* TAG:xx for inline records *) diff --git a/compiler/core/lam_compile.ml b/compiler/core/lam_compile.ml index 739056132b..2e16395049 100644 --- a/compiler/core/lam_compile.ml +++ b/compiler/core/lam_compile.ml @@ -183,6 +183,86 @@ let get_literal_cases (sw_names : Ast_untagged_variants.switch_names option) = | {name; tag_type = None} -> res := String name :: !res)); !res +let has_explicit_tag_name (sw_names : Ast_untagged_variants.switch_names option) + : bool = + match sw_names with + | None -> false + | Some {blocks} -> + Array.exists + (fun {Ast_untagged_variants.tag_name} -> tag_name <> None) + blocks + +let discriminant_expr ~untagged ~sw_names ~tag_name (e : E.t) : E.t = + if untagged && has_explicit_tag_name sw_names then E.tag ~name:tag_name e + else e + +let split_sw_blocks_by_catchall sw_blocks get_block_tag = + let is_literal_block (i, _) = + match get_block_tag i with + | Some {Ast_untagged_variants.tag_type = Some (Untagged _)} -> false + | Some {Ast_untagged_variants.tag_type = Some _} -> true + | _ -> false + in + let literals = List.filter is_literal_block sw_blocks in + let untagged_only = + List.filter + (fun (i, _) -> + match get_block_tag i with + | Some {Ast_untagged_variants.tag_type = Some (Untagged _)} -> true + | _ -> false) + sw_blocks + in + (literals, untagged_only) + +let block_literal_cases_for_guard sw_blocks get_block_tag = + List.filter_map + (fun (i, _) -> + match get_block_tag i with + | Some {Ast_untagged_variants.tag_type = Some t} -> Some t + | _ -> None) + sw_blocks + +let all_literal_cases_with_block_tags + (sw_names : Ast_untagged_variants.switch_names option) : + Ast_untagged_variants.tag_type list = + match sw_names with + | None -> [] + | Some {blocks; _} as names -> ( + match + Array.find_opt + (fun {Ast_untagged_variants.tag_name} -> tag_name <> None) + blocks + with + | None -> get_literal_cases names + | Some _ -> + let acc = ref (get_literal_cases names) in + Ext_array.iter blocks (function + | {Ast_untagged_variants.block_type = None; tag} -> ( + match tag.tag_type with + | Some t -> acc := t :: !acc + | None -> acc := String tag.name :: !acc) + | _ -> ()); + !acc) + +(* Compile the split path for tagged unions with literal block tags and a + primitive catch-all on the discriminant: first try literal tags on the + discriminant value, otherwise fall back to the primitive catch-all cases. *) +let compile_literal_then_catchall ~cxt ~discr ~block_cases ~default + ~get_block_tag sw_blocks_literal_only sw_blocks_untagged_only : + initialization = + [ + S.if_ + (E.is_a_literal_case + ~literal_cases: + (block_literal_cases_for_guard sw_blocks_literal_only get_block_tag) + ~block_cases discr) + (compile_cases ~cxt ~switch_exp:discr ~block_cases ~default + ~get_tag:get_block_tag sw_blocks_literal_only) + ~else_: + (compile_cases ~untagged:true ~cxt ~switch_exp:discr ~block_cases + ~default ~get_tag:get_block_tag sw_blocks_untagged_only); + ] + let has_null_undefined_other (sw_names : Ast_untagged_variants.switch_names option) = let null, undefined, other = (ref false, ref false, ref false) in @@ -700,7 +780,13 @@ let compile output_prefix = Some tag in let tag_name = get_tag_name sw_names in - let untagged = block_cases <> [] in + (* Whether this switch includes block (non-const) cases. Used to decide + whether to compile via the untagged/block path in case lowering. *) + let has_block_cases = block_cases <> [] in + (* For tagged unions with a primitive catch-all on the discriminant: + - Guard first on literal cases against the discriminant value. + - If none match, fall back to the primitive typeof checks (catch-alls). + This mirrors unboxed variant handling but targets the tag field. *) let compile_whole (cxt : Lam_compile_context.t) = match compile_lambda {cxt with continuation = NeedValue Not_tail} switch_arg @@ -710,9 +796,23 @@ let compile output_prefix = block @ if sw_consts_full && sw_consts = [] then - compile_cases ~block_cases ~untagged ~cxt - ~switch_exp:(if untagged then e else E.tag ~name:tag_name e) - ~default:sw_blocks_default ~get_tag:get_block_tag sw_blocks + let has_explicit = has_explicit_tag_name sw_names in + let sw_blocks_literal_only, sw_blocks_untagged_only = + split_sw_blocks_by_catchall sw_blocks get_block_tag + in + let has_literal_block_tags = sw_blocks_literal_only <> [] in + if has_block_cases && has_explicit && has_literal_block_tags then + let discr = + discriminant_expr ~untagged:has_block_cases ~sw_names ~tag_name e + in + compile_literal_then_catchall ~cxt ~discr ~block_cases + ~default:sw_blocks_default ~get_block_tag sw_blocks_literal_only + sw_blocks_untagged_only + else + compile_cases ~block_cases ~untagged:has_block_cases ~cxt + ~switch_exp: + (if has_block_cases then e else E.tag ~name:tag_name e) + ~default:sw_blocks_default ~get_tag:get_block_tag sw_blocks else if sw_blocks_full && sw_blocks = [] then compile_cases ~cxt ~switch_exp:e ~block_cases ~default:sw_num_default ~get_tag:get_const_tag sw_consts @@ -720,10 +820,13 @@ let compile output_prefix = (* [e] will be used twice *) let dispatch e = let is_a_literal_case () = - if untagged then - E.is_a_literal_case - ~literal_cases:(get_literal_cases sw_names) - ~block_cases e + if has_block_cases then + let lit_e = + discriminant_expr ~untagged:has_block_cases ~sw_names + ~tag_name e + in + let lit_cases = all_literal_cases_with_block_tags sw_names in + E.is_a_literal_case ~literal_cases:lit_cases ~block_cases lit_e else E.is_int_tag ~has_null_undefined_other:(has_null_undefined_other sw_names) @@ -737,7 +840,7 @@ let compile output_prefix = | _ -> false in if - untagged + has_block_cases && List.length sw_consts = 0 && eq_default sw_num_default sw_blocks_default then @@ -745,19 +848,24 @@ let compile output_prefix = let has_null_case = List.mem Ast_untagged_variants.Null literal_cases in - compile_cases ~untagged ~cxt - ~switch_exp:(if untagged then e else E.tag ~name:tag_name e) + compile_cases ~untagged:has_block_cases ~cxt + ~switch_exp: + (if has_block_cases then e else E.tag ~name:tag_name e) ~block_cases ~has_null_case ~default:sw_blocks_default ~get_tag:get_block_tag sw_blocks else [ S.if_ (is_a_literal_case ()) - (compile_cases ~cxt ~switch_exp:e ~block_cases - ~default:sw_num_default ~get_tag:get_const_tag sw_consts) + (compile_cases ~cxt + ~switch_exp: + (discriminant_expr ~untagged:has_block_cases ~sw_names + ~tag_name e) + ~block_cases ~default:sw_num_default ~get_tag:get_const_tag + sw_consts) ~else_: - (compile_cases ~untagged ~cxt + (compile_cases ~untagged:has_block_cases ~cxt ~switch_exp: - (if untagged then e else E.tag ~name:tag_name e) + (if has_block_cases then e else E.tag ~name:tag_name e) ~block_cases ~default:sw_blocks_default ~get_tag:get_block_tag sw_blocks); ] diff --git a/compiler/ml/ast_untagged_variants.ml b/compiler/ml/ast_untagged_variants.ml index 9cb7d015c8..de08d630d4 100644 --- a/compiler/ml/ast_untagged_variants.ml +++ b/compiler/ml/ast_untagged_variants.ml @@ -58,6 +58,15 @@ type error = | InvalidVariantTagAnnotation | InvalidUntaggedVariantDefinition of untagged_error | TagFieldNameConflict of string * string * string + (* Errors for tagged variants with primitive catch-all (@as(int|float|string)) *) + | TaggedPrimitiveCatchAll_AtMostOneNumber + | TaggedPrimitiveCatchAll_AtMostOneString + | TaggedPrimitiveCatchAll_OnNullaryConstructor of string + | TaggedPrimitiveCatchAll_InlineRecordRequired of string + | TaggedPrimitiveCatchAll_MissingTagField of string * string + | TaggedPrimitiveCatchAll_TooManyTagFields of string * string + | TaggedPrimitiveCatchAll_TagFieldOptional of string * string + | TaggedPrimitiveCatchAll_TagFieldWrongType of string * string * string exception Error of Location.t * error let report_error ppf = @@ -97,6 +106,41 @@ let report_error ppf = value of inline record field \"%s\". Use a different @tag name or \ rename the field." constructor_name runtime_value field_name + | TaggedPrimitiveCatchAll_AtMostOneNumber -> + fprintf ppf + "At most one number catch-all (@as(int|float)) is allowed per variant" + | TaggedPrimitiveCatchAll_AtMostOneString -> + fprintf ppf + "At most one string catch-all (@as(string)) is allowed per variant" + | TaggedPrimitiveCatchAll_OnNullaryConstructor name -> + fprintf ppf + "Constructor \"%s\": primitive catch-all @as(int|float|string) is not \ + allowed on nullary constructors" + name + | TaggedPrimitiveCatchAll_InlineRecordRequired name -> + fprintf ppf + "Constructor \"%s\": primitive catch-all requires an inline record \ + payload" + name + | TaggedPrimitiveCatchAll_MissingTagField (name, tag_name) -> + fprintf ppf + "Constructor \"%s\": inline record must contain exactly one field named \ + \"%s\" (or @as(\"%s\")) carrying the discriminant" + name tag_name tag_name + | TaggedPrimitiveCatchAll_TooManyTagFields (name, tag_name) -> + fprintf ppf + "Constructor \"%s\": inline record must contain exactly one field named \ + \"%s\" (or @as(\"%s\")) carrying the discriminant" + name tag_name tag_name + | TaggedPrimitiveCatchAll_TagFieldOptional (name, field_name) -> + fprintf ppf + "Constructor \"%s\": field \"%s\" must not be optional for primitive \ + catch-all" + name field_name + | TaggedPrimitiveCatchAll_TagFieldWrongType (name, field_name, expected) -> + fprintf ppf + "Constructor \"%s\": field \"%s\" must have type %s (direct builtin)" name + field_name expected (* Type of the runtime representation of an untagged block (case with payoad) *) type block_type = @@ -207,6 +251,9 @@ let process_tag_type (attrs : Parsetree.attributes) = | None -> () | Some (Lident "null") -> st := Some Null | Some (Lident "undefined") -> st := Some Undefined + | Some (Lident "int") -> st := Some (Untagged IntType) + | Some (Lident "float") -> st := Some (Untagged FloatType) + | Some (Lident "string") -> st := Some (Untagged StringType) | Some _ -> raise (Error (loc, InvalidVariantAsAnnotation))); if !st = None then raise (Error (loc, InvalidVariantAsAnnotation)) else Used_attributes.mark_used_attribute attr) @@ -214,6 +261,17 @@ let process_tag_type (attrs : Parsetree.attributes) = | _ -> ()); !st +(* Helpers for tagged-variant primitive catch-alls *) +let primitive_catchall_kind_of_attrs (attrs : Parsetree.attributes) : + block_type option = + match process_tag_type attrs with + | Some (Untagged IntType) | Some (Untagged FloatType) -> Some IntType + | Some (Untagged StringType) -> Some StringType + | _ -> None + +let has_primitive_catchall (attrs : Parsetree.attributes) : bool = + primitive_catchall_kind_of_attrs attrs |> Option.is_some + let () = Location.register_error_of_exn (function | Error (loc, err) -> Some (Location.error_of_printer loc report_error err) @@ -291,7 +349,9 @@ let get_block_type_from_typ ~env (t : Types.type_expr) : block_type option = let get_block_type ~env (cstr : Types.constructor_declaration) : block_type option = match (process_untagged cstr.cd_attributes, cstr.cd_args) with - | false, _ -> None + | false, _ -> + (* Also surface block_type for tagged primitive catch-all constructors *) + primitive_catchall_kind_of_attrs cstr.cd_attributes | true, Cstr_tuple [t] when get_block_type_from_typ ~env t |> Option.is_some -> get_block_type_from_typ ~env t @@ -478,26 +538,102 @@ let check_tag_field_conflicts (cstrs : Types.constructor_declaration list) = | Some explicit_tag -> explicit_tag | None -> constructor_name in + (* detect primitive catch-all on constructor *) + let primitive_catch_all_kind : block_type option = + primitive_catchall_kind_of_attrs cstr.cd_attributes + in match cstr.cd_args with - | Cstr_record fields -> - List.iter - (fun (field : Types.label_declaration) -> + | Cstr_record fields -> ( + match primitive_catch_all_kind with + | None -> + (* Original conflict rule for regular tagged inline records *) + List.iter + (fun (field : Types.label_declaration) -> + let field_name = Ident.name field.ld_id in + let effective_field_name = + match process_tag_type field.ld_attributes with + | Some (String as_name) -> as_name + (* @as payload types other than string have no effect on record fields *) + | Some _ | None -> field_name + in + if effective_field_name = effective_tag_name then + raise + (Error + ( cstr.cd_loc, + TagFieldNameConflict + (constructor_name, field_name, effective_field_name) ))) + fields + | Some kind -> ( + (* Primitive catch-all: enforce exactly one tag field named as tag *) + let matching_fields = + List.filter + (fun (field : Types.label_declaration) -> + let field_name = Ident.name field.ld_id in + let effective_field_name = + match process_tag_type field.ld_attributes with + | Some (String as_name) -> as_name + | Some _ | None -> field_name + in + effective_field_name = effective_tag_name) + fields + in + match matching_fields with + | [] -> + raise + (Error + ( cstr.cd_loc, + TaggedPrimitiveCatchAll_MissingTagField + (constructor_name, effective_tag_name) )) + | _ :: _ :: _ -> + raise + (Error + ( cstr.cd_loc, + TaggedPrimitiveCatchAll_TooManyTagFields + (constructor_name, effective_tag_name) )) + | [field] -> let field_name = Ident.name field.ld_id in - let effective_field_name = - match process_tag_type field.ld_attributes with - | Some (String as_name) -> as_name - (* @as payload types other than string have no effect on record fields *) - | Some _ | None -> field_name + if field.ld_optional then + raise + (Error + ( cstr.cd_loc, + TaggedPrimitiveCatchAll_TagFieldOptional + (constructor_name, field_name) )); + (* enforce exact builtin type, no alias/expansion *) + let expected, ok = + match kind with + | IntType -> ( + match field.ld_type.desc with + | Tconstr (path, _, _) when Path.same path Predef.path_int -> + ("int", true) + | _ -> ("int", false)) + | StringType -> ( + match field.ld_type.desc with + | Tconstr (path, _, _) when Path.same path Predef.path_string -> + ("string", true) + | _ -> ("string", false)) + | FloatType -> ( + match field.ld_type.desc with + | Tconstr (path, _, _) when Path.same path Predef.path_float -> + ("float", true) + | _ -> ("float", false)) + | _ -> assert false in - (* Check if effective field name conflicts with tag *) - if effective_field_name = effective_tag_name then + if not ok then raise (Error ( cstr.cd_loc, - TagFieldNameConflict - (constructor_name, field_name, effective_field_name) ))) - fields - | _ -> ()) + TaggedPrimitiveCatchAll_TagFieldWrongType + (constructor_name, field_name, expected) )))) + | _ -> ( + match primitive_catch_all_kind with + | None -> () + | Some _ -> + (* Must be inline record for primitive catch-all *) + raise + (Error + ( cstr.cd_loc, + TaggedPrimitiveCatchAll_InlineRecordRequired constructor_name + )))) cstrs type well_formedness_check = { @@ -507,6 +643,30 @@ type well_formedness_check = { let check_well_formed ~env {is_untagged_def; cstrs} = check_tag_field_conflicts cstrs; + (* Perform duplicate primitive catch-all checks for tagged variants *) + let number_catchalls = ref 0 in + let string_catchalls = ref 0 in + List.iter + (fun (cstr : Types.constructor_declaration) -> + match + (is_nullary_variant cstr.cd_args, process_tag_type cstr.cd_attributes) + with + | true, Some (Untagged (IntType | FloatType | StringType)) -> + raise + (Error + ( cstr.cd_loc, + TaggedPrimitiveCatchAll_OnNullaryConstructor + (Ident.name cstr.cd_id) )) + | _, Some (Untagged IntType) | _, Some (Untagged FloatType) -> + incr number_catchalls + | _, Some (Untagged StringType) -> incr string_catchalls + | _ -> ()) + cstrs; + if not is_untagged_def then ( + if !number_catchalls > 1 then + raise (Error (Location.none, TaggedPrimitiveCatchAll_AtMostOneNumber)); + if !string_catchalls > 1 then + raise (Error (Location.none, TaggedPrimitiveCatchAll_AtMostOneString))); ignore (names_from_type_variant ~env ~is_untagged_def cstrs) let has_undefined_literal attrs = process_tag_type attrs = Some Undefined diff --git a/docs/TaggedUnionPrimitiveCatchAll.md b/docs/TaggedUnionPrimitiveCatchAll.md new file mode 100644 index 0000000000..876efcba30 --- /dev/null +++ b/docs/TaggedUnionPrimitiveCatchAll.md @@ -0,0 +1,154 @@ +Rationale +Consider a common interop type with a numeric discriminant where only a few literal values are special, and everything else should go to “Other”: + +```res +@tag("kind") +type response = + | @as(202) Ok202({code: int}) + | @as(200) Ok200({code: int}) + | @as(int) Other({kind: int, body: string}) + +let decode = (x: response) => + switch x { + | Ok202(r) => r.code + 1 + | Ok200(r) => r.code + 3 + | Other(r) => r.kind + 2 // any other number lands here + } +``` + +Before this feature, there was no elegant way to express “everything else that’s a number” for a tagged variant. You either had to hand‑write a decoder that inspects `x.kind` and constructs a variant by enumerating all literal cases yourself, or attempt exhaustive matches that still couldn’t represent unknown future values. Hand‑written decoding is tedious, error‑prone, and typically forces you to duplicate the discriminant logic outside the type just to avoid runtime match failures. + +With a primitive catch‑all annotation like `@as(int|float|string)`, the type itself states the intent. The compiler generates literal‑first checks over the discriminant field and only then falls back to a single primitive “catch all” branch. This captures the real‑world use case (you only care about a few literals; everything else of that primitive kind is one case), avoids bespoke decoders, and stays sound even when a particular match expression doesn’t enumerate all literal members. + +Title: Tagged-Union Primitive Catch‑All (@as(int|float|string)) + +Summary + +- Allow a single catch‑all case per primitive kind in tagged unions declared with `@tag("…")`. +- Syntax: use `@as(int)`, `@as(float)`, or `@as(string)` on a payload constructor to denote: “match any value of this JS primitive type that isn’t one of the explicit literal tags.” +- Evaluation order: always test literal tags first; only if none match, test the primitive catch‑all of that kind. +- Mirrors existing behavior for `@unboxed` variants, but works for regular tagged variants as well. + +Motivation + +- Interop scenarios often have a numeric/string "discriminant" where only a handful of literal values have special meaning; everything else of that primitive kind should map to one “Other” constructor. +- Today we can model this for `@unboxed` variants. This proposal extends the same ergonomics to regular `@tag` variants. + +Syntax and Examples + +- Definition: + @tag("kind") + type response = + | @as(202) Ok202({..}) + | @as(200) Ok200({..}) + | @as(int) Other({..}) + +- Allowed primitive catch‑alls: `int`, `float` (both map to JS `number`), `string`. +- Literals remain as today: numbers, strings, booleans, `null`, `undefined`. +- No catch‑all for `null`/`undefined` (they’re literals only). + +Rules and Constraints + +- One per kind: at most one primitive catch‑all per JS primitive kind in a single variant type: + - number: at most one of `@as(int)` or `@as(float)` (they’re equivalent at runtime). + - string: at most one `@as(string)`. +- Ordering: literal tags of a kind are matched first; the primitive catch‑all for that kind is tried only after all its literals fail. +- Applicability: only on constructors with payloads in `@tag("…")` variants. Rejected on nullary constructors and on `@unboxed` types (which already have their own mechanism). +- Soundness in matches: even if a match expression does not list all literal members, codegen must still treat all known literal tags as higher priority than the primitive catch‑all, so we never misroute a literal to the catch‑all. + +Construction (Inline Record Only) + +- Only inline records are allowed for primitive catch‑all constructors. +- Required tag field: + - Exactly one field whose effective runtime name equals the `@tag` name (e.g., `"kind"`). Use `@as("kind")` on that field if its source name differs. + - The field’s type must exactly match the catch‑all primitive: `int`, `float`, or `string` — used directly. No aliases, no abstract types, no expansion. The declared type must literally be one of the builtins. + - The field must be required (non‑optional). + - This specific tag‑name collision is allowed for the primitive catch‑all constructor; for all other constructors, the usual `TagFieldNameConflict` rule remains in force. +- No other payload shapes are permitted (no tuple payloads, no missing payload). +- Construction example: + @tag("kind") + type response = + | @as(202) Ok202({code: int}) + | @as(200) Ok200({code: int}) + | @as(int) Other({kind: int, body: string}) + // Usage: Other({kind: 404, body: "Not Found"}) + +Runtime Semantics + +- Representation is unchanged for normal cases. For primitive catch‑all cases we must provide the actual tag value at construction time via an inline record field whose runtime name equals the `@tag` name (details below). The compiler will not auto‑insert an extra tag property for such constructors (to avoid duplication). +- Pattern matching and switches: + - Compute the discriminant expression `e` as the tag field (e.g., `x.kind`). + - Guard: build a test that determines “is `e` one of the known literal tags?” using all type literals, not just the literals enumerated by the current match. + - If guard passes, jump to the literal branch switch; otherwise, evaluate primitive catch‑all checks (typeof) per the declared catch‑alls. + - For numbers, `int` and `float` share the same `typeof e === "number"` check. We still prefer direct equality against literal numeric tags before the typeof guard. + +Parity With Unboxed Variants + +- Ordering: identical to unboxed variants — first test all literal tags, then test primitive catch‑alls by `typeof`. +- Checks: reuse the existing DynamicChecks machinery; we simply apply it to the tag field (`E.tag ~name:tagName e`) instead of the raw value. +- Kinds: `int` and `float` collapse to JS `number`; `string` maps to JS `string`. `null`/`undefined` remain literals. +- Reuse over fork: we do not introduce a new matching strategy; we activate the existing unboxed dynamic path by making `block_cases` non‑empty for these constructors. + +Compiler Changes + +- Parsing/attributes (ML layer): + - Extend `@as(...)` parsing to accept identifiers `int|float|string` in addition to existing literal payloads. Introduce an internal marker for “primitive catch‑all” on constructors, but do not reuse `Untagged ...` for tag value emission (that would emit the string "number"). +- AST/plumbing: + - In `names_from_type_variant`/`get_block_type`, surface a `block_type` for constructors annotated with a primitive catch‑all (int/float/string) even when the type is not `@unboxed`. This makes the compiler “see” that dynamic typeof checks are required for this tagged union. + - Also carry a small bit on such constructors indicating how to retrieve the dynamic tag value at construction: "from field named tagName present in inline record". +- Well‑formedness checks: + - Add checks (mirroring unboxed invariants) to ensure at most one catch‑all per primitive kind per variant type; treat `int` and `float` as the same “number” bucket. + - Reject primitive catch‑alls on nullary constructors and when combined with `@unboxed`. + - For inline record payloads with primitive catch‑all: require exactly one field whose effective runtime name equals the tag name (e.g., `"kind"`) and whose type matches the primitive; allow this specific tag‑name collision by relaxing `TagFieldNameConflict` in this case. +- Codegen (lambda → JS): + - Reuse existing unboxed dynamic check machinery for `typeof` checks over the tag field expression (`E.tag ~name:tagName e`). This is already implemented via `DynamicChecks` in `ast_untagged_variants.ml` and used from `lam_compile` when `block_cases` is non‑empty. + - Ensure literal guard uses all known literals from the type definition (via `get_literal_cases sw_names`), so missing cases in a match don’t misroute execution to the primitive catch‑all. + - Value construction in `js_dump`: + - For primitive catch‑all + inline record: do not auto‑insert the tag property; the inline record field renamed to the tag name supplies it. +- Error messages / pretty printing: + - Update invalid `@as` diagnostics to include primitive identifiers `int|float|string` when used under `@tag` on payload constructors. + - Improve duplicate‑primitive errors (e.g., “At most one number or one string catch‑all in this variant”). + +Exhaustiveness and Soundness + +- Exhaustiveness warnings behave as today. The presence of a primitive catch‑all does not automatically make matches exhaustive, because explicit literal tags still need coverage. +- JS generation remains sound: the literal‑first guard prevents a runtime value equal to a known literal (e.g., `200`) from being handled by the primitive catch‑all (e.g., `@as(int)`), even when the specific literal branch is not listed in the current match. + +Edge Cases + +- Overlap with literals: if a program constructs a value with a primitive tag equal to a declared literal (e.g., `Other` with `kind=200`), pattern matching still resolves to the literal branch due to guard ordering. We may optionally add a lint/warning when constructing such values. +- Numbers: `int` and `float` both map to JS `number`; we enforce “one number catch‑all” across both. +- Interop: behavior mirrors unboxed variant rules for typeof checks; `null`/`undefined` remain literal‑only. + +Testing Plan + +- Syntax tests: acceptance for `@as(int|float|string)` on payload constructors under `@tag`, and rejections on nullary or non‑tagged types. +- Lambda/JS IR tests: validate guard ordering, emitted typeof checks, and that unmatched literals route to the match default rather than the primitive catch‑all. + - Construction: verify js_dump objects for inline record payloads set the tag from the provided value and do not duplicate it. +- End‑to‑end tests: typical interop scenarios with sparse literal coverage plus a catch‑all, including string/number cases and overlap with `null`/`undefined` literals. +- Negative cases: + - Optional tag field (e.g., `@as("kind") kind?: int`) is rejected. + - Missing tag field in the catch‑all constructor is rejected. + - More than one field with effective tag name is rejected. + - Duplicate primitive catch‑alls (e.g., both `@as(int)` and `@as(float)`) are rejected. + +Implementation Notes (module touchpoints) + +- compiler/ml/ast_untagged_variants.ml + - Extend `process_tag_type` to recognize primitive identifiers; mark constructors as “primitive catch‑all (int|float|string)”. + - In `get_block_type`, surface `Some ` for such constructors (even when not `@unboxed`). + - In `check_invariant`, add “at‑most‑one per kind” checks for tagged primitive catch‑alls; relax `TagFieldNameConflict` when the constructor is a primitive catch‑all and the inline record contains the one required tag‑value field. +- compiler/core/lam_compile.ml + - No structural change: `get_block_cases` becomes non‑empty when a tagged primitive catch‑all exists, which triggers reuse of the existing dynamic check path. The guard for literals vs. non‑literals is already implemented (`is_a_literal_case`). +- compiler/core/js_dump.ml + - In `Blk_record_inlined` and `Blk_constructor` printing, add the construction rules above to set the tag from payload and avoid duplicating it. +- Error/help text updates in `report_error` and related pretty printers. + +Backward Compatibility + +- Existing code is unaffected. New syntax is opt‑in and does not change current matching or codegen for variants without primitive catch‑alls. + +Open Questions + +- Should we emit a warning when constructing a primitive catch‑all value whose tag equals a declared literal (e.g., `Other({kind: 200})`)? This is safe due to guard ordering but might be surprising. +- Should we support a convenience sugar for tuple payloads so that `Other(payload)` can be used and the tag value is pulled from a named payload field automatically? For now we keep the construction rules explicit. diff --git a/tests/build_tests/super_errors/expected/primitive_catchall_duplicate_number.res.expected b/tests/build_tests/super_errors/expected/primitive_catchall_duplicate_number.res.expected new file mode 100644 index 0000000000..0f11413e47 --- /dev/null +++ b/tests/build_tests/super_errors/expected/primitive_catchall_duplicate_number.res.expected @@ -0,0 +1,10 @@ + + We've found a bug for you! + /.../fixtures/primitive_catchall_duplicate_number.res:4:3-43 + + 2 │ type t = + 3 │ | @as(int) A({@as("kind") kind: int}) + 4 │ | @as(float) B({@as("kind") kind: float}) + 5 │ + + Constructor "B": field "kind" must have type int (direct builtin) \ No newline at end of file diff --git a/tests/build_tests/super_errors/expected/primitive_catchall_duplicate_string.res.expected b/tests/build_tests/super_errors/expected/primitive_catchall_duplicate_string.res.expected new file mode 100644 index 0000000000..4773eb4327 --- /dev/null +++ b/tests/build_tests/super_errors/expected/primitive_catchall_duplicate_string.res.expected @@ -0,0 +1,5 @@ + + We've found a bug for you! + /.../fixtures/primitive_catchall_duplicate_string.res + + At most one string catch-all (@as(string)) is allowed per variant \ No newline at end of file diff --git a/tests/build_tests/super_errors/expected/primitive_catchall_inline_record_required.res.expected b/tests/build_tests/super_errors/expected/primitive_catchall_inline_record_required.res.expected new file mode 100644 index 0000000000..7a2bb71152 --- /dev/null +++ b/tests/build_tests/super_errors/expected/primitive_catchall_inline_record_required.res.expected @@ -0,0 +1,9 @@ + + We've found a bug for you! + /.../fixtures/primitive_catchall_inline_record_required.res:2:10-26 + + 1 │ @tag("kind") + 2 │ type t = | @as(int) A(int) + 3 │ + + Constructor "A": primitive catch-all requires an inline record payload \ No newline at end of file diff --git a/tests/build_tests/super_errors/expected/primitive_catchall_missing_tag_field.res.expected b/tests/build_tests/super_errors/expected/primitive_catchall_missing_tag_field.res.expected new file mode 100644 index 0000000000..817e6b0dae --- /dev/null +++ b/tests/build_tests/super_errors/expected/primitive_catchall_missing_tag_field.res.expected @@ -0,0 +1,9 @@ + + We've found a bug for you! + /.../fixtures/primitive_catchall_missing_tag_field.res:2:10-45 + + 1 │ @tag("kind") + 2 │ type t = | @as(int) A({x: int, body: string}) + 3 │ + + Constructor "A": inline record must contain exactly one field named "kind" (or @as("kind")) carrying the discriminant \ No newline at end of file diff --git a/tests/build_tests/super_errors/expected/primitive_catchall_on_nullary.res.expected b/tests/build_tests/super_errors/expected/primitive_catchall_on_nullary.res.expected new file mode 100644 index 0000000000..4882bcecdd --- /dev/null +++ b/tests/build_tests/super_errors/expected/primitive_catchall_on_nullary.res.expected @@ -0,0 +1,9 @@ + + We've found a bug for you! + /.../fixtures/primitive_catchall_on_nullary.res:2:10-21 + + 1 │ @tag("kind") + 2 │ type t = | @as(int) A + 3 │ + + Constructor "A": primitive catch-all requires an inline record payload \ No newline at end of file diff --git a/tests/build_tests/super_errors/expected/primitive_catchall_wrong_type.res.expected b/tests/build_tests/super_errors/expected/primitive_catchall_wrong_type.res.expected new file mode 100644 index 0000000000..eaa93228e1 --- /dev/null +++ b/tests/build_tests/super_errors/expected/primitive_catchall_wrong_type.res.expected @@ -0,0 +1,9 @@ + + We've found a bug for you! + /.../fixtures/primitive_catchall_wrong_type.res:2:10-62 + + 1 │ @tag("kind") + 2 │ type t = | @as(int) A({@as("kind") kind: float, body: string}) + 3 │ + + Constructor "A": field "kind" must have type int (direct builtin) \ No newline at end of file diff --git a/tests/build_tests/super_errors/fixtures/primitive_catchall_duplicate_number.res b/tests/build_tests/super_errors/fixtures/primitive_catchall_duplicate_number.res new file mode 100644 index 0000000000..e86b4ef281 --- /dev/null +++ b/tests/build_tests/super_errors/fixtures/primitive_catchall_duplicate_number.res @@ -0,0 +1,4 @@ +@tag("kind") +type t = + | @as(int) A({@as("kind") kind: int}) + | @as(float) B({@as("kind") kind: float}) diff --git a/tests/build_tests/super_errors/fixtures/primitive_catchall_duplicate_string.res b/tests/build_tests/super_errors/fixtures/primitive_catchall_duplicate_string.res new file mode 100644 index 0000000000..0dd5dfb867 --- /dev/null +++ b/tests/build_tests/super_errors/fixtures/primitive_catchall_duplicate_string.res @@ -0,0 +1,4 @@ +@tag("kind") +type t = + | @as(string) A({@as("kind") kind: string}) + | @as(string) B({@as("kind") kind: string}) diff --git a/tests/build_tests/super_errors/fixtures/primitive_catchall_inline_record_required.res b/tests/build_tests/super_errors/fixtures/primitive_catchall_inline_record_required.res new file mode 100644 index 0000000000..d2bcba1b3a --- /dev/null +++ b/tests/build_tests/super_errors/fixtures/primitive_catchall_inline_record_required.res @@ -0,0 +1,2 @@ +@tag("kind") +type t = | @as(int) A(int) diff --git a/tests/build_tests/super_errors/fixtures/primitive_catchall_missing_tag_field.res b/tests/build_tests/super_errors/fixtures/primitive_catchall_missing_tag_field.res new file mode 100644 index 0000000000..8ceeee4ece --- /dev/null +++ b/tests/build_tests/super_errors/fixtures/primitive_catchall_missing_tag_field.res @@ -0,0 +1,2 @@ +@tag("kind") +type t = | @as(int) A({x: int, body: string}) diff --git a/tests/build_tests/super_errors/fixtures/primitive_catchall_on_nullary.res b/tests/build_tests/super_errors/fixtures/primitive_catchall_on_nullary.res new file mode 100644 index 0000000000..099193dcde --- /dev/null +++ b/tests/build_tests/super_errors/fixtures/primitive_catchall_on_nullary.res @@ -0,0 +1,2 @@ +@tag("kind") +type t = | @as(int) A diff --git a/tests/build_tests/super_errors/fixtures/primitive_catchall_wrong_type.res b/tests/build_tests/super_errors/fixtures/primitive_catchall_wrong_type.res new file mode 100644 index 0000000000..4fb75b4b04 --- /dev/null +++ b/tests/build_tests/super_errors/fixtures/primitive_catchall_wrong_type.res @@ -0,0 +1,2 @@ +@tag("kind") +type t = | @as(int) A({@as("kind") kind: float, body: string}) diff --git a/tests/syntax_tests/data/idempotency/TaggedPrimitiveCatchAll.res b/tests/syntax_tests/data/idempotency/TaggedPrimitiveCatchAll.res new file mode 100644 index 0000000000..598d522975 --- /dev/null +++ b/tests/syntax_tests/data/idempotency/TaggedPrimitiveCatchAll.res @@ -0,0 +1,8 @@ +@tag("kind") +type response = + | @as(202) Ok202({code: int}) + | @as(200) Ok200({code: int}) + | @as(int) Other({@as("kind") kind: int, body: string}) + +let mk = Other({kind: 404, body: "x"}) + diff --git a/tests/tests/src/TaggedVariants.mjs b/tests/tests/src/TaggedVariants.mjs new file mode 100644 index 0000000000..773631f4c0 --- /dev/null +++ b/tests/tests/src/TaggedVariants.mjs @@ -0,0 +1,170 @@ +// Generated by ReScript, PLEASE EDIT WITH CARE + + +function test(x) { + if (x.kind === 200 || x.kind === 202) { + if (x.kind === 202) { + return x.code + 1 | 0; + } else { + return x.code + 3 | 0; + } + } else { + return x.kind + 2 | 0; + } +} + +function classify(x) { + if (x.k === "ok" || x.k === 200) { + if (x.k === 200) { + return "num200"; + } else { + return "strok"; + } + } else if (typeof x.k === "number") { + return "num:" + String(x.k); + } else { + return "str:" + x.k; + } +} + +function classifyPartial(x) { + if (x.k === "ok" || x.k === 200) { + return "lit"; + } else if (typeof x.k === "number") { + return "num:" + String(x.k); + } else { + return "str:" + x.k; + } +} + +let NumAndStrCatchAll_a = { + k: 200, + v: 1 +}; + +let NumAndStrCatchAll_b = { + k: "ok", + msg: "m" +}; + +let NumAndStrCatchAll_c = { + k: 404, + x: 1 +}; + +let NumAndStrCatchAll_d = { + k: "else", + s: "s" +}; + +let NumAndStrCatchAll = { + classify: classify, + classifyPartial: classifyPartial, + a: NumAndStrCatchAll_a, + b: NumAndStrCatchAll_b, + c: NumAndStrCatchAll_c, + d: NumAndStrCatchAll_d +}; + +function route(x) { + if (x.k === "warn" || x.k === 201) { + if (x.k === 201) { + return "n201"; + } else { + return "warn"; + } + } else if (typeof x.k === "number") { + return "n:" + String(x.k); + } else { + return "s:" + x.k; + } +} + +function routePartial(x) { + if (x.k === "warn" || x.k === 201) { + return "lit"; + } else if (typeof x.k === "number") { + return "n:" + String(x.k); + } else { + return "s:" + x.k; + } +} + +let NumAndStrLitsAndCatchAlls_n = { + k: 201, + v: 1 +}; + +let NumAndStrLitsAndCatchAlls_w = { + k: "warn", + level: 2 +}; + +let NumAndStrLitsAndCatchAlls_on = { + k: 451, + payload: 0 +}; + +let NumAndStrLitsAndCatchAlls_os = { + k: "other", + payload: "" +}; + +let NumAndStrLitsAndCatchAlls = { + route: route, + routePartial: routePartial, + n: NumAndStrLitsAndCatchAlls_n, + w: NumAndStrLitsAndCatchAlls_w, + on: NumAndStrLitsAndCatchAlls_on, + os: NumAndStrLitsAndCatchAlls_os +}; + +function sum(x) { + if (x.k !== 3 && x.k !== 1 && x.k !== 2) { + return x.k + x.y | 0; + } + switch (x.k) { + case 1 : + return x.x + 10 | 0; + case 2 : + return x.x + 20 | 0; + case 3 : + return x.x + 30 | 0; + } +} + +let ManyNumLiteralsWithCatchAll_a = { + k: 1, + x: 1 +}; + +let ManyNumLiteralsWithCatchAll_b = { + k: 2, + x: 2 +}; + +let ManyNumLiteralsWithCatchAll_c = { + k: 3, + x: 3 +}; + +let ManyNumLiteralsWithCatchAll_d = { + k: 42, + y: 1 +}; + +let ManyNumLiteralsWithCatchAll = { + sum: sum, + a: ManyNumLiteralsWithCatchAll_a, + b: ManyNumLiteralsWithCatchAll_b, + c: ManyNumLiteralsWithCatchAll_c, + d: ManyNumLiteralsWithCatchAll_d +}; + +export { + test, + NumAndStrCatchAll, + NumAndStrLitsAndCatchAlls, + ManyNumLiteralsWithCatchAll, +} +/* No side effect */ diff --git a/tests/tests/src/TaggedVariants.res b/tests/tests/src/TaggedVariants.res new file mode 100644 index 0000000000..4aad5a44af --- /dev/null +++ b/tests/tests/src/TaggedVariants.res @@ -0,0 +1,98 @@ +@tag("kind") +type response = + | @as(202) Ok202({code: int}) + | @as(200) Ok200({code: int}) + | @as(int) Other({@as("kind") kind: int, body: string}) + +let test = (x: response) => + switch x { + | Ok202(r) => r.code + 1 + | Other(r) => r.kind + 2 + | Ok200(r) => r.code + 3 + } + +/* Mixed number + string catch-alls */ +module NumAndStrCatchAll = { + @tag("k") + type t = + | @as(200) Num200({v: int}) + | @as("ok") StrOk({msg: string}) + | @as(int) OtherNum({@as("k") k: int, x: int}) + | @as(string) OtherStr({@as("k") k: string, s: string}) + + let classify = (x: t): string => + switch x { + | Num200(_) => "num200" + | StrOk(_) => "strok" + | OtherNum(r) => "num:" ++ string_of_int(r.k) + | OtherStr(r) => "str:" ++ r.k + } + + /* Intentionally not enumerating literals here. We want to ensure + literals still win before the primitive catch-alls. */ + let classifyPartial = (x: t): string => + switch x { + | OtherNum(r) => "num:" ++ string_of_int(r.k) + | OtherStr(r) => "str:" ++ r.k + | _ => "lit" + } + + let a = Num200({v: 1}) + let b = StrOk({msg: "m"}) + let c = OtherNum({k: 404, x: 1}) + let d = OtherStr({k: "else", s: "s"}) +} + +/* Number + string literals and both catch-alls */ +module NumAndStrLitsAndCatchAlls = { + @tag("k") + type t = + | @as(201) Num201({v: int}) + | @as("warn") Warn({level: int}) + | @as(int) OtherNum({@as("k") k: int, payload: int}) + | @as(string) OtherStr({@as("k") k: string, payload: string}) + + let route = (x: t): string => + switch x { + | Num201(_) => "n201" + | Warn(_) => "warn" + | OtherNum(r) => "n:" ++ string_of_int(r.k) + | OtherStr(r) => "s:" ++ r.k + } + + /* Only match catch-alls; literals should still not be misrouted */ + let routePartial = (x: t): string => + switch x { + | OtherNum(r) => "n:" ++ string_of_int(r.k) + | OtherStr(r) => "s:" ++ r.k + | _ => "lit" + } + + let n = Num201({v: 1}) + let w = Warn({level: 2}) + let on = OtherNum({k: 451, payload: 0}) + let os = OtherStr({k: "other", payload: ""}) +} + +/* Three+ same-kind literals to exercise switch(x.k) shape */ +module ManyNumLiteralsWithCatchAll = { + @tag("k") + type t = + | @as(1) One({x: int}) + | @as(2) Two({x: int}) + | @as(3) Three({x: int}) + | @as(int) Other({@as("k") k: int, y: int}) + + let sum = (x: t): int => + switch x { + | One(r) => r.x + 10 + | Two(r) => r.x + 20 + | Three(r) => r.x + 30 + | Other(r) => r.k + r.y + } + + let a = One({x: 1}) + let b = Two({x: 2}) + let c = Three({x: 3}) + let d = Other({k: 42, y: 1}) +}