(** Forms → AST. Recognises special forms, desugars sugar, reports malformed
    syntax with the location of the offending form.

    Everything not recognised here is a call, which is how a Lisp should work:
    [at], [len], [push], [abort] and the rest are ordinary functions resolved
    by the checker, not syntax. *)

open Form

let fail (f : Form.t) fmt = Loc.fail f.loc fmt

let sym (f : Form.t) =
  match f.v with
  | Sym s -> s
  | _ -> fail f "expected a name, found %s" (Form.to_string f)

(* Names for the temporaries a destructuring binding needs — the value is bound
   once and every name in the pattern reads *that*, so a pattern over a call
   calls it once. [~] is a delimiter in the reader, so no symbol anyone can
   write contains one: these cannot collide with a source name and a source
   name cannot shadow one. Reset per program so the names, and therefore the
   slot numbering downstream, are the same every run. *)
let temps = ref 0

let fresh_temp () = incr temps; Printf.sprintf "destructure~%d" !temps

(* Destructuring binds in [let] and nowhere else. Every other binding position —
   a [defn] parameter, a [defstruct] field, an [fn] parameter, a [dotimes]
   counter, a [match] arm's binds — takes a plain name, and a pattern written
   there is refused here rather than falling out of [sym] as "expected a name".

   A parameter is the one worth saying why about: it is a name/type pair, and a
   pattern has no name to pair the type with, so supporting it means a pattern
   inside [Ast.field] — a record [Load] and [Shim] both build and read, and
   neither is this file's to change. *)
let no_pattern (f : Form.t) =
  match f.v with
  | Map _ | Vec _ ->
    fail f
      "%s is a destructuring pattern, and a pattern binds only in let — this \
       position takes a plain name. Take the value under a name and \
       destructure it in the body"
      (Form.to_string f)
  | _ -> ()

(* Primitive type names are lowercase but concrete; every other lowercase name
   in type position is a type variable (plan.org, Types). *)
let primitives =
  [ "i8"; "i16"; "i32"; "i64"; "u8"; "u16"; "u32"; "u64";
    "f32"; "f64"; "bool"; "string"; "Unit"; "Never" ]

let is_primitive s = List.mem s primitives

module Names = Set.Make (String)

(* Type constructors the language provides. User types are collected by a
   pre-pass over the file's declarations — see [program]. *)
let builtin_types =
  Names.of_list (primitives @ [ "Ptr"; "Option"; "Result"; "Vec"; "Map";
                                "Handle"; "Fn" ])

(* ── Type expressions ──────────────────────────────────────────────── *)

let rec texpr (f : Form.t) : Ast.texpr =
  let mk t = { Ast.t; tloc = f.loc } in
  match f.v with
  | Sym s -> mk (Ast.Tname s)
  | Vec [ elem ] -> mk (Ast.Tslice (texpr elem))
  | Vec [ n; elem ] -> mk (Ast.Tarray (len n, texpr elem))
  | Vec _ ->
    fail f "a type in brackets is [T] for a slice or [n T] for a fixed array"
  | Map [ k; v ] -> mk (Ast.Tmap (texpr k, texpr v))
  | Map _ -> fail f "a map type is {K V}"
  | List ({ v = Sym "Fn"; _ } :: rest) ->
    (match rest with
     | [ { v = Vec params; _ }; ret ] ->
       mk (Ast.Tfn (List.map texpr params, texpr ret))
     | _ -> fail f "a function type is (Fn [T ...] R)")
  | List ({ v = Sym name; _ } :: args) when args <> [] ->
    mk (Ast.Tapp (name, List.map texpr args))
  | _ -> fail f "expected a type, found %s" (Form.to_string f)

and len (f : Form.t) : Ast.len =
  match f.v with
  | Int n -> Ast.Lint n
  | Sym s -> Ast.Lname s
  | _ -> fail f "an array length is an integer or a constant's name"

(* Inline name/type pairs: [x i32  y f32] — as in let, defstruct and defn. *)
let rec fields (f : Form.t) (items : Form.t list) : Ast.field list =
  match items with
  | [] -> []
  | name :: ty :: rest ->
    no_pattern name;
    { Ast.fname = sym name; fty = texpr ty; floc = name.loc } :: fields f rest
  | [ odd ] ->
    Loc.fail odd.loc "field %s has no type — these come in name/type pairs"
      (Form.to_string odd)

(* ── Expressions ───────────────────────────────────────────────────── *)

let rec expr (f : Form.t) : Ast.expr =
  let mk e = { Ast.e; loc = f.loc } in
  match f.v with
  | Int i -> mk (Ast.Int i)
  | Float x -> mk (Ast.Float x)
  | Byte b -> mk (Ast.Byte b)
  | Str s -> mk (Ast.Str s)
  | Kw k -> mk (Ast.Kw k)
  | Sym s -> mk (Ast.Var s)
  (* In value position brackets are a fixed-array literal; in type position
     they are a slice or array type. Position disambiguates, as with {}. *)
  | Vec items -> mk (Ast.Arr (List.map expr items))
  | Map _ -> fail f "a bare map is not an expression; write (Type {:field v})"
  | List [] -> fail f "() is not an expression"
  | List (head :: args) -> form f mk head args

and form f mk (head : Form.t) (args : Form.t list) : Ast.expr =
  match head.v with
  (* ── quote ─────────────────────────────────────────────────────── *)
  | Sym "quote" ->
    (match args with
     | [ { v = Sym s; _ } ] -> mk (Ast.Quote s)
     | _ -> fail f "quote takes one symbol")

  (* ── sequencing and binding ────────────────────────────────────── *)
  | Sym "do" -> mk (Ast.Do (List.map expr args))

  | Sym "let" ->
    (match args with
     | { v = Vec bs; _ } :: body -> mk (Ast.Let (bindings f bs, body_of body))
     | _ -> fail f "let is (let [name value ...] body ...)")

  (* ── conditionals ──────────────────────────────────────────────── *)
  | Sym "if" ->
    (match args with
     | [ c; t ] -> mk (Ast.If (expr c, expr t, None))
     | [ c; t; e ] -> mk (Ast.If (expr c, expr t, Some (expr e)))
     | _ -> fail f "if is (if test then) or (if test then else)")

  (* Sugar, desugared here: special forms until macros land at milestone 5. *)
  | Sym "when" ->
    (match args with
     | c :: body when body <> [] ->
       mk (Ast.If (expr c, { Ast.e = Ast.Do (body_of body); loc = f.loc }, None))
     | _ -> fail f "when is (when test body ...)")

  | Sym "unless" ->
    (match args with
     | c :: body when body <> [] ->
       let neg = { Ast.e = Ast.Call ({ Ast.e = Ast.Var "not"; loc = head.loc },
                                     [ expr c ]); loc = f.loc } in
       mk (Ast.If (neg, { Ast.e = Ast.Do (body_of body); loc = f.loc }, None))
     | _ -> fail f "unless is (unless test body ...)")

  | Sym "cond" -> cond f args

  (* Short-circuiting, so they cannot be ordinary calls. *)
  | Sym "and" -> shortcircuit f args ~is_and:true
  | Sym "or" -> shortcircuit f args ~is_and:false

  (* ── loops ─────────────────────────────────────────────────────── *)
  | Sym "while" ->
    (match args with
     | c :: body -> mk (Ast.While (expr c, body_of body))
     | [] -> fail f "while is (while test body ...)")

  | Sym "until" ->
    (match args with
     | c :: body ->
       let neg = { Ast.e = Ast.Call ({ Ast.e = Ast.Var "not"; loc = head.loc },
                                     [ expr c ]); loc = f.loc } in
       mk (Ast.While (neg, body_of body))
     | [] -> fail f "until is (until test body ...)")

  (* ── control ───────────────────────────────────────────────────── *)
  | Sym "return" ->
    (match args with
     | [] -> mk (Ast.Return None)
     | [ v ] -> mk (Ast.Return (Some (expr v)))
     | _ -> fail f "return takes at most one value")

  | Sym "set" ->
    (match args with
     | [ target; value ] -> mk (Ast.Set (place target, expr value))
     | _ -> fail f "set is (set place value)")

  | Sym "match" ->
    (match args with
     | scrutinee :: rest -> mk (Ast.Match (expr scrutinee, arms f rest))
     | [] -> fail f "match is (match value pattern body ...)")

  (* ── binding and control: never a call ─────────────────────────── *)
  (* A form that binds a name or alters control flow cannot fall through to
     Call — it would parse cleanly and mean the wrong thing, silently. *)
  | Sym "fn" ->
    (match args with
     | { v = Vec ps; _ } :: body when body <> [] ->
       List.iter no_pattern ps;
       mk (Ast.Fn (List.map sym ps, body_of body))
     | _ -> fail f "fn is (fn [param ...] body ...)")

  | Sym "dotimes" ->
    (match args with
     | { v = Vec [ n; count ]; _ } :: body ->
       no_pattern n;
       mk (Ast.Dotimes (sym n, expr count, body_of body))
     | _ -> fail f "dotimes is (dotimes [name count] body ...)")

  | Sym "defer" ->
    (match args with
     | [] -> fail f "defer is (defer body ...)"
     | body -> mk (Ast.Defer (body_of body)))

  | Sym "some" ->
    (match args with
     | [ v ] -> mk (Ast.Unwrap (Ast.Usome, expr v))
     | _ -> fail f "some is (some option-value)")

  | Sym "try" ->
    (match args with
     | [ v ] -> mk (Ast.Unwrap (Ast.Utry, expr v))
     | _ -> fail f "try is (try result-value)")

  (* (signal c) : Unit, always. When every applicable handler returns normally
     the signalling function simply carries on, and with no handler at all it is
     a no-op — spec-conditions.md §1 and §2. *)
  (* And (error c) : Never — §2's diverging variant. Same lookup, but a
     handler that returns normally does not answer it: with nothing
     transferring the program stops. *)
  | Sym (("signal" | "error") as how) ->
    let kind = if how = "signal" then Ast.Ssignal else Ast.Serror in
    (match args with
     | [ c ] -> mk (Ast.Signal (kind, expr c))
     | _ -> fail f "%s is (%s condition)" how how)

  (* (handler-bind [(Type [c] body ...) ...] body ...)

     A clause names a condition type, binds the condition, and runs for effect;
     matching is by type, since there is no condition hierarchy. *)
  | Sym "handler-bind" ->
    let clauses, body =
      match args with
      | { v = Vec clauses; _ } :: body when body <> [] -> (clauses, body)
      | _ ->
        fail f "handler-bind is (handler-bind [(Type [name] body ...) ...] body ...)"
    in
    let clause (c : Form.t) =
      match c.Form.v with
      | Form.List (ty :: { v = Form.Vec [ { v = Form.Sym n; _ } ]; _ } :: cbody)
        when cbody <> [] ->
        { Ast.hty = texpr ty; hname = n; hbody = List.map expr cbody;
          hloc = c.Form.loc }
      | _ ->
        fail c "a handler-bind clause is (Type [name] body ...)"
    in
    mk (Ast.HandlerBind (List.map clause clauses, body_of body))

  (* (restart-case BODY (name [] BODY-1) ...) — spec-conditions.md §3.
     The body and every clause have the same type, which is the form's.
     Restarts take no parameters in this version; a clause that declares one is
     rejected below rather than ignored. *)
  | Sym "restart-case" ->
    let body, clauses =
      match args with
      | body :: clauses when clauses <> [] -> (body, clauses)
      | _ ->
        fail f "restart-case is (restart-case body (name [] body ...) ...)"
    in
    let clause (c : Form.t) =
      match c.Form.v with
      | Form.List ({ v = Form.Sym n; _ } :: { v = Form.Vec ps; _ } :: cbody)
        when cbody <> [] ->
        if ps <> [] then
          fail c
            "a restart takes no parameters yet — spec-conditions.md §3 has \
             them, and they need argument marshalling and a runtime arity \
             check that this version does not do";
        { Ast.rname = n; rbody = List.map expr cbody; rloc = c.Form.loc }
      | _ -> fail c "a restart-case clause is (name [] body ...)"
    in
    mk (Ast.RestartCase (expr body, List.map clause clauses))

  (* (invoke-restart 'name) : Never. The name is a quoted symbol — that is what
     the reader's quote is for — and it is resolved on the restart stack at run
     time, since restarts are dynamically scoped. *)
  | Sym "invoke-restart" ->
    (match args with
     | [ { v = Form.List [ { v = Form.Sym "quote"; _ }; { v = Form.Sym n; _ } ]; _ } ] ->
       mk (Ast.InvokeRestart n)
     | [ _ ] ->
       fail f
         "invoke-restart takes a quoted restart name, as in \
          (invoke-restart 'use-placeholder)"
     | _ ->
       fail f
         "a restart takes no arguments yet — spec-conditions.md §3 has them, \
          and they need argument marshalling and a runtime arity check that \
          this version does not do")

  (* ── macros ────────────────────────────────────────────────────── *)
  (* The reader now produces these three, so they arrive here as ordinary heads
     and would fall through to Call — coming back from the checker as "unknown
     name quasiquote", which says nothing about what is actually missing. *)
  | Sym "quasiquote" ->
    fail f "`x is read, but not expanded: macro expansion is not wired up yet \
            (NEXT.md says what it needs)"

  (* Not a milestone, a mistake: these two mean nothing anywhere else, and the
     reader cannot tell, because it does not track where it is. *)
  | Sym "unquote" ->
    fail f "~x means nothing outside a quasiquote"
  | Sym "unquote-splicing" ->
    fail f "~@x means nothing outside a quasiquote, and splices only into a \
            list or a vector"

  | Sym "defmacro" ->
    fail f "defmacro is a top-level declaration, not an expression"

  (* Neither a reader token nor a special form: an ordinary function that a
     macro body calls while the macro runs. There is nowhere for it to run
     yet, so it says that rather than arriving as an unknown name. *)
  | Sym "gensym" ->
    fail f "gensym is only meaningful inside a macro body, and macro expansion \
            is not wired up yet (NEXT.md says what it needs)"

  (* Recognised, deliberately unimplemented. Rejected rather than left to fall
     through to Call, where they would parse and mean nothing. *)
  | Sym ("handler-case"
        (* Named in the spec and not written yet, so each says so rather than
           falling through to Call and coming back as an unknown name:
           [find-restart] and [compute-restarts] are §4's two ways to look at
           the restart stack without committing to one. *)
        | "find-restart" | "compute-restarts"
        | "errdefer" | "loop" | "recur"
        (* plan.org's loop story is settled as imperative while/for with these
           two and [return]. Neither exists, and both *alter control flow* —
           the first thing the house rule says must be recognised explicitly.
           Falling through to Call answered "unknown function break", which
           reads as a typo rather than as a missing feature. *)
        | "break" | "continue"
        | "await" as name) ->
    fail f "%s is not implemented yet (see the build sequence in plan.org)" name

  (* ── field access: (.pos c) ────────────────────────────────────── *)
  | Sym s when String.length s > 1 && s.[0] = '.' ->
    let field = String.sub s 1 (String.length s - 1) in
    (match args with
     | [ target ] -> mk (Ast.Field (expr target, field))
     | _ -> fail f "field access is (.%s value)" field)

  (* ── struct literal: (Cursor {:src s :pos 0}) ───────────────────── *)
  | Sym name when args <> [] && is_map (List.hd args) ->
    (match args with
     | [ { v = Map kvs; _ } ] -> mk (Ast.Struct (name, struct_fields f kvs))
     | _ -> fail f "a struct literal is (%s {:field value ...})" name)

  (* ── anything else is a call ────────────────────────────────────── *)
  | _ -> mk (Ast.Call (expr head, List.map expr args))

and is_map (f : Form.t) = match f.v with Map _ -> true | _ -> false

and body_of (items : Form.t list) : Ast.expr list = List.map expr items

and bindings f (items : Form.t list) : Ast.binding list =
  (* [name value ...] and [name Type value ...] both read; a type is a form
     that is not a value position — disambiguated by pair vs triple is
     ambiguous, so let requires (let [name value]) and types are inferred.
     Annotated locals are not needed by any acceptance program. *)
  let rec go = function
    | [] -> []
    | pat :: value :: rest ->
      let bs = destructure pat (expr value) in
      no_duplicates pat bs;
      bs @ go rest
    | [ odd ] ->
      Loc.fail odd.loc "binding %s has no value — let takes name/value pairs"
        (Form.to_string odd)
  in
  if items = [] then Loc.fail f.loc "let needs at least one binding" else go items

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

(* The temporary every pattern binds its value to before anything reads it, so
   that the value is evaluated once however many names come out of it. Returning
   the reference as well as the binding is what makes the two impossible to
   separate by accident. *)
and temp (p : Form.t) (v : Ast.expr) : Ast.expr * Ast.binding =
  let t = fresh_temp () in
  ({ Ast.e = Ast.Var t; loc = p.loc },
   { Ast.bname = t; bty = None; bval = v; bloc = p.loc })

(* Clojure's destructuring, desugared here into the bindings and field accesses
   the language already has. [Ast.binding] carries a name and nothing else, and
   deliberately so: nothing downstream — not [Load]'s renaming, not [Check], not
   any backend — learns that a pattern exists. The same reason [dotimes] is a
   [Let] plus a [While].

   The one thing this cannot decide is whether an array pattern's arity matches
   the value's, because that is a type and there are none here. [destructure~nth]
   carries the question to [Check], which answers it and emits an ordinary [at].

   A binding is a pattern only when it is written in brackets or braces; a bare
   name is what it always was. *)
and destructure (p : Form.t) (v : Ast.expr) : Ast.binding list =
  match p.v with
  | Sym name -> [ { Ast.bname = name; bty = None; bval = v; bloc = p.loc } ]
  (* The value goes into a temporary first, so it is evaluated once however
     many names the pattern binds, and so that [(let [{:keys [p]} p] ...)]
     reads the old [p] rather than the one it is in the middle of rebinding. *)
  | Map items -> let t, bind = temp p v in bind :: dmap p t items
  | Vec items -> let t, bind = temp p v in bind :: dvec p t items
  | _ ->
    fail p
      "expected a name or a destructuring pattern, found %s — a pattern is \
       {:keys [x y]} over a struct or [a b] over a fixed array"
      (Form.to_string p)

(* {:keys [x y]} and {inner :field}, over a struct. Clojure's map destructuring
   with Flan's structs standing in for its maps: [:keys] is the common case and
   the pair form is what nests, since a [:keys] entry is a name and never a
   pattern. Everything else Clojure puts in this position — [:as], [:or],
   [:strs], [:syms] — is refused by name where it is written. *)
and dmap (p : Form.t) (t : Ast.expr) (items : Form.t list) : Ast.binding list =
  let ex loc e : Ast.expr = { Ast.e; loc } in
  let field loc name = ex loc (Ast.Field (t, name)) in
  let rec go = function
    | [] -> []
    | { v = Kw "keys"; _ } :: names :: rest ->
      let ns =
        match names.v with
        | Vec ns -> ns
        | _ ->
          Loc.fail names.loc
            ":keys takes a bracketed list of field names, found %s"
            (Form.to_string names)
      in
      let rec each = function
        | [] -> []
        | (n : Form.t) :: more ->
          let name =
            match n.v with
            | Sym s -> s
            | _ ->
              Loc.fail n.loc
                ":keys binds field names, and %s is not one — a nested pattern \
                 is written {%s :field}"
                (Form.to_string n) (Form.to_string n)
          in
          { Ast.bname = name; bty = None; bval = field n.loc name; bloc = n.loc }
          :: each more
      in
      each ns @ go rest
    | ({ v = Kw k; _ } as bad) :: _ :: rest ->
      ignore rest;
      Loc.fail bad.loc
        ":%s is not implemented in a destructuring pattern — a struct pattern \
         is {:keys [x y]} or {name :field}, and nothing else" k
    | pat :: ({ v = Kw fld; _ } as fform) :: rest ->
      destructure pat (field fform.loc fld) @ go rest
    | pat :: other :: _ ->
      Loc.fail other.loc
        "expected :field after %s, found %s — a struct pattern binds \
         {name :field}" (Form.to_string pat) (Form.to_string other)
    | [ odd ] ->
      Loc.fail odd.loc "%s has no :field — a struct pattern comes in pairs"
        (Form.to_string odd)
  in
  if items = [] then
    fail p "an empty struct pattern {} binds nothing — write the names it should bind"
  else go items

(* [a b] and [a b & rest], over a fixed array. Not over a slice: see [Check]. *)
and dvec (p : Form.t) (t : Ast.expr) (items : Form.t list) : Ast.binding list =
  let ex loc e : Ast.expr = { Ast.e; loc } in
  let var loc n = ex loc (Ast.Var n) in
  let rec split acc = function
    | [] -> (List.rev acc, None)
    | ({ v = Sym "&"; _ } as amp) :: rest ->
      (match rest with
       | [ r ] -> (List.rev acc, Some r)
       | [] -> Loc.fail amp.loc "& needs a name after it, as in [a b & rest]"
       | _ :: extra :: _ ->
         Loc.fail extra.loc
           "& takes one name and it is the last thing in the pattern")
    | x :: rest -> split (x :: acc) rest
  in
  let elems, rest = split [] items in
  let n = List.length elems in
  (match elems, rest with
   | [], None ->
     fail p "an empty array pattern [] binds nothing — write the names it should bind"
   | [], Some r ->
     Loc.fail r.loc
       "[& %s] binds the whole value — write %s on its own instead of a pattern"
       (Form.to_string r) (Form.to_string r)
   | _ -> ());
  (* With a [& rest] the pattern says "at least this many"; without one it says
     "exactly this many". [Check] is where the array's length is known, so the
     count and which of the two it means travel there as arguments. *)
  let exact = if rest = None then 1L else 0L in
  let nth i =
    ex p.loc
      (Ast.Call (var p.loc "destructure~nth",
                 [ t;
                   ex p.loc (Ast.Int (Int64.of_int i));
                   ex p.loc (Ast.Int (Int64.of_int n));
                   ex p.loc (Ast.Int exact) ]))
  in
  let rec each i = function
    | [] -> []
    | e :: more -> destructure e (nth i) @ each (i + 1) more
  in
  let rest_binding =
    match rest with
    | None -> []
    | Some r ->
      (* An ordinary (slice t n (len t)): the tail of the temporary, which is a
         local and outlives the body that reads it. Nothing new. *)
      let name =
        match r.v with
        | Sym s -> s
        | _ ->
          Loc.fail r.loc
            "& binds one name for the tail, and %s is not one — the tail is a \
             slice, so it cannot be destructured further" (Form.to_string r)
      in
      [ { Ast.bname = name; bty = None; bloc = r.loc;
          bval =
            ex r.loc
              (Ast.Call (var r.loc "slice",
                         [ t;
                           ex r.loc (Ast.Int (Int64.of_int n));
                           ex r.loc (Ast.Call (var r.loc "len", [ t ])) ])) } ]
  in
  each 0 elems @ rest_binding

(* One pattern binding the same name twice is a mistake, not a shadowing: the
   second would win and the first would bind nothing. Across a let's bindings it
   *is* shadowing and stays legal, so this looks at one pattern at a time. *)
and no_duplicates (p : Form.t) (bs : Ast.binding list) =
  let rec go seen = function
    | [] -> ()
    | (b : Ast.binding) :: rest ->
      if String.contains b.Ast.bname '~' then go seen rest
      else if List.mem b.Ast.bname seen then
        Loc.fail b.Ast.bloc "this pattern binds %s twice" b.Ast.bname
      else go (b.Ast.bname :: seen) rest
  in
  ignore p; go [] bs

and struct_fields f (items : Form.t list) : (string * Ast.expr) list =
  let rec go = function
    | [] -> []
    | { v = Kw k; _ } :: value :: rest -> (k, expr value) :: go rest
    | other :: _ :: _ ->
      Loc.fail other.loc "expected :field, found %s" (Form.to_string other)
    | [ odd ] -> Loc.fail odd.loc "field %s has no value" (Form.to_string odd)
  in
  ignore f; go items

and cond f (args : Form.t list) : Ast.expr =
  let rec go = function
    | [] -> { Ast.e = Ast.Do []; loc = f.loc }   (* no clause matched: Unit *)
    | { v = Kw "else"; _ } :: body :: _ -> expr body
    | test :: body :: rest ->
      { Ast.e = Ast.If (expr test, expr body, Some (go rest)); loc = f.loc }
    | [ odd ] -> Loc.fail odd.loc "cond clause %s has no body"
                   (Form.to_string odd)
  in
  if args = [] then Loc.fail f.loc "cond needs at least one clause" else go args

and shortcircuit f (args : Form.t list) ~is_and : Ast.expr =
  let mk e = { Ast.e; loc = f.loc } in
  let rec go = function
    | [] -> mk (Ast.Var (if is_and then "true" else "false"))
    | [ last ] -> expr last
    | x :: rest ->
      if is_and then mk (Ast.If (expr x, go rest, Some (mk (Ast.Var "false"))))
      else mk (Ast.If (expr x, mk (Ast.Var "true"), Some (go rest)))
  in
  go args

and place (f : Form.t) : Ast.place =
  match f.v with
  | Sym s -> Ast.Pvar s
  | List ({ v = Sym s; _ } :: args)
    when String.length s > 1 && s.[0] = '.' ->
    let field = String.sub s 1 (String.length s - 1) in
    (match args with
     | [ target ] -> Ast.Pfield (expr target, field)
     | _ -> fail f "field place is (.%s value)" field)
  | List ({ v = Sym "at"; _ } :: target :: idx) when idx <> [] ->
    Ast.Pindex (expr target, List.map expr idx)
  (* Not a place. spec-memory.md gives a map an upsert of its own — [put]
     either inserts or replaces — so there is no store into a lookup, and an
     entry that is absent has no location to store into. Refused here rather
     than parsed into a place form the language does not have. *)
  | List ({ v = Sym "get"; _ } :: _) ->
    fail f "(get m k) is not a place — a map is written with (put m k v)"
  | List [ { v = Sym "deref"; _ }; p ] -> Ast.Pderef (expr p)
  | _ ->
    fail f
      "%s is not assignable. set takes a name, (.field x), (at a i ...), \
       or (deref p)"
      (Form.to_string f)

and arms f (items : Form.t list) : Ast.arm list =
  let rec go = function
    | [] -> []
    | p :: body :: rest ->
      { Ast.pat = pattern p; body = [ expr body ]; aloc = p.loc } :: go rest
    | [ odd ] ->
      Loc.fail odd.loc "match arm %s has no body" (Form.to_string odd)
  in
  if items = [] then Loc.fail f.loc "match needs at least one arm" else go items

and pattern (f : Form.t) : Ast.pattern =
  match f.v with
  | Sym "_" -> Ast.Pwild
  | Kw "else" -> Ast.Pwild
  | Sym ctor -> Ast.Pctor (ctor, [])
  (* An enum member, which is the one other thing [match] could plausibly be
     over: an enum is an i32 at run time, so the arms would be a chain of [=]
     and the members are all known, which is exhaustiveness [cond] cannot give.
     What stops it is not the lowering, it is that a keyword pattern needs a
     case in [Ast.pattern] — and [lib/load.ml] matches that type exhaustively,
     so the variant cannot be added from here. Refused by name rather than
     spelled as a constructor it is not. *)
  | Kw member ->
    fail f
      ":%s is not implemented as a pattern — match is over an Option here, \
       and an enum member cannot be one until Ast.pattern can hold a keyword. \
       Use cond with (= k :%s)" member member
  | List ({ v = Sym ctor; _ } :: binds) ->
    List.iter no_pattern binds;
    Ast.Pctor (ctor, List.map sym binds)
  | _ -> fail f "expected a pattern, found %s" (Form.to_string f)

(* ── Declarations ──────────────────────────────────────────────────── *)

let rec decl types (f : Form.t) : Ast.decl =
  let mk d = { Ast.d; dloc = f.loc } in
  match f.v with
  | List ({ v = Sym "package"; _ } :: args) ->
    (match args with
     | [ n ] -> mk (Ast.Package (sym n))
     | _ -> fail f "package is (package name)")

  | List ({ v = Sym "import"; _ } :: args) ->
    (match args with
     | [ alias; { v = Str path; _ } ] -> mk (Ast.Import (sym alias, path))
     | _ -> fail f "import is (import alias \"collection:path\")")

  | List ({ v = Sym "defalias"; _ } :: args) ->
    (match args with
     | [ n; t ] -> mk (Ast.Defalias (sym n, texpr t))
     | _ -> fail f "defalias is (defalias Name Type)")

  | List ({ v = Sym "defstruct"; _ } :: args) ->
    (match args with
     | [ n; { v = Vec fs; _ } ] -> mk (Ast.Defstruct (sym n, fields f fs))
     | _ -> fail f "defstruct is (defstruct Name [field Type ...])")

  | List ({ v = Sym "defunion"; _ } :: args) ->
    (match args with
     | [ n; { v = Vec vs; _ } ] -> mk (Ast.Defunion (sym n, List.map variant vs))
     | _ -> fail f "defunion is (defunion Name [(Case [field Type ...]) ...])")

  | List ({ v = Sym "defn"; _ } :: args) ->
    (match args with
     | n :: { v = Vec ps; _ } :: rest ->
       let ret, body =
         match rest with
         (* An omitted return type means Unit. A leading form that is a type
            and is not the whole body is the return type. *)
         | [] -> None, []
         | first :: more when more <> [] && is_type_form types first ->
           Some (texpr first), body_of more
         | _ -> None, body_of rest
       in
       mk (Ast.Defn { Ast.name = sym n; params = fields f ps; ret;
                      fbody = body; nloc = n.loc })
     | _ -> fail f "defn is (defn name [param Type ...] ReturnType? body ...)")

  | List ({ v = Sym ("declare" | "declare-c" as which); _ } :: args) ->
    (* (declare name [param Type ...] ReturnType? "c_symbol"). The C symbol is
       last and is always written: a foreign name is not derivable from a Flan
       one, and guessing it would fail at link time rather than here.

       [declare-c] is the same shape and a different claim about the symbol.
       [declare]'s signature IS the C signature, already flattened by whoever
       wrote the C; [declare-c]'s is the *library's* — structs by value — and
       [Shim] generates the flattening. The two cannot be one form, because
       (declare f [p string] ...) already means the symbol takes ptr+len and
       (declare-c f [p string] ...) means it takes a NUL-terminated char *. *)
    let mkd fn csym =
      if String.equal which "declare-c" then Ast.DeclareC (fn, csym)
      else Ast.Declare (fn, csym)
    in
    let usage =
      Printf.sprintf
        "%s is (%s name [param Type ...] ReturnType? \"c_symbol\")" which which
    in
    (match List.rev args with
     | { v = Str csym; _ } :: rest ->
       (match List.rev rest with
        | [ n; { v = Form.Vec ps; _ } ] ->
          mk (mkd { Ast.name = sym n; params = fields f ps;
                    ret = None; fbody = []; nloc = n.loc } csym)
        | [ n; { v = Form.Vec ps; _ }; r ] ->
          mk (mkd { Ast.name = sym n; params = fields f ps;
                    ret = Some (texpr r); fbody = []; nloc = n.loc } csym)
        | _ -> fail f "%s" usage)
     | _ -> fail f "%s" usage)

  | List ({ v = Sym "defenum"; _ } :: args) ->
    (match args with
     | [ n; { v = Form.Vec ms; _ } ] ->
       let rec pairs = function
         | [] -> []
         | { v = Form.Sym m; _ } :: { v = Form.Int k; _ } :: rest ->
           (m, k) :: pairs rest
         | bad :: _ ->
           fail bad "an enum member is a name followed by an integer, found %s"
             (Form.to_string bad)
       in
       mk (Ast.Defenum (sym n, pairs ms))
     | _ -> fail f "defenum is (defenum Name [member value ...])")

  | List ({ v = Sym "defvar"; _ } :: args) ->
    (match args with
     | [ n; t ] -> mk (Ast.Defvar (sym n, Some (texpr t), Ast.Zeroed))
     | [ n; t; { v = Sym "uninit"; _ } ] ->
       mk (Ast.Defvar (sym n, Some (texpr t), Ast.Uninit))
     | [ n; t; v ] -> mk (Ast.Defvar (sym n, Some (texpr t), Ast.Init (expr v)))
     | _ -> fail f "defvar is (defvar name Type value?)")

  | List ({ v = Sym "defconst"; _ } :: args) ->
    (match args with
     | [ n; v ] -> mk (Ast.Defconst (sym n, None, expr v))
     | [ n; t; v ] -> mk (Ast.Defconst (sym n, Some (texpr t), expr v))
     | _ -> fail f "defconst is (defconst name Type? value)")

  (* Checked for shape and then refused, which is deliberate. Getting the shape
     wrong and getting the whole feature are two different mistakes, and a
     "defmacro is (defmacro ...)" that only ever fired after expansion landed
     would be a rule nothing enforced in the meantime.

     The refusal is not about parsing. Expanding a macro means running it, and
     there is no interpreter — the compiled path is the only backend. So it
     means compiling the macro and dlopening it into the compiler, which is
     what Emit.redefinition and Build.shared already do for the dev loop.
     NEXT.md writes down how that goes together. *)
  | List ({ v = Sym "defmacro"; _ } :: args) ->
    (match args with
     | n :: { v = Form.Vec ps; _ } :: body when body <> [] ->
       let name = sym n in
       List.iter (fun (p : Form.t) -> ignore (sym p)) ps;
       fail f
         "defmacro %s parses, but is not expanded: running a macro means \
          compiling it and loading it into the compiler, which is not wired \
          up yet (NEXT.md says what it needs)" name
     | _ ->
       fail f "defmacro is (defmacro name [param ...] body ...)")

  | List ({ v = Sym s; _ } :: _) -> fail f "unknown top-level form (%s ...)" s
  | _ -> fail f "expected a top-level declaration, found %s" (Form.to_string f)

(* Is this form the function's return type, or the first form of its body?

   Shape alone cannot tell: [(Option f64)] and [(Some 1)] are identical
   s-expressions, one a type application and one a constructor call. Capitalised
   heads are not a good enough signal — [(defn f [] (Some 1) (bar))] would eat
   the body's first form as a return type, silently.

   So the decision uses the set of names that are actually types, which the
   pre-pass in [program] collects from the file's own declarations. That makes
   it exact rather than heuristic, because types are only ever introduced by
   defstruct, defunion and defalias — all syntactically obvious. *)
(* A name a package brought in — [rl/Vector2]. It cannot be in [types]: the set
   comes from this file's own declarations, and an import is not resolved until
   after parsing, so a package's structs are unknown here by construction.

   The signal is the alias plus the capital. An alias is syntactically obvious,
   collected by the same pre-pass; and a bare capitalised symbol is never a
   *value* in this language — a struct or union constructor is [(Name {...})],
   a List, and an enum member is a keyword. So [alias/Name] in a type position
   is a type, and the case the comment above warns about — a body form eaten as
   a return type — cannot arise, because there is no body form of that shape.

   A lowercase qualified name stays an expression, which is what [rl/get-color]
   in [(defn f [] rl/get-color)] has to be. *)
and qualified_type types s =
  match String.index_opt s '/' with
  | None -> false
  | Some i ->
    let alias = String.sub s 0 i and name = String.sub s (i + 1) (String.length s - i - 1) in
    Names.mem ("import " ^ alias) types
    && name <> ""
    && name.[0] >= 'A' && name.[0] <= 'Z'

and is_type_form types (f : Form.t) =
  match f.v with
  | Sym s ->
    Names.mem s types || Names.mem ("enum " ^ s) types || qualified_type types s
  | Vec _ -> true                            (* [T] and [n T] are only types *)
  | Map _ -> true                            (* {K V} in this position       *)
  | List ({ v = Sym n; _ } :: _) ->
    Names.mem n types || qualified_type types n
  | _ -> false

and variant (f : Form.t) : Ast.variant =
  match f.v with
  | Sym n -> { Ast.vname = n; vfields = []; vloc = f.loc }
  | List [ { v = Sym n; _ }; { v = Vec fs; _ } ] ->
    { Ast.vname = n; vfields = fields f fs; vloc = f.loc }
  | List [ { v = Sym n; _ } ] -> { Ast.vname = n; vfields = []; vloc = f.loc }
  | _ -> fail f "a union case is Name or (Name [field Type ...])"

(* Names introduced as types by this file, plus the builtins. Collected before
   anything is parsed, so a type declared at the bottom of a file is still known
   to a function at the top — top-level names are order-independent. *)
let declared_types (forms : Form.t list) : Names.t =
  List.fold_left
    (fun acc (f : Form.t) ->
       match f.v with
       | List [ { v = Sym ("defstruct" | "defunion" | "defalias"); _ };
                { v = Sym n; _ }; _ ] -> Names.add n acc
       (* The aliases too, under a key no symbol can collide with, so that
          [qualified_type] can tell [rl/Vector2] from a name with a slash in
          it that nothing imported. *)
       | List [ { v = Sym "import"; _ }; { v = Sym a; _ }; { v = Str _; _ } ] ->
         Names.add ("import " ^ a) acc
       (* An enum is a type too, but under its own key rather than beside the
          structs, because [(Key n)] is now a *value* — the integer-to-enum
          conversion — and putting Key in [types] would make [is_type_form]
          read that as a type application and eat it as a return type. So an
          enum name counts only as a bare symbol, which is the one position it
          can appear in as a type, and never as a list head. *)
       | List [ { v = Sym "defenum"; _ }; { v = Sym n; _ }; _ ] ->
         Names.add ("enum " ^ n) acc
       | _ -> acc)
    builtin_types forms

let program (forms : Form.t list) : Ast.decl list =
  let types = declared_types forms in
  temps := 0;
  List.map (decl types) forms

(* Single-declaration entry point, for tests and the REPL. Sees only the
   builtin types plus whatever this one form declares. *)
let decl (f : Form.t) : Ast.decl = temps := 0; decl (declared_types [ f ]) f