coop/rose-ash
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

sx: step 8 — non-exhaustive match warnings

Browse Source 
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:
giles
2026-05-07 00:13:41 +00:00
parent 7b050fb217
commit 6d39111992
8 changed files with 281 additions and 15 deletions
Download Patch File Download Diff File Expand all files Collapse all files

12
hosts/javascript/platform.py
View File

@@ -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(), [], []));

5
hosts/ocaml/lib/sx_primitives.ml
View File

@@ -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] ->

73
hosts/ocaml/lib/sx_ref.ml
View File

@@ -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 =

4
hosts/ocaml/lib/sx_runtime.ml
View File

@@ -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

14
plans/sx-improvements.md
View File

@@ -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 | [ ] | — |

62
shared/static/scripts/sx-browser.js
View File

@@ -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(), [], []));

95
spec/evaluator.sx
View File

@@ -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

31
spec/tests/test-adt.sx
View File

@@ -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))))))