(* Reader tests. Plain assertions, no test framework — another dependency that
   would have to be reimplemented if the compiler is ever self-hosted. *)

open Flan

(* The watchdog first: a hang is the one failure mode that reports
   nothing at all. See watchdog.ml. *)
let () = Watchdog.arm ~seconds:600 "test_flan"

let failures = ref 0

let check name cond =
  if not cond then begin
    incr failures;
    Printf.printf "FAIL  %s\n" name
  end

let contains hay needle =
  let n = String.length needle and h = String.length hay in
  let rec go i = i + n <= h && (String.sub hay i n = needle || go (i + 1)) in
  n = 0 || go 0

(* Every read in this table runs under a five-second alarm. The reader is the
   one part of the compiler whose mistakes loop rather than raise — a branch
   that forgets to advance reads the same character for ever — and a hanging
   case reports nothing at all. Five seconds is thousands of times what any
   row here needs; what it buys is that a loop becomes a named failing row and
   the rest of the table still runs. *)
(* Once one read has not returned, the reader is looping and every row after
   it would spend the same five seconds proving the same thing — a hundred
   rows is eight minutes of that. So the first timeout wedges the rest: they
   fail immediately and the binary still reports, which is the whole point of
   the alarm. *)
let wedged = ref false

let guarded seconds f =
  if !wedged then raise Watchdog.Timeout
  else
    match Watchdog.within seconds f with
    | x -> x
    | exception Watchdog.Timeout -> wedged := true; raise Watchdog.Timeout

let read ?(file = "<test>") src =
  guarded 5 (fun () -> Reader.read_all ~file src)

(* The corpus files, which are larger and are read from disk. *)
let read_file path = guarded 30 (fun () -> Reader.read_file path)

let reads name src expected =
  match read src with
  | forms ->
    let got = String.concat " " (List.map Form.to_string forms) in
    if got <> expected then begin
      incr failures;
      Printf.printf "FAIL  %s\n        src: %s\n        got: %s\n    wanted: %s\n"
        name src got expected
    end
  | exception Loc.Error { Loc.dloc = loc; dmsg = msg; _ } ->
    incr failures;
    Printf.printf "FAIL  %s\n        src: %s\n      error: %s: %s\n"
      name src (Loc.to_string loc) msg
  | exception Watchdog.Timeout ->
    incr failures;
    Printf.printf "FAIL  %s\n        src: %s\n      the reader did not return\n"
      name src

(* [needle] is the point: a read error that fires for the wrong reason is not
   the test passing. Without it "backtick at end of input" would be green even
   if the backtick were still an ordinary symbol character. *)
let rejects ?needle name src =
  match read src with
  | _ -> incr failures; Printf.printf "FAIL  %s: expected a read error\n" name
  | exception Watchdog.Timeout ->
    incr failures;
    Printf.printf "FAIL  %s: the reader did not return\n" name
  | exception Loc.Error { Loc.dmsg = msg; _ } ->
    (match needle with
     | Some n when not (contains msg n) ->
       incr failures;
       Printf.printf "FAIL  %s\n      error: %s\n     wanted: ...%s...\n" name msg n
     | _ -> ())

let () =
  (* ── Atoms ─────────────────────────────────────────────────────── *)
  reads "integer"        "42" "42";
  reads "negative"       "-1" "-1";
  (* A sign is part of the number, both ways. [+5] is the one that reads as a
     symbol the moment the '+' case is dropped from the dispatch, and a symbol
     named "+5" is an unknown name much later and somewhere else. *)
  reads "leading plus"   "+5" "5";
  reads "plus float"     "+0.5" "0.5";
  reads "plus in a call" "(f +5 -5)" "(f 5 -5)";
  (* And the operator is still itself: [+] alone is the addition symbol, and
     [(+ 1 2)] must not read its head as a number. *)
  reads "bare plus"      "+" "+";
  reads "float"          "0.05" "0.05";
  reads "hex"            "0xE6B800FF" "3870818559";
  reads "string"         "\"SAND\"" "\"SAND\"";
  reads "symbol"         "empty-at?" "empty-at?";
  reads "qualified"      "rl/draw-fps" "rl/draw-fps";
  reads "field access"   ".pos" ".pos";
  reads "operator"       "->>" "->>";
  reads "bare minus"     "-" "-";
  reads "keyword"        ":space" ":space";
  reads "else keyword"   ":else" ":else";

  (* Byte literals, as used by calc-me's tokenizer. *)
  reads "byte named"     "\\space" "\\space";
  reads "byte digit"     "\\0" "\\0";
  reads "byte paren"     "\\(" "\\(";
  reads "byte dot"       "\\." "\\.";

  (* ── Sequences ─────────────────────────────────────────────────── *)
  reads "list"           "(+ 1 2)" "(+ 1 2)";
  reads "vector"         "[1 2 3]" "[1 2 3]";
  reads "map literal"    "{.src src .pos 0}" "{.src src .pos 0}";
  reads "type notation"  "[4 f32]" "[4 f32]";
  reads "nested type"    "[rows [cols u32]]" "[rows [cols u32]]";
  reads "commas as space" "[1, 2, 3]" "[1 2 3]";
  reads "nested"         "(a (b [c {.d e}]))" "(a (b [c {.d e}]))";

  (* ── Trivia ────────────────────────────────────────────────────── *)
  reads "line comment"   "; nope\n42" "42";
  reads "trailing comment" "42 ; nope" "42";
  reads "banner comment" ";;;; header\n(f)" "(f)";
  reads "multiple forms" "(a) (b)" "(a) (b)";
  reads "empty source"   "" "";
  reads "only comments"  "; nothing here" "";

  (* ── Quote ─────────────────────────────────────────────────────── *)
  (* Restart names are quoted symbols. Before this existed, 'skip-form read as
     a symbol *named* "'skip-form", which is silently a different symbol from
     skip-form and nothing would ever have reported it. *)
  reads "quote symbol" "'skip-form" "(quote skip-form)";
  reads "quote in call" "(invoke-restart 'use-placeholder)"
                        "(invoke-restart (quote use-placeholder))";
  reads "quote list"    "'(a b)" "(quote (a b))";

  (* ── Quasiquote ────────────────────────────────────────────────── *)
  (* The bug this closes: a backtick was an ordinary symbol character, so
     `(a b) came back as the unknown name "`" — the apostrophe's old failure
     mode, still open one sigil over. Clojure's ` ~ ~@ rather than Common
     Lisp's ` , ,@ because a comma is whitespace here and every binding vector
     depends on that. *)
  reads "quasiquote list"   "`(a b)" "(quasiquote (a b))";
  reads "unquote"           "`(a ~b)" "(quasiquote (a (unquote b)))";
  reads "unquote-splicing"  "`(a ~@bs)" "(quasiquote (a (unquote-splicing bs)))";
  reads "unquote a call"    "`(+ ~(f x) 1)"
                            "(quasiquote (+ (unquote (f x)) 1))";
  (* Nesting: the reader does not count levels, it just wraps again. Which
     level an unquote belongs to is the expander's problem, not the reader's. *)
  reads "nested quasiquote" "`(a `(b ~c))"
                            "(quasiquote (a (quasiquote (b (unquote c)))))";
  (* An unquote outside any quasiquote still reads. It has to: the reader is
     dumb and has no idea where it is. Parse refuses it — see the parse tests. *)
  reads "unquote alone"     "~x" "(unquote x)";
  reads "splice alone"      "~@x" "(unquote-splicing x)";
  (* A quote inside a quasiquote stays a quote; the two sigils do not merge. *)
  reads "quote in quasi"    "`(a 'b)" "(quasiquote (a (quote b)))";
  (* The delimiter half of the fix: without it ~x is one symbol named "~x". *)
  reads "tilde ends a name" "(f a~b)" "(f a (unquote b))";
  reads "backtick ends a name" "(f a`b)" "(f a (quasiquote b))";
  reads "backtick in vec"   "[`a ~b]" "[(quasiquote a) (unquote b)]";

  (* ── Discard ───────────────────────────────────────────────────── *)
  (* [#_] reads the next form and throws it away, so commenting out a form does
     not mean counting its closing parens. Clojure's spelling and Clojure's
     semantics, including the repeated form. *)
  reads "discard in a call"   "(f #_a b)" "(f b)";
  reads "discard the last"    "(f a #_b)" "(f a)";
  reads "discard the first"   "(#_f g a)" "(g a)";
  reads "discard a list"      "(f #_(g x) b)" "(f b)";
  reads "discard in a vector" "[a #_b c]" "[a c]";
  reads "discard in a map"    "{:a 1 #_:b #_2 :c 3}" "{:a 1 :c 3}";
  (* Two discards drop two forms, and that is the recursion rather than a
     count: the outer discard reads one form, and the form it reads is itself a
     discard that returns the one after. *)
  reads "two discards"        "(f #_#_a b c)" "(f c)";
  reads "three discards"      "(f #_#_#_a b c d)" "(f d)";
  (* Every position a form can appear in. *)
  reads "discard at top level" "#_(defn a [] () 1) (defn b [] () 2)" "(defn b [] () 2)";
  reads "discard a whole file" "#_(defn a [] () 1)" "";
  reads "discard before quote" "(f #_a 'b)" "(f (quote b))";
  reads "discard of a quote"   "(f #_'a b)" "(f b)";
  (* Nested, which the recursive read gives for free. *)
  reads "discard inside a discarded form" "(f #_(g #_h i) j)" "(f j)";
  (* A name may still contain '#' — it is only a discard at the start of a
     form, after trivia. *)
  reads "hash inside a name"  "(f a#_b)" "(f a#_b)";
  (* Nothing to discard is an error, not a silent nothing. *)
  rejects ~needle:"end of input" "discard at end of input" "(f a #_";
  rejects ~needle:"unbalanced" "discard of a closing paren" "(f a #_)";

  (* The whole class: no reader-significant character may end up inside a name. *)
  let rec bad_names f =
    let open Form in
    match f.v with
    | Sym s | Kw s ->
      if String.exists (fun c -> c = '\'' || c = '^' || c = '`' || c = '~') s
      then [ s ] else []
    | List l | Vec l | Map l -> List.concat_map bad_names l
    | _ -> []
  in
  let corpus =
    "(invoke-restart 'skip-form) (a 'b [c 'd] {.e 'f}) '(g 'h) \
     `(i ~j ~@k) `(l `(m ~n)) [`o ~p] {.q `r} (f a~b x`y)"
  in
  check "no sigils leak into names"
    (bad_names (Form.make (Form.List (read corpus))
                  Loc.unknown) = []);

  (* ── Errors ────────────────────────────────────────────────────── *)
  rejects "unclosed list"     "(f x";
  rejects "unbalanced close"  ")";
  rejects "mismatched"        "(f x]";
  rejects "unterminated str"  "\"abc";
  rejects "empty keyword"     ":";
  rejects "unknown char"      "\\bogus";
  (* An escape the reader does not know is a typo, not a character: accepting
     \q as 'q' silently reads a different string than the one that was
     written, and nothing downstream can tell. *)
  rejects "unknown string escape" "\"a\\qb\"" ~needle:"unknown string escape";
  (* The escapes it does know still decode, which is what says the rejection
     above rejects the unknown one and not escaping itself. Asserted on the
     string's bytes rather than through [Form.to_string], which escapes them
     again and would compare the source with itself. *)
  (match read "\"a\\nb\\tc\\\\d\\\"e\\0f\"" with
   | [ { Form.v = Form.Str s; _ } ] ->
     check "known escapes" (s = "a\nb\tc\\d\"e\000f")
   | _ -> check "known escapes: one string" false);
  rejects "metadata"          "^:async";
  rejects "dangling quote"    "'";
  (* Each of these asserts the reason, not merely that something failed. *)
  rejects "backtick at end"   "`"  ~needle:"unexpected end of input";
  rejects "tilde at end"      "~"  ~needle:"unexpected end of input";
  rejects "splice at end"     "~@" ~needle:"unexpected end of input";
  rejects "quasiquote unclosed" "`(a b" ~needle:"unclosed";

  (* ── Locations ─────────────────────────────────────────────────── *)
  (match read ~file:"f.flan" "(a)\n  (b)" with
   | [ a; b ] ->
     check "loc line 1" (a.loc.line = 1 && a.loc.col = 1);
     check "loc line 2" (b.loc.line = 2 && b.loc.col = 3);
     check "loc file"   (a.loc.file = "f.flan")
   | _ -> check "loc: two forms" false);

  (match read ~file:"f.flan" "(f\n  bad" with
   | _ -> check "unclosed reports opening loc" false
   | exception Loc.Error { Loc.dloc = loc; _ } ->
     check "unclosed reports opening loc" (loc.line = 1 && loc.col = 1));

  (* ── Spans ─────────────────────────────────────────────────────
     A location ends where the form ends, which is what an underline needs
     and what a column number cannot give. Asserted on the width rather than
     on the end column alone: a span that never got widened is zero wide, and
     that is the failure mode worth catching — the field would exist, nothing
     would fill it, and every squiggle would be one character long. *)
  (match read ~file:"f.flan" "(foo bar)" with
   | [ l ] ->
     check "span covers the list" (Loc.width l.loc = Some 9);
     (match l.Form.v with
      | Form.List [ head; arg ] ->
        check "span covers the head symbol" (Loc.width head.loc = Some 3);
        check "span covers the argument"    (Loc.width arg.loc = Some 3);
        check "span starts at the symbol"   (arg.loc.col = 6)
      | _ -> check "span: two elements" false)
   | _ -> check "span: one form" false);

  (match read ~file:"f.flan" "\"hi\" 42 :kw" with
   | [ s; n; k ] ->
     check "span covers a string with its quotes" (Loc.width s.loc = Some 4);
     check "span covers a number" (Loc.width n.loc = Some 2);
     check "span covers a keyword with its colon" (Loc.width k.loc = Some 3)
   | _ -> check "span: three atoms" false);

  (* A form that runs over a line end has no width on its first line, and says
     so rather than reporting a negative one. *)
  (match read ~file:"f.flan" "(a\n b)" with
   | [ l ] ->
     check "multi-line span is flagged" (Loc.multiline l.loc);
     check "multi-line span has no single-line width" (Loc.width l.loc = None)
   | _ -> check "span: one multi-line form" false);

  if !failures = 0 then print_endline "reader: all tests passed"
  else begin
    Printf.printf "\n%d failure(s)\n" !failures;
    exit 1
  end

(* ═══ Parse: forms → AST ═══════════════════════════════════════════ *)

let parse1 src =
  match read src with
  | [ f ] -> Parse.expr f
  | _ -> failwith "test source must be exactly one form"

let parse_decl src =
  match read src with
  | [ f ] -> Parse.decl f
  | _ -> failwith "test source must be exactly one form"

(* [needle] again: the house rule is that an unimplemented form is refused by
   name with the reason, so a test that only proves *something* failed does not
   observe the rule it is there for. *)
let parse_rejects ?needle name src =
  match read src |> Parse.program with
  | _ -> incr failures; Printf.printf "FAIL  %s: expected a parse error\n" name
  | exception Loc.Error { Loc.dmsg = msg; _ } ->
    (match needle with
     | Some n when not (contains msg n) ->
       incr failures;
       Printf.printf "FAIL  %s: wrong reason\n      wanted: %s\n         got: %s\n"
         name n msg
     | _ -> ())

let () =
  let open Ast in

  (* ── Sugar is desugared, not preserved ─────────────────────────── *)
  (match (parse1 "(when c a b)").e with
   | If (_, { e = Do [ _; _ ]; _ }, None) -> ()
   | _ -> check "when -> if+do" false);

  (* unless was here, and is not any more: it is a defmacro in the prelude,
     and the parser has nothing to say about it. What it expands to is the
     same if-over-(not) this used to assert, and it is asserted where it can
     be now -- test/programs/macro-unless.flan, through a compiler that has to
     run the macro to get there. *)

  (* The label is peeled off the head, and [break] carries the name it was
     given rather than anything resolved — resolving it is the checker's job,
     which is what makes it not a goto. *)
  (match (parse1 "(while :outer c a)").e with
   | While (Some "outer", _, [ _ ]) -> ()
   | _ -> check "while takes a label" false);

  (match (parse1 "(break :outer)").e with
   | Break (Some "outer") -> ()
   | _ -> check "break takes a label" false);

  (match (parse1 "(continue)").e with
   | Continue None -> ()
   | _ -> check "bare continue" false);

  (match (parse1 "(until c a)").e with
   | While (None, { e = Call ({ e = Var "not"; _ }, [ _ ]); _ }, [ _ ]) -> ()
   | _ -> check "until -> while(not)" false);

  (match (parse1 "(cond a 1 b 2 :else 3)").e with
   | If (_, _, Some { e = If (_, _, Some { e = Int 3L; _ }); _ }) -> ()
   | _ -> check "cond -> nested if with :else last" false);

  (* and/or short-circuit, so they must not become calls *)
  (match (parse1 "(and a b)").e with
   | If (_, _, Some { e = Var "false"; _ }) -> ()
   | _ -> check "and short-circuits" false);
  (match (parse1 "(or a b)").e with
   | If (_, { e = Var "true"; _ }, Some _) -> ()
   | _ -> check "or short-circuits" false);

  (* ── Forms that bind or alter control are never calls ──────────── *)
  (* This is the class that silently misparses: it reads fine as a call and
     means something entirely different. *)
  (match (parse1 "(dotimes [i 10] (f i))").e with
   | Dotimes (None, "i", { e = Int 10L; _ }, [ _ ]) -> ()
   | _ -> check "dotimes binds" false);
  (match (parse1 "(fn [x y] x)").e with
   | Fn ([ "x"; "y" ], [ _ ]) -> ()
   | _ -> check "fn binds" false);
  (match (parse1 "(defer (close f))").e with
   | Defer [ _ ] -> ()
   | _ -> check "defer is not a call" false);
  (match (parse1 "(some (find x))").e with
   | Unwrap (Usome, _) -> ()
   | _ -> check "some is not a call" false);
  (match (parse1 "(try (read x))").e with
   | Unwrap (Utry, _) -> ()
   | _ -> check "try is not a call" false);

  (* ── Places: the fixed assignable list, not setf ───────────────── *)
  (match (parse1 "(set x 1)").e with
   | Set (Pvar "x", _) -> () | _ -> check "set local" false);
  (match (parse1 "(set (.hp e) 1)").e with
   | Set (Pfield (_, "hp"), _) -> () | _ -> check "set field" false);
  (match (parse1 "(set (at g r c) 1)").e with
   | Set (Pindex (_, [ _; _ ]), _) -> () | _ -> check "set index" false);
  (match (parse1 "(set (deref p) 1)").e with
   | Set (Pderef _, _) -> () | _ -> check "set deref" false);
  parse_rejects "set on a call" "(set (foo x) 1)";

  (* ── Field access and struct literals ──────────────────────────── *)
  (match (parse1 "(.pos c)").e with
   | Field ({ e = Var "c"; _ }, "pos") -> ()
   | _ -> check "field access" false);
  (match (parse1 "(Cursor {.src s .pos 0})").e with
   | Struct ("Cursor", [ ("src", _); ("pos", _) ]) -> ()
   | _ -> check "struct literal" false);
  (match (parse1 "[1 2 3]").e with
   | Arr [ _; _; _ ] -> () | _ -> check "array literal" false);

  (* ── Types: brackets mean different things by position ─────────── *)
  let ty src =
    match parse_decl (Printf.sprintf "(defn f [x %s] ())" src) with
    | { d = Defn { params = [ { fty; _ } ]; _ }; _ } -> fty.t
    | _ -> failwith "bad type test"
  in
  (match ty "[u8]" with Tslice _ -> () | _ -> check "[T] is a slice" false);
  (match ty "[4 f32]" with
   | Tarray (Lint 4L, _) -> () | _ -> check "[n T] is an array" false);
  (match ty "[rows [cols u32]]" with
   | Tarray (Lname "rows", { t = Tarray (Lname "cols", _); _ }) -> ()
   | _ -> check "nested array with named lengths" false);
  (match ty "(Ptr Cursor)" with
   | Tapp ("Ptr", [ _ ]) -> () | _ -> check "(Ptr T)" false);
  (* A map type is an application like (Ptr T) and (Vec T) now that the brace
     spelling is gone: [Ast.Tmap] survives only as what [Cimport] builds. *)
  (match ty "(Map string i32)" with
   | Tapp ("Map", [ _; _ ]) -> () | _ -> check "(Map K V) is a map type" false);
  (match ty "(Fn [a a] bool)" with
   | Tfn ([ _; _ ], _) -> () | _ -> check "(Fn [T] R)" false);

  (* ── Declarations ──────────────────────────────────────────────── *)
  (match (parse_decl "(defn f [x i32] bool x)").d with
   | Defn { ret = Some _; params = [ _ ]; fbody = [ _ ]; _ } -> ()
   | _ -> check "defn with return type" false);
  (* () is the unit return type, and the body is what follows it. *)
  (match (parse_decl "(defn f [x i32] () (g x))").d with
   | Defn { ret = Some { t = Tname "Unit"; _ }; fbody = [ _ ]; _ } -> ()
   | _ -> check "defn returning ()" false);
  (* A lone () is the return type and an empty body, not a body of one form. *)
  (match (parse_decl "(defn f [x i32] ())").d with
   | Defn { ret = Some { t = Tname "Unit"; _ }; fbody = []; _ } -> ()
   | _ -> check "defn returning () with no body" false);
  (match (parse_decl "(defvar grid [4 u32])").d with
   | Defvar ("grid", Some _, Zeroed) -> ()
   | _ -> check "defvar is ZII" false);
  (match (parse_decl "(defvar buf [4 u8] uninit)").d with
   | Defvar (_, _, Uninit) -> () | _ -> check "defvar uninit opts out" false);
  (match (parse_decl "(import rl \"vendor:raylib\")").d with
   | Import ("rl", "vendor:raylib") -> () | _ -> check "import" false);

  (* ── Unimplemented forms are rejected, not silently called ─────── *)
  parse_rejects "handler-bind" "(handler-bind [E h] body)";
  parse_rejects "restart-case" "(restart-case body (r [] 1))";
  parse_rejects "loop/recur"   "(loop [x 1] (recur x))";

  (* ── Macros ─────────────────────────────────────────────────────── *)
  (* A defmacro is a defn. There is no Ast.Defmacro and there is not going to
     be one: a macro is [Form] -> Form, compiled by the same backend as
     everything else, and what makes it a macro is that the expander calls it
     at compile time rather than the program calling it at run time. *)
  (match (parse_decl "(defmacro m [args] (at args 0))").d with
   | Defn { name = "m"; params = [ p ]; ret = Some r; _ } ->
     (match p.fty.t, r.t with
      | Tslice { t = Tname "Form"; _ }, Tname "Form" -> ()
      | _ -> check "defmacro is [Form] -> Form" false)
   | _ -> check "defmacro parses as a defn" false);

  (* One parameter, the forms at the call site. Two is not an arity mistake, it
     is a misunderstanding of what a macro takes, and it gets its own reason. *)
  parse_rejects "defmacro with two parameters" "(defmacro m [a b] a)"
    ~needle:"a macro takes one parameter";
  (* Shape and feature were separate mistakes and stay separate reasons. *)
  parse_rejects "defmacro with no body" "(defmacro m [x])"
    ~needle:"defmacro is (defmacro name [param ...] body ...)";
  parse_rejects "defmacro with no params" "(defmacro m x)"
    ~needle:"defmacro is (defmacro name [param ...] body ...)";
  parse_rejects "defmacro with a non-name param" "(defmacro m [1] x)"
    ~needle:"expected a name";
  parse_rejects "defmacro in expression position" "(defn f [] () (defmacro m [] 1))"
    ~needle:"top-level declaration";

  (* The tagged sum is [defdata] now. The old spelling is refused by name
     rather than aliased, because the name is reserved for a type with
     different semantics — a file that kept [defunion] must be made to say
     which of the two it means instead of being quietly given one of them. *)
  parse_rejects "the old defunion spelling"
    "(defunion Shape [(Circle [r f32]) (Square [s f32])])"
    ~needle:"the tagged sum is defdata now";
  (* The shape that would otherwise parse: two bare case names read as one
     member of a type. Same refusal, and this is the one that matters — it
     would have compiled. *)
  parse_rejects "the old defunion spelling with payload-less cases"
    "(defunion U [A B])"
    ~needle:"the tagged sum is defdata now";
  (match read "(defunion U [A B])" |> Parse.program with
   | _ -> check "the old spelling has a kind" false
   | exception Loc.Error { Loc.kind; _ } ->
     check "the old spelling has a kind" (kind = "parse/defunion-renamed"));

  (* The return type is not optional. A void function writes (), and the
     refusal says so rather than leaving someone to find it in a grammar. *)
  parse_rejects "defn with no return type" "(defn f [] (g))"
    ~needle:"a function that returns nothing writes ()";
  parse_rejects "defn with nothing after the parameters" "(defn f [])"
    ~needle:"The return type is not optional";
  (* One spelling for unit, and the old one names the new one. *)
  parse_rejects "the old Unit spelling in return position" "(defn f [] Unit (g))"
    ~needle:"unit is written (), not Unit";
  parse_rejects "the old Unit spelling anywhere else"
    "(defn f [g (Fn [i32] Unit)] () (g 1))"
    ~needle:"unit is written (), not Unit";

  (* Quasiquote is a desugaring over Form, and it has already run by the time
     the parser sees anything, so what is written here is what a macro body
     actually compiles to: the prelude's three form-building functions and
     nothing else. Spelled out rather than described, because the desugaring
     *is* the contract with the prelude. *)
  let desugars name src want =
    match read src with
    | [ f ] ->
      let got = Form.to_string (Expand.quasiquote f) in
      if got <> want then begin
        incr failures;
        Printf.printf "FAIL  %s\n        got:    %s\n        wanted: %s\n"
          name got want
      end
    | _ -> check (name ^ ": one form") false
  in
  desugars "a quasiquoted list is form-cons over Form nodes" "`(a ~b)"
    "(Form.List {.xs (form-cons (Form.Sym {.s \"a\"}) (form-cons b (form-nil)))})";
  desugars "a splice is form-append" "`(a ~@bs)"
    "(Form.List {.xs (form-cons (Form.Sym {.s \"a\"}) (form-append bs (form-nil)))})";
  (* A vector keeps its bracket through the desugaring: a binding vector is the
     commonest thing a macro builds and Form.Vec is not Form.List. *)
  desugars "a quasiquoted vector stays a vector" "`[~x 1]"
    "(Form.Vec {.xs (form-cons x (form-cons (Form.Int {.i 1}) (form-nil)))})";
  (* Levels are not counted -- not by the reader, deliberately, and not here,
     which is why the inner one is refused by name rather than given a meaning
     nobody chose. *)
  parse_rejects "a quasiquote inside a quasiquote" "(defn f [] Form `(a `(b)))"
    ~needle:"quasiquote inside a quasiquote";
  (* Not a missing feature — an unquote outside a quasiquote is a mistake, and
     the reader cannot catch it because it does not track where it is. *)
  parse_rejects "unquote outside a quasiquote" "(defn f [] () ~x)"
    ~needle:"means nothing outside a quasiquote";
  parse_rejects "splice where a splice makes no sense" "(defn f [] () (+ 1 ~@xs))"
    ~needle:"splices only into a list or a vector";
  (* A splice with no bracket around it. The quasiquote is real here, so this
     one is the desugaring's refusal and not the parser's. *)
  parse_rejects "splice not inside a bracket" "(defn f [] Form `~@xs)"
    ~needle:"nothing here for it to splice into";

  (* ── defenum: a value is optional, and autoincrements ──────────── *)
  (* The numbers are the whole of what the form means, so they are what is
     asserted on -- the parser has resolved them by the time a decl exists, and
     nothing downstream can tell an implicit value from a written one. *)
  let enum_values name src want =
    match (parse_decl src).d with
    | Defenum (_, ms) ->
      let show vs = String.concat " " (List.map Int64.to_string vs) in
      let got = List.map snd ms in
      if got <> want then begin
        incr failures;
        Printf.printf "FAIL  %s\n      wanted: [%s]\n         got: [%s]\n"
          name (show want) (show got)
      end
    | _ -> check (name ^ ": parses as a defenum") false
  in
  enum_values "every member implicit" "(defenum E [A B C])" [ 0L; 1L; 2L ];
  enum_values "every member explicit" "(defenum E [A 3  B 9  C -1])"
    [ 3L; 9L; -1L ];
  (* The mixed case is the point of the feature: an explicit value resets the
     count, and the members below it carry on from there. *)
  enum_values "an implicit member follows the explicit one above it"
    "(defenum E [A B C 10 D])" [ 0L; 1L; 10L; 11L ];
  (* The C idiom the explicit-duplicate rule exists for. *)
  enum_values "a written duplicate is an alias and is kept"
    "(defenum E [First 0  Second 1  Last 1])" [ 0L; 1L; 1L ];
  enum_values "an enum with no members at all" "(defenum E [])" [];

  (* A value autoincrement walked into is refused, because nothing in the
     source chose it -- and the refusal has to name the *other* member, which
     is the half a reader cannot see from the line that failed. Three needles
     for one source: the message is only doing its job if both names, the
     number, and the way out are all in it. *)
  parse_rejects "an autoincrement onto a value already taken"
    "(defenum E [A 0  B 1  C 0  D])"
    ~needle:"D has no value of its own, so it autoincrements to 1";
  parse_rejects "the refusal names the member already holding the value"
    "(defenum E [A 0  B 1  C 0  D])"
    ~needle:"which is the value B already has";
  parse_rejects "the refusal says how to say the alias was meant"
    "(defenum E [A 0  B 1  C 0  D])"
    ~needle:"Give D its value explicitly";
  (* The member collided with is as often below as above: here it is [A], the
     implicit one, that is refused, and a left-to-right check would pass it. *)
  parse_rejects "an autoincrement onto a value written further down"
    "(defenum E [A  B 0])"
    ~needle:"A has no value of its own, so it autoincrements to 0";

  (* Genuinely malformed input still says what a member is, in the grammar the
     form now has. *)
  parse_rejects "an enum member that is not a name" "(defenum E [1 A])"
    ~needle:"an enum member is a name, optionally followed by an integer";
  parse_rejects "a defenum with no member vector" "(defenum E)"
    ~needle:"defenum is (defenum Name [member value? ...])";

  (* ── Malformed syntax is caught with a location ────────────────── *)
  parse_rejects "odd let bindings"  "(let [a])";
  parse_rejects "odd field pairs"   "(defstruct S [a])";
  parse_rejects "cond without body" "(cond a)";
  parse_rejects "unknown top form"  "(nope x)";
  parse_rejects "break takes only a label" "(defn f [] () (break 1))"
    ~needle:"break is (break) or (break :label)";
  parse_rejects "continue takes only a label" "(defn f [] () (continue x))"
    ~needle:"continue is (continue) or (continue :label)";
  parse_rejects "a labelled while still needs a test" "(defn f [] () (while :o))"
    ~needle:"(while :label test body ...)";
  parse_rejects "array with no type" "(defn f [] () (array 4))"
    ~needle:"array is (array COUNT TYPE)";
  parse_rejects "array given a value, not a type" "(defn f [] () (array 4 5))"
    ~needle:"expected a type";
  parse_rejects "array with a non-constant count" "(defn f [] () (array (+ 1 1) f32))"
    ~needle:"an array length is an integer or a constant's name";

  (* ── The corpus parses ─────────────────────────────────────────── *)
  List.iter
    (fun path ->
       match read_file path |> Parse.program with
       | _ -> ()
       | exception Loc.Error { Loc.dloc = loc; dmsg = msg; _ } ->
         incr failures;
         Printf.printf "FAIL  %s does not parse: %s: %s\n"
           path (Loc.to_string loc) msg)
    (* dune runs tests in _build/default/test/; the corpus is declared as a
       dep in test/dune and lands at the build root. *)
    [ "../calc-me.flan"; "../sand.flan" ];

  if !failures = 0 then print_endline "parse: all tests passed"
  else begin
    Printf.printf "\n%d failure(s)\n" !failures;
    exit 1
  end

(* ═══ The return type is the slot, not a guess ══════════════ *)
(* (Option f64) and (Some 1) are the same s-expression shape, and the parser
   used to tell them apart by looking the head up in a set of the file's type
   names. The set had to be complete, it twice was not, and the failure was a
   body form silently eaten as a return type. The slot is mandatory now, so
   there is nothing to look up: whatever is written there is a type, and
   whatever follows is the body. These pin that down from both sides. *)

(* Through [read], so the parser and checker tables are under the reader's
   alarm too: their sources go through the same reader. *)
let program src = read src |> Parse.program

let () =
  let open Ast in
  (* Pick the defn out; some sources also declare a struct. *)
  let ret_and_body name src =
    match
      List.find_map
        (fun (d : decl) ->
           match d.d with Defn fn -> Some fn | _ -> None)
        (program src)
    with
    | Some { ret; fbody; _ } -> (ret <> None, List.length fbody)
    | None -> check (name ^ ": has a defn") false; (false, 0)
  in

  check "the slot is the return type"
    (ret_and_body "option" "(defn f [] (Option f64) (g))" = (true, 1));

  (* The two that used to be decided by the table, and are decided by position
     now: a constructor call and a prelude struct literal are body forms
     because they are not in the slot, not because anything knows what they
     are. [(Rune {.code 65})] is the one that was misparsed in every file in
     the language. *)
  check "a ctor after the slot is a body form"
    (ret_and_body "some" "(defn f [] () (Some 1) (bar))" = (true, 2));
  check "a prelude struct literal after the slot is a body form"
    (ret_and_body "preludelit" "(defn f [] () (Rune {.code 65}) (bar))"
     = (true, 2));

  (* And what is *in* the slot is a type whether or not the parser could know
     it: a struct declared further down the file, a package's type behind an
     alias the parser has not resolved, a prelude type. None of these needed a
     pre-pass any more. *)
  check "a type declared later is still the return type"
    (ret_and_body "later"
       "(defn f [] Cursor (g)) (defstruct Cursor [pos i32])" = (true, 1));
  check "a prelude type is the return type"
    (ret_and_body "prelude" "(defn f [] Form (g))" = (true, 1));
  check "an unknown name in the slot is still the return type"
    (ret_and_body "unknown" "(defn f [] Nope (bar))" = (true, 1));

  (* The body may be empty, which is the shape the old optional slot could not
     produce: [(defn f [])] had nowhere to put the type. *)
  check "a function with a return type and no body"
    (ret_and_body "nobody" "(defn f [] ())" = (true, 0));

  ()

(* ── Checker: AST → typed IR ───────────────────────────────────────── *)

let checked src = program src |> Check.program

(* The type a defconst's value infers to, as the checker prints it. Enough to
   pin down literal defaulting and every primitive's result. *)
let infers name src expected =
  match checked (Printf.sprintf "(defconst probe %s)" src) with
  | p ->
    (match List.find_opt (fun (g : Tast.global) -> g.gname = "probe") p.globals with
     | Some g ->
       let got = Types.to_string g.gty in
       if got <> expected then begin
         incr failures;
         Printf.printf "FAIL  %s\n        src: %s\n        got: %s\n    wanted: %s\n"
           name src got expected
       end
     | None -> incr failures; Printf.printf "FAIL  %s: no probe\n" name)
  | exception Loc.Error { Loc.dloc = loc; dmsg = msg; _ } ->
    incr failures;
    Printf.printf "FAIL  %s\n        src: %s\n      error: %s: %s\n"
      name src (Loc.to_string loc) msg
  | exception Watchdog.Timeout ->
    incr failures;
    Printf.printf "FAIL  %s\n        src: %s\n      the reader did not return\n"
      name src

let accepts name src =
  match checked src with
  | _ -> ()
  | exception Loc.Error { Loc.dloc = loc; dmsg = msg; _ } ->
    incr failures;
    Printf.printf "FAIL  %s\n        src: %s\n      error: %s: %s\n"
      name src (Loc.to_string loc) msg
  | exception Watchdog.Timeout ->
    incr failures;
    Printf.printf "FAIL  %s\n        src: %s\n      the reader did not return\n"
      name src

(* [needle] pins the *reason* down: a rejection for the wrong reason is not a
   passing test, and the unimplemented-feature errors are the whole point. *)
let rejects_check name ?needle src =
  match checked src with
  | _ ->
    incr failures;
    Printf.printf "FAIL  %s: expected a type error\n        src: %s\n" name src
  | exception Loc.Error { Loc.dmsg = msg; _ } ->
    (match needle with
     | Some n
       when not
              (List.exists
                 (fun i -> String.length msg - i >= String.length n
                           && String.sub msg i (String.length n) = n)
                 (List.init (max 1 (String.length msg)) Fun.id)) ->
       incr failures;
       Printf.printf "FAIL  %s: wrong reason\n      wanted: %s\n         got: %s\n"
         name n msg
     | _ -> ())

let () =
  (* ── Literal defaulting and inference ──────────────────────────── *)
  infers "int defaults to i32"   "42" "i32";
  infers "float defaults to f64" "0.5" "f64";
  infers "byte is u8"            "\\space" "u8";
  infers "string"                "\"hi\"" "string";
  infers "bool"                  "true" "bool";
  infers "arithmetic keeps kind" "(+ 1 2)" "i32";
  infers "comparison is bool"    "(< 1 2)" "bool";
  infers "cast"                  "(f64 3)" "f64";
  infers "array literal"         "[1 2 3]" "[3 i32]";
  infers "nested array"          "[[1 2] [3 4]]" "[2 [2 i32]]";
  (* (array COUNT TYPE): the constructor a [let] binding needs, because a let
     has no type slot and [4 P] there is a two-element literal whose second
     element is a name nothing declares. The type spelling is unchanged — the
     two [infers] above still hold — and this is the position that had no way
     to say it. *)
  infers "array constructor"     "(array 4 f32)" "[4 f32]";
  infers "array of a struct"     "(array 2 i32)" "[2 i32]";
  infers "array of an array"     "(array 2 [3 u8])" "[2 [3 u8]]";
  infers "bytes of a string"     "(bytes \"hi\")" "[u8]";
  infers "len is i32"            "(len (bytes \"hi\"))" "i32";
  infers "slice of a slice"      "(slice (bytes \"hi\") 0 1)" "[u8]";
  infers "parse text to f64"     "(bytes->f64 (bytes \"1.5\"))" "f64";

  (* An untyped integer constant is usable where a float is wanted, as in
     Odin; the reverse is not. *)
  infers "int literal into a float" "(+ 1 0.5)" "f64";
  rejects_check "float literal into an int"
    "(defn f [] i32 (+ 1 0.5))" ~needle:"expected i32";

  (* ── Bidirectional flow ────────────────────────────────────────── *)
  accepts "return type types the literal" "(defn f [] u8 0)";
  accepts "return type types None"        "(defn f [] (Option f64) None)";
  rejects_check "bare None has no type"   "(defconst x None)"
    ~needle:"what None is an Option of";
  accepts "param types the literal"
    "(defn g [x u8] ()) (defn f [] () (g 3))";
  rejects_check "wrong argument type"
    "(defn g [x u8] ()) (defn f [] () (g 0.5))" ~needle:"expected u8";
  rejects_check "wrong arity"
    "(defn g [x u8] ()) (defn f [] () (g 1 2))" ~needle:"takes 1 argument";
  rejects_check "wrong return type"
    "(defn f [] bool 1)" ~needle:"expected bool";
  (* What the mandatory slot bought: a mistyped type in return position is a
     mistyped type. It used to be parsed as the first form of the body and
     reported as an unknown *name*, which points at the wrong mistake. *)
  rejects_check "a mistyped return type says which type was meant"
    "(defn f [] f65 0.0)" ~needle:"did you mean f64";
  rejects_check "if branches disagree"
    "(defn f [] i32 (if true 1 true))" ~needle:"expected i32";

  (* ── Unknown types ─────────────────────────────────────────────── *)
  (* A lowercase name is a type variable (plan.org, Types), so a mistyped
     primitive would otherwise be reported as unimplemented generics and send
     you to plan.org instead of to the character you mistyped. *)
  rejects_check "a mistyped primitive"  "(defn f [x f65] ())"
    ~needle:"did you mean f64?";
  rejects_check "a transposed primitive" "(defn f [x stirng] ())"
    ~needle:"did you mean string?";
  rejects_check "a mistyped struct"
    "(defstruct Cursor [x i32]) (defn f [c Curser] ())"
    ~needle:"did you mean Cursor?";
  (* Nothing close: the type-variable rule still applies, and still names the
     milestone. *)
  rejects_check "a real type variable" "(defn f [x t] ())"
    ~needle:"milestone 5";
  rejects_check "an unknown concrete type" "(defn f [x Widget] ())"
    ~needle:"unknown type Widget";

  (* ── Static bounds ─────────────────────────────────────────────── *)
  (* A literal index into a fixed array is known now, so it is an error now
     rather than a trap later; everything else is the emitted bounds check's
     job. A [defconst] is a global in the typed IR, not a folded constant, so
     it deliberately stays a runtime trap. *)
  let arr = "(defvar a [3 i32]) " in
  accepts "last valid index"        (arr ^ "(defn f [] i32 (at a 2))");
  rejects_check "index past the end" (arr ^ "(defn f [] i32 (at a 3))")
    ~needle:"out of bounds for length 3";
  rejects_check "negative index"     (arr ^ "(defn f [] i32 (at a -1))")
    ~needle:"is negative";
  rejects_check "index past the end of an inner dimension"
    "(defvar g [2 [4 i32]]) (defn f [] i32 (at g 1 4))"
    ~needle:"out of bounds for length 4";
  accepts "a variable index is checked at runtime, not here"
    (arr ^ "(defn f [i i32] i32 (at a i))");
  accepts "a defconst index is not folded"
    ("(defconst k 9) " ^ arr ^ "(defn f [] i32 (at a k))");

  (* A slice bound may sit one past the end; an index may not. *)
  accepts "slice ending at len"      (arr ^ "(defn f [] [i32] (slice a 1 3))");
  accepts "empty slice at len"       (arr ^ "(defn f [] [i32] (slice a 3 3))");
  rejects_check "slice bound past len" (arr ^ "(defn f [] [i32] (slice a 1 4))")
    ~needle:"out of bounds for length 3";
  rejects_check "negative slice bound" (arr ^ "(defn f [] [i32] (slice a -1 2))")
    ~needle:"is negative";
  rejects_check "reversed slice"     (arr ^ "(defn f [] [i32] (slice a 2 1))")
    ~needle:"runs backwards";
  (* A slice has no static length, so only the two target-independent rules
     apply to one. *)
  rejects_check "reversed slice of a slice"
    "(defn f [s [u8]] [u8] (slice s 2 1))" ~needle:"runs backwards";
  accepts "a slice's length is not known here"
    "(defn f [s [u8]] [u8] (slice s 0 99))";

  (* (slice-from-ptr p n). The one form in the language whose central claim the
     compiler cannot check — whether n is the truth about what p addresses — so
     what it does check is worth pinning: the argument really is a pointer, the
     length is not absurd on its face, and the result owns nothing. *)
  accepts "a pointer plus a length is a slice"
    "(defn f [p (Ptr i32) n i32] i32 (at (slice-from-ptr p n) 0))";
  accepts "zero is a length"
    "(defn f [p (Ptr i32)] i32 (len (slice-from-ptr p 0)))";
  rejects_check "slice-from-ptr of something that is not a pointer"
    "(defn f [s [i32]] i32 (len (slice-from-ptr s 3)))"
    ~needle:"takes a (Ptr T)";
  rejects_check "slice-from-ptr with a negative literal length"
    "(defn f [p (Ptr i32)] i32 (len (slice-from-ptr p -1)))"
    ~needle:"is negative";
  (* The storage stays C's. A slice is not move-only and carries no allocator,
     so free refuses one by the rule it already had — this pins that the new
     form did not become a thing anybody could hand to free. *)
  rejects_check "free of a slice made from a pointer"
    "(defn f [p (Ptr i32)] () (free (slice-from-ptr p 3)))"
    ~needle:"free takes a move-only value";

  (* ── Structs, fields and auto-deref ────────────────────────────── *)
  let cursor = "(defstruct Cursor [src [u8] pos i32]) " in
  accepts "struct literal, omitted field zeroed"
    (cursor ^ "(defn f [s [u8]] Cursor (Cursor {.src s}))");
  rejects_check "unknown field"
    (cursor ^ "(defn f [s [u8]] Cursor (Cursor {.nope s}))")
    ~needle:"has no field nope";
  rejects_check "field given twice"
    (cursor ^ "(defn f [s [u8]] Cursor (Cursor {.pos 0 .pos 1}))")
    ~needle:"given twice";
  (* The old spelling is refused rather than quietly accepted, and the refusal
     names the new one. Two accepted spellings is how two spellings become
     permanent, and the colon is wanted for keys. *)
  rejects_check "a field label written with a colon"
    (cursor ^ "(defn f [s [u8]] Cursor (Cursor {:src s}))")
    ~needle:"a field label is written .src, not :src";
  accepts "field through a pointer auto-derefs"
    (cursor ^ "(defn f [c (Ptr Cursor)] i32 (.pos c))");
  accepts "set through a pointer"
    (cursor ^ "(defn f [c (Ptr Cursor)] () (set (.pos c) 1))");
  rejects_check "field of a non-struct"
    "(defn f [x i32] i32 (.pos x))" ~needle:"is not a struct";

  (* ── Places ────────────────────────────────────────────────────── *)
  accepts "a local is assignable"
    "(defn f [] i32 (let [x 1] (set x 2) x))";
  rejects_check "a parameter is not assignable"
    "(defn f [x i32] () (set x 2))" ~needle:"parameters are not assignable";
  rejects_check "a constant is not assignable"
    "(defconst k 1) (defn f [] () (set k 2))" ~needle:"is a constant";
  accepts "addr of a local gives a pointer"
    (cursor ^ "(defn g [c (Ptr Cursor)] i32 (.pos c)) \
               (defn f [s [u8]] i32 (let [c (Cursor {.src s})] (g (addr c))))");
  rejects_check "addr of a non-place"
    "(defn f [] () (addr (+ 1 2)))" ~needle:"addr takes the address of a place";
  (* An Option's two fields exist in both backends' layouts — the tag and the
     value — and the structural printer reads the tag through them. What has no
     spelling in the source language is reaching one: [match] and [some] are
     how an Option is opened, and a (.field o) that read the value of a None
     would be reading storage the tag says is not there. FIX.org recorded
     [Addr (Pfield ...)] on an Option as a hole in both backends; this is the
     pair of rows that says the hole has no door — the refusal is the field
     access itself, so (addr ...) never gets a place to take the address of. *)
  rejects_check "a field of an Option"
    "(defstruct Point [x i32  y i32])\n\
     (defn f [o (Option Point)] i32 (.x o))"
    ~needle:"(Option Point) is not a struct, so it has no fields";
  rejects_check "the address of a field of an Option"
    "(defstruct Point [x i32  y i32])\n\
     (defn f [o (Option Point)] (Ptr i32) (addr (.x o)))"
    ~needle:"(Option Point) is not a struct, so it has no fields";

  (* ── Option, some, match ───────────────────────────────────────── *)
  accepts "some unwraps in an Option-returning function"
    "(defn g [] (Option i32) None) (defn f [] (Option i32) (Some (some (g))))";
  rejects_check "some outside an Option-returning function"
    "(defn g [] (Option i32) None) (defn f [] i32 (some (g)))"
    ~needle:"must return an Option";
  accepts "match on Option"
    "(defn g [] (Option i32) None) \
     (defn f [] i32 (match (g) (Some v) v None 0))";
  rejects_check "match must be exhaustive"
    "(defn g [] (Option i32) None) (defn f [] i32 (match (g) (Some v) v))"
    ~needle:"not exhaustive";
  accepts "a wildcard arm is exhaustive"
    "(defn g [] (Option i32) None) (defn f [] i32 (match (g) (Some v) v _ 0))";
  rejects_check "match on a non-Option"
    "(defn f [x i32] i32 (match x _ 0))" ~needle:"match works on an Option";

  (* ── Names, order-independence, entry point ────────────────────── *)
  accepts "mutually recursive, no forward declaration"
    "(defn even? [n i32] bool (if (= n 0) true (odd? (- n 1)))) \
     (defn odd?  [n i32] bool (if (= n 0) false (even? (- n 1))))";
  rejects_check "unknown name" "(defn f [] i32 nope)" ~needle:"unknown name";
  rejects_check "unknown function" "(defn f [] i32 (nope 1))"
    ~needle:"unknown function";
  rejects_check "defined twice" "(defn f [] ()) (defn f [] ())"
    ~needle:"defined twice";
  accepts "main with no parameters and no return" "(defn main [] ())";
  accepts "main with argv and a status" "(defn main [args [string]] i32 0)";
  rejects_check "main with a wrong parameter" "(defn main [n i32] ())"
    ~needle:"main takes no parameters";
  rejects_check "main returning the wrong type" "(defn main [] bool true)"
    ~needle:"main returns i32";
  (* And both of them point at the [main] that is wrong. They used to open with
     <unknown>:0:0 — the checker's rule about the entry point is the one place
     that had a name and no span, because [env.locs] records where a *type* was
     declared and a function is not in it. The span is the whole difference
     between a message you can act on and a message you have to go looking for,
     so it is pinned here rather than left to the reader of a report. *)
  let main_at name src =
    match checked src with
    | _ ->
      incr failures;
      Printf.printf "FAIL  %s: expected a type error\n" name
    | exception Loc.Error { Loc.dloc; _ } ->
      let got = Loc.to_string dloc in
      if got <> "<test>:1:7" then begin
        incr failures;
        Printf.printf "FAIL  %s\n      wanted: %s\n         got: %s\n"
          name "<test>:1:7" got
      end
  in
  main_at "a wrong main parameter points at main" "(defn main [n i32] ())";
  main_at "a wrong main return type points at main" "(defn main [] bool true)";

  (* ── Unconstrained operators, and everything past milestone 2 ──── *)
  rejects_check "no built-in = on strings"
    "(defn f [] bool (= \"a\" \"b\"))" ~needle:"no built-in comparison";
  (* (Vec T) is built. What is still refused is the arity: one element type,
     and a near-miss there would otherwise resolve to a type variable and come
     back as generics. *)
  rejects_check "Vec takes one type"    "(defn f [x (Vec i32 i32)] ())"
    ~needle:"exactly one type";
  (* (Map K V) is the map type spelling, and now the only one: the brace form
     is withdrawn from type position, so braces there are refused with the
     surviving spelling named. What is refused here is the arity, for the same
     reason Vec's is: a near-miss would otherwise resolve to a type variable
     and come back as generics. *)
  rejects_check "Map takes two types"   "(defn f [x (Map i32)] ())"
    ~needle:"exactly two types";
  rejects_check "Result is milestone 6" "(defn f [] (Result i32 i32) None)"
    ~needle:"milestone 6";
  (* (Handle T) and (Pool T) are built. What stays refused is the arity, for
     the reason Vec's and Map's arities are, and the four shapes below — each
     of which is a way of losing the one property the type exists to have. *)
  rejects_check "Handle takes one type" "(defn f [x (Handle i32 i32)] ())"
    ~needle:"exactly one type";
  rejects_check "Pool takes one type"   "(defn f [x (Pool i32 i32)] ())"
    ~needle:"exactly one type";
  (* A pool of an owning element used to be refused here, with the Vec's and
     the Map's, and the three came down together: the reason all of them gave
     was teardown, and a region has none. What replaced them is a run-time
     branch on the allocator's can-free at the construction, so the *type* is
     ordinary and only the tier is a question. See the arena rows below. *)
  accepts "a pool of a Vec" "(defn f [x (Pool (Vec i32))] ())";

  (* ── The region rule, spec-memory.md's arena rule ────────────────────
     The compile-time half of it, which is the only half a checker row can
     see: which declarations are admitted, and which are still refused. The
     run-time half — the branch that decides whether a given construction site
     met a region allocator — is programs/arena-region.flan, because it needs
     a program that dies to say anything. *)
  (* The recursive dynamic value, which is the whole point: a union naming
     itself through a container. Admitted because such a container can only
     have been built against a region, and one free-all takes the graph. *)
  accepts "a data type case holding a Vec of itself"
    "(defdata Value [Nil (List [items (Vec Value)])])";
  accepts "a data type case holding a Map of itself"
    "(defdata Value [Nil (Table [entries (Map string Value)])])";
  (* And the narrowing is exact, which is what these two are for. A container
     whose elements own *nothing* is not forced into a region by anything, so
     it would sit in a copyable aggregate on the heap with two headers and one
     buffer between them — the double free the original refusal existed to
     prevent. It stays refused, in a struct and in a union alike. *)
  rejects_check "a data type case holding a plain Vec"
    "(defdata Value [Nil (Bytes [bs (Vec u8)])])"
    ~needle:"makes the data type move-only";
  rejects_check "a struct field holding a plain Vec"
    "(defstruct B [buf (Vec u8)])"
    ~needle:"a struct that owns one is move-only too";
  (* free does not recurse and does not quietly release the outer block: it
     names free-all, which is the operation that actually releases the graph. *)
  rejects_check "free on a container of owning elements"
    "(defdata V [Nil (L [xs (Vec V)])])\n\
     (defn f [v (Vec V)] () (free v))"
    ~needle:"(free-all a) takes it";
  (* clone is refused for a reason the region does *not* dissolve: it promises
     an independent copy and a bytewise one is an alias. *)
  rejects_check "clone on a container of owning elements"
    "(defdata V [Nil (L [xs (Vec V)])])\n\
     (defn f [v (Vec V)] () (let [c (clone v)] (free c)))"
    ~needle:"cannot be cloned";

  (* ── A move-only global ─────────────────────────────────────────────
     Legal now, and legal because of one rule: reading one is always a borrow.
     The accepted side is programs/vec-global.flan, which has to run to say
     anything; these are the four things the rule refuses, and between them
     they are the whole of it.

     The first two are the rule itself. Ownership is what may not be taken, and
     the two ways to take it — hand the global to something that owns its
     parameter, or bind it to a local that owns it — are the same refusal at
     the read, because that is where a move would have been recorded for a
     local. [free] is the third of them and reaches it the same way: it does
     not borrow its target, so nothing special had to be written for it. *)
  rejects_check "passing a global Vec to a function"
    "(defvar g (Vec u8)) (defn eat [v (Vec u8)] () (free v)) (defn f [] () (eat g))"
    ~needle:"only ever borrowed";
  rejects_check "freeing a global Vec"
    "(defvar g (Vec u8)) (defn f [] () (free g))"
    ~needle:"only ever borrowed";
  rejects_check "binding a global Vec to a local"
    "(defvar g (Vec u8)) (defn f [] () (let [v g] (free v)))"
    ~needle:"only ever borrowed";
  (* And the two declaration shapes. A computed initialiser would have to run
     before main, which is a path [Emit.const] does not have and which
     [x86.ml] deliberately leaves out of a reload module; a defconst could
     never be assigned, so nothing could ever load it. Both name the (defvar g
     (Vec u8)) that works, which is the point of refusing them here rather
     than letting the backend say "this one is computed" three passes later. *)
  rejects_check "a global Vec with a computed initialiser"
    "(defvar g (Vec u8) (slurp \"game-data.edn\")) (defn f [] ())"
    ~needle:"starts zeroed";
  rejects_check "a move-only global as a defconst"
    "(defconst g (Vec u8) (slurp \"game-data.edn\")) (defn f [] ())"
    ~needle:"a defvar and not a defconst";
  (* The borrows, which are what is left once ownership is off the table: a
     global Vec is read, mutated in place, viewed and copied, and the copy is
     the one thing something else may own. *)
  accepts "a global Vec is borrowed, mutated and cloned"
    "(defvar g (Vec u8)) \
     (defn f [] () (set g (vec-new u8)) (push g 1) (set (at g 0) 2) \
       (println (len (as-slice g))) (let [c (clone g)] (free c)))";
  (* Ordering handles would order a slot index, which is a free-list artefact.
     Equality is admitted and ordering is not, which is why there are two
     predicates in Types rather than one. *)
  rejects_check "handles do not order"
    "(defn f [a (Handle i32) b (Handle i32)] bool (< a b))"
    ~needle:"no built-in comparison";
  (* free takes the owner. A handle is a copyable number that owns nothing, so
     consuming one copy would say nothing about the others — which is why a
     slot is recycled by (release p h) and not by free. *)
  rejects_check "free of a handle"
    "(defn f [h (Handle i32)] () (free h))" ~needle:"a handle owns nothing";
  (* Cloning a pool would duplicate the generation counters with the slots, so
     one handle would resolve in both copies and name two different things. *)
  rejects_check "a pool cannot be cloned"
    "(defn f [p (Pool i32)] () (let [q (clone p)] (do)))"
    ~needle:"cannot be cloned";
  rejects_check "try is milestone 6"    "(defn f [] i32 (try 1))"
    ~needle:"milestone 6";
  (* dotimes and defer are implemented, and a defer in a [let] is now one of
     the places it may be written: a let at the top level of a function body
     has exactly the function's extent (see test/programs/defer-let.flan). What
     is still rejected is a loop body and a branch, because a defer is copied
     into every exit path — so a loop body's would fire once at function exit
     rather than once per iteration, and a branch cannot say "maybe
     registered". *)
  rejects_check "defer is refused in a loop body"
    "(defn g [] () 0) (defn f [] () (while true (defer (g))))"
    ~needle:"a loop body";
  rejects_check "defer is refused in a branch"
    "(defn g [] () 0) (defn f [] () (if true (defer (g)) 0))"
    ~needle:"a branch";
  (* break and continue. The interesting half is the *relative* rule: a jump
     may not cross a construct that has work to do on the way out, and the
     refusal names which construct. That is what replaced the blanket refusal
     [return] still carries, and the accepting cases below are the ones a
     blanket rule would have got wrong. *)
  accepts "break leaves the innermost loop"
    "(defn f [] () (while true (break)))";
  accepts "a labelled break leaves the named loop"
    "(defn f [] () (while :o true (while true (break :o))))";
  accepts "continue in a dotimes"
    "(defn f [] () (dotimes [i 3] (continue)))";
  rejects_check "break outside a loop"
    "(defn f [] () (break))" ~needle:"only allowed inside a loop";
  rejects_check "continue outside a loop"
    "(defn f [] () (continue))" ~needle:"only allowed inside a loop";
  rejects_check "a label naming no enclosing loop"
    "(defn f [] () (while true (break :nope)))" ~needle:"no loop named :nope";
  (* The rule the blanket one could not express, both ways round. A loop
     wholly inside a restart-case body keeps its local break; a break that
     would *leave* the restart-case is refused, and says so. *)
  accepts "a loop inside a restart-case may break out of itself"
    "(defn f [] () (restart-case (while true (break)) (go [] (println \"\"))))";
  rejects_check "break may not leave a restart-case"
    "(defn f [] () (while true (restart-case (break) (go [] (println \"\")))))"
    ~needle:"a restart-case";
  (* A clause is a barrier for the same reason the body is: it runs after a
     transfer landed, with the form's frames still to be popped. *)
  rejects_check "break may not leave a restart-case from a clause"
    "(defn f [] () (while true (restart-case (println \"\") (go [] (break)))))"
    ~needle:"a restart-case";
  accepts "a loop inside a handler-bind may break out of itself"
    "(defstruct C [n i32])      (defn f [] () (handler-bind [(C [c] 0)] (while true (break))))";
  rejects_check "break may not leave a handler-bind"
    "(defstruct C [n i32])      (defn f [] () (while true (handler-bind [(C [c] 0)] (break))))"
    ~needle:"a handler-bind";
  (* loop and recur. The same stack, the same barriers, and one rule of its
     own: a recur must be in the loop body's tail. That is what makes this
     better than a silent TCO rather than only cheaper — the mistake is a
     compile error here and would be a stack overflow there. *)
  accepts "recur in the tail of the body"
    "(defn f [] i32 (loop [i 0] (if (= i 3) i (recur (+ i 1)))))";
  accepts "recur in the tail of a when"
    "(defn f [] () (loop [i 0] (when (< i 3) (recur (+ i 1)))))";
  accepts "recur in the tail of a nested let"
    "(defn f [] i32 (loop [i 0] (let [n (+ i 1)] (if (= i 3) i (recur n)))))";
  rejects_check "recur that is not in tail position"
    "(defn f [] () (loop [i 0] (recur (+ i 1)) (println \"\")))"
    ~needle:"tail position";
  rejects_check "recur under a call is not in tail position"
    "(defn f [] i32 (loop [i 0] (+ 1 (recur (+ i 1)))))"
    ~needle:"tail position";
  rejects_check "recur in a nested loop body is not in tail position"
    "(defn f [] () (loop [i 0] (while true (recur (+ i 1)))))"
    ~needle:"tail position";
  (* Where the "refuse mutual recursion by name" answer lives: there are no
     tail calls, so a function cannot recur into itself either. *)
  rejects_check "recur outside a loop"
    "(defn f [] () (recur))" ~needle:"no tail calls";
  rejects_check "recur with the wrong number of values"
    "(defn f [] i32 (loop [i 0  j 1] (recur 1)))"
    ~needle:"binds 2 names and this recur passes 1";
  (* The barrier, asked the same question break asks and given the same
     answer, rather than a second mechanism. *)
  rejects_check "recur may not leave a restart-case"
    "(defn f [] () (loop [i 0] (restart-case (recur (+ i 1)) (go [] (println \"\")))))"
    ~needle:"a restart-case";
  (* And the restriction this form adds: a loop answers with the value of its
     body, so a jump out of one would have no value to give. A while written
     inside a loop is untouched, which is the relative rule again. *)
  accepts "a while inside a loop keeps its own break"
    "(defn f [] () (loop [i 0] (while true (break))))";
  rejects_check "break may not leave a loop"
    "(defn f [] () (loop [i 0] (break)))" ~needle:"no value to give";
  rejects_check "a labelled break may not leave a loop"
    "(defn f [] () (while :o true (loop [i 0] (break :o))))"
    ~needle:"no value to give";
  (* A while's condition runs once per trip, so it lives under the same rule
     as the body: what it gives away, it gives away again next time round.
     Before this was checked the program below compiled and aborted in free(). *)
  rejects_check "a while condition may not move what the loop is standing on"
    "(defn eat [v (Vec i32)] bool (do (free v) true)) \
     (defn f [] () (let [v (vec-new i32)] (while (eat v) (break))))"
    ~needle:"evaluated again at the top of every trip";
  accepts "a condition that only looks at what it tests is fine"
    "(defn f [] () (let [v (vec-new i32)  n 0] \
       (while (and (< n 10) (> (len v) 0)) (set n (+ n 1))) (free v)))";
  rejects_check "loop takes no label"
    "(defn f [] () (loop :o [i 0] (recur i)))" ~needle:"loop takes no label";
  rejects_check "a loop binding is a plain name"
    "(defn f [] () (loop [[a b] 0] (recur 0)))" ~needle:"destructuring pattern";
  (* into. The expansion is asserted in programs/into.flan, where the values
     coming out are the test; what belongs here is the three things it refuses,
     each through the one facility a macro has — a name nothing defines. *)
  rejects_check "into needs a source and a destination"
    "(defn f [] () (free (into [1 2 3])))"
    ~needle:"into-takes-a-source-a-destination-and-transforms";
  rejects_check "a transform is map or filter"
    "(defn f [] () (free (into [1 2 3] (vec-new i32) (take 2))))"
    ~needle:"into-transform-is-map-or-filter";
  rejects_check "a transform names one function"
    "(defn f [] () (free (into [1 2 3] (vec-new i32) (map))))"
    ~needle:"into-transform-is-map-or-filter-of-one-function";
  (* An import is resolved by [Load] before the checker runs, so one that
     reaches [Check] means a driver skipped that step. *)
  rejects_check "an unresolved import is a driver bug"
    "(import rl \"vendor:raylib\")" ~needle:"not resolved";
  (* Keywords resolve against an enum and against nothing else. *)
  rejects_check "a keyword needs an enum"
    "(defn g [x i32] ()) (defn f [] () (g :space))" ~needle:"is expected here";
  rejects_check "a keyword with no expectation"
    "(defn f [] () (print (i64 :space)))" ~needle:"no keyword type";
  rejects_check "a keyword that is not a member"
    "(defenum Key [space 32]) (defn g [k Key] ()) (defn f [] () (g :spcae))"
    ~needle:"has no member :spcae";
  accepts "a keyword that is a member"
    "(defenum Key [space 32  r 82]) (defn g [k Key] ()) (defn f [] () (g :r))";
  (* Converting an enum, explicitly, in both directions. The point of the
     conversion is that it is written at the site: a bare integer still does
     not fit an enum parameter, so the checked property — a typo is an error
     here rather than a wrong number later — is untouched. *)
  accepts "an enum converts to an integer"
    "(defenum Key [space 32]) (defn f [k Key] i32 (i32 k))";
  accepts "an enum converts to a float, through its i32"
    "(defenum Key [space 32]) (defn f [k Key] f32 (f32 k))";
  accepts "an integer converts to an enum"
    "(defenum Key [space 32]) (defn g [k Key] ()) (defn f [i i32] () (g (Key i)))";
  accepts "a value that is no declared member converts"
    "(defenum Key [space 32]) (defn g [k Key] ()) (defn f [] () (g (Key 999)))";
  rejects_check "an integer still does not fit an enum on its own"
    "(defenum Key [space 32]) (defn g [k Key] ()) (defn f [i i32] () (g i))"
    ~needle:"expected Key";
  rejects_check "an enum does not convert to another enum"
    "(defenum A [x 1]) (defenum B [y 1]) (defn f [a A] B (B a))"
    ~needle:"converts an integer to an enum";
  rejects_check "a float does not convert to an enum"
    "(defenum Key [space 32]) (defn f [x f32] Key (Key x))"
    ~needle:"converts an integer to an enum";
  (* An enum is a return type, which needed parse.ml to know enum names. It
     knows them under a key of their own: (Key n) is a value now, so putting
     Key in [types] would make a body starting with one be eaten as a return
     type — the exact trap [is_type_form]'s comment is about. *)
  accepts "an enum is a return type"
    "(defenum Key [space 32]) (defn f [i i32] Key (Key i))";
  accepts "an enum conversion at the head of a body is not a return type"
    "(defenum Key [space 32]) (defn g [k Key] ()) \
     (defn f [] () (Key 1) (g :space))";
  rejects_check "an enum conversion takes one argument"
    "(defenum Key [space 32]) (defn f [] Key (Key 1 2))"
    ~needle:"1 argument";
  (* A folded constant skips [check], so its range check has to be its own. *)
  rejects_check "a folded constant is still range-checked"
    "(defconst c u8 300) (defn f [] u8 c)" ~needle:"does not fit in u8";
  (* One top-level namespace, enforced across declaration kinds. Each of these
     used to pass the checker — the tables are per-kind — and be caught by LLVM
     as a redefinition of an emitted symbol, or not caught at all. *)
  rejects_check "a global defined twice"
    "(defvar x i32 1) (defvar x i32 2)" ~needle:"defined twice";
  rejects_check "a constant shadowing a variable"
    "(defconst c 1) (defvar c i32 2)" ~needle:"defined twice";
  rejects_check "a function and a global"
    "(defn item [] i32 1) (defvar item i32 2)" ~needle:"defined twice";
  rejects_check "a struct and an alias"
    "(defstruct P [x i32]) (defalias P i32)" ~needle:"defined twice";
  rejects_check "an enum and a struct"
    "(defenum E [a 1]) (defstruct E [x i32])" ~needle:"defined twice";
  rejects_check "an extern and a constant"
    "(declare cw [] \"flan_cw\") (defconst cw 1)" ~needle:"defined twice";
  (* A shift by the operand's own width or more is poison in LLVM, and at -O2
     a poison return is a function that returns nothing at all. A literal count
     is rejected; a computed one is masked in [emit]. *)
  rejects_check "a shift past the operand's width"
    "(defn f [] i32 (<< 1 32))" ~needle:"out of range";
  rejects_check "a right shift past the operand's width"
    "(defn f [] u8 (>> (u8 1) 8))" ~needle:"out of range";
  accepts "a shift by the widest count in range"
    "(defn f [] i32 (<< 1 31))";
  (* An index converts from a narrower integer and never from a wider one. *)
  accepts "a u32 index" "(defvar a [4 u32]) (defn f [] u32 (let [i 2] (at a (u32 i))))";
  rejects_check "an i64 index"
    "(defvar a [4 u32]) (defn f [] u32 (let [i 2] (at a (i64 i))))"
    ~needle:"is wider";

  (* An aggregate cannot cross to C — the shim's job, in C, per target. *)
  rejects_check "an extern may not take a struct"
    "(defstruct V [x f32]) (declare f [v V] \"c_f\")" ~needle:"cannot cross to C";
  rejects_check "an extern may not return a struct"
    "(defstruct V [x f32]) (declare f [] V \"c_f\")" ~needle:"cannot cross to C";
  (* Function values landed; what stayed refused is what they do not include.
     An fn takes its parameter types from the position it is written in, and a
     defn's body that just answers one says nothing about them. *)
  rejects_check "an fn with nothing to say what it takes"
    "(defn f [] () (fn [x] x))" ~needle:"nothing here says what this fn";
  rejects_check "type variables are milestone 5" "(defn f [x a] ())"
    ~needle:"milestone 5";
  (* The other half: a name in value position now *works*, and the arity is
     checked against the function it names. *)
  rejects_check "a function value at the wrong arity"
    "(defn g [x i32] i32 x) (defn u [f (Fn [i32] i32)] i32 (f 1 2)) \
     (defn f [] i32 (u g))"
    ~needle:"takes 1 argument, given 2";

  rejects_check "a struct cannot contain itself by value"
    "(defstruct Node [next Node])" ~needle:"contains itself by value";
  rejects_check "nor through a fixed array"
    "(defstruct Node [kids [2 Node]])" ~needle:"contains itself by value";
  accepts "a pointer breaks the cycle"
    "(defstruct Node [next (Ptr Node)])";
  rejects_check "an integer literal must fit its type"
    "(defn f [] u8 300)" ~needle:"does not fit in u8";
  accepts "sequential let bindings"
    "(defn f [] i32 (let [a 1 b (+ a 1)] b))";

  (* An array literal is [n T] and does not satisfy a slice expectation:
     the two are distinct in type and in ownership (spec-memory.md). *)
  rejects_check "array literal is not a slice"
    "(defn f [] [u8] [1 2 3])" ~needle:"expected [u8]";
  rejects_check "array literal is not a struct"
    "(defstruct C [pos i32]) (defn f [] C [1 2])" ~needle:"expected C";
  rejects_check "wrong element count"
    "(defvar xs [2 i32] [1 2 3])" ~needle:"expected 2 elements";

  (* Top-level names are order-independent (plan.org, Modules) — including
     constants used as array lengths and constants defined in terms of each
     other. *)
  accepts "a constant declared after its use as a length"
    "(defvar grid [rows i32]) (defconst rows 8)";
  accepts "constants defined out of order"
    "(defconst a (+ b 1)) (defconst b 1)";
  accepts "an untyped constant from a later function"
    "(defconst k (g)) (defn g [] u8 1)";
  rejects_check "a genuinely unknown constant still reports itself"
    "(defconst a (+ nope 1))" ~needle:"unknown name nope";

  (* ── Conditions, spec-conditions.md §1 and §2 ──────────────────── *)

  accepts "handler-bind over a struct condition"
    "(defstruct C [id i32]) (defvar n i64)\n\
     (defn f [] () (handler-bind [(C [c] (set n 1))] (signal (C {.id 2}))))";
  (* Matching is by type and there is no hierarchy, so a condition has to be a
     struct — an integer would have nothing to match against. *)
  rejects_check "signalling a non-struct"
    "(defn f [] () (signal 1))" ~needle:"a condition is a struct";
  rejects_check "erroring with a non-struct"
    "(defn f [] () (error 1))" ~needle:"a condition is a struct";
  (* §2: error is Never, so it unifies with anything — including the position
     where a value of some other type was expected. That is what makes it
     usable as a restart-case body's fall-through. *)
  accepts "error in value position"
    "(defstruct C [id i32])\n\
     (defn f [] i32 (error (C {.id 1})))";
  (* And signal is not: it is Unit, whatever it finds. *)
  rejects_check "signal in value position"
    "(defstruct C [id i32])\n\
     (defn f [] i32 (signal (C {.id 1})))" ~needle:"expected i32";
  (* A handler is lifted into a function of its own, so the establishing
     function's locals are not there. Capturing them is a closure, which is
     milestone 5 — until then it is refused for the reason it is refused for
     rather than as an unknown name. *)
  rejects_check "a handler capturing a local"
    "(defstruct C [id i32])\n\
     (defn f [] () (let [n 0] (handler-bind [(C [c] (set n 1))] (signal (C {.id 2})))))"
    ~needle:"a handler cannot see n";
  (* The frames are popped on the way out of the body, so an early exit would
     leave them on the stack pointing into a function that has gone. *)
  rejects_check "return inside handler-bind"
    "(defstruct C [id i32])\n\
     (defn f [] i32 (handler-bind [(C [c] (signal c))] (return 1)) 0)"
    ~needle:"return is not allowed inside handler-bind";
  (* spec-memory.md gives a map an upsert of its own, so there is no store
     into a lookup and no place form for one. Refused with that reason rather
     than as a milestone that will never arrive. *)
  rejects_check "a map entry as a place"
    "(defn f [] () (set (get m 1) 2))"
    ~needle:"a map is written with (put m k v)";

  (* ── restart-case and invoke-restart, §3 to §6 ─────────────────── *)

  accepts "restart-case with a clause that transfers into it"
    "(defstruct C [id i32])\n\
     (defn g [] i32 (signal (C {.id 1})) 0)\n\
     (defn f [] i32 (restart-case (g) (skip [] 7)))\n\
     (defn h [] i32 (handler-bind [(C [c] (invoke-restart 'skip))] (f)))";
  (* §3: the body and every clause yield the whole form, so they have to agree
     — which is also what makes the fall-through path visible in the source.
     With a type expected from outside they are each checked against it; with
     none, as in a let binding, the first one that produces a value sets it. *)
  rejects_check "a clause that disagrees with the body"
    "(defn f [] i32 (restart-case 1 (skip [] \"no\")))"
    ~needle:"expected i32, found string";
  rejects_check "two clauses that disagree, with nothing expected"
    "(defn f [] i32 (let [x (restart-case (exit 1) (a [] 1) (b [] \"no\"))] 0))"
    ~needle:"expected i32, found string";
  (* §4 finds the first frame offering a name. Two of one name in one frame
     would make that a choice nothing in the source shows. *)
  rejects_check "one restart-case offering a name twice"
    "(defn f [] i32 (restart-case 1 (skip [] 2) (skip [] 3)))"
    ~needle:"offers skip twice";
  (* Same rule as handler-bind: the restart frames are popped on the way out. *)
  rejects_check "return inside restart-case"
    "(defn f [] i32 (restart-case (return 1) (skip [] 2)))"
    ~needle:"return is not allowed inside restart-case";
  (* §3's parameters. A clause binds them like a function's, so the body sees
     them and nothing outside does; what they are is checked against the
     invoke at run time, because the two ends meet on a dynamic stack. *)
  accepts "a restart with parameters"
    "(defn f [] i32 (restart-case 1 (skip [n i32] n)))";
  accepts "invoke-restart with arguments"
    "(defn f [] () (invoke-restart 'skip 1))";
  rejects_check "a restart parameter outside its clause"
    "(defn f [] i32 (+ (restart-case 1 (skip [n i32] n)) n))"
    ~needle:"unknown name n";
  rejects_check "a restart argument that is not a value"
    "(defn f [] () (invoke-restart 'skip (println \"\")))"
    ~needle:"a restart argument must be a value";
  rejects_check "invoke-restart on an unquoted name"
    "(defn f [] () (invoke-restart skip))"
    ~needle:"a quoted restart name and then its arguments";
  (* §5 runs the defers on the way out, so a defer is already the cleanup path
     a transfer uses. One that starts its own transfer has no answer. *)
  rejects_check "invoke-restart inside a defer"
    "(defn f [] i32 (defer (invoke-restart 'skip)) 0)"
    ~needle:"not allowed inside a defer";
  (* Still unimplemented, and still says so by name — which is the point: an
     operator the spec names and the compiler lacks must not fall through to a
     call and come back as an unknown name. *)
  List.iter
    (fun (name, src) ->
       rejects_check (name ^ " is still unimplemented") src
         ~needle:"not implemented yet")
    [ "handler-case",     "(defn f [] () (handler-case 1))";
      "find-restart",     "(defn f [] () (find-restart 'skip))";
      "compute-restarts", "(defn f [] () (compute-restarts))" ];

  (* ── Destructuring ─────────────────────────────────────────────── *)

  (* A pattern is desugared in [Parse] into the bindings and field accesses that
     already existed, so what these assert is that the desugaring is *checked* —
     the same errors an equivalent hand-written let would raise, pointing at the
     pattern that stands in for it. *)
  let pt = "(defstruct Point [x i32  y i32])\n" in
  let line = pt ^ "(defstruct Line [a Point  b Point])\n" in

  accepts "struct pattern with :keys"
    (pt ^ "(defn f [p Point] i32 (let [{:keys [x y]} p] (+ x y)))");
  accepts "struct pattern with a name/:field pair"
    (pt ^ "(defn f [p Point] i32 (let [{a .x b .y} p] (+ a b)))");
  accepts "a nested struct pattern"
    (line ^ "(defn f [l Line] i32 (let [{{:keys [x y]} .a} l] (+ x y)))");
  (* A later binding sees an earlier pattern's names, as in any let. *)
  accepts "a binding after a pattern sees its names"
    (pt ^ "(defn f [p Point] i32 (let [{:keys [x]} p  y (+ x 1)] y))");
  (* Shadowing works because the value goes into a temporary first. *)
  accepts "a pattern may shadow the name it destructures"
    (line ^ "(defn f [a Line] i32 (let [{a .a} a] (.x a)))");
  accepts "a pattern over a call"
    (pt ^ "(defn mk [] Point (Point {.x 1 .y 2}))\n\
           (defn f [] i32 (let [{:keys [x y]} (mk)] (+ x y)))");

  rejects_check "a field the struct does not have"
    (pt ^ "(defn f [p Point] i32 (let [{:keys [x z]} p] (+ x z)))")
    ~needle:"Point has no field z";
  rejects_check "a struct pattern over something that is not a struct"
    "(defn f [n i32] i32 (let [{:keys [x]} n] x))"
    ~needle:"i32 is not a struct, so it has no fields";
  rejects_check "one pattern binding a name twice"
    (pt ^ "(defn f [p Point] i32 (let [{:keys [x x]} p] x))")
    ~needle:"this pattern binds x twice";
  rejects_check "an empty struct pattern"
    (pt ^ "(defn f [p Point] i32 (let [{} p] 0))")
    ~needle:"an empty struct pattern {} binds nothing";
  rejects_check "a field name with no pattern before it"
    (pt ^ "(defn f [p Point] i32 (let [{.x} p] 0))")
    ~needle:"has no .field";
  rejects_check "a pattern with no field name after it"
    (pt ^ "(defn f [p Point] i32 (let [{a b} p] 0))")
    ~needle:"expected .field after a";
  (* The same refusal on the destructuring side: a field is a field wherever it
     is named, so the rule is not half-applied. :keys is the one that keeps its
     colon, and the test below it says so. *)
  rejects_check "a destructured field written with a colon"
    (pt ^ "(defn f [p Point] i32 (let [{a :x} p] a))")
    ~needle:"a field label is written .x, not :x";
  accepts ":keys keeps its colon, naming no field"
    (pt ^ "(defn f [p Point] i32 (let [{:keys [x y]} p] (+ x y)))");

  (* Clojure's other map-destructuring keys. Each is refused by its own name:
     "unexpected form" would leave the author guessing which of the four they
     wrote is the one this does not have. *)
  List.iter
    (fun k ->
       rejects_check (k ^ " in a struct pattern")
         (pt ^ Printf.sprintf
                 "(defn f [p Point] i32 (let [{:keys [x] %s q} p] x))" k)
         ~needle:(k ^ " is not implemented in a destructuring pattern"))
    [ ":as"; ":or"; ":strs"; ":syms" ];

  (* ── Sequential patterns, and the asymmetry ────────────────────── *)

  (* A fixed array's length is in its type, so the arity is a claim the checker
     can settle. *)
  accepts "an array pattern naming every element"
    "(defn f [] i32 (let [xs [1 2 3]  [a b c] xs] (+ a (+ b c))))";
  accepts "an array pattern with & rest"
    "(defn f [] i32 (let [xs [1 2 3]  [a & r] xs] (+ a (len r))))";
  accepts "& rest taking an empty tail"
    "(defn f [] i32 (let [xs [1 2]  [a b & r] xs] (+ a (+ b (len r)))))";
  accepts "a struct pattern nested in an array pattern"
    (pt ^ "(defn f [ps [2 Point]] i32 \
             (let [[{:keys [x]} {y .y}] ps] (+ x y)))");

  rejects_check "an array pattern that names too few elements"
    "(defn f [] i32 (let [xs [1 2 3]  [a b] xs] (+ a b)))"
    ~needle:"this pattern binds 2 names, but [3 i32] has 3 elements";
  rejects_check "an array pattern that names too many"
    "(defn f [] i32 (let [xs [1 2]  [a b c] xs] (+ a (+ b c))))"
    ~needle:"this pattern binds 3 names, but [2 i32] has 2 elements";
  rejects_check "& rest with more names before it than there are elements"
    "(defn f [] i32 (let [xs [1 2]  [a b c & r] xs] a))"
    ~needle:"binds 3 names before the &, but [2 i32] has only 2 elements";

  (* The asymmetry, and the reason this is refused rather than lowered to a
     bounds-checked [at]: over a slice the arity is a claim about a number that
     does not exist until the program runs, so a pattern that type checks would
     be one that kills the program instead. *)
  rejects_check "an array pattern over a slice"
    "(defn f [s [i32]] i32 (let [[a b] s] (+ a b)))"
    ~needle:"a slice's length is a runtime value";
  rejects_check "an array pattern over a slice, even with & rest"
    "(defn f [s [i32]] i32 (let [[a & r] s] (+ a (len r))))"
    ~needle:"a slice's length is a runtime value";
  rejects_check "an array pattern over something with no elements at all"
    "(defn f [n i32] i32 (let [[a b] n] (+ a b)))"
    ~needle:"i32 is not a fixed array";

  rejects_check "an empty array pattern"
    "(defn f [] i32 (let [xs [1 2]  [] xs] 0))"
    ~needle:"an empty array pattern [] binds nothing";
  rejects_check "& with nothing after it"
    "(defn f [] i32 (let [xs [1 2]  [a &] xs] a))"
    ~needle:"& needs a name after it";
  rejects_check "& with two names after it"
    "(defn f [] i32 (let [xs [1 2]  [a & r s] xs] a))"
    ~needle:"& takes one name";
  rejects_check "a pattern that is only & rest"
    "(defn f [] i32 (let [xs [1 2]  [& r] xs] (len r)))"
    ~needle:"binds the whole value";
  rejects_check "one array pattern binding a name twice"
    "(defn f [] i32 (let [xs [1 2]  [a a] xs] a))"
    ~needle:"this pattern binds a twice";

  (* ── Where a pattern is not a binding form ─────────────────────── *)

  (* Every other binding position takes a plain name. A parameter is the one
     worth a reason: it is a name/type pair, and a pattern has no name for the
     type to pair with. Refused where it is written, not left to fall out of
     "expected a name". *)
  List.iter
    (fun (what, src) ->
       rejects_check ("a pattern in " ^ what) src
         ~needle:"a pattern binds only in let")
    [ "a defn parameter",    pt ^ "(defn f [{:keys [x]} Point] i32 x)";
      "a defstruct field",   "(defstruct S [[a b] i32])";
      "an fn parameter",     "(defn f [] i32 (let [g (fn [[a b]] a)] 0))";
      "a dotimes counter",   "(defn f [] () (dotimes [[a b] 3] 0))";
      "a declare parameter", pt ^ "(declare g [{:keys [x]} Point] \"G\")" ];

  (* ── match over an enum ────────────────────────────────────────── *)

  (* Not shipped, and refused twice over because there are two ways to write it
     and they fail in different files. Both now say the same thing, which is the
     point: the lowering is not what is missing — a keyword has no case in
     [Ast.pattern], and [lib/load.ml] matches that type exhaustively. *)
  rejects_check "match over an enum, members written as keywords"
    "(defenum K [lo 0  hi 1])\n(defn f [k K] i32 (match k :lo 1 :hi 2))"
    ~needle:"is not implemented as a pattern";
  rejects_check "match over an enum, members written as names"
    "(defenum K [lo 0  hi 1])\n(defn f [k K] i32 (match k lo 1 hi 2))"
    ~needle:"match over the enum K is not implemented";
  (* The old message blamed milestone 2, which was never the reason, and the
     milestone has since arrived: match now works over a declared data type as
     well, so the message names both subjects and no milestone. *)
  rejects_check "match over something that is neither"
    "(defn f [n i32] i32 (match n _ 2))"
    ~needle:"match works on an Option or a data type, not on i32";
  (* A destructuring pattern in an arm's binds is a name position like any
     other. *)
  rejects_check "a pattern inside a match arm's binds"
    "(defstruct P [x i32])\n\
     (defn f [o (Option P)] i32 (match o (Some {:keys [x]}) x None 0))"
    ~needle:"a pattern binds only in let";

  (* The desugaring's own machinery is unspellable: the reader makes [~] a
     delimiter, so the name never reaches the parser as one symbol. *)
  rejects_check "the desugaring's internal name cannot be written by hand"
    "(defn f [] i32 (let [xs [1 2]] (destructure~nth xs 0 2 1)))"
    ~needle:"means nothing outside a quasiquote";

  (* ── The untagged union ────────────────────────────────────────── *)

  (* Every one of these is a rule the type would be unsound or useless
     without, and each says so in its own words rather than falling through to
     something generic. The layout itself is pinned where a layout can only be
     pinned, against the backend that computes it — see the DWARF/LLVM oracle
     in test_acceptance.ml — and what it *does* is pinned by a program that
     writes one member and reads another, which is the whole point of the
     type. What is here is the catalogue of what it refuses. *)
  (match (parse_decl "(defunion U [i i32  f f32])").Ast.d with
   | Ast.Defunion ("U", [ a; b ]) ->
     check "defunion parses as a member list"
       (a.Ast.fname = "i" && b.Ast.fname = "f")
   | _ -> check "defunion parses as a member list" false);

  (* Nothing to read out of, and no size. It parses; it is refused where the
     message can name the shape. *)
  rejects_check "a union with no members"
    "(defunion U [])\n(defn f [u U] i32 0)"
    ~needle:"declares no members";
  rejects_check "a union that declares a member twice"
    "(defunion U [x i32  x f32])\n(defn f [u U] i32 0)"
    ~needle:"declares the same member twice";
  (* The size is the largest member and the largest member is the whole type,
     so this is the same infinite type a self-containing struct is. *)
  rejects_check "a union that contains itself by value"
    "(defunion U [a i32  b U])\n(defn f [u U] i32 0)"
    ~needle:"contains itself by value";
  (* Not waiting on drop, unlike the struct and data type refusals: nothing
     records which member is live, so there is no fact recursive teardown
     could read. *)
  rejects_check "a union member that is move-only"
    "(defunion U [n i64  v (Vec i32)])\n(defn f [u U] i32 0)"
    ~needle:"nothing records which was written";
  (* And the one the optimiser would otherwise be handed: a byte that is
     neither 0 nor 1 read as an i1. Refused at any depth, which is why the
     second row goes through a struct. *)
  rejects_check "a bool member"
    "(defunion U [b bool  n u8])\n(defn f [u U] i32 0)"
    ~needle:"a union may not hold one at any depth";
  rejects_check "a bool inside a struct member"
    "(defstruct S [flag bool  n i32])\n\
     (defunion U [s S  n i64])\n(defn f [u U] i32 0)"
    ~needle:"a union may not hold one at any depth";
  (* The same hazard as uninit on a data type, arriving the other way round: a
     member written over the tag leaves a tag no case names, and a match on it
     falls into a block the optimiser may treat as unreachable. Refused at any
     depth for the reason bool is. *)
  rejects_check "a data type member"
    "(defdata D [A (B [x i32])])\n\
     (defunion U [d D  n i64])\n(defn f [u U] i32 0)"
    ~needle:"a data type's tag steers every match";
  rejects_check "a data type inside a struct member"
    "(defdata D [A B])\n(defstruct S [d D  n i32])\n\
     (defunion U [s S  n i64])\n(defn f [u U] i32 0)"
    ~needle:"a data type's tag steers every match";
  (* An Option is not on that list, and the difference is the lowering: its
     match is a test of the tag byte and a branch, so a scribbled tag reads as
     a Some with a payload nobody stored — which is what this language says a
     union read is. *)
  (match checked "(defunion U [o (Option i32)  n i64])\n\
                  (defn f [u U] i32 (match (.o u) (Some x) x None 0))" with
   | _ -> check "an Option member is allowed" true
   | exception Loc.Error { Loc.dmsg = msg; _ } ->
     incr failures;
     Printf.printf "FAIL  an Option member is allowed: %s\n" msg);
  (* One member named twice is a different mistake from two members named, and
     it gets the refusal the struct path already had. *)
  rejects_check "a union literal naming one member twice"
    "(defunion U [i i32])\n\
     (defn f [] i32 (let [u (U {.i 1  .i 2})] (.i u)))"
    ~needle:"member i is given twice";

  (* Two members is one storage written twice, and which one survived would be
     whatever the compiler happened to do last. *)
  rejects_check "a union literal giving two members"
    "(defunion U [i i32  f f32])\n\
     (defn f [] i32 (let [u (U {.i 1  .f 2.0})] (.i u)))"
    ~needle:"only one of them can be written";
  rejects_check "a union literal giving a member it does not have"
    "(defunion U [i i32])\n(defn f [] i32 (let [u (U {.z 1})] (.i u)))"
    ~needle:"U has no member z";
  (* There is no tag, so there is nothing for the arms to be alternatives
     over. Said by name because the two kinds of union are one keyword apart
     and somebody will write it. *)
  rejects_check "match on a union"
    "(defunion U [i i32  f f32])\n\
     (defn f [u U] i32 (match u _ 0))"
    ~needle:"there is nothing in one to match on";
  (* A member narrower than the union leaves the rest indeterminate, so two
     values that agree about everything anybody wrote would hash apart. *)
  rejects_check "a union as a map key"
    "(defunion U [i i32  f f32])\n\
     (defn f [m (Map U i32) k U] () (put m k 1))"
    ~needle:"a union is not a map key";
  (* A global's initialiser is a constant and writing a member is a store. The
     zeroed and uninit forms need none of that and are accepted below. *)
  rejects_check "a global initialised with a union member"
    "(defunion U [i i32])\n(defvar g U (U {.i 1}))\n(defn f [] i32 0)"
    ~needle:"cannot be written into a global";
  (* A defconst reaches the same emitter by a different path, so it gets the
     same refusal rather than coming back as "this one is computed". *)
  rejects_check "a constant initialised with a union member"
    "(defunion U [i i32])\n(defconst c U (U {.i 1}))\n(defn f [] i32 0)"
    ~needle:"cannot be written into a constant";
  (* The all-bytes-zero value is a constant and goes through, which is what
     makes (U {}) and a declaration with no value the same thing. *)
  (match checked "(defunion U [i i32])\n(defvar g U (U {}))\n\
                  (defn f [] i32 (.i g))" with
   | _ -> check "a global zeroed through a literal is allowed" true
   | exception Loc.Error { Loc.dmsg = msg; _ } ->
     incr failures;
     Printf.printf "FAIL  a global zeroed through a literal is allowed: %s\n" msg);
  (* uninit is refused on a data type because its tag steers a match into a
     block LLVM may treat as unreachable. An untagged union steers nothing, so
     the argument does not carry over and the answer is different. *)
  (match checked "(defunion U [i i32  f f32])\n(defvar g U uninit)\n\
                  (defn f [] i32 (.i g))" with
   | _ -> check "uninit on a union is allowed" true
   | exception Loc.Error { Loc.dmsg = msg; _ } ->
     incr failures;
     Printf.printf "FAIL  uninit on a union is allowed: %s\n" msg);
  (* The shim writes structs and has no spelling for a union yet — a refusal
     about the generator, not about the type, and it says so. *)
  rejects_check "a union crossing to C by value"
    "(defunion U [i i32])\n(declare-c take [u U] () \"take\")"
    ~needle:"the shim generator writes structs only";

  (* ── Reading a C header (cimport.ml, cjson.ml) ─────────────────── *)

  (* Against test/headers/sample.h, which is one function per decision the
     importer makes and is committed so that it cannot move. The raylib case
     is better evidence and worse coverage: it needs raylib installed, at the
     version whose .so is linked, with FLAN_RAYLIB_H set, so as the only test
     of this it would skip everywhere.

     The assertions are on the *reasons*, not on the counts, for the reason the
     acceptance table gives: a refusal that fires for the wrong cause still
     refuses, and a count still matches. *)
  let imported, dump, env, fixture_ds =
    let fixture =
      "(defstruct Pair [x f32  y f32])\n\
       (defstruct Shade [r u8  g u8  b u8  a u8])\n\
       (defenum Mood [calm 0  cross 1])\n\
       (defunion Overlay [i i32  f f32])\n\
       (defstruct Slot [kind i32  v Overlay])\n"
    in
    let ds = program fixture in
    let taken = Hashtbl.create 16 in
    List.iter
      (fun d ->
         match Ast.declared_name d with
         | Some n -> Hashtbl.replace taken n ()
         | None -> ())
      ds;
    let known_structs =
      List.filter_map
        (fun (d : Ast.decl) ->
           match d.Ast.d with Ast.Defstruct (n, _) -> Some n | _ -> None)
        ds
    and known_unions =
      List.filter_map
        (fun (d : Ast.decl) ->
           match d.Ast.d with Ast.Defunion (n, _) -> Some n | _ -> None)
        ds
    and known_enums =
      List.filter_map
        (fun (d : Ast.decl) ->
           match d.Ast.d with Ast.Defenum (n, _) -> Some n | _ -> None)
        ds
    in
    let i, d, e =
      Cimport.header ~loc:Loc.unknown ~header:"headers/sample.h" ~flags:[]
        ~known_structs ~known_unions ~known_enums ~taken ~bound_syms:[]
        ~config:Cimport.no_config
    in
    (i, d, e, ds)
  in

  (* What came out, as source, so a wrong type is visible as the line somebody
     would otherwise have had to write by hand. *)
  let produced = List.map Cimport.decl_source imported.Cimport.decls in
  let emits name line =
    check ("import-c emits " ^ name) (List.mem line produced)
  in
  emits "a scalar signature" "(declare-c set-seed [seed u32] \"set_seed\")";
  emits "two scalars and a return"
    "(declare-c add-ints [a i32  b i32] i32 \"add_ints\")";
  (* An aggregate return is the flattening path: Shim turns it into an
     out-pointer, and the declaration it starts from has to say the struct. *)
  emits "an aggregate return"
    "(declare-c make-pair [x f32  y f32] Pair \"make_pair\")";
  emits "an aggregate parameter" "(declare-c pair-len [p Pair] f32 \"pair_len\")";
  (* const char * is a string going in — the one C spelling that means
     something different in a parameter than it does anywhere else. *)
  emits "const char * as a string parameter"
    "(declare-c name-length [text string] i32 \"name_length\")";
  emits "a pointer parameter"
    "(declare-c count-at [values (Ptr i32)  n i32] i32 \"count_at\")";
  (* struct Pair is both Pair and Point in the header and the package
     describes it once, so both names have to land on the one defstruct —
     raylib does exactly this with Texture2D and TextureCubemap. *)
  emits "a second typedef name for a described record"
    "(declare-c point-of [p Pair] Pair \"point_of\")";
  (* A C enum is an int, and so is a Flan defenum at the boundary; matching by
     name is what keeps the nicer face. *)
  emits "a C enum against a defenum of the same name"
    "(declare-c mood-value [m Mood] i32 \"mood_value\")";
  emits "a function of no arguments" "(declare-c take-nothing [] \"take_nothing\")";

  (* And the refusals, each by its reason rather than by a count. *)
  let refused name needle =
    check
      ("import-c refuses " ^ name ^ ": " ^ needle)
      (List.exists
         (fun (n, why) -> n = name && contains why needle)
         imported.Cimport.hidden)
  in
  refused "name-of" "returns char *";
  refused "fill-buffer" "C may write through";
  refused "printf-like" "is variadic";
  refused "on-event" "is a function pointer";
  refused "file-time" "width that differs";
  refused "make-undescribed" "the package does not describe";
  (* The order-dependent one. Spin2D and spin2d both kebab to spin-2d, so
     neither may have it: whichever won would depend on the order the header
     declares them in, and moving two lines in somebody else's header would
     rebind a name a program is already calling. *)
  refused "spin-2d" "would depend on the order";
  check "a colliding name is not imported after all"
    (not (List.exists (fun l -> contains l "\"Spin2D\"") produced));
  check "nor is the other half of the collision"
    (not (List.exists (fun l -> contains l "\"spin2d\"") produced));

  (* ── The config beside the header (Cimport.read_config) ────────── *)

  (* Why there is a config at all: the generated declarations are committed, so
     a hand-edit to them is destroyed by the next regeneration and the edit has
     to live somewhere regeneration reads instead. These are the two things it
     can say. *)
  let with_config config =
    let taken = Hashtbl.create 16 in
    List.iter
      (fun d ->
         match Ast.declared_name d with
         | Some n -> Hashtbl.replace taken n ()
         | None -> ())
      fixture_ds;
    let known_structs =
      List.filter_map
        (fun (d : Ast.decl) ->
           match d.Ast.d with Ast.Defstruct (n, _) -> Some n | _ -> None)
        fixture_ds
    and known_unions =
      List.filter_map
        (fun (d : Ast.decl) ->
           match d.Ast.d with Ast.Defunion (n, _) -> Some n | _ -> None)
        fixture_ds
    and known_enums =
      List.filter_map
        (fun (d : Ast.decl) ->
           match d.Ast.d with Ast.Defenum (n, _) -> Some n | _ -> None)
        fixture_ds
    in
    let i, _, _ =
      Cimport.header ~loc:Loc.unknown ~header:"headers/sample.h" ~flags:[]
        ~known_structs ~known_unions ~known_enums ~taken ~bound_syms:[] ~config
    in
    (List.map Cimport.decl_source i.Cimport.decls, i.Cimport.hidden)
  in

  let lines, hidden =
    with_config { Cimport.no_config with Cimport.excludes = [ "set_seed" ] }
  in
  check "an excluded symbol is not generated"
    (not (List.exists (fun l -> contains l "\"set_seed\"") lines));
  (* Not silently absent. "there is no such binding" and "the package decided
     against this binding" are different answers and a reader gets the second,
     which is what [hidden] is for. *)
  check "and it says it was excluded rather than going quiet"
    (List.exists
       (fun (n, why) -> n = "set-seed" && contains why "excluded by the package")
       hidden);

  let lines, _ =
    with_config { Cimport.no_config with Cimport.excludes = [ "add_*" ] }
  in
  check "an exclude pattern matches by prefix"
    (not (List.exists (fun l -> contains l "\"add_ints\"") lines));
  check "and leaves everything it does not match"
    (List.exists (fun l -> contains l "\"set_seed\"") lines);

  let lines, _ =
    with_config
      { Cimport.no_config with Cimport.renames = [ ("set_seed", "seed!") ] }
  in
  (* The C symbol is kept verbatim, so an override changes the Flan face and
     nothing else — which is what makes it safe to spell a predicate the way
     Lisp spells one. *)
  check "a name override is the Flan name, and the C symbol is untouched"
    (List.mem "(declare-c seed! [seed u32] \"set_seed\")" lines);

  (* The collision above is refused because neither Spin2D nor spin2d may take
     [spin-2d] by an accident of header order. Naming one of them is the way
     out, and it is the reason the kebab rule is consulted in exactly one
     place: the groups are computed on the name a function will really take,
     so the rename dissolves the group rather than leaving both refused. *)
  let lines, hidden =
    with_config
      { Cimport.no_config with Cimport.renames = [ ("Spin2D", "spin-2d-upper") ] }
  in
  check "a rename resolves a collision for both halves"
    (List.exists (fun l -> contains l "\"Spin2D\"") lines
     && List.exists (fun l -> contains l "\"spin2d\"") lines);
  check "and the collision is no longer refused"
    (not (List.mem_assoc "spin-2d" hidden));

  (* The file, since a typo in it would otherwise show up as a binding under
     the wrong name. A line that is neither directive is an error rather than a
     line quietly skipped. *)
  let config_file text =
    let f = Filename.temp_file "flan-bindings" "" in
    let ch = open_out f in
    output_string ch text;
    close_out ch;
    f
  in
  let c = Cimport.read_config (config_file "# a comment\n\nexclude Mem*\nname IsWindowReady window-ready?\n") in
  check "read_config reads an exclude" (c.Cimport.excludes = [ "Mem*" ]);
  check "read_config reads a name override"
    (c.Cimport.renames = [ ("IsWindowReady", "window-ready?") ]);
  check "a missing config is no exclusions and no overrides"
    (Cimport.read_config "no-such-bindings-file" = Cimport.no_config);
  check "a line that is neither directive is refused"
    (match Cimport.read_config (config_file "rename Foo bar\n") with
     | _ -> false
     | exception Loc.Error { Loc.dmsg = m; _ } -> contains m "and this is neither");

  (* A refused name is a name that exists and cannot be had — Zig's failDecl,
     which Load.refuse_hidden already implements for main. Nothing may be in
     both lists, or asking for a name that works would report that it does
     not. *)
  check "nothing is both imported and refused"
    (not
       (List.exists
          (fun (d : Ast.decl) ->
             match Ast.declared_name d with
             | Some n -> List.mem_assoc n imported.Cimport.hidden
             | None -> false)
          imported.Cimport.decls));

  (* The struct check, which is the point of reading a header the generator
     does not otherwise need: the defstruct and the header's record have
     different authors, so a disagreement is real information. A
     _Static_assert was rejected in docs/BUILT.md as circular for want of exactly
     that. *)
  let structs_of ds =
    List.filter_map
      (fun (d : Ast.decl) ->
         match d.Ast.d with Ast.Defstruct (n, fs) -> Some (n, fs) | _ -> None)
      ds
  in
  check "a defstruct that matches the header is not reported"
    (Cimport.check_structs ~env ~structs:(structs_of fixture_ds) dump = []);
  (* Permuted: the failure docs/BUILT.md says only a test can catch, because every
     field still reads as a plausible number. *)
  check "a permuted defstruct is reported"
    (match
       Cimport.check_structs ~env
         ~structs:(structs_of (program "(defstruct Pair [y f32  x f32])\n")) dump
     with
     | [ ("Pair", why) ] -> contains why "field order"
     | _ -> false);
  (* Widened: the other half of the same hazard and the one docs/BUILT.md names —
     f64 where the library says float lays out eight bytes where there are
     four, and every field after it moves. *)
  check "a widened field is reported"
    (match
       Cimport.check_structs ~env
         ~structs:(structs_of (program "(defstruct Pair [x f32  y f64])\n")) dump
     with
     | [ ("Pair", why) ] -> contains why "f64" && contains why "f32"
     | _ -> false);
  (* A struct the header says nothing about is not a disagreement: a package
     may describe something the library does not name. *)
  check "a struct the header does not describe is left alone"
    (Cimport.check_structs ~env
       ~structs:(structs_of (program "(defstruct Nowhere [q i32])\n")) dump
     = []);

  (* An enum field against the header's [int]. A Flan defenum lowers to
     int32_t in a struct field exactly as it does in a parameter, so this is
     the same four bytes with a better face on it and not a disagreement —
     which is what let raylib's Camera3D.projection stop being an i32 with a
     conversion function beside it. *)
  check "an enum-typed field against the header's int is not reported"
    (Cimport.check_structs ~env
       ~structs:(structs_of (program "(defstruct Mode [kind Mood  scale f32])\n"))
       dump
     = []);
  (* Symmetric: the header may be the side that names the enum. *)
  check "an i32 field against the header's enum is not reported"
    (Cimport.check_structs ~env
       ~structs:(structs_of (program "(defstruct Feel [mood i32  n i32])\n")) dump
     = []);
  (* And the whole point of the check survives it. The tolerance is for a
     32-bit integer and nothing else, so the width hazard docs/BUILT.md names — f64
     where the library says float — still fails, in the very struct whose
     other field is an enum. *)
  check "a widened field beside an enum field is still reported"
    (match
       Cimport.check_structs ~env
         ~structs:(structs_of (program "(defstruct Mode [kind Mood  scale f64])\n"))
         dump
     with
     | [ ("Mode", why) ] -> contains why "f64" && contains why "f32"
     | _ -> false);
  (* An enum is four bytes, so an enum against something that is not four
     bytes is a real disagreement and stays one. *)
  check "an enum against a field that is not 32 bits is still reported"
    (match
       Cimport.check_structs ~env
         ~structs:(structs_of (program "(defstruct Feel [mood i64  n i32])\n")) dump
     with
     | [ ("Feel", why) ] -> contains why "i64"
     | _ -> false);

  (* The same claim for a [defunion], and what it unlocked. A record holding a
     union member used to be skipped entirely — not recorded, so the
     [defstruct] beside it was unchecked too — because there was no Flan type
     to compare the member against. There is one now, and [Slot] in the
     fixture is checked member by member like any other struct. *)
  let unions_of ds =
    List.filter_map
      (fun (d : Ast.decl) ->
         match d.Ast.d with Ast.Defunion (n, ms) -> Some (n, ms) | _ -> None)
      ds
  in
  check "a defunion that matches the header is not reported"
    (Cimport.check_unions ~env ~unions:(unions_of fixture_ds) dump = []);
  check "and the struct holding it is checked rather than skipped"
    (Cimport.check_structs ~env ~structs:(structs_of fixture_ds) dump = []);
  check "a struct whose union member is given the wrong type is reported"
    (match
       Cimport.check_structs ~env
         ~structs:(structs_of (program "(defstruct Slot [kind i32  v Pair])\n"))
         dump
     with
     | [ ("Slot", why) ] -> contains why "Overlay"
     | _ -> false);
  (* Order is the whole hazard for a struct and means nothing for a union:
     every member is at offset zero, so a permuted defunion is the same type
     and reporting it would be a finding that is not one. *)
  check "a permuted defunion is not reported"
    (Cimport.check_unions ~env
       ~unions:(unions_of (program "(defunion Overlay [f f32  i i32])\n")) dump
     = []);
  (* Missing is the one that changes the size, and a union embedded by value
     puts every field after it in the wrong place. *)
  check "a defunion missing a member is reported"
    (match
       Cimport.check_unions ~env
         ~unions:(unions_of (program "(defunion Overlay [i i32])\n")) dump
     with
     | [ ("Overlay", why) ] -> contains why "f" && contains why "widest"
     | _ -> false);
  check "a defunion with a member the header lacks is reported"
    (match
       Cimport.check_unions ~env
         ~unions:(unions_of
                    (program "(defunion Overlay [i i32  f f32  d f64])\n")) dump
     with
     | [ ("Overlay", why) ] -> contains why "d"
     | _ -> false);
  check "a defunion whose member is the wrong width is reported"
    (match
       Cimport.check_unions ~env
         ~unions:(unions_of (program "(defunion Overlay [i i32  f f64])\n")) dump
     with
     | [ ("Overlay", why) ] -> contains why "f64" && contains why "f32"
     | _ -> false);
  (* Two different layouts under one name, which is the same class of finding
     a permuted struct is and has a one-keyword fix. *)
  check "a defstruct against a union in the header is reported"
    (match
       Cimport.check_structs ~env
         ~structs:(structs_of (program "(defstruct Overlay [i i32  f f32])\n"))
         dump
     with
     | [ ("Overlay", why) ] -> contains why "union in the header"
     | _ -> false);
  check "a defunion against a struct in the header is reported"
    (match
       Cimport.check_unions ~env
         ~unions:(unions_of (program "(defunion Pair [x f32  y f32])\n")) dump
     with
     | [ ("Pair", why) ] -> contains why "struct in the header"
     | _ -> false);
  check "a union the header does not describe is left alone"
    (Cimport.check_unions ~env
       ~unions:(unions_of (program "(defunion Nowhere [q i32])\n")) dump
     = []);
  (* And the gap that remains, said out loud so it is a decision rather than
     an oversight: an anonymous union member has no name and no Flan
     spelling, so the record holding one is still not recorded and the
     defstruct beside it is still unchecked rather than checked wrongly. *)
  check "a record with an anonymous union member is still skipped"
    (Cimport.check_structs ~env
       ~structs:(structs_of (program "(defstruct Anon [kind i32  junk i32])\n"))
       dump
     = []);

  (* ── The constants (Cimport.check_constants) ───────────────────── *)

  (* The half of generate-c's claim that used to be missing. A wrong flag bit
     and a wrong enum member are the two errors here that are completely
     silent — no link error, no type error — which is exactly the class the
     header read exists to catch.

     Shading is anonymous in sample.h and its typedef carries the name, which
     is how raylib writes every one of its enums; SHADE_DARK has no
     initialiser, so 6 is counted rather than read. *)
  let const_fixture ?(mood = "[calm 0  cross 1]")
      ?(shading = "[light 4  mid 5  dark 6  half-dark 9]") ?(fancy = "4")
      ?(extra = "") () =
    Printf.sprintf
      "(defenum Mood %s)\n\
       (defenum Shading %s)\n\
       (defconst opt-loud u32 1)\n\
       (defconst opt-fast u32 2)\n\
       (defconst opt-fancy-mode u32 %s)\n\
       (defconst lucky u32 7)\n\
       %s"
      mood shading fancy extra
  in
  let enums_of ds =
    List.filter_map
      (fun (d : Ast.decl) ->
         match d.Ast.d with Ast.Defenum (n, ms) -> Some (n, ms) | _ -> None)
      ds
  and pconsts_of ds =
    List.filter_map
      (fun (d : Ast.decl) ->
         match d.Ast.d with Ast.Defconst (n, _, e) -> Some (n, e) | _ -> None)
      ds
  in
  let mapping =
    { Cimport.no_config with
      Cimport.enum_prefixes = [ ("Mood", "MOOD_"); ("Shading", "SHADE_") ];
      const_prefixes = [ ("opt-", "OPT_") ];
      (* SHADE_HALFDARK is one word where its siblings are underscored, so the
         prefix rule cannot reach it. The narrow exception, said once. *)
      constants = [ ("Shading/half-dark", "SHADE_HALFDARK") ] }
  in
  let raw_constants ?(config = mapping) src =
    Cimport.check_constants ~config ~enums:(enums_of (program src))
      ~consts:(pconsts_of (program src)) dump
  in
  let constants ?(config = mapping) src =
    List.map
      (fun (x : Cimport.const_diff) -> (x.Cimport.cname, x.Cimport.cwhy))
      (raw_constants ~config src)
  in
  check "constants that agree with the header are not reported"
    (constants (const_fixture ()) = []);
  (* The value is compared, which is the whole point: 340 is KEY_LEFT_SHIFT
     and 341 is a key that never fires. *)
  check "a wrong enum member value is reported, by its C name"
    (match constants (const_fixture ~mood:"[calm 0  cross 2]" ()) with
     | [ ("Mood/cross", why) ] ->
       contains why "MOOD_CROSS" && contains why "is 2 here"
     | _ -> false);
  (* An enumerator with no [= n] carries no value in clang's dump at all, so
     it has to be counted the way C counts it. raylib's TraceLogLevel is eight
     members with one initialiser between them. *)
  check "an implicitly-numbered enumerator is counted, not skipped"
    (match
       constants
         (const_fixture ~shading:"[light 4  mid 5  dark 7  half-dark 9]" ())
     with
     | [ ("Shading/dark", why) ] ->
       contains why "SHADE_DARK" && contains why "is 6 in the header"
     | _ -> false);
  (* A name the rule builds and the header does not have is reported and not
     skipped. A mapping that quietly matched nothing would read as coverage
     and provide none, which would be worse than no check. *)
  check "a member the header has no constant for is reported"
    (match constants (const_fixture ~mood:"[calm 0  cross 1  murky 2]" ()) with
     | [ ("Mood/murky", why) ] -> contains why "no constant named MOOD_MURKY"
     | _ -> false);
  (* The defconst half. These are raylib's 16 ConfigFlags bits. *)
  check "a wrong defconst value is reported"
    (match constants (const_fixture ~fancy:"8" ()) with
     | [ ("opt-fancy-mode", why) ] ->
       contains why "OPT_FANCY_MODE" && contains why "is 4 in the header"
     | _ -> false);
  (* And a defconst no rule reaches is not reported: a package's constants are
     mostly its own, and raylib's 26 colours have no enumerator behind them. *)
  check "a defconst no rule reaches is left alone"
    (constants (const_fixture ~extra:"(defconst unmapped u32 99)\n" ()) = []);
  (* The [constant] line is what reaches a name the prefix rule gets wrong. *)
  check "without the constant line the odd name is reported"
    (match
       constants ~config:{ mapping with Cimport.constants = [] }
         (const_fixture ())
     with
     | [ ("Shading/half-dark", why) ] ->
       contains why "no constant named SHADE_HALF_DARK"
     | _ -> false);

  (* Coverage itself must not go quiet. A defenum nobody mapped would be
     silently unchecked, which is the same hole one level up. *)
  check "a defenum with no enum line is itself a finding"
    (match constants (const_fixture ~extra:"(defenum Nobody [a 0])\n" ()) with
     | [ ("Nobody", why) ] -> contains why "no `enum` line"
     | _ -> false);
  (* And the way to say so deliberately, for an enum the header cannot check. *)
  check "enum - excuses an enum the header says nothing about"
    (constants
       ~config:
         { mapping with
           Cimport.enum_prefixes = ("Nobody", "-") :: mapping.Cimport.enum_prefixes }
       (const_fixture ~extra:"(defenum Nobody [a 0])\n" ())
     = []);
  (* A rule that reaches nothing is a typo, and it would otherwise read as
     coverage. *)
  check "an enum rule naming no defenum is reported"
    (match
       constants
         ~config:
           { mapping with
             Cimport.enum_prefixes =
               ("Ghost", "G_") :: mapping.Cimport.enum_prefixes }
         (const_fixture ())
     with
     | [ ("Ghost", why) ] -> contains why "names no defenum"
     | _ -> false);
  check "a const rule matching no defconst is reported"
    (match
       constants
         ~config:
           { Cimport.no_config with Cimport.const_prefixes = [ ("zzz-", "ZZZ_") ] }
         "(defconst lucky u32 7)\n"
     with
     | [ ("zzz-", why) ] -> contains why "matches no defconst"
     | _ -> false);
  check "a constant line naming nothing is reported"
    (match
       constants
         ~config:
           { Cimport.no_config with
             Cimport.constants = [ ("Mood/nope", "MOOD_NOPE") ] }
         "(defconst lucky u32 7)\n"
     with
     | [ ("Mood/nope", why) ] -> contains why "names no defconst"
     | _ -> false);

  (* The two kinds of finding are told apart, because they have different
     dispositions: a value that disagrees with the library stops an ordinary
     build, and an enum nobody wrote a line for is about the package's own
     config and gates `generate-c` instead. *)
  check "a value disagreement is not a mapping finding"
    (match raw_constants (const_fixture ~fancy:"8" ()) with
     | [ x ] -> not x.Cimport.cmapping
     | _ -> false);
  check "an unmapped defenum is a mapping finding"
    (match raw_constants (const_fixture ~extra:"(defenum Nobody [a 0])\n" ()) with
     | [ x ] -> x.Cimport.cmapping
     | _ -> false);

  (* The name rule, which is not an inverse of kebab and does not need to be:
     a constant has no declaration to store its C spelling in. *)
  List.iter
    (fun (flan, c) ->
       check
         (Printf.sprintf "screaming %s -> %s" flan c)
         (String.equal (Cimport.screaming flan) c))
    [ ("left-shift", "LEFT_SHIFT"); ("msaa-4x-hint", "MSAA_4X_HINT");
      ("a", "A"); ("window-mouse-passthrough", "WINDOW_MOUSE_PASSTHROUGH") ];

  (* diff_bound: a hand-written declare-c against the header's own signature.
     This is the check with no other source — a wrong declare-c is wrong in the
     generated prototype too, so the two halves agree with each other and only
     the library knows better. *)
  let bound_of src =
    List.filter_map
      (fun (d : Ast.decl) ->
         match d.Ast.d with Ast.DeclareC (fn, sym) -> Some (fn, sym) | _ -> None)
      (program src)
  in
  let differs name src needle =
    check ("declare-c against the header: " ^ name)
      (match Cimport.diff_bound ~env ~bound:(bound_of src) dump with
       | [ d ] -> contains d.Cimport.dwhy needle
       | _ -> false)
  in
  check "a declare-c that matches the header is not reported"
    (Cimport.diff_bound ~env
       ~bound:(bound_of "(declare-c add [a i32  b i32] i32 \"add_ints\")") dump
     = []);
  differs "a wrong parameter width"
    "(declare-c add [a f64  b i32] i32 \"add_ints\")" "parameter a is f64";
  differs "a wrong arity" "(declare-c add [a i32] i32 \"add_ints\")"
    "the header says 2";
  differs "a wrong return type"
    "(declare-c add [a i32  b i32] f32 \"add_ints\")" "returns f32";
  (* A symbol the header does not have at all is the version-drift case, and
     it is how a package pinned to the wrong release announces itself. *)
  differs "a symbol the header does not declare"
    "(declare-c gone [] \"no_such_function\")" "does not declare";
  (* An enum face against a plain int is the expected difference and not a
     finding: that is what a defenum is at the boundary. *)
  check "an enum face against the header's int is not a difference"
    (Cimport.diff_bound ~env
       ~bound:(bound_of "(declare-c mv [m Mood] i32 \"mood_value\")") dump
     = []);

  (* The pointer arm. The importer renders a C pointer into whichever Flan type
     it thinks is the nicest face — [const char *] becomes [string], [void *]
     becomes [(Ptr u8)] — and a hand-written line that wants the raw address
     instead is disagreeing with that choice rather than with the header. These
     say which of those disagreements are real. *)
  let agreed name src =
    check ("declare-c against the header: " ^ name)
      (Cimport.diff_bound ~env ~bound:(bound_of src) dump = [])
  in
  (* The case docs/PORTING.md §A.1 could not write: GetCodepointPrevious reads
     backwards from its pointer, so a Flan string — which crosses as a
     NUL-terminated copy — is the one thing it must not be handed. *)
  agreed "a (Ptr u8) where the header says const char *"
    "(declare-c name-length [text (Ptr u8)] i32 \"name_length\")";
  (* And the string face goes on being right, because this is an addition. *)
  agreed "a string where the header says const char *"
    "(declare-c name-length [text string] i32 \"name_length\")";
  agreed "a pointer that matches the header exactly"
    "(declare-c count-at [values (Ptr i32)  n i32] i32 \"count_at\")";
  (* void * is opaque about what it points at, so there is no element type in
     the header to disagree with — §A.2's LoadImageColors → UpdateTexture. *)
  agreed "any pointer where the header says void *"
    "(declare-c blit [dst (Ptr Pair)  src (Ptr Shade)  n i32] \"blit\")";
  agreed "any pointer where the header returns void *"
    "(declare-c scratch [n i32] (Ptr Pair) \"scratch\")";
  (* An enum through a pointer is the same four bytes an enum is beside one. *)
  agreed "a (Ptr enum) where the header says a pointer to int"
    "(declare-c count-at [values (Ptr Mood)  n i32] i32 \"count_at\")";

  (* And the refusals, which are the whole value of the arm: a binding that
     lies about the header still has to be caught, and the message still has to
     name the disagreement. *)
  differs "a pointer to the wrong named type"
    "(declare-c pair-len-p [p (Ptr Shade)] f32 \"pair_len_p\")"
    "parameter p is (Ptr Shade) and the header says (Ptr Pair)";
  differs "a pointer to the wrong width"
    "(declare-c count-at [values (Ptr f64)  n i32] i32 \"count_at\")"
    "parameter values is (Ptr f64)";
  (* void * gives up the element type and nothing else. It is still a pointer,
     and a scalar declared against one is still a finding. *)
  differs "a scalar where the header says void *"
    "(declare-c blit [dst i64  src (Ptr u8)  n i32] \"blit\")"
    "parameter dst is i64";
  differs "a scalar where the header says a pointer"
    "(declare-c count-at [values i32  n i32] i32 \"count_at\")"
    "parameter values is i32";
  (* The byte tolerance is the pointee's and not the world's: inside a pointer
     i8 and u8 are two spellings of one byte, and as a scalar they are not. *)
  differs "a byte where the header says a wider integer"
    "(declare-c add [a u8  b i32] i32 \"add_ints\")" "parameter a is u8";

  (* The name rule. Reversibility is by storage — the C symbol is kept verbatim
     in the declaration — so what the rule has to be is injective over one
     header, which the collision case above asserts. These pin its shape. *)
  List.iter
    (fun (c, flan) ->
       check
         (Printf.sprintf "kebab %s -> %s" c flan)
         (String.equal (Cimport.kebab c) flan))
    [ ("InitWindow", "init-window");
      (* An acronym stays one word rather than becoming separate letters. *)
      ("SetTargetFPS", "set-target-fps");
      ("ColorToHSV", "color-to-hsv");
      ("UnloadUTF8", "unload-utf8");
      (* A digit run takes the uppercase after it, so 2D is one word. *)
      ("BeginMode2D", "begin-mode-2d");
      ("GetScreenToWorld2D", "get-screen-to-world-2d");
      ("snake_case_already", "snake-case-already") ];

  (* cjson.ml, on the shapes clang's dump actually contains. *)
  check "json: an escaped string"
    (match Cjson.parse "{\"a\":\"x\\ny\"}" with
     | Cjson.Obj [ ("a", Cjson.Str "x\ny") ] -> true
     | _ -> false);
  check "json: nesting, numbers, booleans and null"
    (match Cjson.parse "{\"i\":[1,-2,3.5e2],\"b\":true,\"n\":null}" with
     | Cjson.Obj
         [ ("i", Cjson.Arr [ _; _; _ ]); ("b", Cjson.Bool true);
           ("n", Cjson.Null) ] -> true
     | _ -> false);
  check "json: empty containers"
    (match Cjson.parse "{\"a\":{},\"b\":[]}" with
     | Cjson.Obj [ ("a", Cjson.Obj []); ("b", Cjson.Arr []) ] -> true
     | _ -> false);
  check "json: trailing bytes are refused"
    (match Cjson.parse "{} x" with
     | _ -> false
     | exception Cjson.Bad _ -> true);

  (* ── Lifted function names, and why they are counted per kind ────────
     A handler clause and an fn literal are both lifted into functions of their
     own, and both are numbered within the function they came out of. One
     shared counter would mean that adding a handler-bind above an existing fn
     renamed the fn — a rename for a body that did not change, in exactly the
     names a dev redefinition module emits and matches on. These check that
     each sequence is stable against the other. *)
  let lifted_names src =
    List.filter_map
      (fun (f : Tast.fn) ->
         match f.Tast.fparent with Some _ -> Some f.Tast.name | None -> None)
      (Check.program (Parse.program (read src))).Tast.fns
  in
  let with_handler =
    "(defstruct Boom [n i32]) (defvar hit i32) \
     (defn u [f (Fn [i32] i32)] i32 (f 1)) \
     (defn m [] i32 \
       (handler-bind [(Boom [c] (set hit (.n c)))] (u (fn [x] x))) 0)"
  in
  let without_handler =
    "(defstruct Boom [n i32]) (defvar hit i32) \
     (defn u [f (Fn [i32] i32)] i32 (f 1)) \
     (defn m [] i32 (u (fn [x] x)) 0)"
  in
  check "an fn keeps its number when a handler-bind is added beside it"
    (List.mem "fn/m/0" (lifted_names with_handler)
     && List.mem "fn/m/0" (lifted_names without_handler));
  check "and the handler clause has a sequence of its own"
    (List.exists
       (fun n -> contains n "handler/m/0/Boom") (lifted_names with_handler));

  (* ── The prelude's own macro calls, and the bootstrap that allows them ──
     A macro module is compiled *from* the prelude, so a prelude function that
     calls a prelude macro cannot be in the module that would expand it. The
     answer is [Macro.reduce]: for that one build the prelude loses every defn
     depending on a macro, directly or transitively. These check the reduction
     itself, since the thing it prevents is a cycle and a cycle does not show
     up as a wrong answer — it shows up as a build that cannot start. *)
  let names_of forms =
    List.filter_map
      (fun (f : Form.t) ->
         match f.Form.v with
         | Form.List ({ Form.v = Form.Sym ("defn" | "defmacro"); _ }
                      :: { Form.v = Form.Sym n; _ } :: _) -> Some n
         | _ -> None)
      forms
  in
  let reduced = names_of (Macro.reduce (Prelude.forms ())) in
  let full = names_of (Prelude.forms ()) in
  check "the reduced prelude drops a defn that calls a macro"
    (List.mem "format-f64" full && not (List.mem "format-f64" reduced));
  (* The macros survive — they are what the module is being built to export —
     and so does everything that does not reach one, which is almost all of it. *)
  check "the reduced prelude keeps the macros themselves"
    (List.mem "clamp" reduced && List.mem "unless" reduced);
  check "the reduced prelude keeps a defn that calls no macro"
    (List.mem "join" reduced && List.mem "split" reduced);

  (* Transitively: a caller of a dropped function is as unbuildable as the
     function, so it goes too. Written against a synthetic prelude rather than
     the real one, which has no such chain today. *)
  let synth src = Reader.read_all ~file:"<synth>" src in
  let chain =
    synth
      "(defmacro m [args] `(do))\n\
       (defn a [] () (m))\n\
       (defn b [] () (a))\n\
       (defn c [] () (do))\n"
  in
  check "the reduction is transitive"
    (names_of (Macro.reduce chain) = [ "m"; "c" ]);

  (* And the one rule that stays: a prelude macro may not call a macro. It used
     to fail as an unknown name inside a clang build; it names itself now. *)
  let ring = synth "(defmacro m [args] `(do))\n(defmacro n [args] (m args))\n" in
  check "a prelude macro calling a macro is refused by name"
    (match Macro.reduce ring with
     | _ -> false
     | exception Loc.Error { Loc.dmsg = m; _ } ->
       contains m "the prelude macro n calls a macro");

  (* ── Diagnostics: kind, notes, and more than one ───────────────
     The house rule is that a test asserts the *reason* a thing is refused. A
     kind is that assertion made stable: the message may be reworded and the
     row still holds, and a row that matches on a kind is saying something a
     substring match on prose could only approximate. The messages themselves
     are unchanged, so every existing needle still means what it meant. *)

  let diag_of src =
    match checked src with
    | _ -> None
    | exception Loc.Error d -> Some d
  in
  let kind_is name src k =
    check name (match diag_of src with Some d -> d.Loc.kind = k | None -> false)
  in
  kind_is "unknown name has a kind"
    "(defn f [] i32 nope)" "check/unknown-name";
  kind_is "unknown field has a kind"
    "(defstruct S [a i32])\n(defn f [s S] i32 (.b s))" "check/unknown-field";
  kind_is "a name defined twice has a kind"
    "(defn f [] i32 1)\n(defn f [] i32 2)" "check/defined-twice";

  (* The note is the half a location and a string could never carry: the
     *other* place, with its own span and its own explanation. *)
  (match diag_of "(defn f [] i32 1)\n(defn f [] i32 2)" with
   | Some d ->
     check "defined twice points at the second"  (d.Loc.dloc.Loc.line = 2);
     (match d.Loc.notes with
      | [ n ] ->
        check "and notes the first"      (n.Loc.nloc.Loc.line = 1);
        check "and says what it is"      (contains n.Loc.nmsg "already defined")
      | ns -> check "defined twice has one note" (ns = []))
   | None -> check "defined twice is refused" false);

  (match diag_of "(defstruct S [a i32])\n(defn f [s S] i32 (.b s))" with
   | Some d ->
     (match d.Loc.notes with
      | [ n ] ->
        check "an unknown field notes the declaration"
          (n.Loc.nloc.Loc.line = 1);
        check "and lists the fields there" (contains n.Loc.nmsg "with a")
      | _ -> check "an unknown field has one note" false)
   | None -> check "an unknown field is refused" false);

  (* The reader's own two-place error. The bracket that is open is the error
     and the end of input is the note, because the fix goes at the first and
     the surprise is at the second. *)
  (match read "(f\n  bad" with
   | _ -> check "unclosed is refused" false
   | exception Loc.Error d ->
     check "unclosed has a kind" (d.Loc.kind = "reader/unclosed");
     check "unclosed notes where the input ran out"
       (match d.Loc.notes with [ n ] -> n.Loc.nloc.Loc.line = 2 | _ -> false));

  (match read "(f x]" with
   | _ -> check "a mismatched closer is refused" false
   | exception Loc.Error d ->
     check "a mismatched closer has a kind"
       (d.Loc.kind = "reader/mismatched-closer");
     check "and notes the opener"
       (match d.Loc.notes with [ n ] -> n.Loc.nloc.Loc.col = 1 | _ -> false));

  (* More than one per run, which is the point of the whole batch. Three bad
     bodies, three diagnostics, and the count is exact: a checker that reported
     the first and a checker that reported thirty pieces of wreckage would both
     fail this row. *)
  (match
     Check.program_all
       (Parse.program_all
          (read "(defn a [] i32 nope1)\n\
                 (defn b [] i32 nope2)\n\
                 (defn c [] i32 nope3)\n"))
   with
   | _ -> check "three bad bodies are refused" false
   | exception Loc.Errors ds ->
     check "three bad bodies give three errors" (List.length ds = 3);
     check "and they are in source order"
       (List.map (fun (d : Loc.diag) -> d.Loc.dloc.Loc.line) ds = [ 1; 2; 3 ]));

  (* The parser resynchronises on a top-level form, so two bad declarations are
     two errors rather than one. *)
  (match Parse.program_all (read "(defn a)\n(defn b)\n") with
   | _ -> check "two bad declarations are refused" false
   | exception Loc.Errors ds ->
     check "two bad declarations give two errors" (List.length ds = 2));

  (* [Check.program] is a different function from [Check.program_all], and
     that is the guarantee: the session calls this one, it raises one
     diagnostic, and nobody can turn it into a list by passing a label. *)
  (match Check.program (Parse.program (read "(defn a [] i32 nope1)\n\
                                             (defn b [] i32 nope2)\n")) with
   | _ -> check "Check.program still refuses" false
   | exception Loc.Errors _ ->
     check "Check.program never answers with a list" false
   | exception Loc.Error _ -> ());

  (* The first line of a report is exactly the GNU format compilation-mode
     parses, and the squiggle is on an indented line under it, which that mode
     ignores. Both halves are load-bearing and neither is visible from the
     message alone. *)
  (match diag_of "(defn f [] i32 nope)" with
   | Some d ->
     let lines = String.split_on_char '\n' (Loc.report d) in
     (match lines with
      | head :: rest ->
        check "the first line is file:line:col: message"
          (head = Loc.to_string d.Loc.dloc ^ ": " ^ d.Loc.dmsg);
        check "and the rest is indented"
          (List.for_all (fun l -> l = "" || l.[0] = ' ') rest)
      | [] -> check "a report has a first line" false)
   | None -> check "a report needs a diagnostic" false);

  (* ── Generics: the syntax, the predicates, and the two defaults ── *)

  (* The one syntax question the feature had, and how it stopped being one.
     [{K V}] used to be a legal *return type* spelling for (Map K V), so a
     defn with a map return type and a constraint map put two braces in a row
     meaning different things. The brace spelling is now withdrawn from type
     position entirely, so the slot after the return type can be nothing but
     the constraint map, and braces in a type say where the spelling went. *)
  accepts "a map return type, written the one way there is"
    "(defn f [] (Map string i32) (map-new string i32))";
  accepts "a map return type followed by a constraint map"
    "(defn f [x $t] (Map string i32) {:where (copyable? $t)} \
     (do x (map-new string i32)))";
  rejects_check "braces in type position say where the spelling went"
    ~needle:"written (Map K V)"
    "(defn f [] {string i32} (map-new string i32))";

  (* The predicates, and each one gating the operator it is for. *)
  accepts "ordered? admits <"
    "(defn less [a $t b $t] bool {:where (ordered? $t)} (< a b))";
  accepts "equal? admits ="
    "(defn same [a $t b $t] bool {:where (equal? $t)} (= a b))";
  accepts "numeric? admits +"
    "(defn add [a $t b $t] $t {:where (numeric? $t)} (+ a b))";
  rejects_check "equal? does not admit <"
    ~needle:"nothing here says t is ordered?"
    "(defn less [a $t b $t] bool {:where (equal? $t)} (< a b))";
  (* The entailments, which are the reason a signature is one predicate long
     rather than three. Every type the language orders is a number or an enum,
     so it is equatable and it is not move-only. *)
  accepts "ordered? entails equal?"
    "(defn same [a $t b $t] bool {:where (ordered? $t)} (= a b))";
  accepts "numeric? entails ordered?"
    "(defn less [a $t b $t] bool {:where (numeric? $t)} (< a b))";
  accepts "ordered? entails copyable?"
    "(defn twice [a $t] bool {:where (ordered? $t)} (< a a))";
  rejects_check "a predicate nobody has heard of"
    ~needle:"is not a type predicate"
    "(defn f [a $t] $t {:where (sortable? $t)} a)";
  rejects_check "a predicate about a variable the signature never bound"
    ~needle:"is not a type variable of f"
    "(defn f [a i32] i32 {:where (ordered? $t)} a)";

  (* Move-only by default, which is the other half of the where clause and the
     one with no Odin counterpart: Odin has no move semantics, so its $T never
     has to answer. The prior art is Rust's T: Copy, and the difference is
     that copyable? is a question the compiler answers rather than a trait a
     user implements. Conservative in the safe direction — move is the
     stricter rule, so assuming it can only refuse a valid program. *)
  rejects_check "a type variable is move-only until it says otherwise"
    ~needle:"cannot be used again"
    "(defn twice [a $t b (Fn [$t $t] $t)] $t (b a a))";
  accepts "and copyable? is the opt-out"
    "(defn twice [a $t b (Fn [$t $t] $t)] $t {:where (copyable? $t)} (b a a))";

  (* The allow-list, and it has two members. println over a type variable is
     deferred to the instantiation, because its legality is only decidable
     after substituting — which is the one thing the abstract pass otherwise
     refuses to do. *)
  accepts "println over a type variable is deferred"
    "(defn show [x $t] () {:where (copyable? $t)} (println x))";
  accepts "and so is print"
    "(defn show [x $t] () {:where (copyable? $t)} (print x))";

  (* A predicate a body relies on has to be carried by every signature between
     it and the call site, or the refusal moves into code the caller did not
     write. *)
  rejects_check "a predicate is not carried through a generic call"
    ~needle:"has to be carried by every signature"
    "(defn outer [s [$t]] () {:where (copyable? $t)} (sort! s))";
  accepts "and is accepted when it is"
    "(defn outer [s [$t]] () {:where (ordered? $t)} (sort! s))";

  (* A map key that is a type variable has no hash and no equality to emit:
     they are chosen from the concrete type, which does not exist yet. So the
     map operations join print and println on the list of forms the abstract
     pass defers to the instantiation — but only under the predicate, which is
     what gives the deferred refusal somewhere to land. Without one the type
     itself is refused where it is written, at the definition. *)
  rejects_check "a map keyed by a type variable that is not hashable?"
    ~needle:"is not a map key"
    "(defn f [m (Map $t i32)] i32 {:where (copyable? $t)} (len m))";
  accepts "and hashable? is what says it is"
    "(defn f [m (Map $t i32)] i32 {:where (hashable? $t)} (len m))";
  accepts "and under it the operations are deferred, not refused"
    "(defn f [m (Map $t i32)  k $t] () {:where (hashable? $t)} (put m k 1))";
  accepts "get over a type-variable key answers an (Option V)"
    "(defn f [m (Map $t i32)  k $t] i32 {:where (hashable? $t)} \
       (match (get m k) (Some v) v _ 0))";
  (* And so does the removal, whose placeholder is [get]'s for the same reason:
     it answers an (Option V), so the match around it still has to check while
     the key is a variable. *)
  accepts "map-remove! over a type-variable key answers an (Option V)"
    "(defn f [m (Map $t i32)  k $t] i32 {:where (hashable? $t)} \
       (match (map-remove! m k) (Some v) v _ 0))";
  accepts "and so do has-key?, reserve and clone"
    "(defn f [m (Map $t i32)  k $t] bool {:where (hashable? $t)} \
       (do (reserve m 8) (let [c (clone m)] (free c) (has-key? m k))))";
  (* The definition is still where a generic with no clause to point at is
     refused: nothing has been written down for an instantiation to be judged
     against, so the refusal has nowhere to move to. *)
  rejects_check "a map built inside a generic that declares nothing"
    ~needle:"is not a map key"
    "(defn f [k $t] () (let [m (map-new t i32)] (put m k 1) (free m)))";

  (* ── The acceptance program checks end to end ──────────────────── *)
  accepts "calc-me.flan type checks"
    (In_channel.with_open_bin "../calc-me.flan" In_channel.input_all);

  if !failures = 0 then print_endline "all tests passed"
  else begin
    Printf.printf "\n%d failure(s)\n" !failures;
    exit 1
  end