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

open Flan

let failures = ref 0

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

let reads name src expected =
  match Reader.read_all ~file:"<test>" 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

let rejects name src =
  match Reader.read_all ~file:"<test>" src with
  | _ -> incr failures; Printf.printf "FAIL  %s: expected a read error\n" name
  | exception Loc.Error _ -> ()

let () =
  (* ── Atoms ─────────────────────────────────────────────────────── *)
  reads "integer"        "42" "42";
  reads "negative"       "-1" "-1";
  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))";

  (* 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 = '^') 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)" in
  check "no sigils leak into names"
    (bad_names (Form.make (Form.List (Reader.read_all ~file:"<test>" 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";
  rejects "metadata"          "^:async";
  rejects "dangling quote"    "'";

  (* ── Locations ─────────────────────────────────────────────────── *)
  (match Reader.read_all ~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 Reader.read_all ~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 Reader.read_all ~file:"<test>" src with
  | [ f ] -> Parse.expr f
  | _ -> failwith "test source must be exactly one form"

let parse_decl src =
  match Reader.read_all ~file:"<test>" src with
  | [ f ] -> Parse.decl f
  | _ -> failwith "test source must be exactly one form"

let parse_rejects name src =
  match Reader.read_all ~file:"<test>" src |> Parse.program with
  | _ -> incr failures; Printf.printf "FAIL  %s: expected a parse error\n" name
  | exception Loc.Error _ -> ()

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

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

  (match (parse1 "(until c a)").e with
   | While ({ 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 ("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))";
  parse_rejects "defmacro"     "(defmacro m [] 1)";

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

  (* ── The corpus parses ─────────────────────────────────────────── *)
  List.iter
    (fun path ->
       match Reader.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. *)

let program src = Reader.read_all ~file:"<test>" 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));

  ()

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

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

(* [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]]";
  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";
  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";
  rejects_check "Vec is milestone 6"    "(defn f [x (Vec i32)])"
    ~needle:"milestone 6";
  rejects_check "Map is milestone 6"    "(defn f [x {string i32}])"
    ~needle:"milestone 6";
  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; what is still rejected is a defer that
     is not a top-level form, because it would run at function exit rather than
     at the exit of the block it was written in. *)
  rejects_check "defer must be top-level"
    "(defn f [] (let [x 1] (defer (g))))" ~needle:"top-level";
  (* 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 (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))";
  (* 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";
  rejects_check "fn values are milestone 5" "(defn f [] (fn [x] x))"
    ~needle:"milestone 5";
  rejects_check "type variables are milestone 5" "(defn f [x a])"
    ~needle:"milestone 5";
  rejects_check "a function name as a value is milestone 5"
    "(defn g []) (defn f [] i32 g)" ~needle:"milestone 5";

  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";
  (* The two halves of §3 this version does not do, each refused by name with
     the reason rather than parsed into something that means less. *)
  rejects_check "a restart with parameters"
    "(defn f [] i32 (restart-case 1 (skip [n i32] n)))"
    ~needle:"a restart takes no parameters yet";
  rejects_check "invoke-restart with arguments"
    "(defn f [] (invoke-restart 'skip 1))"
    ~needle:"a restart takes no arguments yet";
  rejects_check "invoke-restart on an unquoted name"
    "(defn f [] (invoke-restart skip))"
    ~needle:"quoted restart name";
  (* §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))" ];

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