sx: step 8 — non-exhaustive match warnings
Emit a warning when a `match` expression on an ADT value misses one or more constructors and lacks an `else`/`_` clause. Behaviour is non-fatal — the match still runs, the warning goes to stderr. - spec/evaluator.sx: helpers `match-clause-is-else?`, `match-clause-ctor-name`, `match-warn-non-exhaustive`, `match-check-exhaustiveness`. The latter reads the `*adt-registry*` (already populated by `define-type`), collects constructor patterns from clauses, and dedupes via an `*adt-warned*` env-bound dict so each (type, missing-set) warns once. Wired into `step-sf-match` via a `do` block before clause dispatch. - hosts/javascript/platform.py: `host-warn` primitive (`console.warn`) + matching `hostWarn` js-id helper so the JS-transpiled spec code can call it directly. Spec code reaches JS via `sx_build target=js`. - hosts/ocaml/lib/sx_runtime.ml + sx_primitives.ml: `host-warn` runtime helper (`prerr_endline`) and registered primitive. - hosts/ocaml/lib/sx_ref.ml: HAND-PATCHED. `step_sf_match` now calls a hand-written `match_check_exhaustiveness` that handles both `AdtValue` and back-compat dict-shape ADT values. The OCaml side is *not* retranspiled because regenerating sx_ref.ml drops several preamble fixes (seq_to_list, string->symbol mangling, empty-dict literal bug). Future retranspile must reapply this patch. - spec/tests/test-adt.sx: 5 new tests covering exhaustive, non-exhaustive (warning is non-fatal), `else` suppression, partial coverage with one missing constructor, and `_` wildcard suppression. Tests assert return values only — warnings go to stderr and are not captured. Warning format: `[sx] match: non-exhaustive — TypeName: missing Ctor1, Ctor2` Both hosts emit identical messages. Tests: OCaml 4540 → 4545 (+5), JS 2586 → 2591 (+5). Zero regressions. Co-Authored-By: Claude Opus 4.7 (1M context) <noreply@anthropic.com>
This commit is contained in:
@@ -2124,6 +2124,13 @@ PLATFORM_JS_PRE = '''
|
||||
// hostError — throw a host-level error that propagates out of cekRun.
|
||||
function hostError(msg) { throw new Error(typeof msg === "string" ? msg : inspect(msg)); }
|
||||
|
||||
// hostWarn — emit a host-level warning to console (no-op if console missing).
|
||||
function hostWarn(msg) {
|
||||
var m = typeof msg === "string" ? msg : inspect(msg);
|
||||
if (typeof console !== "undefined" && console.warn) console.warn(m);
|
||||
return NIL;
|
||||
}
|
||||
|
||||
// Render dispatch — call the active adapter's render function.
|
||||
// Set by each adapter when loaded; defaults to identity (no rendering).
|
||||
var _renderExprFn = null;
|
||||
@@ -4010,6 +4017,11 @@ def fixups_js(has_html, has_sx, has_dom, has_signals=False, has_deps=False, has_
|
||||
// -----------------------------------------------------------------------
|
||||
PRIMITIVES["error"] = function(msg) { throw new Error(msg); };
|
||||
PRIMITIVES["host-error"] = function(msg) { throw new Error(typeof msg === "string" ? msg : inspect(msg)); };
|
||||
PRIMITIVES["host-warn"] = function(msg) {
|
||||
var m = typeof msg === "string" ? msg : inspect(msg);
|
||||
if (typeof console !== "undefined" && console.warn) console.warn(m);
|
||||
return NIL;
|
||||
};
|
||||
PRIMITIVES["try-catch"] = function(tryFn, catchFn) {
|
||||
try {
|
||||
return cekRun(continueWithCall(tryFn, [], makeEnv(), [], []));
|
||||
|
||||
@@ -1281,6 +1281,11 @@ let () =
|
||||
match args with [String msg] -> raise (Eval_error msg)
|
||||
| [a] -> raise (Eval_error (to_string a))
|
||||
| _ -> raise (Eval_error "host-error: 1 arg"));
|
||||
register "host-warn" (fun args ->
|
||||
match args with
|
||||
| [String msg] -> prerr_endline msg; Nil
|
||||
| [a] -> prerr_endline (to_string a); Nil
|
||||
| _ -> raise (Eval_error "host-warn: 1 arg"));
|
||||
register "try-catch" (fun args ->
|
||||
match args with
|
||||
| [try_fn; catch_fn] ->
|
||||
|
||||
@@ -759,7 +759,78 @@ and match_pattern pattern value env =
|
||||
|
||||
(* step-sf-match *)
|
||||
and step_sf_match args env kont =
|
||||
(let val' = (trampoline ((eval_expr ((first (args))) (env)))) in let clauses = (rest (args)) in (let result' = (match_find_clause (val') (clauses) (env)) in (if sx_truthy ((is_nil (result'))) then (make_cek_value ((String (sx_str [(String "match: no clause matched "); (inspect (val'))]))) (env) ((kont_push ((make_raise_eval_frame (env) ((Bool false)))) (kont)))) else (make_cek_state ((nth (result') ((Number 1.0)))) ((first (result'))) (kont)))))
|
||||
(let val' = (trampoline ((eval_expr ((first (args))) (env)))) in let clauses = (rest (args)) in (let () = ignore (match_check_exhaustiveness val' clauses env) in (let result' = (match_find_clause (val') (clauses) (env)) in (if sx_truthy ((is_nil (result'))) then (make_cek_value ((String (sx_str [(String "match: no clause matched "); (inspect (val'))]))) (env) ((kont_push ((make_raise_eval_frame (env) ((Bool false)))) (kont)))) else (make_cek_state ((nth (result') ((Number 1.0)))) ((first (result'))) (kont))))))
|
||||
|
||||
(* match-check-exhaustiveness — Step 8 hand-patched into sx_ref.ml *)
|
||||
and match_check_exhaustiveness val' clauses env =
|
||||
let is_else_pat p =
|
||||
match p with
|
||||
| Symbol "_" | Symbol "else" -> true
|
||||
| Keyword "else" -> true
|
||||
| _ -> false
|
||||
in
|
||||
let clause_is_else c =
|
||||
match c with
|
||||
| List (p :: _) -> is_else_pat p
|
||||
| _ -> false
|
||||
in
|
||||
let clause_ctor_name c =
|
||||
match c with
|
||||
| List (List (Symbol n :: _) :: _) -> Some n
|
||||
| _ -> None
|
||||
in
|
||||
let type_name_opt = match val' with
|
||||
| AdtValue a -> Some a.av_type
|
||||
| Dict d ->
|
||||
(match Hashtbl.find_opt d "_adt" with
|
||||
| Some (Bool true) ->
|
||||
(match Hashtbl.find_opt d "_type" with
|
||||
| Some (String s) -> Some s
|
||||
| _ -> None)
|
||||
| _ -> None)
|
||||
| _ -> None
|
||||
in
|
||||
match type_name_opt with
|
||||
| None -> Nil
|
||||
| Some type_name ->
|
||||
if not (sx_truthy (env_has env (String "*adt-registry*"))) then Nil
|
||||
else
|
||||
let registry = env_get env (String "*adt-registry*") in
|
||||
let registered = match registry with
|
||||
| Dict r ->
|
||||
(match Hashtbl.find_opt r type_name with
|
||||
| Some (List ctors) -> Some ctors
|
||||
| _ -> None)
|
||||
| _ -> None in
|
||||
(match registered with
|
||||
| None -> Nil
|
||||
| Some ctor_vals ->
|
||||
let clauses_list = match clauses with List xs -> xs | _ -> [] in
|
||||
if List.exists clause_is_else clauses_list then Nil
|
||||
else
|
||||
let clause_ctors = List.filter_map clause_ctor_name clauses_list in
|
||||
let registered_names = List.filter_map (function
|
||||
| String s -> Some s | _ -> None) ctor_vals in
|
||||
let missing = List.filter (fun c -> not (List.mem c clause_ctors)) registered_names in
|
||||
if missing = [] then Nil
|
||||
else begin
|
||||
if not (sx_truthy (env_has env (String "*adt-warned*"))) then
|
||||
ignore (env_bind env (String "*adt-warned*") (Dict (Hashtbl.create 4)));
|
||||
let warned = env_get env (String "*adt-warned*") in
|
||||
let key = type_name ^ "|" ^ String.concat "," missing in
|
||||
let already = match warned with
|
||||
| Dict w -> (match Hashtbl.find_opt w key with Some (Bool true) -> true | _ -> false)
|
||||
| _ -> false in
|
||||
if already then Nil
|
||||
else begin
|
||||
(match warned with
|
||||
| Dict w -> Hashtbl.replace w key (Bool true)
|
||||
| _ -> ());
|
||||
let msg = "[sx] match: non-exhaustive — " ^ type_name ^ ": missing " ^ String.concat ", " missing in
|
||||
ignore (host_warn (String msg));
|
||||
Nil
|
||||
end
|
||||
end)
|
||||
|
||||
(* step-sf-handler-bind *)
|
||||
and step_sf_handler_bind args env kont =
|
||||
|
||||
@@ -411,6 +411,10 @@ let callcc_continuation_winders_len v = match v with
|
||||
let host_error msg =
|
||||
raise (Eval_error (value_to_str msg))
|
||||
|
||||
let host_warn msg =
|
||||
prerr_endline (value_to_str msg);
|
||||
Nil
|
||||
|
||||
let dynamic_wind_call before body after _env =
|
||||
ignore (sx_call before []);
|
||||
let result = sx_call body [] in
|
||||
|
||||
Reference in New Issue
Block a user