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

(* ── 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) -> 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
    (String.concat (" " ^ op ^ " ") (ft :: List.map (at (lvl + 1)) 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)
  | 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)
          | _ ->
            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 "fn", [ { v = Form.Vec ps; _ }; body ] when List.for_all sym_param ps ->
    ("fn(" ^ commas ps ^ ") = " ^ at 0 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
  | 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

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

(* 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
  if spaced && List.mem w reserved 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_split (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;
       if is_with || last_stmt then begin
         let k = ref 0 in
         List.iteri
           (fun i (a : Form.t) ->
              match a.v with Form.List (_ :: _) -> () | _ -> k := i + 1)
           args;
         Some !k
       end
       else None)
  | _ -> None

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

let rec block n (fs : Form.t list) : string list =
  let rec go = function
    | [] -> []
    | [ x ] -> stmt n ~last:true x
    | x :: rest -> stmt n ~last:false x @ go rest
  in
  go fs

and stmt n ~last (f : Form.t) : string list =
  let ls = match sugar n ~last 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 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 ^ ":"
         | _ -> head_text h ^ "(" ^ commas fixed ^ "):"
       in
       [ ind n ^ guard opener ] @ block (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
  | _ -> [ 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 n + String.length inline <= width then [ ind n ^ inline ]
  else
    match v.v with
    | 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)
    | _ -> [ ind n ^ inline ]

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

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

and sugar n ~last (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 ~last 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
    let line = i ^ fst (expr f) in
    if simple a && simple 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
    (match rest with
     | { v = Form.Vec ({ v = Form.Sym v; _ } :: bs); _ } :: (_ :: _ as body)
       when def_name v && bs <> [] && List.length bs <= 3 && v <> "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 ->
        Option.map
          (fun pt -> (i ^ "restart " ^ r ^ "(" ^ pt ^ ")") :: 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 ^ ") -> "
         ^ ty ret ^ where_
       in
       (match body with
        | [] -> Some [ head ]
        | [ x ] when (match x.v with
            | Form.List ({ v = Form.Sym h; _ } :: _) -> not (List.mem h sugar_heads)
            | _ -> true)
                  && String.length head + 3 + String.length (at 0 x) <= width
                  && not (!inside f) ->
          Some [ head ^ " = " ^ at 0 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 (("defstruct" | "defunion") as d); _ };
                { v = Form.Sym name; _ }; { v = Form.Vec fs; _ } ]
    when def_name name ->
    (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)
          :: 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 "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] last in its block reads to the block's end, so it is written flat.
   One with siblings after it takes its body as an indented block under the
   first binding, and the rest of the bindings go inside that block. *)
and let_lines n ~last 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 ->
      ("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
  if last then List.concat_map (lines n) prs @ block n body
  else
    match prs with
    | b :: rest ->
      let p, v = bind b in
      tagged b [ ind n ^ p ^ " = " ^ at 0 v ]
      @ List.concat_map (lines (n + 2)) rest
      @ block (n + 2) body
    | [] -> block n body

(** A whole file: top-level forms with a blank line between them. *)
let program ?source (fs : Form.t list) : string =
  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);
  let rec go = function
    | [] -> []
    | [ x ] -> [ String.concat "\n" (stmt 0 ~last:true x) ]
    | x :: rest -> String.concat "\n" (stmt 0 ~last:false x) :: go rest
  in
  let text =
    try String.concat "\n\n" (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