(** The indented reader: [.fln] text to exactly the [Form.t] tree the paren
    reader ([Reader]) makes. Nothing after the reader knows which syntax a form
    came from. spec-syntax.md is the grammar; this comment is only the shape.

    Three passes. [lex] turns text into tokens, reusing [Reader]'s own string,
    character, number and quoted-datum readers so the atoms mean exactly what
    they mean in a [.flan] file. [layout] adds NEWLINE, INDENT and DEDENT at
    bracket depth zero from an indent stack of columns. The parser is a
    statement parser (soft keywords at the start of a line) over a precedence
    climber for expressions.

    Locations are spans, as [Reader] makes them: a form starts at its first
    token and ends where its last one does. A form this reader invents — the
    [dyn] of an untyped parameter, the [do] around a block, the [set] of an
    assignment — takes the location of the text that asked for it. *)

type tok =
  | NAME of string        (* a name run, after field splitting *)
  | KW of string
  | ATOM of Form.value    (* number, string, character *)
  | DATUM of Form.t       (* 'x and '(a b), read by the paren reader *)
  | LP | RP | LB | RB | LC | RC
  | COMMA
  | COLON                 (* x: T, and the trailing : of a call's block *)
  | UNQ | SPLICE          (* ~ and ~@ *)
  | NEG                   (* the - glued to the front of a name *)
  | NEWLINE | INDENT | DEDENT | EOF

type token = { tok : tok; loc : Loc.t; sp : bool (* whitespace before it *) }

let failk ?notes kind loc fmt = Loc.failk ?notes ("indent/" ^ kind) loc fmt

let show = function
  | NAME s -> s
  | KW s -> ":" ^ s
  | ATOM v -> Form.to_source (Form.make v Loc.unknown)
  | DATUM f -> Form.to_source f
  | LP -> "(" | RP -> ")" | LB -> "[" | RB -> "]" | LC -> "{" | RC -> "}"
  | COMMA -> "," | COLON -> ":" | UNQ -> "~" | SPLICE -> "~@" | NEG -> "-"
  | NEWLINE -> "the end of the line"
  | INDENT -> "an indented line"
  | DEDENT -> "the end of the block"
  | EOF -> "the end of the file"

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

(* Binary operators and their levels, low to high (spec §2 "Precedence").
   [not] sits at 3 and unary minus at 8; neither is binary. *)
let binops =
  [ ("or", 1); ("and", 2);
    ("==", 4); ("!=", 4); ("<", 4); ("<=", 4); (">", 4); (">=", 4);
    ("<<", 5); (">>", 5); ("+", 6); ("-", 6); ("*", 7); ("/", 7); ("%", 7) ]

let binop_level s = List.assoc_opt s binops
let is_binop s = binop_level s <> None

(* [==] is Flan's [=]; every other operator is its own name. *)
let op_sym = function "==" -> "=" | s -> s

(* Words that are operators rather than names wherever a value is read. Alone
   before a comma or a closer they are the symbol itself, [reduce(+, 0, xs)];
   glued to a parenthesis they are a call, [+(a, b, c)]. *)
let is_op_word s = is_binop s || s = "not" || s = "="

let assign_ops = [ ("+=", "+"); ("-=", "-"); ("*=", "*"); ("/=", "/") ]

(* A [-] glued to one of these starts a negation: [-x] is [(- x)]. Anything
   else keeps the Lisp reading, so [--], [->] and [-=] stay names. *)
let is_neg_char c =
  (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z') || c = '$' || c = '_'
  || c = '*'

(* The segment a dot splits after, checked for a capital: [Shape.Rect] and
   [tree/Node.Branch] are one qualified name, [camera.target.x] is two field
   accesses. The part after a package's [/] is what is checked. *)
let capitalised seg =
  let base =
    match String.rindex_opt seg '/' with
    | Some i -> String.sub seg (i + 1) (String.length seg - i - 1)
    | None -> seg
  in
  base <> "" && base.[0] >= 'A' && base.[0] <= 'Z'

let split_fields text =
  if text = "" || text.[0] = '.' then [ text ]
  else
    let segs = String.split_on_char '.' text in
    if List.length segs < 2 || List.mem "" segs || capitalised (List.hd segs)
    then [ text ]
    else segs

(* ── Lexing ────────────────────────────────────────────────────────── *)

let lex ~file src : token list =
  let st = Reader.of_string ~file src in
  let out = ref [] in
  let sp = ref true in
  let line_start = ref true in
  let tab = ref None in
  let emit tok loc = out := { tok; loc; sp = !sp } :: !out; sp := false in
  let piece line col len =
    { (Loc.make file line col) with Loc.eline = line; ecol = col + len }
  in
  let name_run () =
    let l0 = Reader.here st in
    let text = Reader.take_while st (fun c -> not (Reader.is_delimiter c)) in
    let n = String.length text in
    let line = l0.Loc.line and col = l0.Loc.col in
    if n = 0 then
      failk "unexpected-character" l0 "unexpected character %C" (Reader.peek st);
    if text = ":" then emit COLON (piece line col 1)
    else if text.[0] = ':' then emit (KW (String.sub text 1 (n - 1))) (piece line col n)
    else begin
      let body, colon =
        if text.[n - 1] = ':' then (String.sub text 0 (n - 1), true)
        else (text, false)
      in
      let bn = String.length body in
      let bcol, body =
        if bn > 1 && body.[0] = '-' && is_neg_char body.[1] then begin
          emit NEG (piece line col 1);
          (col + 1, String.sub body 1 (bn - 1))
        end
        else (col, body)
      in
      let off = ref 0 in
      List.iteri
        (fun i seg ->
           let s = if i = 0 then seg else "." ^ seg in
           emit (NAME s) (piece line (bcol + !off) (String.length s));
           off := !off + String.length s)
        (split_fields body);
      if colon then emit COLON (piece line (col + n - 1) 1)
    end
  in
  let token c =
    let l0 = Reader.here st in
    let simple t = Reader.advance st; emit t (Loc.upto l0 (Reader.here st)) in
    match c with
    | '(' -> simple LP | ')' -> simple RP
    | '[' -> simple LB | ']' -> simple RB
    | '{' -> simple LC | '}' -> simple RC
    | ',' -> simple COMMA
    | '"' -> let f = Reader.read_string st in emit (ATOM f.v) f.loc
    | '\\' -> let f = Reader.read_byte st in emit (ATOM f.v) f.loc
    (* The paren reader reads the quoted datum whole, so ['(a (b c))] is the
       Lisp list it always was and nothing here re-invents it. *)
    | '\'' -> let f = Reader.read_form st in emit (DATUM f) f.loc
    | '`' ->
      failk "backquote" l0
        "` is not read in a .fln file. A quasiquote is quote followed by an \
         indented block, or quasiquote(x) on one line"
    | '~' ->
      Reader.advance st;
      if Reader.peek st = '@' then begin
        Reader.advance st;
        emit SPLICE (Loc.upto l0 (Reader.here st))
      end
      else emit UNQ (Loc.upto l0 (Reader.here st))
    | c when Reader.is_digit c
          || ((c = '-' || c = '+') && Reader.is_digit (Reader.peek2 st)) ->
      (* [while x < 3:] — the colon is a mistake the parser explains, and not
         part of the number, so the number is read without it. *)
      let rec run i =
        if i < String.length src && not (Reader.is_delimiter src.[i]) then run (i + 1)
        else i
      in
      let stop = run st.Reader.pos in
      if stop - st.Reader.pos > 1 && src.[stop - 1] = ':' then begin
        let text = String.sub src st.Reader.pos (stop - st.Reader.pos - 1) in
        let f = Reader.read_number (Reader.of_string ~file text) in
        let n = String.length text in
        for _ = 1 to n do Reader.advance st done;
        emit (ATOM f.v) (piece l0.Loc.line l0.Loc.col n);
        Reader.advance st;
        emit COLON (piece l0.Loc.line (l0.Loc.col + n) 1)
      end
      else
        let f = Reader.read_number st in
        emit (ATOM f.v) f.loc
    | _ -> name_run ()
  in
  let rec go () =
    if not (Reader.at_end st) then
      match Reader.peek st with
      | ' ' | '\r' -> Reader.advance st; sp := true; go ()
      | '\t' ->
        if !line_start && !tab = None then tab := Some (Reader.here st);
        Reader.advance st; sp := true; go ()
      | '\n' ->
        Reader.advance st; sp := true; line_start := true; tab := None; go ()
      | ';' ->
        while (not (Reader.at_end st)) && Reader.peek st <> '\n' do
          Reader.advance st
        done;
        go ()
      | c ->
        (match !tab with
         | Some l when !line_start ->
           failk "tab" l
             "this line is indented with a tab. Indentation in a .fln file is \
              measured in columns, and a tab has no one width, so only spaces \
              indent. Replace the tab with spaces"
         | _ -> ());
        line_start := false;
        token c;
        go ()
  in
  go ();
  List.rev !out

(* ── Layout ────────────────────────────────────────────────────────── *)

let point (l : Loc.t) = { l with Loc.line = l.Loc.eline; col = l.Loc.ecol }

(* NEWLINE, INDENT and DEDENT, at bracket depth zero only: inside ( [ { a
   line break is whitespace. A line continues the one before it when either
   side of the break is a spaced binary operator (spec §2 "Continuation"). *)
let layout ?(base = 1) (toks : token list) : token array =
  let arr = Array.of_list toks in
  let n = Array.length arr in
  let out = ref [] in
  let add tok loc = out := { tok; loc; sp = true } :: !out in
  let stack = ref [ base ] in
  let depth = ref 0 in
  let binop t = match t.tok with NAME s -> is_binop s | _ -> false in
  for i = 0 to n - 1 do
    let t = arr.(i) in
    (if i = 0 then begin
        if t.loc.Loc.col <> base then
          failk "unexpected-indent" t.loc
            "the first line starts at column %d, and a file's top-level lines \
             start at column %d. Remove the indentation"
            t.loc.Loc.col base
      end
     else
       let p = arr.(i - 1) in
       if !depth = 0 && t.loc.Loc.line > p.loc.Loc.eline then begin
         let spaced_after =
           i + 1 < n && arr.(i + 1).loc.Loc.line = t.loc.Loc.line
           && arr.(i + 1).sp
         in
         let continues = (binop p && p.sp) || (binop t && spaced_after) in
         (* A continuation line sits deeper than the statement it continues.
            One at or left of that statement's column is not read as joining
            it: that would pull a line into a block it was written outside
            of, silently. *)
         if continues && t.loc.Loc.col <= List.hd !stack then
           failk "continuation" t.loc
             "%s"
             (if binop t then
                Printf.sprintf
                  "this line starts with the operator %s, so it continues the \
                   line above, but it is not indented past the start of that \
                   line (column %d). Indent it further to continue the line, \
                   or give %s a value on its left"
                  (show t.tok) (List.hd !stack) (show t.tok)
              else
                Printf.sprintf
                  "the line above ends with the operator %s, so this line \
                   continues it, but it is not indented past the start of \
                   that line (column %d). Indent it further, or finish the \
                   line above"
                  (show p.tok) (List.hd !stack));
         if not continues then begin
           let at = point p.loc in
           add NEWLINE at;
           let col = t.loc.Loc.col in
           let top = List.hd !stack in
           if col > top then begin
             stack := col :: !stack;
             add INDENT at
           end
           else if col < top then begin
             let closed = ref top in
             let rec pop () =
               match !stack with
               | top :: (_ :: _ as rest) when col < top ->
                 closed := top; stack := rest; add DEDENT at; pop ()
               | _ -> ()
             in
             pop ();
             if col <> List.hd !stack then
               failk "dedent" t.loc
                 "this line starts at column %d, between the block at column \
                  %d and the one at column %d it would close, so it belongs \
                  to neither. The enclosing blocks start at column%s %s: line \
                  it up with one of them"
                 col (List.hd !stack) !closed
                 (if List.length !stack > 1 then "s" else "")
                 (String.concat ", "
                    (List.rev_map string_of_int !stack))
           end
         end
       end);
    out := t :: !out;
    (match t.tok with
     | LP | LB | LC -> incr depth
     | RP | RB | RC -> if !depth > 0 then decr depth
     | _ -> ())
  done;
  (if n > 0 then
     let at = point arr.(n - 1).loc in
     add NEWLINE at;
     List.iter (fun _ -> add DEDENT at) (List.tl !stack));
  let eof_loc = if n > 0 then point arr.(n - 1).loc else Loc.unknown in
  add EOF eof_loc;
  Array.of_list (List.rev !out)

(* ── Parsing ───────────────────────────────────────────────────────── *)

type p = { toks : token array; mutable i : int }

let peek p = p.toks.(p.i)
let peek_at p k = p.toks.(min (p.i + k) (Array.length p.toks - 1))
let advance p =
  let t = peek p in
  if t.tok <> EOF then p.i <- p.i + 1;
  t
let last p = p.toks.(max 0 (p.i - 1))

(* From [l] to the end of the last token consumed. *)
let span p (l : Loc.t) =
  let e = (last p).loc in
  if e.Loc.eline > l.Loc.line
     || (e.Loc.eline = l.Loc.line && e.Loc.ecol > l.Loc.col)
  then { l with Loc.eline = e.Loc.eline; ecol = e.Loc.ecol }
  else l

let mk p l v = Form.make v (span p l)
let sym l s = Form.make (Form.Sym s) l

(* Where a stray token is, pointing at the real token after a layout one. *)
let where_ p =
  let t = peek p in
  match t.tok with
  | NEWLINE | INDENT | DEDENT -> (peek_at p 1).loc
  | _ -> t.loc

let starts_value = function
  | NAME _ | KW _ | ATOM _ | DATUM _ | LP | LB | LC | UNQ | SPLICE | NEG -> true
  | _ -> false

let ends_value = function
  | RP | RB | RC | COMMA | NEWLINE | EOF | INDENT | DEDENT -> true
  | _ -> false

let negative_literal = function
  | ATOM (Form.Int i) -> Int64.compare i 0L < 0
  | ATOM (Form.Float f) -> f < 0.
  | _ -> false

(* Something followed a complete value where nothing may. The two shapes that
   get their own sentence are the ones a Lisp hand writes: [a -1] and
   [f (x)]. *)
let stray p ~after =
  let t = peek p in
  match t.tok with
  | ATOM _ when t.sp && negative_literal t.tok ->
    let text = show t.tok in
    let digits = String.sub text 1 (String.length text - 1) in
    failk "glued-minus" t.loc
      "%s is read as the number %s, right after %s with nothing between them. \
       To subtract, space the minus: %s - %s. For two values, separate them \
       with a comma: %s, %s"
      text text after after digits after text
  | LP when t.sp ->
    failk "spaced-call" t.loc
      "there is a space before this (, so it does not call %s — a call has \
       none. Write %s(...), or put a comma before the ( if it is a separate \
       value"
      after after
  | LB when t.sp ->
    failk "spaced-index" t.loc
      "there is a space before this [, so it does not index %s — indexing has \
       none. Write %s[i]"
      after after
  | NEWLINE | INDENT | DEDENT | EOF ->
    failk "unexpected-end" (where_ p) "the line ends after %s, which is not \
                                       finished here" after
  | NAME "=" ->
    failk "assign-in-test" t.loc
      "= assigns, and here it follows %s where a value is being read. To \
       compare, write ==: %s == ..."
      after after
  | COLON ->
    failk "header-colon" t.loc
      "this line ends in a colon after %s. A header (if, elif, else, while, \
       until, for, fn, match, ...) opens its block with no colon; only a call \
       takes one, as in f(x):. Remove the colon"
      after
  | _ ->
    failk "unexpected-token" t.loc
      "%s follows %s, and two values cannot sit side by side here. Separate \
       them with a comma, or join them with an operator"
      (show t.tok) after

let expect p tok ~what =
  let t = peek p in
  if t.tok = tok then ignore (advance p)
  else
    failk "expected" (where_ p) "expected %s here, and found %s" what
      (show t.tok)

let expect_name p s ~what =
  match (peek p).tok with
  | NAME n when n = s -> ignore (advance p)
  | t -> failk "expected" (where_ p) "expected %s here, and found %s" what (show t)

(* The end of a line that is not followed by a block. *)
let expect_eol p ~after =
  match (peek p).tok with
  | NEWLINE ->
    ignore (advance p);
    if (peek p).tok = INDENT then
      failk "stray-indent" (peek_at p 1).loc
        "this line is indented under %s, which takes no block. A call takes \
         an indented block only with a trailing colon, as in \
         rl/with-drawing():"
        after
  | EOF -> ()
  | _ -> stray p ~after

let check_name (t : token) s =
  if String.contains s ':' then
    failk "colon-in-name" t.loc
      "%s has a colon inside it, and a name cannot. A type annotation puts a \
       space after the colon: %s"
      s
      (match String.index_opt s ':' with
       | Some i -> String.sub s 0 (i + 1) ^ " " ^ String.sub s (i + 1) (String.length s - i - 1)
       | None -> s)

(* A form's own text, for the "after" half of a message. *)
let text_of (f : Form.t) =
  let s = Form.to_source f in
  if String.length s > 40 then String.sub s 0 37 ^ "..." else s

let unclosed p c l0 =
  failk "unclosed" l0
    ~notes:[ Loc.note (where_ p) "the input ends here, still inside it" ]
    "unclosed %C" c

let refuse_ws ?(brace = false) loc e =
  failk "separate-elements" loc
    "%s has an operator in it and sits in a list separated by spaces, where \
     only single values are. Separate the %s with commas: %s"
    (text_of e)
    (if brace then "entries" else "elements")
    (if brace then "{.x a + 1, .y 2}" else "[a - 1, b]")

(* Expressions come back with their syntactic level: 10 an atom or a bracket,
   9 a postfix chain, 8 a unary minus, 1-7 a binary operator's level, 3 a
   [not], 0 a one-line [if] or a lambda. Anything under 8 is "compound": it
   has an operator at its top, so it cannot sit in a list separated only by
   whitespace. *)
let rec expr p : Form.t * int = binary p 1

and binary p lvl : Form.t * int =
  if lvl = 3 then not_ p
  else if lvl > 7 then unary p
  else
    let l0 = (peek p).loc in
    let ((first, _) as fst_) = binary p (lvl + 1) in
    let close op operands =
      match List.rev operands with
      | [ x ] -> (x, lvl)
      | ops ->
        if op = "!=" && List.length ops > 2 then
          failk "chained-not-equal" l0
            "a != b != c is not read. != with more than two values means all \
             of them are distinct, which is not what the chain says, so it is \
             written as a call: !=(a, b, c)";
        (mk p l0 (Form.List (sym l0 (op_sym op) :: ops)), lvl)
    in
    (* An operator glued to a parenthesis is a call, [+(a, b)], and never
       the operator between two values. *)
    let binary_here s =
      binop_level s = Some lvl
      && not ((peek_at p 1).tok = LP && not (peek_at p 1).sp)
    in
    let rec run op operands =
      match (peek p).tok with
      | NAME s when binary_here s ->
        let ot = advance p in
        if not (ot.sp && (peek p).sp) then
          failk "unspaced-operator" ot.loc
            "%s is an operator here, and a binary operator has a space on each \
             side: a %s b. Without them a-b is one name"
            s s;
        let rhs, _ = binary p (lvl + 1) in
        if s = op then run op (rhs :: operands)
        else begin
          if lvl = 4 then
            failk "mixed-comparison" ot.loc
              "%s follows %s in one chain, and a chain compares with one \
               operator. Join the tests with and, or parenthesise one side"
              s op;
          let folded, _ = close op operands in
          run s [ rhs; folded ]
        end
      | _ -> close op operands
    in
    (* [run] folds a different operator at the same level into the left
       operand, so the first operator here only starts the first run. *)
    match (peek p).tok with
    | NAME s when binary_here s -> run s [ first ]
    | _ -> fst_

and not_ p =
  let t = peek p in
  match t.tok with
  | NAME "not" when (peek_at p 1).sp && starts_value (peek_at p 1).tok ->
    ignore (advance p);
    let x, _ = not_ p in
    (mk p t.loc (Form.List [ sym t.loc "not"; x ]), 3)
  | _ -> binary p 4

and unary p =
  let t = peek p in
  match t.tok with
  | NEG ->
    ignore (advance p);
    let x, _ = postfix p in
    (mk p t.loc (Form.List [ sym t.loc "-"; x ]), 8)
  | _ -> postfix p

and postfix p =
  let l0 = (peek p).loc in
  let rec loop ((f, _) as fp) =
    let t = peek p in
    if t.sp then fp
    else
      match t.tok with
      | LP ->
        ignore (advance p);
        let args = items p RP t.loc ~what:"arguments" in
        loop (mk p l0 (Form.List (f :: args)), 9)
      | LB ->
        ignore (advance p);
        let idx = items p RB t.loc ~what:"indices" in
        loop (mk p l0 (Form.List (sym t.loc "at" :: f :: idx)), 9)
      | NAME s when String.length s > 1 && s.[0] = '.' ->
        ignore (advance p);
        loop (mk p l0 (Form.List [ sym t.loc s; f ]), 9)
      | LC ->
        ignore (advance p);
        let m = map_items p t.loc in
        loop (mk p l0 (Form.List [ f; Form.make (Form.Map m) (span p t.loc) ]), 9)
      | _ -> fp
  in
  loop (primary p)

and primary p : Form.t * int =
  let t = peek p in
  let l0 = t.loc in
  match t.tok with
  | NAME s ->
    let nxt = peek_at p 1 in
    let glued_lp = nxt.tok = LP && not nxt.sp in
    if s = "if" && nxt.sp && starts_value nxt.tok then if_expr p
    else if s = "fn" && glued_lp then fn_expr p
    else if is_op_word s then begin
      if glued_lp || ends_value nxt.tok then begin
        ignore (advance p);
        (sym l0 (op_sym s), 10)
      end
      else
        failk "operator-operand" l0
          "%s is an operator, and nothing is on its left. As a value on its \
           own it goes before a comma or a closing bracket, reduce(%s, xs); \
           as a call it is glued to its parenthesis, %s(a, b)"
          s s s
    end
    else begin
      ignore (advance p);
      check_name t s;
      (sym l0 s, 10)
    end
  | KW k -> ignore (advance p); (Form.make (Form.Kw k) l0, 10)
  | ATOM v ->
    ignore (advance p);
    (Form.make v l0, if negative_literal t.tok then 8 else 10)
  | DATUM f -> ignore (advance p); (f, 10)
  | LP ->
    ignore (advance p);
    if (peek p).tok = RP then begin
      ignore (advance p);
      (mk p l0 (Form.List []), 10)
    end
    else
      let e, _ = expr p in
      (match (peek p).tok with
       | RP -> ignore (advance p)
       | EOF -> unclosed p '(' l0
       | COMMA ->
         failk "tuple" (peek p).loc
           "parentheses group one value, and this comma starts a second. \
            Several values in a list are written in brackets, [a, b]; \
            arguments go glued to a name, f(a, b)"
       | _ -> stray p ~after:(text_of e));
      (e, 10)
  | LB ->
    ignore (advance p);
    let xs = vec_items p l0 in
    (mk p l0 (Form.Vec xs), 10)
  | LC ->
    ignore (advance p);
    let xs = map_items p l0 in
    (mk p l0 (Form.Map xs), 10)
  | UNQ | SPLICE ->
    ignore (advance p);
    let x, _ = primary p in
    let name = if t.tok = UNQ then "unquote" else "unquote-splicing" in
    (mk p l0 (Form.List [ sym l0 name; x ]), 10)
  | NEG -> unary p
  | tk ->
    failk "expected-value" (where_ p) "expected a value here, and found %s"
      (show tk)

(* [if c then a else b]: the one-line form, for a value. *)
and if_expr p =
  let t = advance p in
  let c, _ = binary p 1 in
  (match (peek p).tok with
   | NAME "then" -> ignore (advance p)
   | _ ->
     failk "if-then" (where_ p)
       "an if inside a line is if c then a else b, and there is no then \
        after %s. Write the then, or start the if on its own line with its \
        branches indented under it"
       (text_of c));
  let a = inline_stmt p in
  match (peek p).tok with
  | NAME "else" ->
    ignore (advance p);
    let b = inline_stmt p in
    (mk p t.loc (Form.List [ sym t.loc "if"; c; a; b ]), 0)
  | NAME "elif" ->
    failk "one-line-elif" (peek p).loc
      "a one-line if has then and else and no elif. Chain another if after \
       the else — if a then x else if b then y else z — or write the if over \
       several lines, where elif goes"
  | _ -> (mk p t.loc (Form.List [ sym t.loc "when"; c; a ]), 0)

(* What a one-line slot takes — a match arm's value, a then or an else, the
   thing after defer: a value, or one of the statements that fit on a line,
   break, continue, return and an assignment. *)
and inline_stmt p : Form.t =
  let t = peek p in
  let glued = let n = peek_at p 1 in n.tok = LP && not n.sp in
  match t.tok with
  | NAME (("break" | "continue") as w) when not glued ->
    ignore (advance p);
    (match (peek p).tok with
     | KW k ->
       let kt = advance p in
       mk p t.loc (Form.List [ sym t.loc w; Form.make (Form.Kw k) kt.loc ])
     | _ -> mk p t.loc (Form.List [ sym t.loc w ]))
  | NAME "return" when not glued ->
    ignore (advance p);
    let n = peek p in
    if starts_value n.tok && not (n.tok = NAME "else") then
      let v, _ = expr p in
      mk p t.loc (Form.List [ sym t.loc "return"; v ])
    else mk p t.loc (Form.List [ sym t.loc "return" ])
  | _ ->
    let e, _ = expr p in
    match (peek p).tok with
    | NAME "=" ->
      let eq = advance p in
      let v, _ = expr p in
      mk p t.loc (Form.List [ sym eq.loc "set"; e; v ])
    | NAME op when List.mem_assoc op assign_ops ->
      let eq = advance p in
      let v, _ = expr p in
      mk p t.loc
        (Form.List
           [ sym eq.loc "set"; e;
             Form.make (Form.List [ sym eq.loc (List.assoc op assign_ops); e; v ])
               (span p e.loc) ])
    | _ -> e

(* [fn(a, b) = body] is a lambda; [fn(...)] followed by anything else is the
   fallback call spelling of [(fn ...)]. *)
and fn_expr p =
  let t = advance p in
  let lp = advance p in
  let args = items p RP lp.loc ~what:"parameters" in
  match (peek p).tok with
  | NAME "=" ->
    ignore (advance p);
    let ps = lambda_params args in
    let body, _ = expr p in
    (mk p t.loc
       (Form.List
          [ sym t.loc "fn"; Form.make (Form.Vec ps) (span_of_list lp.loc args); body ]),
     0)
  | _ -> (mk p t.loc (Form.List (sym t.loc "fn" :: args)), 9)

and span_of_list l args =
  match List.rev args with
  | [] -> l
  | (x : Form.t) :: _ -> { l with Loc.eline = x.loc.Loc.eline; ecol = x.loc.Loc.ecol }

and lambda_params args =
  List.map
    (fun (a : Form.t) ->
       match a.v with
       | Form.Sym _ -> a
       | _ ->
         failk "lambda-param" a.loc
           "a lambda's parameter is a name, and this is %s. Take the value \
            under a name and destructure it in the body"
           (text_of a))
    args

(* Comma-separated values up to [closer]. [const T] is two elements without a
   comma, for [Ptr(const u8)]: const is a reserved word in a type and never a
   value. *)
and items p closer open_loc ~what =
  let opener = if closer = RB then '[' else '(' in
  let rec go acc =
    let t = peek p in
    if t.tok = closer then (ignore (advance p); List.rev acc)
    else if t.tok = EOF then unclosed p opener open_loc
    else
      match t.tok, peek_at p 1 with
      | NAME "const", n when n.sp && starts_value n.tok ->
        ignore (advance p);
        go (sym t.loc "const" :: acc)
      | _ ->
        let e, _ = expr p in
        (match (peek p).tok with
         | COMMA -> ignore (advance p); go (e :: acc)
         | tk when tk = closer -> ignore (advance p); List.rev (e :: acc)
         | EOF -> unclosed p opener open_loc
         | _ ->
           let n = peek p in
           if starts_value n.tok && n.sp && not (negative_literal n.tok) then
             failk "missing-comma" n.loc
               "%s follows %s with no comma between them. Separate %s with \
                commas: f(a, b)"
               (show n.tok) (text_of e) what
           else stray p ~after:(text_of e))
  in
  go []

(* [[a b c]] or [[a, b + 1]]: whitespace separates only single terms. *)
and vec_items p open_loc =
  (* One separator per bracket: [1 2, 3] mixes them, and which elements the
     comma was meant to part is a guess. *)
  let commas = ref false and spaces = ref false in
  let mixed at =
    failk "mixed-separators" at
      "this bracket separates some elements with commas and some with only \
       spaces. Use one: [1, 2, 3] or [1 2 3]"
  in
  let rec go acc prev_ws =
    let t = peek p in
    match t.tok with
    | RB -> ignore (advance p); List.rev acc
    | EOF -> unclosed p '[' open_loc
    | _ ->
      let e, lvl = expr p in
      if lvl < 8 && prev_ws then refuse_ws t.loc e;
      (match (peek p).tok with
       | COMMA ->
         if !spaces then mixed (peek p).loc;
         commas := true;
         ignore (advance p); go (e :: acc) false
       | RB -> ignore (advance p); List.rev (e :: acc)
       | EOF -> unclosed p '[' open_loc
       | tk when starts_value tk && (peek p).sp ->
         if lvl < 8 then refuse_ws t.loc e;
         if !commas then mixed (peek p).loc;
         spaces := true;
         go (e :: acc) true
       | _ -> stray p ~after:(text_of e))
  in
  go [] false

(* Braces pair a key with a value, so a value may be any expression; after
   one that has an operator in it, the next entry needs a comma. *)
and map_items p open_loc =
  let rec go acc =
    let t = peek p in
    match t.tok with
    | RC -> ignore (advance p); List.rev acc
    | EOF -> unclosed p '{' open_loc
    | _ ->
      let e, lvl = expr p in
      (match (peek p).tok with
       | COMMA -> ignore (advance p); go (e :: acc)
       | RC -> ignore (advance p); List.rev (e :: acc)
       | EOF -> unclosed p '{' open_loc
       | tk when starts_value tk && (peek p).sp ->
         if lvl < 8 then refuse_ws ~brace:true t.loc e;
         go (e :: acc)
       | _ -> stray p ~after:(text_of e))
  in
  go []


(* A type after [:] or [->]: a postfix term, plus the arrow of a function
   type, [Fn(A, B) -> R], which reads as [(Fn [A B] R)]. *)
let rec ty p : Form.t =
  let l0 = (peek p).loc in
  let f, _ = postfix p in
  match f.v, (peek p).tok with
    | Form.List (({ v = Form.Sym ("Fn" | "CFn"); _ } as h) :: args), NAME "->"
      when (last p).tok = RP ->
      ignore (advance p);
      let r = ty p in
      mk p l0 (Form.List [ h; Form.make (Form.Vec args) h.loc; r ])
    | _ -> f

(* ── Statements ────────────────────────────────────────────────────── *)

(* The let-statements this reader built, so that a [let] whose whole body is
   another one merges into one binding vector (spec §2), and a [let] written
   as a call does not. *)
type st = { p : p; mutable lets : Form.t list }

let blk (s : st) l (ss : Form.t list) =
  match ss with
  | [ x ] -> x
  | _ -> mk s.p l (Form.List (sym l "do" :: ss))

let is_lambda_candidate (e : Form.t) =
  match e.v with
  | Form.List ({ v = Form.Sym "fn"; _ } :: args) ->
    List.for_all (fun (a : Form.t) -> match a.v with Form.Sym _ -> true | _ -> false) args
  | _ -> false

let header_follow p s =
  let n = peek_at p 1 in
  let plain_name = function
    | NAME x -> not (is_op_word x || x = "=" || List.mem_assoc x assign_ops)
    | _ -> false
  in
  match s with
  | "fn" | "fn-" | "def" | "once" | "const" | "struct" | "union" | "data"
  | "enum" | "import" ->
    n.sp && plain_name n.tok
  | "if" | "while" | "until" | "match" | "let" | "for" ->
    n.sp && starts_value n.tok
    && (match n.tok with
        | NAME x when x = "=" || List.mem_assoc x assign_ops -> false
        | NAME x when is_binop x ->
          let a = peek_at p 2 in
          a.tok = LP && not a.sp
        | _ -> true)
  | "return" -> n.tok = NEWLINE || (n.sp && starts_value n.tok)
  | "break" | "continue" ->
    n.tok = NEWLINE || (n.sp && (match n.tok with KW _ -> true | _ -> false))
  | "defer" ->
    (n.tok = NEWLINE && (peek_at p 2).tok = INDENT) || (n.sp && starts_value n.tok)
  | "handler-case" | "handler-bind" | "restart-case" ->
    n.tok = NEWLINE || (n.sp && starts_value n.tok)
  | "quote" ->
    (n.tok = NEWLINE && (peek_at p 2).tok = INDENT) || (n.sp && starts_value n.tok)
  | _ -> false

let name_tok p ~what =
  let t = peek p in
  match t.tok with
  | NAME s when not (String.length s > 0 && s.[0] = '.') ->
    ignore (advance p);
    check_name t s;
    sym t.loc s
  | tk -> failk "expected-name" (where_ p) "expected %s here, and found %s" what (show tk)

let glued_lp p ~what =
  let t = peek p in
  if t.tok = LP && not t.sp then advance p
  else failk "expected" (where_ p) "expected %s here, and found %s" what (show t.tok)

(* [(a: i32, b)] as name/type pairs, [dyn] written out for the untyped: the
   reader never leaves a vector for [Check.pair_params] to guess at. *)
let params p (lp : token) =
  let rec go acc =
    let t = peek p in
    match t.tok with
    | RP -> ignore (advance p); List.rev acc
    | EOF -> unclosed p '(' lp.loc
    | _ ->
      (match t.tok with
       | NAME "&" ->
         failk "rest-parameter" t.loc
           "a function's parameters are a fixed list of names, each with an \
            optional : Type, and & (a rest parameter) is not one. Take the rest \
            as one parameter, xs: [T]"
       | _ -> ());
      let n = name_tok p ~what:"a parameter's name" in
      let typed = (peek p).tok = COLON in
      let tyf =
        match (peek p).tok with
        | COLON -> ignore (advance p); ty p
        | _ -> sym n.loc "dyn"
      in
      (match (peek p).tok with
       | COMMA -> ignore (advance p)
       | RP -> ()
       | _ -> stray p ~after:(text_of (if typed then tyf else n)));
      go (tyf :: n :: acc)
  in
  go []

let rec stmts (s : st) : Form.t list =
  let p = s.p in
  match (peek p).tok with
  | DEDENT -> ignore (advance p); []
  | EOF -> []
  | NAME "let" when header_follow p "let" -> let_stmt s
  | _ ->
    let f = stmt s in
    f :: stmts s

and block (s : st) ~after : Form.t list =
  let p = s.p in
  match (peek p).tok with
  | INDENT -> ignore (advance p); stmts s
  | _ ->
    failk "expected-block" (where_ p)
      "%s takes an indented block on the lines under it, and the next line is \
       not indented"
      after

(* The rest of a line read as a value, through its end: [= v], or [=] and an
   indented block that reduces to one form, or a lambda with a block body. *)
and value_line ?(block_ok = false) (s : st) ~after : Form.t =
  let p = s.p in
  let l0 = where_ p in
  if (peek p).tok = NEWLINE && (peek_at p 1).tok = INDENT then begin
    ignore (advance p);
    blk s l0 (block s ~after)
  end
  else
    let e, _ = expr p in
    lambda_block ~block_ok s e ~after:(text_of e)

and lambda_block ?(block_ok = false) (s : st) (e : Form.t) ~after =
  let p = s.p in
  if is_lambda_candidate e && (last p).tok = RP && (peek p).tok = NEWLINE
     && (peek_at p 1).tok = INDENT
  then begin
    ignore (advance p);
    let body = block s ~after in
    match e.v with
    | Form.List (h :: args) ->
      mk p e.loc
        (Form.List (h :: Form.make (Form.Vec args) (span_of_list e.loc args) :: body))
    | _ -> assert false
  end
  else begin
    if block_ok && (peek p).tok = NEWLINE then ignore (advance p)
    else expect_eol p ~after;
    e
  end

and let_stmt (s : st) : Form.t list =
  let p = s.p in
  let t = advance p in
  let target, _ = unary p in
  (* [let x: T = v] is [(let [x (the T v)])]: a let binding has no type slot
     of its own, and [the] is the form that says what a value is. *)
  let annot =
    match (peek p).tok with
    | COLON -> ignore (advance p); Some (ty p)
    | _ -> None
  in
  (match (peek p).tok with
   | NAME "=" -> ignore (advance p)
   | _ ->
     failk "let-equals" (where_ p)
       "a let is let name = value, and %s is not followed by =" (text_of target));
  let v = value_line ~block_ok:true s ~after:("let " ^ text_of target) in
  let v =
    match annot with
    | Some tyf ->
      Form.make (Form.List [ sym tyf.loc "the"; tyf; v ]) (span p tyf.loc)
    | None -> v
  in
  let make bindings body =
    let f =
      mk p t.loc
        (Form.List
           (sym t.loc "let" :: Form.make (Form.Vec bindings) (span_of_list target.loc bindings)
            :: body))
    in
    s.lets <- f :: s.lets;
    f
  in
  let merged body =
    match body with
    | [ ({ Form.v = Form.List (_ :: { v = Form.Vec bs; _ } :: body); _ } as inner) ]
      when List.memq inner s.lets ->
      make (target :: v :: bs) body
    | _ -> make [ target; v ] body
  in
  if (peek p).tok = INDENT then begin
    let f = merged (block s ~after:"let") in
    f :: stmts s
  end
  else [ merged (stmts s) ]

and stmt (s : st) : Form.t =
  let p = s.p in
  let t = peek p in
  match t.tok with
  | NAME w when header_follow p w -> header s w
  | NAME (("else" | "elif") as w) ->
    failk "orphan-else" t.loc
      "%s is not under an if at this column. It goes at the same column as \
       the if it belongs to, right after that if's block"
      w
  | _ -> expr_stmt s

and expr_stmt (s : st) : Form.t =
  let p = s.p in
  let i0 = p.i in
  let t0 = peek p in
  let e, _ = expr p in
  match (peek p).tok with
  | NAME "=" ->
    let eq = advance p in
    let v = value_line s ~after:(text_of e ^ " =") in
    mk p t0.loc (Form.List [ sym eq.loc "set"; e; v ])
  | NAME op when List.mem_assoc op assign_ops ->
    let eq = advance p in
    let v = value_line s ~after:(text_of e ^ " " ^ op) in
    let o = List.assoc op assign_ops in
    mk p t0.loc
      (Form.List
         [ sym eq.loc "set"; e;
           Form.make (Form.List [ sym eq.loc o; e; v ]) (span p e.loc) ])
  | COLON ->
    let before = (last p).tok in
    let c = advance p in
    (* [f(x):] and, with no arguments, [comment:] — a bare name — open a
       block; anything else has no call to hang it on. *)
    (match e.v, before with
     | Form.List (_ :: _), RP -> ()
     | Form.Sym _, NAME _ -> ()
     | _ ->
       failk "colon-block" c.loc
         "a trailing colon gives a call an indented block, and %s is not a \
          call. Write it as one, as in f(x): or comment:"
         (text_of e));
    (match (peek p).tok with
     | NEWLINE -> ignore (advance p)
     | _ -> stray p ~after:":");
    let body = block s ~after:(text_of e ^ ":") in
    (match e.v with
     | Form.List items -> mk p t0.loc (Form.List (items @ body))
     | _ -> mk p t0.loc (Form.List (e :: body)))
  | _ ->
    (* [()] alone on a line is the empty statement, spec §2 "Unit". *)
    let e =
      if p.i - i0 = 2 && t0.tok = LP && e.v = Form.List [] then
        Form.make (Form.List [ sym t0.loc "do" ]) e.loc
      else e
    in
    lambda_block s e ~after:(text_of e)

and header (s : st) w : Form.t =
  let p = s.p in
  let t = advance p in
  let l0 = t.loc in
  let form items = mk p l0 (Form.List (sym l0 w :: items)) in
  let named head items = mk p l0 (Form.List (sym l0 head :: items)) in
  match w with
  | "fn" | "fn-" ->
    let name = name_tok p ~what:"the function's name" in
    let lp = glued_lp p ~what:"the parameters, in parentheses glued to the name" in
    let ps = params p lp in
    let rp = last p in
    let ret =
      match (peek p).tok with
      | NAME "->" -> ignore (advance p); ty p
      | _ ->
        let n = match name.v with Form.Sym n -> n | _ -> "" in
        failk "return-type" rp.loc
          "fn %s has no return type after its parameters, and a .fln \
           function states one for now. Write it after an arrow: fn %s(...) \
           -> i32, or -> dyn, or -> () when it returns nothing"
          n n
    in
    let where_clause =
      match (peek p).tok with
      | NAME "where" ->
        let wt = advance p in
        let rec preds acc =
          let e, _ = expr p in
          match (peek p).tok with
          | COMMA -> ignore (advance p); preds (e :: acc)
          | _ -> List.rev (e :: acc)
        in
        let es = preds [] in
        let v =
          match es with
          | [ e ] -> e
          | _ -> Form.make (Form.Vec es) (span p wt.loc)
        in
        [ mk p wt.loc (Form.Map [ Form.make (Form.Kw "where") wt.loc; v ]) ]
      | _ -> []
    in
    let body =
      match (peek p).tok with
      | NAME "=" ->
        ignore (advance p);
        if (peek p).tok = NEWLINE && (peek_at p 1).tok = INDENT then begin
          ignore (advance p);
          block s ~after:"fn"
        end
        else [ value_line s ~after:"=" ]
      | NEWLINE ->
        ignore (advance p);
        if (peek p).tok = INDENT then block s ~after:"fn" else []
      | _ -> stray p ~after:(text_of ret)
    in
    named (if w = "fn" then "defn" else "defn-")
      (name :: Form.make (Form.Vec ps) lp.loc :: ret :: (where_clause @ body))
  | "def" | "once" | "const" ->
    let name = name_tok p ~what:"the name being defined" in
    let tyf =
      match (peek p).tok with
      | COLON -> ignore (advance p); Some (ty p)
      | _ -> None
    in
    let v =
      match (peek p).tok with
      | NAME "=" ->
        ignore (advance p);
        Some (value_line s ~after:(w ^ " " ^ text_of name ^ " ="))
      | _ ->
        expect_eol p ~after:(match tyf with Some f -> text_of f | None -> text_of name);
        None
    in
    let head =
      match w with "def" -> "def" | "once" -> "defonce" | _ -> "defconst"
    in
    let items =
      match w, tyf, v with
      | "const", None, Some v -> [ name; v ]
      | "const", Some t, Some v -> [ name; t; v ]
      | "const", _, None ->
        failk "const-value" l0
          "a const needs its value: const %s = 3" (text_of name)
      | _, None, Some v -> [ name; sym name.loc "dyn"; v ]
      | _, Some t, None -> [ name; t ]
      | _, Some t, Some v -> [ name; t; v ]
      | _, None, None ->
        failk "def-empty" l0
          "%s %s names neither a type nor a value. Give it one or both: %s %s: \
           i32 = 0"
          w (text_of name) w (text_of name)
    in
    named head items
  | "struct" | "union" ->
    let name = name_tok p ~what:"the type's name" in
    expect_eol_block p ~after:(w ^ " " ^ text_of name);
    let fields =
      lines s (fun () ->
        let f = name_tok p ~what:"a field's name" in
        let tf =
          match (peek p).tok with
          | COLON -> ignore (advance p); ty p
          | _ -> sym f.loc "dyn"
        in
        expect_eol p ~after:(text_of tf);
        [ f; tf ])
    in
    named (if w = "struct" then "defstruct" else "defunion")
      [ name; Form.make (Form.Vec fields) (span p name.loc) ]
  | "data" ->
    let name = name_tok p ~what:"the type's name" in
    expect_eol_block p ~after:("data " ^ text_of name);
    let cases =
      lines s (fun () ->
        let c = name_tok p ~what:"a case's name" in
        let f =
          match (peek p).tok with
          | LP when not (peek p).sp ->
            let lp = advance p in
            let ps = params p lp in
            mk p c.loc (Form.List [ c; Form.make (Form.Vec ps) lp.loc ])
          | _ -> c
        in
        expect_eol p ~after:(text_of f);
        [ f ])
    in
    named "defdata" [ name; Form.make (Form.Vec cases) (span p name.loc) ]
  | "enum" ->
    let name = name_tok p ~what:"the enum's name" in
    expect_eol_block p ~after:("enum " ^ text_of name);
    let members =
      lines s (fun () ->
        let m = name_tok p ~what:"a member's name" in
        match (peek p).tok with
        | NAME "=" ->
          ignore (advance p);
          let v, _ = unary p in
          expect_eol p ~after:(text_of v);
          [ m; v ]
        | _ -> expect_eol p ~after:(text_of m); [ m ])
    in
    named "defenum" [ name; Form.make (Form.Vec members) (span p name.loc) ]
  | "import" ->
    let alias = name_tok p ~what:"the package's alias" in
    let path =
      match (peek p).tok with
      | ATOM (Form.Str _ as v) -> let pt = advance p in Form.make v pt.loc
      | tk ->
        failk "import-path" (where_ p)
          "an import is import alias \"collection:path\", and found %s where \
           the path goes"
          (show tk)
    in
    expect_eol p ~after:(text_of path);
    form [ alias; path ]
  | "if" ->
    let c, _ = binary p 1 in
    (match (peek p).tok with
     | NAME "then" ->
       ignore (advance p);
       let a = inline_stmt p in
       let f =
         match (peek p).tok with
         | NAME "else" ->
           ignore (advance p);
           let b = inline_stmt p in
           form [ c; a; b ]
         | NAME "elif" ->
           failk "one-line-elif" (peek p).loc
             "a one-line if has then and else and no elif. Chain another if \
              after the else — if a then x else if b then y else z — or write \
              the if over several lines, where elif goes"
         | _ -> named "when" [ c; a ]
       in
       expect_eol p ~after:(text_of f);
       f
     | _ ->
       expect_line_end p ~after:("if " ^ text_of c);
       let body = block s ~after:("if " ^ text_of c) in
       let rec elifs acc =
         match (peek p).tok with
         | NAME "elif" ->
           ignore (advance p);
           let c, _ = binary p 1 in
           (match (peek p).tok with
            | NAME "then" ->
              failk "elif-then" (peek p).loc
                "elif takes its block on the indented lines under it, with no \
                 then. Put the branch on the next line, indented"
            | _ -> ());
           expect_line_end p ~after:("elif " ^ text_of c);
           let b = block s ~after:"elif" in
           elifs ((c, b) :: acc)
         | _ -> List.rev acc
       in
       let els_ = elifs [] in
       let else_ =
         match (peek p).tok with
         | NAME "else" ->
           let et = advance p in
           (match (peek p).tok with
            | NEWLINE -> ignore (advance p)
            | NAME "if" ->
              failk "else-if" (where_ p)
                "else takes its block on the lines under it. For another test \
                 at this level, write elif c"
            | _ -> stray p ~after:"else");
           Some (et.loc, block s ~after:"else")
         | _ -> None
       in
       (match els_, else_ with
        | [], None -> named "when" (c :: body)
        | [], Some (el, e) -> form [ c; blk s l0 body; blk s el e ]
        | _ ->
          let pairs =
            List.concat_map (fun (c, b) -> [ c; blk s c.Form.loc b ]) ((c, body) :: els_)
          in
          let tail =
            match else_ with
            | Some (el, e) -> [ Form.make (Form.Kw "else") el; blk s el e ]
            | None -> []
          in
          named "cond" (pairs @ tail)))
  | "while" | "until" ->
    let label =
      match (peek p).tok, (peek_at p 1).tok with
      | KW k, n when n <> NEWLINE -> let kt = advance p in [ Form.make (Form.Kw k) kt.loc ]
      | _ -> []
    in
    let c, _ = expr p in
    expect_line_end p ~after:(w ^ " " ^ text_of c);
    let body = block s ~after:w in
    form (label @ (c :: body))
  | "for" ->
    let label =
      match (peek p).tok with
      | KW k -> let kt = advance p in [ Form.make (Form.Kw k) kt.loc ]
      | _ -> []
    in
    let v = name_tok p ~what:"the loop variable" in
    expect_name p "in" ~what:"in, as in for i in range(n)";
    let rt = peek p in
    expect_name p "range" ~what:"range(n), range(a, b) or range(a, b, step)";
    let lp = glued_lp p ~what:"range's bounds in parentheses" in
    let bs = items p RP lp.loc ~what:"bounds" in
    if bs = [] || List.length bs > 3 then
      failk "range-arity" rt.loc
        "range takes one, two or three bounds: range(stop), range(start, stop) \
         or range(start, stop, step)";
    expect_line_end p ~after:"range(...)";
    let body = block s ~after:"for" in
    named "dotimes"
      (label @ (Form.make (Form.Vec (v :: bs)) (span_of_list v.loc bs) :: body))
  | "return" ->
    (match (peek p).tok with
     | NEWLINE -> expect_eol p ~after:"return"; form []
     | _ ->
       let e, _ = expr p in
       expect_eol p ~after:(text_of e);
       form [ e ])
  | "break" | "continue" ->
    (match (peek p).tok with
     | KW k ->
       let kt = advance p in
       expect_eol p ~after:(":" ^ k);
       form [ Form.make (Form.Kw k) kt.loc ]
     | _ -> expect_eol p ~after:w; form [])
  | "defer" ->
    (match (peek p).tok with
     | NEWLINE ->
       ignore (advance p);
       form (block s ~after:"defer")
     | _ ->
       let e = inline_stmt p in
       expect_eol p ~after:(text_of e);
       form [ e ])
  | "match" ->
    let scrut, _ = expr p in
    expect_eol_block p ~after:("match " ^ text_of scrut);
    let arms =
      lines s (fun () ->
        let pat, _ = unary p in
        expect_name p "->" ~what:"-> and the arm's value";
        let body =
          if (peek p).tok = NEWLINE && (peek_at p 1).tok = INDENT then begin
            let nl = advance p in
            blk s nl.loc (block s ~after:"->")
          end
          else begin
            let e = inline_stmt p in
            expect_eol p ~after:(text_of e);
            e
          end
        in
        [ pat; body ])
    in
    form (scrut :: arms)
  | "handler-case" | "handler-bind" ->
    clause_header_end p w;
    let body = block s ~after:w in
    let rec clauses acc =
      match (peek p).tok, (peek_at p 1) with
      | NAME "on", n when n.sp ->
        let ot = advance p in
        let head, _ = postfix p in
        let ty, var =
          match head.v with
          | Form.List [ ty; ({ v = Form.Sym _; _ } as var) ] -> (ty, var)
          | _ ->
            failk "on-clause" head.loc
              "a handler clause is on Type(name), naming the condition type \
               and the name it is bound to, as in on FileError(c)"
        in
        clause_end p ("on " ^ text_of ty ^ "(" ^ text_of var ^ ")");
        let b = block s ~after:"on" in
        let c =
          mk p ot.loc
            (Form.List (ty :: Form.make (Form.Vec [ var ]) var.loc :: b))
        in
        clauses (c :: acc)
      | _ -> List.rev acc
    in
    let cs = clauses [] in
    let vec = Form.make (Form.Vec cs) (span p l0) in
    if w = "handler-case" then form [ blk s l0 body; vec ]
    else form (vec :: body)
  | "restart-case" ->
    clause_header_end p w;
    let body = block s ~after:w in
    let rec clauses acc =
      match (peek p).tok, (peek_at p 1) with
      | NAME "restart", n when n.sp ->
        ignore (advance p);
        let name = name_tok p ~what:"the restart's name" in
        let lp = glued_lp p ~what:"the restart's parameters in parentheses" in
        let ps = params p lp in
        clause_end p ("restart " ^ text_of name ^ "(...)");
        let b = block s ~after:"restart" in
        let c =
          mk p name.loc (Form.List (name :: Form.make (Form.Vec ps) lp.loc :: b))
        in
        clauses (c :: acc)
      | _ -> List.rev acc
    in
    let cs = clauses [] in
    form (blk s l0 body :: cs)
  | "quote" ->
    (* One line, [quote ~x + 1], is the quasiquote of that expression. *)
    (match (peek p).tok with
     | NEWLINE ->
       ignore (advance p);
       let body = block s ~after:"quote" in
       named "quasiquote" [ blk s l0 body ]
     | _ ->
       let e, _ = expr p in
       expect_eol p ~after:(text_of e);
       named "quasiquote" [ e ])
  | _ -> assert false

(* handler-case, handler-bind and restart-case take nothing on their own line. *)
and clause_header_end p w =
  match (peek p).tok with
  | NEWLINE -> ignore (advance p)
  | _ ->
    failk "clause-header" (peek p).loc
      "%s takes its body on the indented lines under it, and its %s clauses \
       at its own column after that, each with its block under it:\n\
       %s\n  body\n%s"
      w (if w = "restart-case" then "restart" else "on") w
      (if w = "restart-case" then "restart name()\n  value" else "on Type(c)\n  value")

and clause_end p head =
  match (peek p).tok with
  | NEWLINE -> ignore (advance p)
  | _ ->
    failk "clause-body" (peek p).loc
      "the body of %s goes on the indented lines under it, not on its line. \
       Move it to the next line, indented"
      head

(* The end of a header line whose block must follow. *)
and expect_line_end p ~after =
  match (peek p).tok with
  | NEWLINE -> ignore (advance p)
  | _ -> stray p ~after

and expect_eol_block p ~after =
  expect_line_end p ~after

(* An indented run of one-line entries — a struct's fields, a match's arms.
   None at all is allowed for the declarations and is refused later, by the
   form, where it matters. *)
and lines (s : st) (one : unit -> Form.t list) : Form.t list =
  let p = s.p in
  if (peek p).tok <> INDENT then []
  else begin
    ignore (advance p);
    let rec go acc =
      match (peek p).tok with
      | DEDENT -> ignore (advance p); List.rev acc
      | EOF -> List.rev acc
      | _ -> go (List.rev_append (one ()) acc)
    in
    go []
  end

(** All top-level forms in a [.fln] source string. [col] is the column the
    text's top level starts at, 1 for a file. *)
let read_all ?(col = 1) ~file src =
  let toks = layout ~base:col (lex ~file src) in
  let s = { p = { toks; i = 0 }; lets = [] } in
  let fs = stmts s in
  (match (peek s.p).tok with
   | EOF -> ()
   | tk -> failk "unexpected-token" (where_ s.p) "unexpected %s" (show tk));
  fs

let read_file path =
  let ic = open_in_bin path in
  Fun.protect ~finally:(fun () -> close_in ic) (fun () ->
    let n = in_channel_length ic in
    read_all ~file:path (really_input_string ic n))