From 6d39111992d564b2319a7d03b3db4f02ba71f07e Mon Sep 17 00:00:00 2001 From: giles Date: Thu, 7 May 2026 00:13:41 +0000 Subject: [PATCH] =?UTF-8?q?sx:=20step=208=20=E2=80=94=20non-exhaustive=20m?= =?UTF-8?q?atch=20warnings?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit 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) --- hosts/javascript/platform.py | 12 ++++ hosts/ocaml/lib/sx_primitives.ml | 5 ++ hosts/ocaml/lib/sx_ref.ml | 73 +++++++++++++++++++++- hosts/ocaml/lib/sx_runtime.ml | 4 ++ plans/sx-improvements.md | 14 ++++- shared/static/scripts/sx-browser.js | 62 ++++++++++++++++++- spec/evaluator.sx | 95 ++++++++++++++++++++++++++--- spec/tests/test-adt.sx | 31 +++++++++- 8 files changed, 281 insertions(+), 15 deletions(-) diff --git a/hosts/javascript/platform.py b/hosts/javascript/platform.py index 9aaa86a8..4cb8bec5 100644 --- a/hosts/javascript/platform.py +++ b/hosts/javascript/platform.py @@ -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(), [], [])); diff --git a/hosts/ocaml/lib/sx_primitives.ml b/hosts/ocaml/lib/sx_primitives.ml index a06292b7..a013a425 100644 --- a/hosts/ocaml/lib/sx_primitives.ml +++ b/hosts/ocaml/lib/sx_primitives.ml @@ -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] -> diff --git a/hosts/ocaml/lib/sx_ref.ml b/hosts/ocaml/lib/sx_ref.ml index c8d8d4ff..e71a889e 100644 --- a/hosts/ocaml/lib/sx_ref.ml +++ b/hosts/ocaml/lib/sx_ref.ml @@ -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 = diff --git a/hosts/ocaml/lib/sx_runtime.ml b/hosts/ocaml/lib/sx_runtime.ml index fa82df5b..5ef5ef24 100644 --- a/hosts/ocaml/lib/sx_runtime.ml +++ b/hosts/ocaml/lib/sx_runtime.ml @@ -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 diff --git a/plans/sx-improvements.md b/plans/sx-improvements.md index e7258c5a..f91ab610 100644 --- a/plans/sx-improvements.md +++ b/plans/sx-improvements.md @@ -142,6 +142,18 @@ zero regressions (OCaml 4532→4540, JS 2578→2586). On first non-exhaustive `match` evaluation: `console.warn("[sx] match: non-exhaustive …")`. No error — warning only. +**Outcome:** `host-warn` primitive added on both hosts (OCaml `prerr_endline`, +JS `console.warn`). Spec-level helpers `match-clause-is-else?`, +`match-clause-ctor-name`, `match-warn-non-exhaustive`, +`match-check-exhaustiveness` added in `spec/evaluator.sx` and +called from `step-sf-match`. `*adt-warned*` env-bound dict used to +dedupe warnings per (type, missing-set). The OCaml `step_sf_match` +in `hosts/ocaml/lib/sx_ref.ml` was hand-patched (not retranspiled) +because `sx_ref.ml` retranspilation drops several preamble fixes; +the spec changes still flow to JS via `sx_build target="js"`. Both +hosts emit identical warnings (e.g. `[sx] match: non-exhaustive — Maybe: missing Nothing`). +5 new tests added. OCaml: 4540 → 4545. JS: 2586 → 2591. Zero regressions. + --- ## Phase 4 — Plugin / extension system @@ -202,7 +214,7 @@ these when operands are known numbers/lists. | 5 — OCaml AdtValue + define-type + match | [x] | 1f49242a | | 6 — JS AdtValue + define-type + match | [x] | fc8a3916 | | 7 — nested patterns | [x] | 0679edf5 | -| 8 — exhaustiveness warnings | [ ] | — | +| 8 — exhaustiveness warnings | [x] | (pending) | | 9 — parser feature registry | [ ] | — | | 10 — compiler + as converter registry | [ ] | — | | 11 — plugin migration + worker | [ ] | — | diff --git a/shared/static/scripts/sx-browser.js b/shared/static/scripts/sx-browser.js index 1573e2ac..55adb165 100644 --- a/shared/static/scripts/sx-browser.js +++ b/shared/static/scripts/sx-browser.js @@ -41,7 +41,7 @@ // ========================================================================= var NIL = Object.freeze({ _nil: true, toString: function() { return "nil"; } }); - var SX_VERSION = "2026-05-06T23:01:54Z"; + var SX_VERSION = "2026-05-07T00:02:13Z"; function isNil(x) { return x === NIL || x === null || x === undefined; } function isSxTruthy(x) { return x !== false && !isNil(x); } @@ -378,6 +378,13 @@ // 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; @@ -3301,14 +3308,58 @@ PRIMITIVES["match-find-clause"] = matchFindClause; })()) : sxEq(pattern, value))))))))); }; PRIMITIVES["match-pattern"] = matchPattern; + // match-clause-is-else? + var matchClauseIsElse_p = function(clause) { return (function() { + var p = first(clause); + return sxOr(sxEq(p, new Symbol("_")), sxEq(p, new Symbol("else")), sxEq(p, "else")); +})(); }; +PRIMITIVES["match-clause-is-else?"] = matchClauseIsElse_p; + + // match-clause-ctor-name + var matchClauseCtorName = function(clause) { return (function() { + var p = first(clause); + return (isSxTruthy((isSxTruthy(isList(p)) && isSxTruthy(!isSxTruthy(isEmpty(p))) && symbol_p(first(p)))) ? symbolName(first(p)) : (isSxTruthy((isSxTruthy(symbol_p(p)) && isSxTruthy(!isSxTruthy(sxEq(p, new Symbol("_")))) && !isSxTruthy(sxEq(p, new Symbol("else"))))) ? NIL : NIL)); +})(); }; +PRIMITIVES["match-clause-ctor-name"] = matchClauseCtorName; + + // match-warn-non-exhaustive + var matchWarnNonExhaustive = function(env, typeName, registered, clauseCtors) { return (function() { + var missing = filter(function(c) { return !isSxTruthy(contains(clauseCtors, c)); }, registered); + if (isSxTruthy(!isSxTruthy(isEmpty(missing)))) { + if (isSxTruthy(!isSxTruthy(envHas(env, "*adt-warned*")))) { + envBind(env, "*adt-warned*", {}); +} +(function() { + var warned = envGet(env, "*adt-warned*"); + var key = (String(typeName) + String("|") + String(join(",", missing))); + return (isSxTruthy(!isSxTruthy(get(warned, key))) ? (dictSet(warned, key, true), hostWarn((String("[sx] match: non-exhaustive — ") + String(typeName) + String(": missing ") + String(join(", ", missing))))) : NIL); +})(); +} + return NIL; +})(); }; +PRIMITIVES["match-warn-non-exhaustive"] = matchWarnNonExhaustive; + + // match-check-exhaustiveness + var matchCheckExhaustiveness = function(val, clauses, env) { return (isSxTruthy((isSxTruthy(isDict(val)) && get(val, "_adt"))) ? (function() { + var typeName = get(val, "_type"); + return (isSxTruthy((isSxTruthy(envHas(env, "*adt-registry*")) && typeName)) ? (function() { + var registered = get(envGet(env, "*adt-registry*"), typeName); + return (isSxTruthy((isSxTruthy(registered) && !isSxTruthy(some(matchClauseIsElse_p, clauses)))) ? (function() { + var clauseCtors = filter(function(n) { return !isSxTruthy(isNil(n)); }, map(matchClauseCtorName, clauses)); + return matchWarnNonExhaustive(env, typeName, registered, clauseCtors); +})() : NIL); +})() : NIL); +})() : NIL); }; +PRIMITIVES["match-check-exhaustiveness"] = matchCheckExhaustiveness; + // step-sf-match var stepSfMatch = function(args, env, kont) { return (function() { var val = trampoline(evalExpr(first(args), env)); var clauses = rest(args); - return (function() { + return (matchCheckExhaustiveness(val, clauses, env), (function() { var result = matchFindClause(val, clauses, env); return (isSxTruthy(isNil(result)) ? makeCekValue((String("match: no clause matched ") + String(inspect(val))), env, kontPush(makeRaiseEvalFrame(env, false), kont)) : makeCekState(nth(result, 1), first(result), kont)); -})(); +})()); })(); }; PRIMITIVES["step-sf-match"] = stepSfMatch; @@ -4874,6 +4925,11 @@ PRIMITIVES["boot-init"] = bootInit; // ----------------------------------------------------------------------- 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(), [], [])); diff --git a/spec/evaluator.sx b/spec/evaluator.sx index 6b0adae8..c360f040 100644 --- a/spec/evaluator.sx +++ b/spec/evaluator.sx @@ -2903,6 +2903,81 @@ pairs))) :else (= pattern value)))) +(define + match-clause-is-else? + (fn + (clause) + (let + ((p (first clause))) + (or + (= p (quote _)) + (= p (quote else)) + (= p :else))))) + +(define + match-clause-ctor-name + (fn + (clause) + (let + ((p (first clause))) + (cond + (and (list? p) (not (empty? p)) (symbol? (first p))) + (symbol-name (first p)) + (and (symbol? p) (not (= p (quote _))) (not (= p (quote else)))) + nil + :else nil)))) + +(define + match-warn-non-exhaustive + (fn + (env type-name registered clause-ctors) + (let + ((missing + (filter (fn (c) (not (contains? clause-ctors c))) registered))) + (when + (not (empty? missing)) + (do + (when + (not (env-has? env "*adt-warned*")) + (env-bind! env "*adt-warned*" (dict))) + (let + ((warned (env-get env "*adt-warned*")) + (key (str type-name "|" (join "," missing)))) + (when + (not (get warned key)) + (do + (dict-set! warned key true) + (host-warn + (str + "[sx] match: non-exhaustive — " + type-name + ": missing " + (join ", " missing)))))))) + nil))) + +(define + match-check-exhaustiveness + (fn + (val clauses env) + (when + (and (dict? val) (get val :_adt)) + (let + ((type-name (get val :_type))) + (when + (and (env-has? env "*adt-registry*") type-name) + (let + ((registered + (get (env-get env "*adt-registry*") type-name))) + (when + (and registered (not (some match-clause-is-else? clauses))) + (let + ((clause-ctors + (filter + (fn (n) (not (nil? n))) + (map match-clause-ctor-name clauses)))) + (match-warn-non-exhaustive + env type-name registered clause-ctors))))))))) + (define step-sf-match (fn @@ -2910,15 +2985,17 @@ (let ((val (trampoline (eval-expr (first args) env))) (clauses (rest args))) - (let - ((result (match-find-clause val clauses env))) - (if - (nil? result) - (make-cek-value - (str "match: no clause matched " (inspect val)) - env - (kont-push (make-raise-eval-frame env false) kont)) - (make-cek-state (nth result 1) (first result) kont)))))) + (do + (match-check-exhaustiveness val clauses env) + (let + ((result (match-find-clause val clauses env))) + (if + (nil? result) + (make-cek-value + (str "match: no clause matched " (inspect val)) + env + (kont-push (make-raise-eval-frame env false) kont)) + (make-cek-state (nth result 1) (first result) kont))))))) (define step-sf-handler-bind diff --git a/spec/tests/test-adt.sx b/spec/tests/test-adt.sx index 78301d15..c9a8a050 100644 --- a/spec/tests/test-adt.sx +++ b/spec/tests/test-adt.sx @@ -454,4 +454,33 @@ (match (WX (LeftX 9)) ((WX (LeftX v)) (str "left-" v)) - ((WX (RightX v)) (str "right-" v))))))) + ((WX (RightX v)) (str "right-" v)))))) + (deftest + "exhaustive match runs without error" + (do + (define-type ExA1 (CaA1 v) (CbA1)) + (assert= 1 (match (CaA1 1) ((CaA1 x) x) ((CbA1) 0))) + (assert= 0 (match (CbA1) ((CaA1 x) x) ((CbA1) 0))))) + (deftest + "non-exhaustive match still returns value (warning is non-fatal)" + (do + (define-type ExA2 (CaA2 v) (CbA2)) + (assert= 9 (match (CaA2 9) ((CaA2 x) x))))) + (deftest + "match with else clause suppresses non-exhaustive warning" + (do + (define-type ExA3 (CaA3 v) (CbA3) (CcA3)) + (assert= "a" (match (CaA3 1) ((CaA3 x) "a") (else "other"))) + (assert= "other" (match (CbA3) ((CaA3 x) "a") (else "other"))))) + (deftest + "match with all-but-one constructor still runs" + (do + (define-type ExA4 (CaA4 v) (CbA4) (CcA4)) + (assert= 5 (match (CaA4 5) ((CaA4 x) x) ((CbA4) 0))) + (assert= 0 (match (CbA4) ((CaA4 x) x) ((CbA4) 0))))) + (deftest + "match wildcard pattern suppresses non-exhaustive warning" + (do + (define-type ExA5 (CaA5 v) (CbA5)) + (assert= 7 (match (CaA5 7) ((CaA5 x) x) (_ 0))) + (assert= 0 (match (CbA5) ((CaA5 x) x) (_ 0))))))