flan/test/test_flan.ml

(* 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, 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 (_, 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, _) ->
     check "unclosed reports opening loc" (loc.line = 1 && loc.col = 1));

  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 (_, 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);
  (match ty "{string i32}" with
   | Tmap (_, _) -> () | _ -> check "{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);
  (* An omitted return type means Unit — the body must not be eaten as a type *)
  (match (parse_decl "(defn f [x i32] (g x))").d with
   | Defn { ret = None; fbody = [ _ ]; _ } -> ()
   | _ -> check "defn without return type" 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";

  (* 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";

  (* ── 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, 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 / body ambiguity ═════════════════════════════ *)
(* (Option f64) and (Some 1) are the same s-expression shape. Which one is a
   return type is decided by the set of names that are actually types, not by
   capitalisation — otherwise a body starting with a constructor call gets
   silently eaten as a return type. *)

(* 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 "known type ctor is a return type"
    (ret_and_body "option" "(defn f [] (Option f64) (g))" = (true, 1));

  check "value ctor is NOT a return type"
    (ret_and_body "some" "(defn f [] (Some 1) (bar))" = (false, 2));

  check "user struct is a return type"
    (ret_and_body "user"
       "(defstruct Cursor [pos i32]) (defn f [] Cursor (g))" = (true, 1));

  (* Order-independent: the type is declared after the function that returns it *)
  check "type declared later is still known"
    (ret_and_body "later"
       "(defn f [] Cursor (g)) (defstruct Cursor [pos i32])" = (true, 1));

  check "unknown capitalised head is a body form"
    (ret_and_body "unknown" "(defn f [] (Nope 1) (bar))" = (false, 2));

  (* The prelude's types are every file's types -- Check.program prepends the
     prelude to every program -- and until macros needed it, nothing told the
     parser so. A macro is (defn m [args [Form]] Form ...) and bare Form in
     return position was read as the first form of the body. *)
  check "a prelude type is a return type"
    (ret_and_body "prelude" "(defn f [] Form (g))" = (true, 1));

  (* And the other half, which is the whole reason those names go in under
     their own key: a prelude type is a bare symbol in type position and never
     a list head, so a struct literal of one opening a body stays a body form.
     Added plainly this reads as a type application and eats the body, in every
     file in the language, and nothing would have said so. *)
  check "a prelude struct literal is NOT a return type"
    (ret_and_body "preludelit" "(defn f [] (Rune {.code 65}) (bar))" = (false, 2));

  ()

(* ── 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, 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, 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 (_, 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";
  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))";

  (* ── 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";

  (* ── 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";

  (* ── 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";
  (* {K V} resolves now — it is the Map type spelling, and the only one, since
     a bare map form in expression position is a struct literal's field list.
     What is still refused 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";
  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";
  (* 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 union 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 union, 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";

  (* ── 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"
    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_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_enums ~taken ~bound_syms:[]
    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));

  (* 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 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 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 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
     = []);

  (* 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 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 [] Unit (m))\n\
       (defn b [] Unit (a))\n\
       (defn c [] Unit (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 (_, m) ->
       contains m "the prelude macro n calls a macro");

  (* ── 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