(** Reading a C header, so a binding is checked against the library instead of
    transcribed from it.

    [declare-c] closed half the gap: the wrapper, the typedefs and the
    prototype are generated, so they cannot disagree with each other. The half
    it left open is the one BUILT.md records as *trusted* — that the signature
    somebody typed is the function's real signature. Nothing checked it,
    because no header was ever read. This reads one.

    {2 Why clang, and why not linked to it}

    Zig's old [@cImport] ran clang as a *library*. That is precisely the
    dependency plan.org rejected when it chose text IR over libLLVM bindings: a
    version-pinned C++ library breaks routinely on upgrade, a binary on PATH
    does not. So this shells out for [clang -Xclang -ast-dump=json
    -fsyntax-only], which is the same binary the build already runs for every
    other purpose and adds no dependency that is not already being paid for.

    (Zig has since replaced clang here altogether with Aro, a C frontend
    written in Zig. Their reason was to ship a compiler containing no clang at
    all, self-contained and cross-compiling anywhere. This project has the
    opposite premise — [clang] on PATH is the whole toolchain assumption — so
    that move is explained by a constraint that does not apply here.)

    {2 What is imported, and what bounds it}

    Functions, and only functions. Not structs, not enums, not macros.

    The bound on how much gets imported is not a curated list — it is the
    package's own [defstruct]s. A C function is imported when every type in its
    signature maps to something the package already declares or to a machine
    scalar; a function mentioning a struct the package has not described is
    refused, by name, with that reason. So [vendor/raylib] describing thirteen
    structs is what makes the import thirteen structs wide, and describing a
    fourteenth is what widens it. The layouts stay hand-written and stay the
    single statement about what raylib's structs are, which is the thing the
    acceptance tests pin; only the *signatures* come from the header.

    This is also why no [defstruct] is generated. Generating one would make the
    header the authority on layout, and then the check below — comparing the
    package's [defstruct]s against the header's records — would be comparing
    the header with itself. Keeping the layouts hand-written is what makes
    [check_structs] an independent second source, and that check is the
    cheapest real closure of BUILT.md's trusted-not-guaranteed gap: a
    [_Static_assert] was rejected there as circular for exactly this reason,
    and this is not circular, because the two sides have different authors.

    {2 Refusing by demotion}

    Taken from Zig, and the one decision here most worth keeping. Zig's
    translator never drops a declaration it cannot handle: [failDecl] emits the
    name bound to a [@compileError] carrying the reason, so the name still
    exists, the program still compiles, and asking for that one name fails —
    at the use site, with the reason. A wholesale import has hundreds of
    refusals and a caller cares about the one they typed.

    Flan has that mechanism already: [Load.refuse_hidden] is the same idea,
    built for [main]. So a refused import becomes a hidden name.
    [rl/get-gamepad-name] is not a name, and a program that writes it is told
    *why* — "returns const char *, and a string only crosses as a parameter" —
    rather than "unknown name".

    This is also the split the existing generator needs and does not have.
    [Shim] refuses through [Loc.fail], which is right when a human named one
    function and wrong for a wholesale import: one returned [const char *]
    would otherwise kill the whole header. Same judgement, different
    disposition — a hand-written [declare-c] still hard-fails, and [Shim] is
    untouched. *)

let fail = Loc.fail

(* ── Names ─────────────────────────────────────────────────────────

   The C symbol is kept verbatim in [Ast.DeclareC], so the kebab rule never
   needs an inverse: the generated wrapper reads the spelling out of the
   declaration rather than reconstructing it. What the rule does have to be is
   *injective over one header*, since two C functions arriving under one Flan
   name is a collision the checker would report as a duplicate declaration
   about a name nobody wrote. That is asserted below, by name.

   The rule, in full. A boundary goes before a character that is

   - an uppercase letter after a lowercase one     — [InitWindow] → init-window
   - an uppercase letter between an uppercase and
     a lowercase one                               — [ColorToHSV] → color-to-hsv
   - a digit after a lowercase letter              — [BeginMode2D] → begin-mode-2d

   and nowhere else; an underscore is a boundary and disappears. The third
   clause is what keeps [2D] together as one word, and the second is what keeps
   an acronym together: [SetTargetFPS] is set-target-fps and not
   set-target-f-p-s, [UnloadUTF8] is unload-utf8. *)

let kebab (s : string) : string =
  let n = String.length s in
  let b = Buffer.create (n + 8) in
  String.iteri
    (fun i c ->
       let prev = if i > 0 then s.[i - 1] else '\000' in
       let next = if i + 1 < n then s.[i + 1] else '\000' in
       let upper c = c >= 'A' && c <= 'Z' in
       let lower c = c >= 'a' && c <= 'z' in
       let digit c = c >= '0' && c <= '9' in
       if
         i > 0 && prev <> '_'
         && ((upper c && lower prev)
             || (upper c && upper prev && lower next)
             || (digit c && lower prev))
       then Buffer.add_char b '-';
       if c = '_' then (if Buffer.length b > 0 then Buffer.add_char b '-')
       else Buffer.add_char b (Char.lowercase_ascii c))
    s;
  Buffer.contents b

(* The other direction, and it is deliberately not an inverse of [kebab].

   A C *function* never needs one: the symbol is stored verbatim in the
   declaration. A C *constant* does, because there is no declaration to store
   it in — a [defenum] member and a [defconst] are Flan names with Flan
   values and nothing in the source says which enumerator in the header they
   came from. So the C name has to be reconstructed, and this is the rule:
   uppercase, and a hyphen becomes an underscore. [left-shift] is
   [LEFT_SHIFT], [msaa-4x-hint] is [MSAA_4X_HINT].

   What it cannot reconstruct is the prefix — raylib's [KEY_], [FLAG_],
   [GAMEPAD_BUTTON_] — because the Flan name does not contain it. That is
   declared in the package's [bindings] file rather than guessed, for the
   reason [read_config] gives about every other guess: a rule that quietly
   fails to match a name would be worse than no check at all. *)
let screaming (s : string) : string =
  String.map (fun c -> if c = '-' then '_' else Char.uppercase_ascii c)
    (String.uppercase_ascii s)

(* ── What clang was asked, and what it said ────────────────────────── *)

(* One C function, as the dump describes it and before anything is decided
   about whether Flan can hold it. *)
type cfn = {
  csym     : string;
  cret     : string;                  (* the return type, as clang spells it *)
  cparams  : (string * string) list;  (* name (possibly ""), type *)
  cvariadic : bool;
  cloc     : Loc.t;                   (* the line of the header it is on *)
}

(* One C struct, for checking a [defstruct] against. *)
type crecord = { rname : string; rfields : (string * string) list }

type dump = {
  fns      : cfn list;
  records  : crecord list;
  (* A typedef's underlying spelling: [Texture2D] → [struct Texture], and
     [Camera] → [Camera3D]. Followed when the spelled name is not one the
     package declares, which is what lets a Flan [defstruct Texture2D] serve a
     C parameter typed [Texture]. *)
  typedefs : (string * string) list;
  (* The typedef names that are enums rather than records. A C enum is an int
     on every target this compiles for, which is also what [Shim] lowers a Flan
     [defenum] to, so the two agree by construction. *)
  enums    : string list;
  (* Every enumerator in the header, flat: name to value.

     Flat and not grouped by enum, because raylib's enums are *anonymous* —
     [typedef enum { FLAG_VSYNC_HINT = 0x40, ... } ConfigFlags;] is an
     [EnumDecl] with no name at all, and the typedef beside it is a separate
     node. Keying on the enum's name would find nothing on the corpus this
     exists for. C puts enumerators in the ordinary namespace at file scope
     anyway, so the flat table is the one C itself keeps. *)
  consts   : (string * int64) list;
}

let clang_argv ~header ~flags =
  [ "clang"; "-Xclang"; "-ast-dump=json"; "-fsyntax-only" ] @ flags @ [ header ]

(* clang's stdout, or its stderr if it failed. Run through [Unix.create_process]
   rather than a shell so a path with a space in it needs no quoting and no
   [Filename.quote] round trip. *)
let run_clang ~loc ~header ~flags =
  if not (Sys.file_exists header) then
    fail loc "no such header: %s" header;
  let argv = clang_argv ~header ~flags in
  let out_r, out_w = Unix.pipe ~cloexec:false () in
  let err_r, err_w = Unix.pipe ~cloexec:false () in
  let pid =
    try
      Unix.create_process "clang" (Array.of_list argv) Unix.stdin out_w err_w
    with Unix.Unix_error _ ->
      List.iter Unix.close [ out_r; out_w; err_r; err_w ];
      fail loc
        "clang is not on PATH, and reading a C header is done by running it \
         (%s)"
        (String.concat " " argv)
  in
  Unix.close out_w;
  Unix.close err_w;
  (* Both pipes have to be drained as they fill: the dump is megabytes and a
     process blocked writing stdout while this waits on its exit is a deadlock
     that only shows up on a big header. *)
  let read_all fd =
    let b = Buffer.create 65536 in
    let chunk = Bytes.create 65536 in
    let rec go () =
      match Unix.read fd chunk 0 65536 with
      | 0 -> ()
      | k -> Buffer.add_subbytes b chunk 0 k; go ()
      | exception Unix.Unix_error (Unix.EINTR, _, _) -> go ()
    in
    go (); Buffer.contents b
  in
  let out_buf = Buffer.create (1 lsl 21) in
  let err_buf = Buffer.create 4096 in
  (* Read stdout first but keep stderr drained too. clang writes very little to
     stderr for a header that parses, and a header that does not parse writes
     little enough to fit a pipe, so alternating is not needed — but stdout is
     the one that is megabytes, so it is the one read in the loop. *)
  Buffer.add_string out_buf (read_all out_r);
  Buffer.add_string err_buf (read_all err_r);
  Unix.close out_r;
  Unix.close err_r;
  let status = snd (Unix.waitpid [] pid) in
  (match status with
   | Unix.WEXITED 0 -> ()
   | _ ->
     fail loc "clang could not parse %s:\n%s" header
       (String.trim (Buffer.contents err_buf)));
  Buffer.contents out_buf

(* ── Reading the dump ──────────────────────────────────────────────── *)

(* clang omits [loc.file] when it is the same as the previous node's, so file
   attribution is a fold over the children in order and not a lookup. Getting
   this wrong is not loud: it silently imports everything the header includes,
   or nothing at all. *)
let qual j = match Cjson.mem "type" j with Some t -> Cjson.str "qualType" t | None -> None

let read_dump ~header (root : Cjson.t) : dump =
  let want = try Unix.realpath header with Unix.Unix_error _ -> header in
  let same f = try Unix.realpath f = want with Unix.Unix_error _ -> f = want in
  let cur = ref "" in
  let fns = ref [] and records = ref [] and typedefs = ref [] and enums = ref [] in
  let consts = ref [] in
  List.iter
    (fun d ->
       (match Cjson.mem "loc" d with
        | Some l -> (match Cjson.str "file" l with Some f -> cur := f | None -> ())
        | None -> ());
       let mine = same !cur in
       let name = Cjson.str "name" d in
       match (Cjson.str "kind" d, name) with
       | Some "FunctionDecl", Some nm when mine ->
         (* A [static] or [inline] definition in a header has no symbol to
            link against from outside the translation unit that has the body.
            Left out rather than imported and met at the linker. *)
         let sc = Cjson.str "storageClass" d in
         if sc <> Some "static" then begin
           let q = match qual d with Some q -> q | None -> "" in
           let cret =
             match String.index_opt q '(' with
             | Some k -> String.trim (String.sub q 0 k)
             | None -> q
           in
           let cparams =
             List.filter_map
               (fun p ->
                  if Cjson.str "kind" p = Some "ParmVarDecl" then
                    Some (Option.value ~default:"" (Cjson.str "name" p),
                          Option.value ~default:"" (qual p))
                  else None)
               (Cjson.arr "inner" d)
           in
           let line =
             match Cjson.mem "loc" d with
             | Some l ->
               (match Cjson.mem "line" l with
                | Some (Cjson.Num f) -> int_of_float f
                | _ -> 0)
             | None -> 0
           in
           fns := { csym = nm; cret; cparams; cvariadic = Cjson.bool "variadic" d;
                    cloc = Loc.make !cur line 1 }
                  :: !fns
         end
       | Some "RecordDecl", Some nm when mine && Cjson.bool "completeDefinition" d ->
         let rfields =
           List.filter_map
             (fun f ->
                if Cjson.str "kind" f = Some "FieldDecl" then
                  Some (Option.value ~default:"" (Cjson.str "name" f),
                        Option.value ~default:"" (qual f))
                else None)
             (Cjson.arr "inner" d)
         in
         (* A bitfield has no address and no Flan spelling; a record holding
            one is not one this can check, so it is not recorded and the
            [defstruct] beside it is left unchecked rather than checked
            wrongly. Same for an unnamed field, which is an anonymous union or
            struct. *)
         let ok =
           List.for_all
             (fun f ->
                Cjson.str "kind" f <> Some "FieldDecl"
                || (not (Cjson.bool "isBitfield" f)
                    && Cjson.str "name" f <> None))
             (Cjson.arr "inner" d)
         in
         if ok then records := { rname = nm; rfields } :: !records
       (* An enumerator with no [= n] carries no [ConstantExpr] in the dump at
          all, so the value has to be counted the way C counts it: one more
          than the one before, starting at zero. That is not an edge case —
          raylib's TraceLogLevel writes [LOG_ALL = 0] and then seven bare
          names, so reading only the explicit ones would check one member of
          eight and quietly pass the rest. *)
       | Some "EnumDecl", _ when mine ->
         let next = ref 0L in
         List.iter
           (fun c ->
              if Cjson.str "kind" c = Some "EnumConstantDecl" then begin
                (match
                   List.find_map
                     (fun i ->
                        if Cjson.str "kind" i = Some "ConstantExpr" then
                          Cjson.str "value" i
                        else None)
                     (Cjson.arr "inner" c)
                 with
                 | Some v ->
                   (match Int64.of_string_opt v with
                    | Some n -> next := n
                    | None -> ())
                 | None -> ());
                (match Cjson.str "name" c with
                 | Some n -> consts := (n, !next) :: !consts
                 | None -> ());
                next := Int64.add !next 1L
              end)
           (Cjson.arr "inner" d)
       | Some "TypedefDecl", Some nm when mine ->
         (match qual d with
          | Some u ->
            typedefs := (nm, u) :: !typedefs;
            if String.length u > 5 && String.sub u 0 5 = "enum " then
              enums := nm :: !enums
          | None -> ())
       | _ -> ())
    (Cjson.arr "inner" root);
  { fns = List.rev !fns; records = List.rev !records;
    typedefs = List.rev !typedefs; enums = List.rev !enums;
    consts = List.rev !consts }

(* ── C types into Flan types ───────────────────────────────────────── *)

(* What the package already says exists. The importer adds no type of its own:
   it either finds a Flan name for a C type here or refuses the function. *)
type env = {
  known_structs : string list;   (* the package's defstruct names *)
  known_enums   : string list;   (* its defenum names *)
  d             : dump;
}

exception Refused of string

let refuse fmt = Printf.ksprintf (fun m -> raise (Refused m)) fmt

let strip_prefix p s =
  let lp = String.length p in
  if String.length s >= lp && String.sub s 0 lp = p then
    Some (String.trim (String.sub s lp (String.length s - lp)))
  else None

(* [const struct Foo] → [Foo]. Qualifiers carry no Flan meaning — Flan has no
   const — but they have to come off before the name is recognised, and
   const-ness is read *before* this, where it still means something (see
   [param_ty]). *)
let rec bare s =
  let s = String.trim s in
  match
    List.find_map (fun p -> strip_prefix p s)
      [ "const "; "volatile "; "restrict "; "struct "; "union "; "enum " ]
  with
  | Some s' -> bare s'
  | None -> s

(* A generated type expression carries no location of its own: the thing a
   message about it wants to point at is the declaration's line in the header,
   which is what the field and the declaration below carry. *)
let ty t = { Ast.t; tloc = Loc.unknown }

let rec ty_source (t : Ast.texpr) =
  match t.Ast.t with
  | Ast.Tname n -> n
  | Ast.Tapp (n, args) ->
    Printf.sprintf "(%s %s)" n (String.concat " " (List.map ty_source args))
  | Ast.Tslice e -> Printf.sprintf "[%s]" (ty_source e)
  | Ast.Tarray (Ast.Lint n, e) -> Printf.sprintf "[%Ld %s]" n (ty_source e)
  | Ast.Tarray (Ast.Lname n, e) -> Printf.sprintf "[%s %s]" n (ty_source e)
  | Ast.Tmap (k, v) -> Printf.sprintf "{%s %s}" (ty_source k) (ty_source v)
  | Ast.Tfn (ps, r) ->
    Printf.sprintf "(Fn [%s] %s)"
      (String.concat " " (List.map ty_source ps)) (ty_source r)

let tname n = ty (Ast.Tname n)

(* The machine scalars, and the ones deliberately left out.

   [long], [size_t] and the rest are refused rather than guessed, and the
   reason is specific to this project rather than general fussiness: it builds
   for x86-64, for wasm32-wasi and for the browser, and [long] is 64 bits on
   the first and 32 on the others. A guess would be right for the target that
   gets tested and silently wrong for the two that do not. A header that wants
   one says so in [declare-c], where a human takes responsibility for it. *)
let scalar = function
  | "void" -> Some "Unit"
  | "_Bool" | "bool" -> Some "bool"
  | "char" | "signed char" | "int8_t" -> Some "i8"
  | "unsigned char" | "uint8_t" -> Some "u8"
  | "short" | "short int" | "int16_t" -> Some "i16"
  | "unsigned short" | "unsigned short int" | "uint16_t" -> Some "u16"
  | "int" | "signed int" | "int32_t" -> Some "i32"
  | "unsigned" | "unsigned int" | "uint32_t" -> Some "u32"
  | "int64_t" | "long long" | "long long int" -> Some "i64"
  | "uint64_t" | "unsigned long long" | "unsigned long long int" -> Some "u64"
  | "float" -> Some "f32"
  | "double" -> Some "f64"
  | _ -> None

let width_varies =
  [ "long"; "long int"; "unsigned long"; "unsigned long int"; "size_t";
    "ssize_t"; "ptrdiff_t"; "intptr_t"; "uintptr_t"; "time_t"; "wchar_t" ]

(* A named type, after qualifiers and pointers are gone: a struct the package
   describes, an enum, or nothing this can hold. *)
let rec named env (n : string) : Ast.texpr =
  if List.mem n env.known_structs then tname n
  else if List.mem n env.known_enums then tname n
  else if List.mem n env.d.enums then
    (* A C enum is an int, which is what [Shim] lowers a Flan [defenum] to, so
       this is the same ABI and not a widening. What it loses is the nice face:
       a parameter typed [Key] takes [:space] at the call site and an [i32]
       does not. That is a reason to keep a hand-written [declare-c] for the
       few calls where it matters, not a reason to refuse the other five
       hundred. *)
    tname "i32"
  else if List.exists (fun r -> r.rname = n) env.d.records then
    (* Checked before the typedef table, because C's usual idiom
       [typedef struct Vector3 { ... } Vector3;] puts the same name in both and
       following it would arrive straight back here.

       One step first, in the other direction: the package may already describe
       this record under one of its *other* typedef names. raylib's record is
       [struct Texture] and [Texture2D], [TextureCubemap] and the package's own
       [defstruct Texture2D] are all names for it, so [LoadTextureCubemap]
       returns the same struct the package has described and refusing it would
       be wrong. Any known struct whose typedef bottoms out at this record
       will do; they denote the same layout by construction. *)
    match
      List.find_opt
        (fun k ->
           match List.assoc_opt k env.d.typedefs with
           | Some u -> String.equal (bare u) n
           | None -> false)
        env.known_structs
    with
    | Some k -> tname k
    | None ->
      refuse
        "%s is a struct the package does not describe — add a defstruct for \
         it, or keep a hand-written declare-c"
        n
  else if List.mem_assoc n env.d.typedefs then begin
    let u = List.assoc n env.d.typedefs in
    if bare u = n then
      refuse "%s is a typedef of itself, which is not a type" n
    else
      (* Back through [value_ty] and not straight to [named]: a typedef may
         name a pointer or a function pointer — raylib's [AudioCallback] is
         one — and only [value_ty] knows what to say about either. Going
         straight to [named] reported a callback as an unknown type rather
         than as the callback it is. *)
      value_ty env u
  end
  else if List.mem n width_varies then
    refuse
      "%s has a width that differs between this project's own targets (64 \
       bits on x86-64, 32 on wasm32), so no single Flan type is right for it"
      n
  else refuse "%s is not a type the header importer knows" n

(* A type in any position but an outermost parameter. Pointers are where C says
   least and Flan has to say something: a [T *] is one T, or an array of them,
   or null, and the header does not distinguish. Flan's [(Ptr T)] claims only
   "the address of a T", which is the weakest of those and therefore the only
   honest one — the same judgement Zig makes when it translates [T *] to
   [[*c]T] rather than to a single-item pointer. *)
and value_ty env (s : string) : Ast.texpr =
  let s = String.trim s in
  if String.length s > 0 && s.[String.length s - 1] = '*' then begin
    let inner = String.trim (String.sub s 0 (String.length s - 1)) in
    let b = bare inner in
    (* [void *] is an address of unknown element type; [(Ptr u8)] is what the
       package already spells that as ([Image.data]). *)
    if b = "void" then ty (Ast.Tapp ("Ptr", [ tname "u8" ]))
    else ty (Ast.Tapp ("Ptr", [ value_ty env inner ]))
  end
  else if String.contains s '[' then
    refuse "%s is an array, which C passes as a pointer and Flan as a value" s
  else if String.contains s '(' then
    refuse "%s is a function pointer, and a C callback is not implemented" s
  else
    let b = bare s in
    match scalar b with
    | Some "Unit" -> refuse "void is not a value"
    | Some p -> tname p
    | None -> named env b

(* A parameter, where two C spellings mean things no other position does.

   [const char *] is a string going in, and [Shim] already knows how to hand
   one over: Flan's ptr+len, NUL-terminated into a copy for the duration of the
   call. [char *] without the const is not that. It is very often a buffer the
   callee *writes*, and handing it a temporary copy would lose the writes with
   no diagnostic anywhere. const is the only thing in the header that separates
   the two, so it is what decides, and a genuine out-buffer keeps a
   hand-written binding that says [(Ptr u8)] and means it. *)
let param_ty env (s : string) : Ast.texpr =
  let s = String.trim s in
  if String.length s > 0 && s.[String.length s - 1] = '*' then begin
    let inner = String.trim (String.sub s 0 (String.length s - 1)) in
    let is_const = strip_prefix "const " inner <> None in
    match bare inner with
    | "char" when is_const -> tname "string"
    | "char" ->
      refuse
        "char * is a parameter C may write through, and a Flan string crosses \
         as a NUL-terminated copy — the writes would be lost. const char * is \
         a string; this one needs a declare-c saying (Ptr u8)"
    | _ -> value_ty env s
  end
  else value_ty env s

(* The return type. Every refusal here is one [Shim] would also make; it is
   made earlier so that the reason names the C spelling rather than the Flan
   one it was about to become. *)
let ret_ty env (s : string) : Ast.texpr option =
  let s = String.trim s in
  if bare s = "void" && not (String.contains s '*') then None
  else if String.length s > 0 && s.[String.length s - 1] = '*' then begin
    let inner = String.trim (String.sub s 0 (String.length s - 1)) in
    match bare inner with
    | "char" ->
      refuse
        "returns char *, and a string only crosses as a parameter — a C \
         function that returns one returns something Flan has no owner for"
    | _ -> Some (value_ty env s)
  end
  else Some (value_ty env s)

(* ── One header, imported ──────────────────────────────────────────── *)

type imported = {
  decls  : Ast.decl list;
  (* Name and reason, for [Load.refuse_hidden]: the name exists as a thing
     that cannot be had, and asking for it says why. Zig's [failDecl]. *)
  hidden : (string * string) list;
}

(* ── The config beside the header ──────────────────────────────────── *)

(* Why a config file exists at all, when the importer decides everything else
   from the header.

   Because the generated declarations are *committed*. A generated file that is
   read at build time can be hand-corrected and the correction survives, since
   nothing rewrites it. A generated file that is checked in is rewritten by the
   next regeneration, so a hand-edit to it is destroyed without anybody being
   told — which is the worst shape an edit can have. The edits therefore have
   to live somewhere regeneration *reads* rather than somewhere it writes, and
   this is that place.

   Two directives, which are the two things the header cannot decide:

   - [exclude], a C symbol or a pattern of them, for what should not be
     generated at all.
   - [name], a C symbol and the Flan name it is to take, for where the kebab
     rule gives something ugly.

   A postprocessing transform pass over the generated file was the alternative
   and was rejected: a second program to understand, run over text the
   generator had already committed to. Both directives here are applied
   *while* the declarations are made, so the file on disk is already what the
   config says and nothing reads it twice. *)

type config = {
  excludes : string list;
  (* C symbol to Flan name. Keyed on the symbol and not on the kebab result,
     because the symbol is the only spelling that is stable — the whole point
     of an override is that the kebab result is not what is wanted. *)
  renames : (string * string) list;
  (* The three that say how a Flan constant is spelled in C, which is the one
     thing neither the header nor the Flan source contains. See [screaming]
     for why it has to be said and [check_constants] for what is done with it.

     [enum_prefixes]: a [defenum]'s name, and the prefix its members carry in
     C. [("Key", "KEY_")] checks [left-shift] against [KEY_LEFT_SHIFT]. The
     prefix ["-"] means the header has nothing to check this enum against and
     that is deliberate.

     [const_prefixes]: a prefix of [defconst] names, and the prefix the
     corresponding C enumerators carry. [("flag-", "FLAG_")] checks
     [flag-vsync-hint] against [FLAG_VSYNC_HINT].

     [constants]: one Flan name, spelled [Enum/member] or as a bare
     [defconst] name, and the exact C name it answers to. The narrow
     exception, for the one name a prefix rule gets wrong — raylib's
     [GESTURE_DOUBLETAP] against a member the package spells [double-tap]. It
     also brings a name under the check that no prefix rule covers. *)
  enum_prefixes  : (string * string) list;
  const_prefixes : (string * string) list;
  constants      : (string * string) list;
}

let no_config =
  { excludes = []; renames = []; enum_prefixes = []; const_prefixes = [];
    constants = [] }

(* [*] stands for any run of characters and nothing else does anything. Enough
   for [rl*] or [*Callback], and small enough to read at a glance; a package
   that needs more than this wants a hand-written declare-c, which it has. *)
let matches (pat : string) (s : string) =
  let np = String.length pat and ns = String.length s in
  let rec go i j =
    if i = np then j = ns
    else if pat.[i] = '*' then
      let rec from k = (k <= ns && go (i + 1) k) || (k < ns && from (k + 1)) in
      from j
    else j < ns && Char.equal pat.[i] s.[j] && go (i + 1) (j + 1)
  in
  go 0 0

let excluded cfg sym = List.exists (fun p -> matches p sym) cfg.excludes

(* The one place the kebab rule is consulted, so an override is not a special
   case anywhere below: collisions are computed on the name a function will
   actually take, which means renaming one of two colliding symbols resolves
   the collision rather than leaving both refused. *)
let flan_name cfg sym =
  match List.assoc_opt sym cfg.renames with Some n -> n | None -> kebab sym

(* The file, in the shape of [headers] and [link] beside it: one directive per
   line, [#] comments, blank lines ignored. A line that is neither directive is
   an error rather than a line quietly skipped — the house rule against
   swallowing things applies to a config as much as to a flag, and a typo in a
   name override would otherwise show up as a binding under the wrong name. *)
let read_config path : config =
  if not (Sys.file_exists path) then no_config
  else begin
    let ch = open_in path in
    let excludes = ref [] and renames = ref [] in
    let enum_prefixes = ref [] and const_prefixes = ref [] and constants = ref [] in
    let rec go n =
      match input_line ch with
      | line ->
        let t = String.trim line in
        if t <> "" && t.[0] <> '#' then begin
          let ws =
            String.split_on_char ' ' t
            |> List.concat_map (String.split_on_char '\t')
            |> List.filter (fun w -> w <> "")
          in
          match ws with
          | [ "exclude"; p ] -> excludes := p :: !excludes
          | [ "name"; sym; flan ] -> renames := (sym, flan) :: !renames
          | [ "enum"; flan; c ] -> enum_prefixes := (flan, c) :: !enum_prefixes
          | [ "const"; flan; c ] -> const_prefixes := (flan, c) :: !const_prefixes
          | [ "constant"; flan; c ] -> constants := (flan, c) :: !constants
          | _ ->
            close_in ch;
            fail (Loc.make path n 0)
              "a line here is `exclude <C symbol or pattern>`, `name <C \
               symbol> <flan-name>`, `enum <FlanEnum> <C_PREFIX>`, `const \
               <flan-prefix> <C_PREFIX>` or `constant <flan-name> <C_NAME>`, \
               and this is neither: %s" t
        end;
        go (n + 1)
      | exception End_of_file -> ()
    in
    go 1;
    close_in ch;
    { excludes = List.rev !excludes; renames = List.rev !renames;
      enum_prefixes = List.rev !enum_prefixes;
      const_prefixes = List.rev !const_prefixes;
      constants = List.rev !constants }
  end

(* [taken] is every name the package already declares, which is what makes the
   sidecar additive: a hand-written [(declare-c get-gamepad-name ...)] wins
   over the header, and a C symbol already bound by hand is not bound twice —
   which [Shim] would refuse for the whole build.

   [-c] as well as the name itself, because [Shim] generates [foo-c] beside a
   [foo] whose signature has a struct in it, and a collision there is refused
   for the whole program rather than for the one binding. *)
let of_dump ~env ~taken ~bound_syms ~config (d : dump) : imported =
  let decls = ref [] and hidden = ref [] in
  (* Collisions are found before anything is emitted, and they take *every*
     name in the colliding group down with them.

     Resolving one by taking the first and refusing the rest is the tempting
     shape and the wrong one: which C function ends up owning the Flan name
     would then depend on the order the header happens to declare them in, so
     moving two lines in somebody else's header silently rebinds a name a Flan
     program is already calling. There is no reading of [spin-2d] that is
     obviously right when the header offers both [Spin2D] and [spin2d], so
     neither gets it, and both say why. The author disambiguates with a
     hand-written declare-c, which is what that form is for.

     [bound_syms] is excluded first: a C function the package already binds by
     hand is not competing for an imported name at all, so it cannot collide
     with one. *)
  let candidates =
    List.filter (fun f -> not (List.mem f.csym bound_syms)) d.fns
  in
  (* Excluded before anything else looks at them, so an excluded symbol is not
     in a collision group either — which is one of the things exclusion is for.
     It still says why, under the name it would have taken: "there is no such
     binding" and "the package decided against this binding" are different
     answers and a reader deserves the second one. *)
  let dropped, candidates =
    List.partition (fun f -> excluded config f.csym) candidates
  in
  List.iter
    (fun f ->
       hidden :=
         (flan_name config f.csym,
          Printf.sprintf
            "%s is excluded by the package's binding config, so no \
             declaration is generated for it" f.csym)
         :: !hidden)
    dropped;
  let groups = Hashtbl.create 512 in
  List.iter
    (fun f ->
       let k = flan_name config f.csym in
       Hashtbl.replace groups k (f.csym :: Option.value ~default:[]
                                             (Hashtbl.find_opt groups k)))
    candidates;
  List.iter
    (fun f ->
       let flan = flan_name config f.csym in
       let skip why = hidden := (flan, why) :: !hidden in
       match List.rev (Hashtbl.find groups flan) with
       | _ :: _ :: _ as all ->
         skip
           (Printf.sprintf
              "%s all kebab to %s, and which one got the name would depend on \
               the order the header declares them in — so none of them takes \
               it. Give the one you want a `name` in the binding config, or \
               bind it with a hand-written declare-c"
              (String.concat ", " all) flan)
       | _ ->
       if Hashtbl.mem taken flan || Hashtbl.mem taken (flan ^ "-c") then
         skip
           (Printf.sprintf
              "%s would be the imported name of %s, and the package declares \
               %s already" flan f.csym flan)
       else if f.cvariadic then
         skip
           (Printf.sprintf
              "%s is variadic, and a wrapper cannot forward an argument list \
               it does not know the shape of" f.csym)
       else
         match
           (try
              let ps =
                List.mapi
                  (fun i (n, t) ->
                     let n = if n = "" then Printf.sprintf "a%d" i else kebab n in
                     { Ast.fname = n; fty = param_ty env t; floc = f.cloc })
                  f.cparams
              in
              (* [void] spelled as the only parameter is C for "none". clang
                 reports it as no ParmVarDecl at all, so this is belt and
                 braces. *)
              let ps = List.filter (fun (p : Ast.field) -> p.Ast.fname <> "void") ps in
              Ok (ps, ret_ty env f.cret)
            with Refused why -> Error why)
         with
         | Error why -> skip (Printf.sprintf "%s %s" f.csym why)
         | Ok (params, ret) ->
           decls :=
             { Ast.d =
                 Ast.DeclareC
                   ({ Ast.name = flan; params; ret; fbody = []; nloc = f.cloc },
                    f.csym);
               dloc = f.cloc }
             :: !decls)
    candidates;
  (* One entry per name. A collision refuses every member of its group and each
     of them writes the same reason under the same name, which [refuse_hidden]
     would look up identically but a report would print twice. *)
  let seen = Hashtbl.create 64 in
  let hidden =
    List.filter
      (fun (n, _) ->
         if Hashtbl.mem seen n then false else (Hashtbl.add seen n (); true))
      (List.rev !hidden)
  in
  { decls = List.rev !decls; hidden }

(* ── Checking the package's layouts against the header's ───────────── *)

(* The point of reading a header that the generator does not otherwise need.

   BUILT.md rejected a [_Static_assert] on [sizeof]/[offsetof] as circular:
   both sides would have come from the same field list. This is not circular.
   The [defstruct] was written by hand and the record comes from the library's
   own header, so a disagreement is real information — and it is the failure
   mode the whole FFI is most exposed to, since a permuted [Texture2D] reads as
   five plausible numbers and no link error.

   Reported and not raised. A package may legitimately describe a prefix of a
   struct it only ever holds by pointer, and a header that is a different
   version of the library is a normal state of affairs to be told about rather
   than stopped by. *)

(* Two rendered Flan types, compared for *representation* rather than for
   spelling.

   The one difference that is not a difference is an enum against a 32-bit
   integer. A Flan [defenum] is an [i32] — that is what [Shim.cty] lowers one
   to, in a struct field and in a parameter alike — and a C enum is an [int],
   so the two lay out the same four bytes and differ only in the face they
   present. Signedness goes with it: raylib spells [IsGestureDetected]'s
   parameter [unsigned int] and the package calls it [Gesture], and both are
   four bytes in a register.

   Symmetric on purpose. The enum may be on either side: the header says
   [CameraProjection] and the [defstruct] says [i32], or the header says [int]
   and the [defstruct] says [CameraProjection]. Both are the same statement
   about four bytes, and reporting either was the bug this closes.

   What it does *not* accept is anything else. [f64] against the library's
   [float] is eight bytes where there are four, every field after it moves,
   and it reads as plausible numbers rather than as a link error — which is
   the whole reason this check exists. An enum against an [i16], an [i64] or
   an [f32] is a real disagreement and stays one. *)
let enum_like env (t : Ast.texpr) =
  match t.Ast.t with
  | Ast.Tname n -> List.mem n env.known_enums
  | _ -> false

let int32_like s = String.equal s "i32" || String.equal s "u32"

let agrees env (a : Ast.texpr) (b : Ast.texpr) =
  let na = ty_source a and nb = ty_source b in
  String.equal na nb
  || (enum_like env a && int32_like nb)
  || (enum_like env b && int32_like na)

let check_structs ~env ~(structs : (string * Ast.field list) list) (d : dump) =
  let record n =
    match List.find_opt (fun r -> r.rname = n) d.records with
    | Some r -> Some r
    | None ->
      (* [defstruct Texture2D] against a header whose record is [Texture] and
         whose typedef says so. *)
      (match List.assoc_opt n d.typedefs with
       | Some u -> List.find_opt (fun r -> r.rname = bare u) d.records
       | None -> None)
  in
  (* Names and widths both. Order is what a permuted [defstruct] gets wrong and
     what BUILT.md says only a test can catch; width is the other half of the
     same hazard and the one it calls out by name — [f64] where the library
     says [float] lays out eight bytes where there are four, and every field
     after it moves. Comparing the rendered Flan type rather than the C
     spelling keeps the two sides commensurable: [u8] and [unsigned char] have
     to come out equal, and [f32] and [double] have to not. *)
  let field_mismatch (fs : Ast.field list) (r : crecord) =
    if List.length fs <> List.length r.rfields then
      Some
        (Printf.sprintf "defstruct has %d fields [%s] and %s has %d [%s]"
           (List.length fs)
           (String.concat " " (List.map (fun (f : Ast.field) -> f.Ast.fname) fs))
           r.rname (List.length r.rfields)
           (String.concat " " (List.map (fun (n, _) -> kebab n) r.rfields)))
    else
      List.find_map
        (fun ((f : Ast.field), (cn, ct)) ->
           if kebab cn <> f.Ast.fname then
             Some
               (Printf.sprintf
                  "the defstruct has %s where %s has %s, so the field order disagrees"
                  f.Ast.fname r.rname (kebab cn))
           else
             match (try Some (value_ty env ct) with Refused _ -> None) with
             | None -> None   (* a field type this cannot render says nothing *)
             | Some want ->
               let a = ty_source want and b = ty_source f.Ast.fty in
               if agrees env want f.Ast.fty then None
               else
                 Some
                   (Printf.sprintf "field %s is %s in the defstruct and %s (%s) in %s"
                      f.Ast.fname b a ct r.rname))
        (List.combine fs r.rfields)
  in
  List.filter_map
    (fun (n, (fs : Ast.field list)) ->
       match record n with
       | None -> None
       | Some r -> Option.map (fun m -> (n, m)) (field_mismatch fs r))
    structs

(* ── Checking the package's constants against the header's ─────────── *)

(* The half of the claim that was missing, and the one with the worst failure
   mode.

   [generate-c] used to say that every [defstruct] and every hand-written
   [declare-c] agreed with the header, and that claim held. It said nothing
   about [defconst] or [defenum] — so a wrong flag bit or a wrong enum member
   was *silent*, which is exactly the class of error the header read exists to
   catch and the one hardest to see by reading. [FLAG_WINDOW_MINIMIZED] is
   0x200; typing 0x100 gives a program that opens a window and hides it, with
   no diagnostic anywhere and nothing in the source that looks wrong.

   {2 How a Flan name is turned into a C one}

   Not by a rule alone. [screaming] reconstructs [LEFT_SHIFT] from
   [left-shift], but the prefix the C name carries — [KEY_], [FLAG_],
   [GAMEPAD_BUTTON_] — is nowhere in the Flan source, so it is *declared*, in
   the package's [bindings] file:

   {v
   enum  Key    KEY_       # (defenum Key [left-shift 340]) vs KEY_LEFT_SHIFT
   const flag-  FLAG_      # (defconst flag-vsync-hint ...) vs FLAG_VSYNC_HINT
   constant Gesture/double-tap GESTURE_DOUBLETAP   # the one the rule misses
   v}

   {2 Nothing goes quiet, in either direction}

   A name the rule builds and the header does not have is *reported* and not
   skipped. A mapping that silently matched nothing would be worse than no
   check at all: it would read as coverage and provide none.

   For the same reason a [defenum] with no [enum] line is itself a finding.
   Otherwise the silence simply moves up one level — the next lane adds an
   enum, adds no line, and nothing notices. [enum Foo -] is how a package says
   out loud that the header has nothing to check [Foo] against; it is a
   sentence somebody wrote rather than a line nobody did. An [enum] or [const]
   rule that matches no Flan name at all is a finding too, which is what
   catches a typo in the rule.

   [defconst] is *not* held to that. A package's constants are mostly its own
   — raylib's 26 colours, a screen size — and demanding a line for each would
   be noise with no second author behind it. A [defconst] is checked when a
   rule or a [constant] line brings it under the check, and raylib's
   [gesture-all] is the honest example of one that is not: 1023 is the OR of
   ten members and no C enumerator has that value to compare against. *)

(* Two kinds of finding, and they have different dispositions.

   [cmapping = false] is a disagreement with the *library*: a value that does
   not match, or a C name the header does not have. That is the same kind of
   thing a permuted [defstruct] is, and an ordinary build stops on it.

   [cmapping = true] is about the package's own [bindings] file — an enum
   nobody mapped, a rule that reaches nothing. Real, and worth fixing, but it
   is not the library contradicting anybody, and stopping a build over it
   would tell a lane that added a [defenum] to go and edit a config file in a
   message shaped like "your layout is wrong". Those gate [generate-c], which
   is where the config is being edited and where the author is standing. *)
type const_diff = { cname : string; cwhy : string; cmapping : bool }

let check_constants ~config
    ~(enums : (string * (string * int64) list) list)
    ~(consts : (string * Ast.expr) list) (d : dump) : const_diff list =
  let found = Hashtbl.create 512 in
  List.iter (fun (n, v) -> Hashtbl.replace found n v) d.consts;
  let out = ref [] in
  let emit mapping name fmt =
    Printf.ksprintf
      (fun m -> out := { cname = name; cwhy = m; cmapping = mapping } :: !out)
      fmt
  in
  let say name fmt = emit false name fmt in
  let mapping_say name fmt = emit true name fmt in
  (* One Flan name, its value, and the C name it claims to be. *)
  let compare_one flan v cname =
    match Hashtbl.find_opt found cname with
    | None ->
      say flan
        "the header has no constant named %s, so nothing here checks %s — \
         fix the mapping in `bindings` or the name in the source"
        cname flan
    | Some cv ->
      if not (Int64.equal cv v) then
        say flan "%s is %Ld here and %s is %Ld in the header" flan v cname cv
  in
  let explicit = config.constants in
  let used = Hashtbl.create 16 in
  (* Enum members. *)
  List.iter
    (fun (ename, members) ->
       match List.assoc_opt ename config.enum_prefixes with
       | None ->
         mapping_say ename
           "the defenum %s has no `enum` line in the package's `bindings`, so \
            nothing checks its members against the header — add `enum %s \
            <C_PREFIX>`, or `enum %s -` to say the header has nothing to \
            check it against"
           ename ename ename
       | Some "-" -> Hashtbl.replace used ("enum:" ^ ename) ()
       | Some prefix ->
         Hashtbl.replace used ("enum:" ^ ename) ();
         List.iter
           (fun (m, v) ->
              let flan = ename ^ "/" ^ m in
              let cname =
                match List.assoc_opt flan explicit with
                | Some c -> c
                | None -> prefix ^ screaming m
              in
              compare_one flan v cname)
           members)
    enums;
  (* Plain constants, and only the ones a rule or a [constant] line reaches. *)
  let int_of (e : Ast.expr) =
    match e.Ast.e with Ast.Int v -> Some v | _ -> None
  in
  List.iter
    (fun (n, e) ->
       (* The prefix is marked as reaching something *before* an explicit
          [constant] line is consulted, so a rule whose every match is also
          spelled out by hand is not reported as reaching nothing. A false
          finding in a check whose whole value is that a finding is real. *)
       let by_rule =
         List.find_map
           (fun (fp, cp) ->
              match strip_prefix fp n with
              | Some rest ->
                Hashtbl.replace used ("const:" ^ fp) ();
                Some (cp ^ screaming rest)
              | None -> None)
           config.const_prefixes
       in
       let cname =
         match List.assoc_opt n explicit with Some c -> Some c | None -> by_rule
       in
       match cname with
       | None -> ()
       | Some cname ->
         (match int_of e with
          | Some v -> compare_one n v cname
          | None ->
            say n
              "%s is mapped to %s but its value is not a plain integer, so \
               there is nothing to compare"
              n cname))
    consts;
  (* A rule that reaches nothing. A typo in a prefix would otherwise read as
     coverage and provide none, which is the failure this whole section is
     about. *)
  List.iter
    (fun (ename, _) ->
       if not (Hashtbl.mem used ("enum:" ^ ename)) then
         mapping_say ename
           "`enum %s` in the package's `bindings` names no defenum the \
            package declares" ename)
    config.enum_prefixes;
  List.iter
    (fun (fp, _) ->
       if not (Hashtbl.mem used ("const:" ^ fp)) then
         mapping_say fp
           "`const %s` in the package's `bindings` matches no defconst the \
            package declares" fp)
    config.const_prefixes;
  (* And a [constant] line naming nothing. *)
  List.iter
    (fun (flan, _) ->
       let known =
         List.mem_assoc flan consts
         || List.exists
              (fun (ename, members) ->
                 List.exists (fun (m, _) -> String.equal (ename ^ "/" ^ m) flan)
                   members)
              enums
       in
       if not known then
         mapping_say flan
           "`constant %s` in the package's `bindings` names no defconst and no \
            enum member the package declares" flan)
    explicit;
  List.rev !out

(* ── The entry point ───────────────────────────────────────────────── *)

let dump_of_clang ~loc ~header ~flags =
  let text = run_clang ~loc ~header ~flags in
  let json =
    try Cjson.parse text
    with Cjson.Bad m ->
      fail loc "clang's AST dump of %s did not parse: %s" header m
  in
  read_dump ~header json

(* ── The caches, two of them ───────────────────────────────────────── *)

(* Measured, not assumed: reading raylib.h costs 64ms — 30ms for clang to write
   1.8 MB of JSON and the rest to parse it and map it — against an 8ms check
   for the whole program without it. The dev loop rebuilds constantly and the
   header does not change between two of those rebuilds, so paying it every
   time is eight times the cost of everything else put together.

   What is cached is the *extracted* dump and not clang's JSON: it is the
   parse that is half the cost, and what comes out is a few hundred signatures
   rather than megabytes of source ranges.

   Keyed the way the object cache is keyed, and for the same reason — on
   everything that could change the answer. The header's path, its size and
   mtime, and the full flag list, because a flag changes what clang sees; plus
   a format version, because the cached value is a marshalled OCaml value and a
   compiler whose [dump] type has changed must not read one written by the old
   one. [Marshal] does not check that for you and a mismatch is a segfault
   rather than an exception, so the discipline is: **change the [dump] type,
   bump [cache_format] in the same commit.** Nothing enforces it.

   It lives under the object cache directory, beside the [.o] files, because it
   is the same kind of thing: derived from an input the compiler did not write,
   stable across builds, and safe to delete. One directory to clear rather than
   two. *)

let cache_format = 2

(* The same directory [Build.cachedir] makes, spelled here rather than called:
   [Load] is upstream of this file and downstream of [Reach], so reaching
   [Build] from here closes a cycle. Two lines that have to agree, and the
   consequence of their disagreeing is a second cache directory rather than a
   wrong answer. *)
let cachedir () =
  let d = Filename.concat (Filename.get_temp_dir_name ()) "flan-objcache" in
  (try Unix.mkdir d 0o700 with Unix.Unix_error (Unix.EEXIST, _, _) -> ());
  d

let dump_of_disk ~loc ~header ~flags =
  let st = try Some (Unix.stat header) with Unix.Unix_error _ -> None in
  match st with
  | None -> dump_of_clang ~loc ~header ~flags
  | Some st ->
    let key =
      Digest.to_hex
        (Digest.string
           (String.concat "\000"
              [ string_of_int cache_format;
                (try Unix.realpath header with Unix.Unix_error _ -> header);
                string_of_int st.Unix.st_size;
                Printf.sprintf "%.6f" st.Unix.st_mtime;
                String.concat " " flags ]))
    in
    let path = Filename.concat (cachedir ()) (key ^ ".dump") in
    let cached =
      if not (Sys.file_exists path) then None
      else
        try
          let ch = open_in_bin path in
          Fun.protect
            ~finally:(fun () -> close_in_noerr ch)
            (fun () -> Some (Marshal.from_channel ch : dump))
        with _ ->
          (* A truncated or stale file is not worth a build failure: the header
             is right there and can be read again. *)
          (try Sys.remove path with Sys_error _ -> ());
          None
    in
    (match cached with
     | Some d -> d
     | None ->
       let d = dump_of_clang ~loc ~header ~flags in
       (* Written to a distinct name and renamed, so two builds running at
          once cannot see a half-written file — the object cache does the
          same. *)
       (try
          let tmp = Printf.sprintf "%s.%d.tmp" path (Unix.getpid ()) in
          let ch = open_out_bin tmp in
          Fun.protect
            ~finally:(fun () -> close_out_noerr ch)
            (fun () -> Marshal.to_channel ch d []);
          Sys.rename tmp path
        with Sys_error _ -> ());
       d)

(* And in front of that file, the session's own copy — which is the level that
   matters for the dev loop, because the daemon is a process that lives for as
   long as the editor does and re-reads the file once per evaluation that
   imports the package again. Reading the cached dump is 0.33ms and extracting
   the declarations from it is another 3.3ms, so this is small; it is here
   because *nothing* is the right amount for a long-lived process to pay twice
   for an answer it already has.

   **Keyed on the header's path and the flags, and deliberately not on its
   mtime.** That is the whole of the mid-session question: a header edited
   while a session is running is not re-read, and the session keeps the
   signatures it started with until it is restarted. It is the same rule a
   changed [.c] file follows — the daemon compiled the package's C once, at
   startup, and a redefinition does not recompile it — and the same rule the
   running program itself follows, since its layouts are the ones it was built
   with. The alternative is worse in both directions: keying on mtime would put
   a [stat] on a path that is supposed to cost nothing, and it would let a
   header change take effect on the next [C-c C-c] in a *program that is still
   running with the old layouts*, which is precisely the silent disagreement
   the header check exists to prevent. A new session reads the new header, and
   the disk cache above keys on mtime so it does not serve it the old one.

   Two tables rather than one, because the two answers have different inputs.
   The *dump* is the header's alone, so a second package importing the same
   header shares it. The *declarations* are the dump read against one package —
   which names it already has taken, which structs and enums it knows, which C
   symbols it binds by hand — so they are keyed on those too, and a package
   whose decls an evaluation has added to gets its declarations worked out
   again rather than served an answer about the decls it used to have. *)

let dumps : (string, dump) Hashtbl.t = Hashtbl.create 4
let imports : (string, imported * dump * env) Hashtbl.t = Hashtbl.create 4

let header_key ~header ~flags =
  String.concat "\000"
    ((try Unix.realpath header with Unix.Unix_error _ -> header) :: flags)

let dump_of ~loc ~header ~flags =
  let k = header_key ~header ~flags in
  match Hashtbl.find_opt dumps k with
  | Some d -> d
  | None ->
    let d = dump_of_disk ~loc ~header ~flags in
    Hashtbl.replace dumps k d;
    d

let env_of ~known_structs ~known_enums d = { known_structs; known_enums; d }

let header ~loc ~header:h ~flags ~known_structs ~known_enums ~taken ~bound_syms
    ~config =
  let k =
    (* Sorted, because neither the taken table nor the declaration order is a
       fact about the package — two loads of the same file that enumerate them
       differently are the same question and must not miss each other. *)
    let sorted xs = List.sort compare xs in
    String.concat "\000"
      (header_key ~header:h ~flags
       :: "\001" :: sorted known_structs
       @ ("\001" :: sorted known_enums)
       @ ("\001" :: sorted (Hashtbl.fold (fun n () acc -> n :: acc) taken []))
       @ ("\001" :: sorted bound_syms)
       (* The config is part of the question: two loads that disagree about
          what is excluded or renamed are different questions, and serving one
          the other's answer is the bug this key exists to prevent. *)
       @ ("\001" :: sorted config.excludes)
       @ ("\001" :: sorted (List.map (fun (a, b) -> a ^ "=" ^ b) config.renames))
       @ ("\001" :: sorted (List.map (fun (a, b) -> a ^ "=" ^ b) config.enum_prefixes))
       @ ("\001" :: sorted (List.map (fun (a, b) -> a ^ "=" ^ b) config.const_prefixes))
       @ ("\001" :: sorted (List.map (fun (a, b) -> a ^ "=" ^ b) config.constants)))
  in
  match Hashtbl.find_opt imports k with
  | Some r -> r
  | None ->
    let d = dump_of ~loc ~header:h ~flags in
    let env = env_of ~known_structs ~known_enums d in
    let r = (of_dump ~env ~taken ~bound_syms ~config d, d, env) in
    Hashtbl.replace imports k r;
    r

(* ── Printing a declaration back as source ─────────────────────────── *)

(* Which makes the third option in DISCUSS.md item 6 available at no extra
   cost: generate the declarations from the header, *commit the result*, and
   regenerate when the library moves. That trade — explicit in the source,
   checked against reality, no header read at build time — is a real one, and
   it needs a printer and nothing else. [flan import-c] is it. *)


let decl_source (d : Ast.decl) =
  match d.Ast.d with
  | Ast.DeclareC (fn, csym) ->
    Printf.sprintf "(declare-c %s [%s]%s %S)" fn.Ast.name
      (String.concat "  "
         (List.map
            (fun (p : Ast.field) ->
               Printf.sprintf "%s %s" p.Ast.fname (ty_source p.Ast.fty))
            fn.Ast.params))
      (match fn.Ast.ret with None -> "" | Some t -> " " ^ ty_source t)
      csym
  | _ -> ""

(* ── A hand-written binding, against the header's own signature ────── *)

(* The other half of closing the trusted gap, and the one that pays off
   immediately: [vendor/raylib] carries 176 [declare-c] lines that were
   transcribed by hand from raylib's documentation, and until now nothing could
   say whether any of them was right. This says so, one at a time.

   Compared as *rendered Flan types*, not as C spellings, because the two sides
   are not written in the same language and only the Flan rendering is
   commensurable. Three differences are expected and are not reported:

   - the Flan name. [IsKeyPressed] is [key-pressed?] by hand and
     [is-key-pressed] by rule, and the hand-written one is better. The C symbol
     is what identifies the function here, not the name.
   - an enum parameter. The header says [KeyboardKey] and the importer has no
     way to know the package calls that [Key], so it says [i32]; the
     hand-written [Key] is the same int with a better face.
   - a [(Ptr T)] where the header says [T *] and the hand-written line chose
     something more specific for a reason it recorded.

   What is left after those is a real disagreement about a width, an arity or a
   direction — which is exactly the class of bug BUILT.md warns about, where
   [f64] against the library's [float] reads as garbage rather than as a link
   error. *)

type sig_diff = { dsym : string; dflan : string; dwhy : string }

let diff_bound ~env ~(bound : (Ast.fn * string) list) (d : dump) =
  let by_sym = Hashtbl.create 512 in
  List.iter (fun f -> Hashtbl.replace by_sym f.csym f) d.fns;
  List.filter_map
    (fun ((fn : Ast.fn), csym) ->
       match Hashtbl.find_opt by_sym csym with
       | None ->
         Some
           { dsym = csym; dflan = fn.Ast.name;
             dwhy = "the header does not declare this function at all" }
       | Some c ->
         let say why = Some { dsym = csym; dflan = fn.Ast.name; dwhy = why } in
         (* [agrees] above is the whole of it: an enum against a 32-bit
            integer is the expected difference and not a finding, and an enum
            against anything else still is one. *)
         let norm (t : Ast.texpr) = ty_source t in
         let same a b = agrees env a b in
         if c.cvariadic then None
         else if List.length fn.Ast.params <> List.length c.cparams then
           say
             (Printf.sprintf "declared with %d parameters and the header says %d (%s)"
                (List.length fn.Ast.params) (List.length c.cparams)
                (String.concat ", " (List.map snd c.cparams)))
         else
           let param_diff =
             List.find_map
               (fun ((p : Ast.field), (_, ct)) ->
                  match (try Some (param_ty env ct) with Refused _ -> None) with
                  | None -> None
                  | Some want ->
                    if same want p.Ast.fty then None
                    else
                      Some
                        (Printf.sprintf "parameter %s is %s and the header says %s (%s)"
                           p.Ast.fname (ty_source p.Ast.fty) (norm want) ct))
               (List.combine fn.Ast.params c.cparams)
           in
           match param_diff with
           | Some why -> say why
           | None ->
             (match (try Ok (ret_ty env c.cret) with Refused w -> Error w) with
              | Error _ -> None
              | Ok want ->
                let agrees =
                  match (want, fn.Ast.ret) with
                  | None, None -> true
                  | Some a, Some b -> same a b
                  | _ -> false
                in
                if agrees then None
                else
                  say
                    (Printf.sprintf "returns %s and the header says %s (%s)"
                       (match fn.Ast.ret with None -> "nothing" | Some t -> ty_source t)
                       (match want with None -> "nothing" | Some t -> ty_source t)
                       c.cret)))
    bound


(* ── Regenerating the committed declarations ───────────────────────── *)

(* Generate once, commit the result, regenerate when the library moves.

   What that buys is in DISCUSS.md item 6 and it is not caching — the dump is
   already cached on disk and in memory, so a build that reads the header pays
   for it once either way. It is that no header is needed by *anybody*: the
   declarations are in the repository, so they are greppable, they diff when
   raylib moves, and a build needs libraylib linkable and nothing else. The
   opt-in that used to decide whether a package had 172 bindings or 428 stops
   deciding anything.

   What it costs is the check. A header read at build time compared every
   hand-written declaration against the library on every build; a committed
   file compares nothing, because a file on disk has no second opinion. That
   check is not decoration — it verified all 172 hand-written declarations and
   all 16 struct layouts against raylib 5.5 and found them exactly right, and
   against a 5.1-dev header on the same machine it found ten real differences.

   So regeneration runs it, and the check *gates the write*. There is no way to
   ask for new declarations without comparing the package against the header
   they come from, because the one function that writes the file is this one
   and it refuses when the two disagree. A regeneration that quietly rewrote
   the bindings against a header the library does not match would produce
   exactly the failure BUILT.md warns about — a permuted struct read as five
   plausible numbers rather than as a link error — and it would produce it in a
   committed file that looks reviewed.

   The hand-written declarations are what make the signature half of that check
   mean anything, which is why they stay. Everything the generator emits agrees
   with the header by construction, so diffing generated output against the
   header it came from is a tautology; the hand-written lines were transcribed
   from raylib's documentation by a person, so they are an independent second
   opinion and the only thing here that the header can actually contradict. *)

type regen = {
  gwrote   : bool;
  gdecls   : int;
  gfns     : int;
  ghidden  : (string * string) list;
  gstructs : (string * string) list;
  gsigs    : sig_diff list;
  gconsts  : const_diff list;
}

let banner h =
  Printf.sprintf
    ";;;; Generated from %s by `flan generate-c`. Do not edit this file.\n\
     ;;;;\n\
     ;;;; Every line here was read out of the C header named by `headers`, and\n\
     ;;;; the next regeneration overwrites the file — so a correction made here\n\
     ;;;; is destroyed without anybody being told. Corrections go in `bindings`\n\
     ;;;; beside it, which is read *while* these lines are made: `exclude` drops\n\
     ;;;; a function, `name` gives one a Flan name the kebab rule would not.\n\
     ;;;; Anything neither directive can express is a hand-written declare-c in\n\
     ;;;; the package's own .flan, which wins over this file and is left alone.\n\
     ;;;;\n\
     ;;;; Regenerating compares the package against the header first and\n\
     ;;;; refuses to write when they disagree, so this file and the\n\
     ;;;; hand-written declarations beside it agreed with %s when it was made.\n\n"
    (Filename.basename h) (Filename.basename h)

(* [ds] is the package's *hand-written* declarations: every .flan in the
   directory except the one being written. Reading the output back in would
   make regeneration idempotent in the worst way — every symbol would already
   be bound, so the second run would generate nothing and cheerfully write an
   empty file. *)
let regenerate ~loc ~header:h ~flags ~(ds : Ast.decl list) ~config ~out =
  let taken = Hashtbl.create 64 in
  List.iter
    (fun d ->
       match Ast.declared_name d with
       | Some n -> Hashtbl.replace taken n ()
       | None -> ())
    ds;
  let pick f = List.filter_map f ds in
  let structs =
    pick (fun (d : Ast.decl) ->
      match d.Ast.d with Ast.Defstruct (n, fs) -> Some (n, fs) | _ -> None)
  and enums =
    pick (fun (d : Ast.decl) ->
      match d.Ast.d with Ast.Defenum (n, ms) -> Some (n, ms) | _ -> None)
  and pconsts =
    pick (fun (d : Ast.decl) ->
      match d.Ast.d with Ast.Defconst (n, _, e) -> Some (n, e) | _ -> None)
  and bound_syms =
    pick (fun (d : Ast.decl) ->
      match d.Ast.d with
      | Ast.Declare (_, s) | Ast.DeclareC (_, s) -> Some s
      | _ -> None)
  and bound =
    pick (fun (d : Ast.decl) ->
      match d.Ast.d with Ast.DeclareC (fn, s) -> Some (fn, s) | _ -> None)
  in
  let imported, dump, env =
    header ~loc ~header:h ~flags ~known_structs:(List.map fst structs)
      ~known_enums:(List.map fst enums) ~taken ~bound_syms ~config
  in
  let gstructs = check_structs ~env ~structs dump in
  let gsigs = diff_bound ~env ~bound dump in
  let gconsts = check_constants ~config ~enums ~consts:pconsts dump in
  let gwrote = gstructs = [] && gsigs = [] && gconsts = [] in
  if gwrote then begin
    let b = Buffer.create 65536 in
    Buffer.add_string b (banner h);
    List.iter
      (fun d ->
         Buffer.add_string b (decl_source d);
         Buffer.add_char b '\n')
      imported.decls;
    let ch = open_out out in
    output_string ch (Buffer.contents b);
    close_out ch
  end;
  { gwrote; gdecls = List.length imported.decls;
    gfns = List.length dump.fns; ghidden = imported.hidden; gstructs; gsigs;
    gconsts }