(** [Form.t] to indented text: the inverse of [Indent_reader], and what
    [flan convert] writes.

    The one rule that keeps the round trip exact: a piece of sugar is printed
    only when the form has exactly the shape that sugar reads back to, and
    everything else goes through the fallback, [head(arg, ...)], or
    [head(arg, ...):] with the trailing arguments as an indented block. The
    fallback reads any form, so a form this printer cannot sweeten still
    prints; what it cannot print at all is a name with no spelling in the
    indented syntax, and that raises [Unprintable].

    Comments are not in a [Form.t], so a converted file has none. *)

module R = Indent_reader

exception Unprintable of Form.t * string

let width = 80

let unprintable (f : Form.t) why = raise (Unprintable (f, why))

(* Words a statement may start with that the reader takes as a header. A
   statement whose text would lead with one is wrapped in parentheses, which
   the reader takes as grouping and so as the plain name. *)
let reserved =
  [ "fn"; "fn-"; "def"; "once"; "const"; "struct"; "union"; "data"; "enum";
    "import"; "if"; "elif"; "else"; "while"; "until"; "match"; "let"; "for";
    "return"; "break"; "continue"; "defer"; "handler-case"; "handler-bind";
    "restart-case"; "quote"; "on"; "restart" ]

(* A symbol the reader gives back as itself when it is written bare. *)
let name_ok s =
  let n = String.length s in
  n > 0
  && (not (String.exists Reader.is_delimiter s))
  && (not (String.contains s ':'))
  && s.[0] <> '\'' && s.[0] <> '\\'
  && (not (Reader.is_digit s.[0]))
  && (not ((s.[0] = '-' || s.[0] = '+') && n > 1 && Reader.is_digit s.[1]))
  && (not (n > 1 && s.[0] = '-' && R.is_neg_char s.[1]))
  && R.split_fields s = [ s ]
  && (not (R.is_op_word s))
  && not (n >= 2 && s.[0] = '#' && s.[1] = '_')

let kw_ok k = k <> "" && not (String.exists Reader.is_delimiter k)

(* A name a definition's header can take: the reader reads a leading dot
   there as a field access, so [.init-once.counter] keeps the fallback. *)
let def_name s = name_ok s && s.[0] <> '.'

let paren s = "(" ^ s ^ ")"

(* A number's own spelling, when the caller has the text it was read from:
   [Form.Int] keeps only the value, so without this 0xFFF00FFF would print
   as 4293922815. Set by [program ~source]. *)
let spelling : (Form.t -> string option) ref = ref (fun _ -> None)

(* Whether a comment sits inside a form, on a line before its last: such a
   form is not squeezed onto one line, or the comment would have no line of
   its own to go to. Set by [program ~source]. *)
let inside : (Form.t -> bool) ref = ref (fun _ -> false)

(* The same form, locations aside. *)
let rec same (a : Form.t) (b : Form.t) =
  match a.v, b.v with
  | Form.List x, Form.List y | Form.Vec x, Form.Vec y | Form.Map x, Form.Map y ->
    List.length x = List.length y && List.for_all2 same x y
  | x, y -> x = y

let is_sym s (f : Form.t) = match f.v with Form.Sym x -> x = s | _ -> false

(* Inside a quasiquote the forms are a template, not code: an unquote may put
   anything in place, a name a flat [let] would then capture included, so no
   [let] there takes in what follows it and no one-argument [and] is dropped. *)
let quasi = ref 0

let in_quasi (f : Form.t) k =
  match f.v with
  | Form.List ({ v = Form.Sym "quasiquote"; _ } :: _) ->
    incr quasi;
    Fun.protect ~finally:(fun () -> decr quasi) k
  | _ -> k ()

(* ── Flat lets ─────────────────────────────────────────────────────── *)

(* A [let] in the indented syntax is always flat: [let x = v] scopes to the
   end of its block. So a [let] with statements after it in a body is printed
   as the [let] taking those statements into its own body. That changes
   nothing when none of them refers to a name it binds — a [let] is no frame
   and a [defer] is function-scoped, so the longer scope releases nothing
   later. When one does, the name is renamed inside the [let] to one the
   whole top-level form does not use. Where a rename cannot be trusted, or
   where the statements are not a body run in order, the [let] goes in a
   [do:] block of its own instead. *)

(* Macros whose trailing arguments are a body run in order, by the name they
   are called by, and the argument the body starts at. Set by [program]. *)
let macros : Body_macros.t ref = ref (Body_macros.create ())

(* Every name spelled in the top-level form being printed, and every part of
   a dotted or slashed one: a new name is none of them. *)
let used : (string, unit) Hashtbl.t = Hashtbl.create 64

let rec note_used (f : Form.t) =
  match f.v with
  | Form.Sym s ->
    List.iter (fun p -> Hashtbl.replace used p ())
      (s :: List.concat_map (String.split_on_char '/') (String.split_on_char '.' s))
  | Form.List l | Form.Vec l | Form.Map l -> List.iter note_used l
  | _ -> ()

(* Each new name, and the name it was made from: renaming [x-3] again makes
   [x-4], not [x-3-2]. *)
let made : (string, string) Hashtbl.t = Hashtbl.create 16

let fresh n =
  let n = Option.value (Hashtbl.find_opt made n) ~default:n in
  let rec go i =
    let c = n ^ "-" ^ string_of_int i in
    if Hashtbl.mem used c then go (i + 1)
    else (Hashtbl.replace used c (); Hashtbl.replace made c n; c)
  in
  go 2

let prefixed pre s =
  String.length s > String.length pre && String.sub s 0 (String.length pre) = pre

let dotted s = String.length s > 1 && s.[0] = '.'

let all f l =
  List.fold_right
    (fun x acc -> match f x, acc with Some y, Some ys -> Some (y :: ys) | _ -> None)
    l (Some [])

(* A struct pattern's entries as [name .field] pairs, in order: [.x] is
   [x .x], and [:keys [x y]] is [x .x y .y] ([Parse.dmap]). [None] for a
   shape [Parse] refuses. *)
let struct_pairs (items : Form.t list) =
  let rec go = function
    | [] -> Some []
    | ({ Form.v = Form.Sym s; _ } as f) :: rest when dotted s ->
      let n = String.sub s 1 (String.length s - 1) in
      Option.map (fun r -> ({ f with v = Form.Sym n }, f) :: r) (go rest)
    | { Form.v = Form.Kw "keys"; _ } :: { Form.v = Form.Vec ns; _ } :: rest ->
      Option.bind
        (all (fun (n : Form.t) -> match n.v with
             | Form.Sym s -> Some (n, { n with v = Form.Sym ("." ^ s) })
             | _ -> None) ns)
        (fun ps -> Option.map (fun r -> ps @ r) (go rest))
    | pat :: ({ Form.v = Form.Sym s; _ } as f) :: rest when dotted s ->
      Option.map (fun r -> (pat, f) :: r) (go rest)
    | _ -> None
  in
  go items

(* The names a binding target binds, or [None] for a target [Parse] would
   refuse. *)
let rec pat_names (t : Form.t) : string list option =
  match t.v with
  | Form.Sym s -> Some [ s ]
  | Form.Vec l ->
    Option.map List.concat
      (all (fun (x : Form.t) -> if x.v = Form.Sym "&" then Some [] else pat_names x) l)
  | Form.Map l ->
    Option.bind (struct_pairs l) (fun ps ->
        Option.map List.concat (all (fun (p, _) -> pat_names p) ps))
  | _ -> None

let binds n t = match pat_names t with Some ns -> List.mem n ns | None -> false

(* Whether [f] mentions [n]: the name, or a field path or qualified name
   starting with it. Any occurrence counts, a quoted one or one under an
   unquote included. A macro whose expansion names a variable its call does
   not spell is [flatten]'s to see, through [!macros.names]; one defined
   nowhere [Body_macros.table] reads is the case nothing here can see. *)
let rec mentions n (f : Form.t) =
  match f.v with
  | Form.Sym s -> s = n || prefixed (n ^ ".") s || prefixed (n ^ "/") s
  | Form.List l | Form.Vec l | Form.Map l -> List.exists (mentions n) l
  | _ -> false

(* [mentions], less what a [let] inside [f] rebinds before any use: a later
   [let a = ...] of the same name is a new [a], not the one before it. *)
let rec refers n (f : Form.t) =
  match f.v with
  | Form.List ({ v = Form.Sym "let"; _ } :: { v = Form.Vec bs; _ } :: body) ->
    let rec go = function
      | t :: v :: rest -> refers n v || ((not (binds n t)) && go rest)
      | [ t ] -> refers n t
      | [] -> List.exists (refers n) body
    in
    go bs
  | Form.List l | Form.Vec l | Form.Map l -> List.exists (refers n) l
  | _ -> mentions n f

(* A binding target with [n] renamed [n']. A struct pattern that binds [n]
   is written out as pairs, so the field keeps its name. *)
let rec rename_pat n n' (t : Form.t) : Form.t option =
  match t.v with
  | Form.Sym s when s = n -> Some { t with v = Form.Sym n' }
  | Form.Sym _ -> Some t
  | Form.Vec l -> Option.map (fun l -> { t with v = Form.Vec l }) (all (rename_pat n n') l)
  | Form.Map l ->
    Option.bind (struct_pairs l) (fun ps ->
        if not (binds n t) then Some t
        else
          Option.map
            (fun ps -> { t with v = Form.Map (List.concat_map (fun (p, f) -> [ p; f ]) ps) })
            (all (fun (p, f) -> Option.map (fun p -> (p, f)) (rename_pat n n' p)) ps))
  | _ -> None

(* [f] with [n] renamed [n'], or [None] where the rename cannot be trusted:
   a quoted [n] is data, [n/x] names a package, and [(n ...)] may call a
   function of that name rather than the local. A [let] inside renames its
   targets as patterns. *)
let rec rename n n' (f : Form.t) : Form.t option =
  match f.v with
  | Form.Sym s when s = n -> Some { f with v = Form.Sym n' }
  | Form.Sym s when prefixed (n ^ ".") s ->
    let k = String.length n in
    Some { f with v = Form.Sym (n' ^ String.sub s k (String.length s - k)) }
  | Form.Sym s when prefixed (n ^ "/") s -> None
  | Form.List ({ v = Form.Sym ("quote" | "quasiquote"); _ } :: _) when mentions n f -> None
  | Form.List ({ v = Form.Sym s; _ } :: _) when s = n -> None
  | Form.List (({ v = Form.Sym "let"; _ } as h) :: ({ v = Form.Vec bs; _ } as bv) :: body) ->
    let rec go = function
      | t :: v :: rest ->
        (match rename_pat n n' t, rename n n' v, go rest with
         | Some t, Some v, Some r -> Some (t :: v :: r)
         | _ -> None)
      | rest -> all (rename n n') rest
    in
    (match go bs, all (rename n n') body with
     | Some bs, Some body -> Some { f with v = Form.List (h :: { bv with v = Form.Vec bs } :: body) }
     | _ -> None)
  | Form.List l -> Option.map (fun l -> { f with v = Form.List l }) (all (rename n n') l)
  | Form.Vec l -> Option.map (fun l -> { f with v = Form.Vec l }) (all (rename n n') l)
  | Form.Map l -> Option.map (fun l -> { f with v = Form.Map l }) (all (rename n n') l)
  | _ -> Some f

(* [n] renamed [n'] in a [let]'s bindings [bs] and [body], from the binding
   that binds it on: the values up to and including that binding's see the
   outer [n]. *)
let rename_let n n' (bs : Form.t list) (body : Form.t list) =
  let rec go = function
    | t :: v :: rest when binds n t ->
      (* From here on, the rest reads as a [let] of its own. *)
      (match rename_pat n n' t,
             rename n n' { t with v = Form.List (Form.make (Form.Sym "let") t.loc
                                                 :: Form.make (Form.Vec rest) t.loc :: body) } with
       | Some t', Some { v = Form.List (_ :: { v = Form.Vec rest'; _ } :: body'); _ } ->
         Some (t' :: v :: rest', body')
       | _ -> None)
    | t :: v :: rest -> Option.map (fun (r, b) -> (t :: v :: r, b)) (go rest)
    | _ -> Some (bs, body)
  in
  go bs

(* The [let] [f] taking [rest] in as the end of its body, its names that
   [rest] refers to renamed; [None] when a rename cannot be trusted. *)
let flatten (f : Form.t) (rest : Form.t list) =
  match f.v with
  | Form.List (({ v = Form.Sym "let"; _ } as h) :: ({ v = Form.Vec bs; _ } as bv) :: (_ :: _ as body))
    when rest <> [] && bs <> [] && List.length bs mod 2 = 0 ->
    Option.bind
      (all pat_names (List.filteri (fun i _ -> i mod 2 = 0) bs))
      (fun names ->
         (* A call of a macro whose expansion names one of [ns]: that name
            in the expansion means whatever is in scope where it lands, so
            the let's scope may not newly reach it and a name it means may
            not be renamed. *)
         let rec captures ns (f : Form.t) =
           match f.v with
           | Form.List ({ v = Form.Sym m; _ } :: _)
             when (match Hashtbl.find_opt !macros.names m with
                 | Some ms -> List.exists (fun n -> List.mem n ms) ns
                 | None -> false) -> true
           | Form.List l | Form.Vec l | Form.Map l -> List.exists (captures ns) l
           | _ -> false
         in
         let names = List.sort_uniq compare (List.concat names) in
         let clash = List.filter (fun n -> List.exists (refers n) rest) names in
         if List.exists (captures names) rest || List.exists (captures clash) body then None
         else
         List.fold_left
           (fun acc n -> Option.bind acc (fun (bs, body) -> rename_let n (fresh n) bs body))
           (Some (bs, body)) clash
         |> Option.map (fun (bs, body) ->
             { f with v = Form.List (h :: { bv with v = Form.Vec bs } :: (body @ rest)) }))
  | _ -> None

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

(* Text and syntactic level, the same scale [Indent_reader] reads: 10 an atom
   or bracket, 9 a postfix chain, 8 a unary minus, 1-7 binary, 3 [not], 0 a
   one-line [if] or a lambda. *)
let rec expr (f : Form.t) : string * int =
  match f.v with
  | Form.Sym s -> sym f s
  | Form.Kw k ->
    if kw_ok k then (":" ^ k, 10) else unprintable f "a keyword with no spelling"
  | Form.Int i ->
    let t = Option.value (!spelling f) ~default:(Int64.to_string i) in
    (t, if t.[0] = '-' then 8 else 10)
  | Form.UInt (_, s) -> (s, 10)
  | Form.Float x ->
    let s = Option.value (!spelling f) ~default:(Form.float_repr x) in
    if not (Reader.is_digit s.[0] || (s.[0] = '-' && String.length s > 1
                                      && Reader.is_digit s.[1]))
    then unprintable f "a float with no literal";
    (s, if s.[0] = '-' then 8 else 10)
  | Form.Str s -> ("\"" ^ Form.escape s ^ "\"", 10)
  | Form.Byte b -> (Form.byte_repr b, 10)
  | Form.Vec xs -> ("[" ^ vec_text xs ^ "]", 10)
  | Form.Map xs -> ("{" ^ map_text xs ^ "}", 10)
  | Form.List [] -> ("()", 10)
  | Form.List (h :: args) -> in_quasi f (fun () -> list f h args)

and sym f s =
  if s = "==" then unprintable f "the name == (it reads as =)"
  else if R.is_op_word s || s = "if" then (paren s, 10)
  else if name_ok s then (s, 10)
  else unprintable f (Printf.sprintf "the name %s" s)

and at lvl f =
  let t, l = expr f in
  if l < lvl then paren t else t

and comma_items xs =
  let rec go = function
    | [] -> []
    | ({ Form.v = Form.Sym "const"; _ }) :: y :: rest ->
      ("const " ^ at 0 y) :: go rest
    | x :: rest -> at 0 x :: go rest
  in
  go xs

and commas xs = String.concat ", " (comma_items xs)

(* Whitespace between single terms, as [[1 2 3]] and [[4 f32]] read; commas
   as soon as one element has an operator in it. *)
and vec_text xs =
  let ts = List.map expr xs in
  if List.for_all (fun (_, l) -> l >= 8) ts then String.concat " " (List.map fst ts)
  else String.concat ", " (List.map (fun (t, _) -> t) ts)

and map_text xs =
  let ts = List.map expr xs in
  if List.for_all (fun (_, l) -> l >= 8) ts then String.concat " " (List.map fst ts)
  else
    let rec pairs = function
      | (k, kl) :: (v, _) :: rest ->
        ((if kl < 8 then paren k else k) ^ " " ^ v) :: pairs rest
      | [ (k, _) ] -> [ k ]
      | [] -> []
    in
    String.concat ", " (pairs ts)

and head_text (h : Form.t) =
  match h.v with
  | Form.Sym "==" -> unprintable h "the name =="
  | Form.Sym s when R.is_op_word s -> s
  | Form.Sym s -> fst (sym h s)
  | _ -> at 9 h

and list f h args =
  let call () = (head_text h ^ "(" ^ commas args ^ ")", 9) in
  match h.v, args with
  | Form.Sym "quote", [ x ] -> ("'" ^ Form.to_source x, 10)
  | Form.Sym "unquote", [ x ] -> ("~" ^ at 10 x, 10)
  | Form.Sym "unquote-splicing", [ x ] -> ("~@" ^ at 10 x, 10)
  | Form.Sym s, _ :: _ :: _
    when (R.is_binop s || s = "=") && s <> "==" && not (s = "!=" && List.length args > 2) ->
    let op = if s = "=" then "==" else s in
    let lvl = Option.get (R.binop_level op) in
    let first = List.hd args and rest = List.tl args in
    let ft, fl = expr first in
    let same = match first.v with
      | Form.List (h' :: _ :: _ :: _) -> is_sym s h' || lvl = 4
      | _ -> false
    in
    let ft = if fl < lvl || (fl = lvl && same) then paren ft else ft in
    (* [(a and b) or c]: the parentheses precedence makes optional are
       written, as most readers expect them. *)
    let and_in_or (x : Form.t) t =
      match x.v with
      | Form.List ({ v = Form.Sym "and"; _ } :: _ :: _ :: _) when s = "or" && t.[0] <> '(' -> paren t
      | _ -> t
    in
    let ft = and_in_or first ft in
    (String.concat (" " ^ op ^ " ")
       (ft :: List.map (fun x -> and_in_or x (at (lvl + 1) x)) rest), lvl)
  | Form.Sym "-", [ x ] ->
    let t, l = expr x in
    if l >= 9 && t <> "" && R.is_neg_char t.[0] then ("-" ^ t, 8)
    else ("-(" ^ at 0 x ^ ")", 9)
  | Form.Sym "not", [ x ] -> ("not " ^ at 3 x, 3)
  (* [and] or [or] of one value is that value. *)
  | Form.Sym ("and" | "or"), [ x ] when !quasi = 0 -> expr x
  | Form.Sym "at", t :: (_ :: _ as idx) -> (at 9 t ^ "[" ^ commas idx ^ "]", 9)
  | Form.Sym s, [ t ]
    when String.length s > 1 && s.[0] = '.' && name_ok s
         && not (String.contains (String.sub s 1 (String.length s - 1)) '.') ->
    let tt, tl = expr t in
    let glued =
      tl >= 9
      && (match t.v with
          | Form.Byte _ -> false
          | Form.Sym x -> name_ok x && not (String.contains x '.') && not (R.capitalised x)
          (* A field of a field chains: [w.x.count]. *)
          | Form.List [ { v = Form.Sym f; _ }; _ ]
            when String.length f > 1 && f.[0] = '.' && tt <> "" && tt.[0] <> '.' ->
            String.length tt > 0 && not (String.contains tt ' ')
          | _ ->
            let c = tt.[String.length tt - 1] in
            c = ')' || c = ']' || c = '}' || c = '"')
    in
    if glued then (tt ^ s, 9) else call ()
  | Form.Sym s, [ ({ v = Form.Map _; _ } as m) ] when name_ok s && R.capitalised s ->
    (s ^ fst (expr m), 9)
  | Form.Sym "the", _ when (match typed_lambda f with Some (_, [ _ ]) -> true | _ -> false) ->
    (match typed_lambda f with
     | Some (head, [ body ]) -> (head ^ " = " ^ unit_text body, 0)
     | _ -> assert false)
  | Form.Sym "fn", [ { v = Form.Vec ps; _ }; body ] when List.for_all sym_param ps ->
    ("fn(" ^ commas ps ^ ") = " ^ unit_text body, 0)
  | Form.Sym "if", [ c; a; b ] ->
    ("if " ^ at 1 c ^ " then " ^ inline_text ~lvl:1 a ^ " else " ^ inline_text b, 0)
  | _ -> call ()

(* A one-line slot's text — an arm's value, a then or an else, what follows
   defer: the statements that fit on a line are written as statements,
   everything else as a value. [lvl] is what a value in the slot needs. *)
and inline_text ?(lvl = 0) (f : Form.t) =
  match f.v with
  (* In a one-line slot a bare [()] reads as [(do)]; the value [()] is
     written [(())]. *)
  | Form.List [] -> "(())"
  | Form.List [ { v = Form.Sym "do"; _ } ] -> "()"
  | Form.List [ { v = Form.Sym (("break" | "continue" | "return") as w); _ } ] -> w
  | Form.List [ { v = Form.Sym (("break" | "continue") as w); _ }; { v = Form.Kw k; _ } ]
    when kw_ok k ->
    w ^ " :" ^ k
  | Form.List [ { v = Form.Sym "return"; _ }; v ] -> "return " ^ at (max lvl 1) v
  | Form.List [ { v = Form.Sym "set"; _ }; t; v ] -> assign_text ~lvl t v
  | Form.List [ { v = Form.Sym "update"; _ }; t; { v = Form.Sym (("+" | "-" | "*" | "/") as op); _ }; w ]
    when not (R.simple_place t) ->
    at 9 t ^ " " ^ op ^ "= " ^ at (max lvl 1) w
  | _ -> at lvl f

(* A body after [=]: [()] there reads as [(do)]. *)
and unit_text (f : Form.t) =
  match f.v with
  | Form.List [] -> "(())"
  | Form.List [ { v = Form.Sym "do"; _ } ] -> "()"
  | _ -> at 0 f

(* [t = v], or [t += w] when [v] is [(+ t w)]. *)
and assign_text ?(lvl = 0) t v =
  let tt = at 9 t in
  match v.v with
  | Form.List [ { v = Form.Sym (("+" | "-" | "*" | "/") as op); _ }; a; w ]
    when same a t && R.simple_place t ->
    tt ^ " " ^ op ^ "= " ^ at (max lvl 1) w
  | _ -> tt ^ " = " ^ at (max lvl 1) v

and sym_param (p : Form.t) =
  match p.v with Form.Sym s -> name_ok s | _ -> false

(* [(the (Fn [C dyn] R) (fn [a b] ...))] as [fn(a: C, b) -> R], the typed
   lambda it reads from; [None] for any other shape. *)
and typed_lambda (f : Form.t) =
  let rec tyt (t : Form.t) =
    match t.v with
    | Form.List [ { v = Form.Sym (("Fn" | "CFn") as h); _ }; { v = Form.Vec ps; _ }; r ] ->
      h ^ "(" ^ String.concat ", " (List.map tyt ps) ^ ") -> " ^ tyt r
    | _ -> at 9 t
  in
  match f.v with
  | Form.List [ { v = Form.Sym "the"; _ };
                { v = Form.List [ { v = Form.Sym "Fn"; _ }; { v = Form.Vec ts; _ }; r ]; _ };
                { v = Form.List ({ v = Form.Sym "fn"; _ } :: { v = Form.Vec ps; _ } :: body); _ } ]
    when List.length ts = List.length ps && List.for_all sym_param ps && body <> [] ->
    let one (n : Form.t) (t : Form.t) =
      if is_sym "dyn" t then fst (expr n) else fst (expr n) ^ ": " ^ tyt t
    in
    Some ("fn(" ^ String.concat ", " (List.map2 one ps ts) ^ ") -> " ^ tyt r, body)
  | _ -> None

(* A type after [:] or [->]: the function-type arrow at the top, a postfix
   term below it. *)
let rec ty (f : Form.t) =
  match f.v with
  | Form.List [ { v = Form.Sym (("Fn" | "CFn") as h); _ }; { v = Form.Vec ps; _ }; r ] ->
    h ^ "(" ^ commas ps ^ ") -> " ^ ty r
  | _ -> at 9 f

(* A [defn]'s parameter type the reader could not mistake for a name: a
   primitive, a capitalised or [$] name, or a bracket. [[x y]] with a
   lowercase [y] keeps the fallback, because what it means depends on
   whether [y] names a type. *)
let type_shaped (f : Form.t) =
  match f.v with
  | Form.Sym t ->
    List.mem t Types.primitive_names || (t <> "" && t.[0] = '$') || R.capitalised t
  | Form.List [] | Form.List ({ v = Form.Sym _; _ } :: _) | Form.Vec _ -> true
  | _ -> false

let rec pairs = function
  | a :: b :: rest -> Option.map (fun r -> (a, b) :: r) (pairs rest)
  | [] -> Some []
  | [ _ ] -> None

(* [(a: i32, b)] from [[a i32 b dyn]], when every name is a plain name. *)
let params_text ?(shaped = false) (ps : Form.t list) =
  match pairs ps with
  | None -> None
  | Some prs ->
    if List.for_all
        (fun ((n : Form.t), t) ->
           (match n.v with Form.Sym x -> def_name x | _ -> false)
           && ((not shaped) || is_sym "dyn" t || type_shaped t))
        prs
    then
      Some
        (String.concat ", "
           (List.map
              (fun ((n : Form.t), t) ->
                 let n = fst (expr n) in
                 if is_sym "dyn" t then n else n ^ ": " ^ ty t)
              prs))
    else None

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

let ind n = String.make n ' '

let lead_word text =
  let n = String.length text in
  let rec go i = if i < n && not (Reader.is_delimiter text.[i]) then go (i + 1) else i in
  let i = go 0 in
  (String.sub text 0 i, i = n || text.[i] = ' ')

(* A statement whose text leads with a reserved word, parenthesised. *)
let guard text =
  let w, spaced = lead_word text in
  (* [data = 3]: a name being assigned is read as one, header word or not. *)
  let assigned =
    let k = String.length w + 1 in
    List.exists
      (fun op ->
         let o = op ^ " " in
         String.length text >= k + String.length o
         && String.sub text k (String.length o) = o)
      [ "="; "+="; "-="; "*="; "/=" ]
  in
  if spaced && List.mem w reserved && not assigned then paren text else text

let stmts_of (f : Form.t) =
  match f.v with
  | Form.List ({ v = Form.Sym "do"; _ } :: (_ :: _ :: _ as ss)) -> ss
  | _ -> [ f ]

(* Heads whose trailing arguments are a body, and how many come before it. *)
let body_guess (h : Form.t) args =
  match h.v with
  | Form.Sym s ->
    let base =
      match String.rindex_opt s '/' with
      | Some i -> String.sub s (i + 1) (String.length s - i - 1)
      | None -> s
    in
    let lead = List.length (List.filter (fun (a : Form.t) ->
        match a.v with Form.List _ -> false | _ -> true) args) in
    (match base with
     | "comment" | "do" -> Some 0
     | "unless" | "loop" -> Some 1
     | "defmacro" -> Some 2
     | "defmethod" -> Some 3
     | _ ->
       (* A with- macro, or any call whose last argument is a statement —
          a let, a loop, an assignment — has a body: the trailing run of
          lists goes in the block. *)
       let stmt_like (a : Form.t) =
         match a.v with
         | Form.List ({ v = Form.Sym h; _ } :: _) ->
           List.mem h [ "let"; "set"; "when"; "unless"; "cond"; "while";
                        "until"; "dotimes"; "match"; "handler-case";
                        "handler-bind"; "restart-case"; "return"; "defer";
                        "do"; "break"; "continue" ]
         | _ -> false
       in
       let is_with = String.length base > 5 && String.sub base 0 5 = "with-" in
       let last_stmt =
         match List.rev args with a :: _ -> stmt_like a | [] -> false
       in
       ignore lead;
       let k = ref 0 in
       List.iteri
         (fun i (a : Form.t) ->
            match a.v with Form.List (_ :: _) -> () | _ -> k := i + 1)
         args;
       (* The block starts at the first statement among the trailing lists,
          so what comes before it — an if's test — stays in the parentheses:
          [if(c):] rather than the test as the block's first line. *)
       let first_stmt =
         let rec go i = function
           | [] -> None
           | a :: rest -> if i >= !k && stmt_like a then Some i else go (i + 1) rest
         in
         go 0 args
       in
       if is_with then Some !k
       else if last_stmt then Some (Option.value first_stmt ~default:!k)
       else
         (* A statement anywhere among the trailing lists makes them a body. *)
         match first_stmt with Some _ -> Some !k | None -> None)
  | _ -> None

let let_sugar (f : Form.t) =
  match f.v with
  | Form.List ({ v = Form.Sym "let"; _ } :: { v = Form.Vec bs; _ } :: _ :: _) ->
    (match pairs bs with None | Some [] -> false | Some _ -> true)
  | _ -> false

(* [Some (k, seq)]: the arguments from [k] on print as a block, and [seq]
   when that block is a body run in order ([Body_macros]), whose start the
   definition gives rather than the guess. *)
let body_split (h : Form.t) args =
  match body_guess h args, h.v with
  | None, Form.Sym s ->
    (* A body with a [let] in it is written as a block, where the [let] can
       be flat. *)
    (match Hashtbl.find_opt !macros.bodies s with
     | Some b when List.exists let_sugar (List.filteri (fun i _ -> i >= b) args) ->
       Some (b, true)
     | _ ->
       (* Any other call with a [let] among its arguments: the trailing run
          of lists as a block, each [let] in a [do:] of its own, rather than
          the [let] written as a call. *)
       if List.exists let_sugar args then begin
         let k = ref 0 in
         List.iteri (fun i (a : Form.t) ->
             match a.v with Form.List (_ :: _) -> () | _ -> k := i + 1) args;
         if List.exists let_sugar (List.filteri (fun i _ -> i >= !k) args)
         then Some (!k, false) else None
       end
       else None)
  | None, _ -> None
  | Some k, Form.Sym s ->
    let n = List.length args in
    (match List.assoc_opt s Body_macros.core, Hashtbl.find_opt !macros.bodies s with
     | Some b, _ | None, Some b when b < n -> Some (b, true)
     | _ -> Some (k, List.mem s [ "defmacro"; "defmethod" ]))
  | Some k, _ -> Some (k, false)

let sugar_heads =
  [ "let"; "set"; "if"; "when"; "cond"; "while"; "until"; "dotimes"; "match";
    "handler-case"; "handler-bind"; "restart-case"; "return"; "defer"; "do";
    "quasiquote"; "update" ]


(* [(do x)]: printed as [do:] and [x] as the one statement of its block. *)
let in_do (x : Form.t) = { x with v = Form.List [ Form.make (Form.Sym "do") x.loc; x ] }

(* [seq] when the block is a body run in order, where a [let] may take in
   the statements after it. Not for the arguments of a call that happen to
   print as a block, whose count that would change. *)
let rec block ?(seq = true) n (fs : Form.t list) : string list =
  let rec go = function
    | [] -> []
    | [ x ] -> stmt n x
    | x :: rest when let_sugar x ->
      (match (if seq && !quasi = 0 then flatten x rest else None) with
       | Some x' -> stmt n x'
       | None -> stmt n (in_do x) @ go rest)
    | x :: rest -> stmt n x @ go rest
  in
  go fs

and stmt n (f : Form.t) : string list =
  in_quasi f @@ fun () ->
  let ls = match sugar n f with Some ls -> ls | None -> plain n f in
  (* The first line carries the line the form came from, for
     [Source_text.weave] to put the comments back by. *)
  match ls with
  | first :: rest -> Source_text.tag f.loc.Loc.line first :: rest
  | [] -> []

and plain n (f : Form.t) : string list =
  let text =
    match f.v with
    | Form.List [] -> "(())"
    | Form.List [ { v = Form.Sym "do"; _ } ] -> "()"
    | Form.Sym s when List.mem s reserved -> paren s
    | _ -> guard (fst (expr f))
  in
  let one = [ ind n ^ text ] in
  match f.v with
  | Form.List (h :: args) when args <> [] ->
    (match body_split h args with
     | Some (k, seq) when k < List.length args ->
       let fixed = List.filteri (fun i _ -> i < k) args in
       let rest = List.filteri (fun i _ -> i >= k) args in
       let opener =
         match h.v, fixed with
         (* No arguments before the block: [comment:] rather than
            [comment():], the author's decision 85. *)
         | Form.Sym s, [] when name_ok s && not (List.mem s reserved) -> s ^ ":"
         (* A header word glued to its parenthesis is the fallback call,
            [if(c):], so it needs no parentheses of its own. *)
         | Form.Sym s, _ :: _ when List.mem s reserved -> s ^ "(" ^ commas fixed ^ "):"
         | _ -> head_text h ^ "(" ^ commas fixed ^ "):"
       in
       [ ind n ^ guard opener ] @ block ~seq (n + 2) rest
     | _ when n + String.length text > width && fst (expr f) = text ->
       wrapped n "" f
     | _ -> one)
  | _ -> one

(* A call too long for its line, broken after commas inside its
   parentheses, where a line break is only whitespace. [prefix] is what
   comes before the call on the first line. *)
and wrapped n prefix (f : Form.t) =
  match f.v with
  | Form.List (h :: (_ :: _ as args)) when (match h.v with
      | Form.Sym ("at" | "quote" | "unquote" | "unquote-splicing") -> false
      | Form.Sym s -> not (R.is_op_word s) && not (String.length s > 1 && s.[0] = '.')
      | _ -> false) ->
    let open_ = prefix ^ head_text h ^ "(" in
    let col = n + String.length open_ in
    let items = comma_items args in
    let rec go line acc = function
      | [] -> List.rev ((line ^ ")") :: acc)
      | [ t ] ->
        if String.length line = col || String.length line + String.length t + 1 <= width
        then go (line ^ t) acc []
        else
          let line = String.sub line 0 (String.length line - 1) in
          go (ind col ^ t) (line :: acc) []
      | t :: rest ->
        let piece = t ^ "," in
        if String.length line = col || String.length line + String.length piece <= width
        then go (line ^ piece ^ " ") acc rest
        else
          let line = String.sub line 0 (String.length line - 1) in
          go (ind col ^ piece ^ " ") (line :: acc) rest
    in
    (* The last item on a line carries a trailing space; the break drops it. *)
    let lines = go (ind n ^ open_) [] items in
    List.map (fun l ->
        let k = String.length l in
        if k > 0 && l.[k - 1] = ' ' then String.sub l 0 (k - 1) else l) lines
  (* A vector literal too long for its line, filled to the width, with the
     separator [vec_text] chose. *)
  | Form.Vec (_ :: _ :: _ as xs) ->
    let open_ = prefix ^ "[" in
    let col = n + String.length open_ in
    let ts = List.map expr xs in
    let sep = if List.for_all (fun (_, l) -> l >= 8) ts then "" else "," in
    let rec go line acc = function
      | [] -> List.rev ((line ^ "]") :: acc)
      | (t, _) :: rest ->
        let piece = if rest = [] then t else t ^ sep in
        if String.length line = col || String.length line + String.length piece + 1 <= width
        then go (line ^ piece ^ (if rest = [] then "" else " ")) acc rest
        else
          let line = String.sub line 0 (String.length line - 1) in
          go (ind col ^ piece ^ (if rest = [] then "" else " ")) (line :: acc) rest
    in
    go (ind n ^ open_) [] ts
  | _ -> [ ind n ^ prefix ^ at 0 f ]

(* [prefix = v], or [prefix =] and the value as an indented block when it is
   too long for the line. *)
and value_lines n prefix (v : Form.t) =
  let inline = prefix ^ " = " ^ at 0 v in
  let is_do =
    match v.v with
    | Form.List ({ v = Form.Sym "do"; _ } :: _ :: _ :: _) -> true
    | _ -> false
  in
  if is_do then [ ind n ^ prefix ^ " =" ] @ block (n + 2) (stmts_of v)
  else if loop_head v <> None then
    let head, body = Option.get (loop_head v) in
    [ ind n ^ prefix ^ " = " ^ head ] @ block (n + 2) body
  else if n + String.length inline <= width then [ ind n ^ inline ]
  else
    match v.v with
    | _ when typed_lambda v <> None ->
      let head, body = Option.get (typed_lambda v) in
      [ ind n ^ prefix ^ " = " ^ head ] @ block (n + 2) body
    | Form.List ({ v = Form.Sym "fn"; _ } :: { v = Form.Vec ps; _ } :: (_ :: _ as body))
      when List.for_all sym_param ps ->
      [ ind n ^ prefix ^ " = fn(" ^ commas ps ^ ")" ] @ block (n + 2) body
    | Form.List ({ v = Form.Sym h; _ } :: _)
      when not (List.mem h sugar_heads || h = "fn" || h = "if") ->
      wrapped n (prefix ^ " = ") v
    | Form.List (_ :: _) -> [ ind n ^ prefix ^ " =" ] @ block (n + 2) (stmts_of v)
    | Form.Vec (_ :: _ :: _) -> wrapped n (prefix ^ " = ") v
    | _ -> [ ind n ^ inline ]

and slot n (f : Form.t) = block n (stmts_of f)

(* [(loop [x a y b] body ...)] as the header [loop x = a, y = b] and its
   body, when every binding is a plain name. A lambda or one-line if as a
   value is parenthesised, so its else cannot run on into the next binding. *)
and loop_head (f : Form.t) =
  match f.v with
  | Form.List ({ v = Form.Sym "loop"; _ } :: { v = Form.Vec bs; _ } :: (_ :: _ as body)) ->
    (match pairs bs with
     | Some (_ :: _ as prs)
       when List.for_all (fun ((x : Form.t), _) ->
           match x.v with Form.Sym x -> def_name x | _ -> false) prs ->
       Some
         ("loop "
          ^ String.concat ", " (List.map (fun (x, v) -> fst (expr x) ^ " = " ^ at 1 v) prs),
          body)
     | _ -> None)
  | _ -> None

and label_of = function
  | ({ Form.v = Form.Kw k; _ }) :: rest when kw_ok k -> (":" ^ k ^ " ", rest)
  | rest -> ("", rest)

and sugar n (f : Form.t) : string list option =
  let i = ind n in
  match f.v with
  | Form.List ({ v = Form.Sym "let"; _ } :: { v = Form.Vec bs; _ } :: (_ :: _ as body)) ->
    (match pairs bs with
     | None | Some [] -> None
     | Some prs -> Some (let_lines n prs body))
  | Form.List [ { v = Form.Sym "update"; _ }; t; { v = Form.Sym ("+" | "-" | "*" | "/"); _ }; _ ]
    when not (R.simple_place t) ->
    Some [ i ^ guard (inline_text f) ]
  | Form.List [ { v = Form.Sym "set"; _ }; t; v ] ->
    let line = i ^ guard (assign_text t v) in
    if String.length line <= width then Some [ line ]
    else Some (value_lines n (guard (at 9 t)) v)
  | Form.List [ { v = Form.Sym "if"; _ }; c; a; b ] ->
    let simple (x : Form.t) =
      match x.v with
      | Form.List ({ v = Form.Sym ("return" | "set" | "break" | "continue"); _ } :: _) -> true
      | Form.List ({ v = Form.Sym h; _ } :: _) -> not (List.mem h sugar_heads)
      | _ -> true
    in
    (* An else that is another if with an else chains on the line:
       [if a then x else if b then y else z]. *)
    let rec chain (x : Form.t) =
      match x.v with
      | Form.List [ { v = Form.Sym "if"; _ }; _; a; b ] -> simple a && chain b
      | _ -> simple x
    in
    let line = i ^ fst (expr f) in
    if simple a && chain b && String.length line <= width && not (!inside f)
    then Some [ line ]
    else
      Some
        ([ i ^ "if " ^ at 1 c ] @ slot (n + 2) a
         @ [ Source_text.tag b.loc.Loc.line (i ^ "else") ] @ slot (n + 2) b)
  | Form.List ({ v = Form.Sym "when"; _ } :: c :: (_ :: _ as body)) ->
    Some ((i ^ "if " ^ at 1 c) :: block (n + 2) body)
  | Form.List ({ v = Form.Sym "cond"; _ } :: args) ->
    (match pairs args with
     | None -> None
     | Some prs ->
       let tests, else_ =
         match List.rev prs with
         | (k, e) :: rest when is_else k -> (List.rev rest, Some (k, e))
         | _ -> (prs, None)
       in
       if List.length tests < 2 then None
       else
         Some
           (List.concat
              (List.mapi
                 (fun j (c, b) ->
                    (* Each test's line carries the test's own line, so a
                       comment written above a clause stays above it. *)
                    Source_text.tag (c : Form.t).loc.Loc.line
                      (i ^ (if j = 0 then "if " else "elif ") ^ at 1 c)
                    :: slot (n + 2) b)
                 tests)
            @ (match else_ with
               | Some ((k : Form.t), e) ->
                 Source_text.tag k.loc.Loc.line (i ^ "else") :: slot (n + 2) e
               | None -> [])))
  | Form.List ({ v = Form.Sym (("while" | "until") as w); _ } :: rest) ->
    let lbl, rest = label_of rest in
    (match rest with
     | c :: (_ :: _ as body) -> Some ((i ^ w ^ " " ^ lbl ^ at 0 c) :: block (n + 2) body)
     | _ -> None)
  | Form.List ({ v = Form.Sym "dotimes"; _ } :: rest) ->
    let lbl, rest = label_of rest in
    (* The variable is a name, or in a template an unquote, [for ~i in ...]. *)
    let var (f : Form.t) =
      match f.v with
      | Form.Sym v when def_name v && v <> "in" -> Some v
      | Form.List [ { v = Form.Sym "unquote"; _ }; _ ] -> Some (fst (expr f))
      | _ -> None
    in
    (match rest with
     | { v = Form.Vec (vf :: bs); _ } :: (_ :: _ as body)
       when var vf <> None && bs <> [] && List.length bs <= 3 ->
       let v = Option.get (var vf) in
       Some
         ((i ^ "for " ^ lbl ^ v ^ " in range(" ^ commas bs ^ ")") :: block (n + 2) body)
     | _ -> None)
  | Form.List [ { v = Form.Sym "return"; _ } ] -> Some [ i ^ "return" ]
  | Form.List [ { v = Form.Sym "return"; _ }; v ] -> Some [ i ^ "return " ^ at 0 v ]
  | Form.List [ { v = Form.Sym (("break" | "continue") as w); _ } ] -> Some [ i ^ w ]
  | Form.List [ { v = Form.Sym (("break" | "continue") as w); _ }; { v = Form.Kw k; _ } ]
    when kw_ok k ->
    Some [ i ^ w ^ " :" ^ k ]
  | Form.List [ { v = Form.Sym "defer"; _ }; x ] ->
    let line = i ^ "defer " ^ inline_text x in
    if String.length line <= width then Some [ line ]
    else Some ((i ^ "defer") :: block (n + 2) [ x ])
  | Form.List ({ v = Form.Sym "defer"; _ } :: (_ :: _ :: _ as body)) ->
    Some ((i ^ "defer") :: block (n + 2) body)
  | Form.List ({ v = Form.Sym "match"; _ } :: s :: (_ :: _ as arms)) ->
    (match pairs arms with
     | None -> None
     | Some prs ->
       Some
         ((i ^ "match " ^ at 0 s)
          :: List.concat_map
            (fun ((pat : Form.t), body) ->
               List.mapi (fun k l -> if k = 0 then Source_text.tag pat.loc.Loc.line l else l) @@
               let pt = at 8 pat in
               let line = ind (n + 2) ^ pt ^ " -> " ^ inline_text body in
               match body.v with
               | Form.List ({ v = Form.Sym "do"; _ } :: _ :: _ :: _) ->
                 (ind (n + 2) ^ pt ^ " ->") :: slot (n + 4) body
               | Form.List (_ :: _) when String.length line > width ->
                 (ind (n + 2) ^ pt ^ " ->") :: slot (n + 4) body
               | _ -> [ line ])
            prs))
  | Form.List [ { v = Form.Sym "handler-case"; _ }; body; { v = Form.Vec cls; _ } ]
    when cls <> [] ->
    Option.map
      (fun cl -> ((i ^ "handler-case") :: slot (n + 2) body) @ cl)
      (handler_clauses n cls)
  | Form.List ({ v = Form.Sym "handler-bind"; _ } :: { v = Form.Vec cls; _ } :: (_ :: _ as body))
    when cls <> [] ->
    Option.map
      (fun cl -> ((i ^ "handler-bind") :: block (n + 2) body) @ cl)
      (handler_clauses n cls)
  | Form.List ({ v = Form.Sym "restart-case"; _ } :: body :: (_ :: _ as cls)) ->
    let clause (c : Form.t) =
      match c.v with
      | Form.List ({ v = Form.Sym r; _ } :: { v = Form.Vec ps; _ } :: (_ :: _ as b))
        when def_name r ->
        let report, b =
          match b with
          | { v = Form.Kw "report"; _ } :: ({ v = Form.Str _; _ } as t) :: (_ :: _ as rest) ->
            (" " ^ fst (expr t), rest)
          | _ -> ("", b)
        in
        Option.map
          (fun pt -> (i ^ "restart " ^ r ^ "(" ^ pt ^ ")" ^ report) :: block (n + 2) b)
          (params_text ps)
      | _ -> None
    in
    let cs = List.map clause cls in
    if List.mem None cs then None
    else
      Some (((i ^ "restart-case") :: slot (n + 2) body)
            @ List.concat_map Option.get cs)
  | Form.List [ { v = Form.Sym "quasiquote"; _ }; x ] ->
    Some ((i ^ "quote") :: slot (n + 2) x)
  | Form.List ({ v = Form.Sym "fn"; _ } :: { v = Form.Vec ps; _ } :: (_ :: _ :: _ as body))
    when List.for_all sym_param ps ->
    Some ((guard (i ^ "fn(" ^ commas ps ^ ")")) :: block (n + 2) body)
  | Form.List ({ v = Form.Sym (("defn" | "defn-") as d); _ } :: { v = Form.Sym name; _ }
               :: { v = Form.Vec ps; _ } :: ret :: body)
    when def_name name ->
    (match params_text ~shaped:true ps with
     | None -> None
     | Some pt ->
       let where_, body =
         match body with
         | { v = Form.Map [ { v = Form.Kw "where"; _ }; x ]; _ } :: rest ->
           let preds =
             match x.v with
             | Form.Vec (_ :: _ :: _ as xs) -> commas xs
             | _ -> at 0 x
           in
           (" where " ^ preds, rest)
         | _ -> ("", body)
       in
       let head =
         i ^ (if d = "defn" then "fn " else "fn- ") ^ name ^ "(" ^ pt ^ ")"
         (* [_] is what the reader makes of no arrow at all. *)
         ^ (match ret.v with Form.Sym "_" -> "" | _ -> " -> " ^ ty ret)
         ^ where_
       in
       (match body with
        | [] -> Some [ head ]
        | [ x ] when (match x.v with
            | Form.List (({ v = Form.Sym h; _ } as hf) :: args) ->
              (* A call that takes a block is a statement, not a value. *)
              not (List.mem h sugar_heads) && body_split hf args = None
            | _ -> true)
                  && String.length head + 3 + String.length (at 0 x) <= width
                  && not (!inside f) ->
          Some [ head ^ " = " ^ unit_text x ]
        | _ -> Some (head :: block (n + 2) body)))
  | Form.List ({ v = Form.Sym (("def" | "defonce" | "defconst") as d); _ }
               :: { v = Form.Sym name; _ } :: rest)
    when def_name name ->
    let w = match d with "def" -> "def" | "defonce" -> "once" | _ -> "const" in
    let pre = i ^ w ^ " " ^ name in
    (match d, rest with
     | "defconst", [ v ] -> Some (value_lines n (w ^ " " ^ name) v)
     | "defconst", [ t; v ] -> Some (value_lines n (w ^ " " ^ name ^ ": " ^ ty t) v)
     | "defconst", _ -> None
     | _, [ t; v ] when is_sym "dyn" t -> Some (value_lines n (w ^ " " ^ name) v)
     | _, [ t ] when type_shaped t -> Some [ pre ^ ": " ^ ty t ]
     | _, [ t; v ] -> Some (value_lines n (w ^ " " ^ name ^ ": " ^ ty t) v)
     | _ -> None)
  | Form.List ({ v = Form.Sym "loop"; _ } :: _) when loop_head f <> None ->
    let head, body = Option.get (loop_head f) in
    Some ((i ^ head) :: block (n + 2) body)
  | Form.List ({ v = Form.Sym "defmacro"; _ } :: { v = Form.Sym name; _ }
               :: { v = Form.Vec ps; _ } :: (_ :: _ as body))
    when def_name name ->
    (* A parameter is a name, a destructuring vector, or & and the rest's
       name, last. *)
    let rec go = function
      | [] -> Some []
      | [ { Form.v = Form.Sym "&"; _ }; { Form.v = Form.Sym r; _ } ] when def_name r ->
        Some [ "& " ^ r ]
      | { Form.v = Form.Sym x; _ } :: rest when def_name x && x <> "&" ->
        Option.map (fun r -> x :: r) (go rest)
      | ({ Form.v = Form.Vec _; _ } as v) :: rest ->
        Option.map (fun r -> fst (expr v) :: r) (go rest)
      | _ -> None
    in
    Option.map
      (fun pt ->
         (i ^ "macro " ^ name ^ "(" ^ String.concat ", " pt ^ ")") :: block (n + 2) body)
      (go ps)
  | Form.List ({ v = Form.Sym (("defstruct" | "defunion") as d); _ }
               :: { v = Form.Sym name; _ } :: rest)
    when def_name name
      && (match d, rest with
          | _, [ { v = Form.Vec _; _ } ] -> true
          (* [(defstruct N :parent P [])] keeps the fallback: no field lines
             reads as the form with no vector. *)
          | "defstruct", [ { v = Form.Kw "parent"; _ }; { v = Form.Sym pn; _ } ]
          | "defstruct", [ { v = Form.Kw "parent"; _ }; { v = Form.Sym pn; _ };
                           { v = Form.Vec (_ :: _); _ } ] ->
            def_name pn
          | _ -> false) ->
    let parent, fs =
      match rest with
      | [ { v = Form.Vec fs; _ } ] -> ("", fs)
      | [ _; pf ] -> (" :parent " ^ ty pf, [])
      | [ _; pf; { v = Form.Vec fs; _ } ] -> (" :parent " ^ ty pf, fs)
      | _ -> assert false
    in
    (match pairs fs with
     | Some prs when List.for_all (fun ((f : Form.t), _) ->
         match f.v with Form.Sym x -> def_name x | _ -> false) prs ->
       Some
         ((i ^ (if d = "defstruct" then "struct " else "union ") ^ name ^ parent)
          :: List.map
            (fun ((f : Form.t), t) ->
               let fname = fst (expr f) in
               Source_text.tag f.loc.Loc.line
                 (ind (n + 2) ^ if is_sym "dyn" t then fname else fname ^ ": " ^ ty t))
            prs)
     | _ -> None)
  | Form.List [ { v = Form.Sym "defalias"; _ }; { v = Form.Sym name; _ }; t ]
    when def_name name && type_shaped t ->
    Some [ i ^ "type " ^ name ^ " = " ^ ty t ]
  | Form.List [ { v = Form.Sym "defdata"; _ }; { v = Form.Sym name; _ }; { v = Form.Vec cs; _ } ]
    when def_name name ->
    let case (c : Form.t) =
      Option.map (Source_text.tag c.loc.Loc.line) @@
      match c.v with
      | Form.Sym s when def_name s -> Some s
      | Form.List [ { v = Form.Sym s; _ }; { v = Form.Vec ps; _ } ] when def_name s ->
        Option.map (fun pt -> s ^ "(" ^ pt ^ ")") (params_text ps)
      | _ -> None
    in
    let cs = List.map case cs in
    if List.mem None cs then None
    else
      Some ((i ^ "data " ^ name)
            :: List.map (fun c ->
                let tags, body = Source_text.untag (Option.get c) in
                List.fold_left (fun l t -> Source_text.tag t l) (ind (n + 2) ^ body) tags) cs)
  | Form.List [ { v = Form.Sym "defenum"; _ }; { v = Form.Sym name; _ }; { v = Form.Vec ms; _ } ]
    when def_name name ->
    let rec members = function
      | ({ Form.v = Form.Sym m; _ } as mf) :: ({ Form.v = Form.Int _ | Form.UInt _; _ } as v) :: rest
        when def_name m ->
        Option.map (fun r -> (mf.loc.Loc.line, m ^ " = " ^ fst (expr v)) :: r) (members rest)
      | ({ Form.v = Form.Sym m; _ } as mf) :: rest when def_name m ->
        Option.map (fun r -> (mf.loc.Loc.line, m) :: r) (members rest)
      | [] -> Some []
      | _ -> None
    in
    Option.map
      (fun ms ->
         (i ^ "enum " ^ name)
         :: List.map (fun (l, m) -> Source_text.tag l (ind (n + 2) ^ m)) ms)
      (members ms)
  | Form.List [ { v = Form.Sym "import"; _ }; { v = Form.Sym a; _ }; ({ v = Form.Str _; _ } as p) ]
    when def_name a ->
    Some [ i ^ "import " ^ a ^ " " ^ fst (expr p) ]
  | _ -> None

and is_else (f : Form.t) = match f.v with Form.Kw "else" -> true | _ -> false

and handler_clauses n cls =
  let clause (c : Form.t) =
    match c.v with
    | Form.List (t :: { v = Form.Vec [ { v = Form.Sym v; _ } ]; _ } :: (_ :: _ as b))
      when def_name v ->
      Some ((ind n ^ "on " ^ at 9 t ^ "(" ^ v ^ ")") :: block (n + 2) b)
    | _ -> None
  in
  let cs = List.map clause cls in
  if List.mem None cs then None else Some (List.concat_map Option.get cs)

(* A [let] is always written flat: [block] has made it the last statement of
   its block, so its body is the rest of the block. *)
and let_lines n prs body =
  (* [(let [x (the T v)])] is [let x: T = v]. *)
  let bind ((t : Form.t), (v : Form.t)) =
    match t.v, v.v with
    | Form.Sym x, Form.List [ { v = Form.Sym "the"; _ }; ty_; w ]
      when def_name x && typed_lambda v = None ->
      ("let " ^ x ^ ": " ^ ty ty_, w)
    | _ -> ("let " ^ guard (at 8 t), v)
  in
  (* Each binding line carries its own source line, so a comment written
     after a binding stays on it. *)
  let tagged ((t : Form.t), _) = function
    | first :: more -> Source_text.tag t.loc.Loc.line first :: more
    | [] -> []
  in
  let lines n b = let p, v = bind b in tagged b (value_lines n p v) in
  List.concat_map (lines n) prs @ block n body

(** A whole file: top-level forms with a blank line between them. [macros]
    is [Body_macros.table] of the file; without it, the prelude's and the
    file's own macros are known and no imported package's. *)
let program ?source ?macros:m (fs : Form.t list) : string =
  macros := (match m with Some m -> m | None -> Body_macros.table fs);
  spelling :=
    (match source with Some src -> Source_text.spelling src | None -> fun _ -> None);
  let cs = match source with Some src -> Source_text.comments src | None -> [] in
  (inside :=
     fun (f : Form.t) ->
       List.exists
         (fun (c : Source_text.comment) ->
            f.loc.Loc.line <= c.line && c.line < f.loc.Loc.eline)
         cs);
  (* A flat [let] at the top level would take in the forms after it, so one
     that is not last goes in a [do:] block. *)
  let top x =
    Hashtbl.reset used;
    Hashtbl.reset made;
    note_used x;
    String.concat "\n" (stmt 0 x)
  in
  let rec go = function
    | [] -> []
    | [ x ] -> [ (x, top x) ]
    | x :: rest -> (x, top (if let_sugar x then in_do x else x)) :: go rest
  in
  let text =
    try Source_text.join_top (go fs) ^ "\n"
    with e -> spelling := (fun _ -> None); inside := (fun _ -> false); raise e
  in
  spelling := (fun _ -> None);
  inside := (fun _ -> false);
  (* With the source, its comments go back where they were; without it the
     tags come out and nothing goes in. *)
  Source_text.weave ~starts:(Source_text.form_starts fs)
    (match source with Some src -> Source_text.comments src | None -> [])
    text