flan/lib/paren_printer.ml

(** [Form.t] to paren text, for [flan convert] of a [.fln] file: the other
    direction of [Indent_printer]. It keeps what [Form.pretty] cannot — the
    source's number spellings and comments, through [Source_text] — and lays
    a form out the way the corpus is written: flat when it fits, otherwise
    the head and the arguments that name the form on the first line and the
    rest one per line, two columns in. *)

let width = 80

let rec flat spell (f : Form.t) =
  let seq l = String.concat " " (List.map (flat spell) l) in
  match f.v with
  | Form.Int _ | Form.Float _ ->
    (match spell f with Some t -> t | None -> Form.to_source f)
  | Form.List l -> "(" ^ seq l ^ ")"
  | Form.Vec l -> "[" ^ seq l ^ "]"
  | Form.Map l -> "{" ^ seq l ^ "}"
  | _ -> Form.to_source f

(* How many arguments stay on the head's line when the form is broken. *)
let kept head =
  match head with
  | "defn" | "defn-" | "defmethod" -> 3
  | "defmacro" | "def" | "defonce" | "defconst" | "defstruct" | "defunion"
  | "defdata" | "defenum" | "import" | "defalias" -> 2
  | "do" | "cond" | "comment" | "restart-case" | "handler-case" -> 0
  | _ -> 1

(* [inside l] says whether a comment sits on a line of [f] before its last,
   where a flat [f] would leave it nowhere to go: such a form is broken. *)
let rec layout ?(inside = fun _ -> false) spell col (f : Form.t) : string list =
  let layout = layout ~inside in
  let one = flat spell f in
  let tagl (x : Form.t) = function
    | first :: rest -> Source_text.tag x.loc.Loc.line first :: rest
    | [] -> []
  in
  if col + String.length one <= width && not (inside f) then [ one ]
  else
    let bracket o c items ~keep =
      let placed inner x =
        match layout spell inner x with
        | first :: more ->
          (* The pad goes after any tags, which lead the line. *)
          let tags, body = Source_text.untag first in
          let padded =
            List.fold_left (fun l t -> Source_text.tag t l) (String.make inner ' ' ^ body) tags
          in
          tagl x (padded :: more)
        | [] -> []
      in
      let lines =
        let head_len k =
          col + 1 + String.length
                      (String.concat " " (List.map (flat spell) (List.filteri (fun i _ -> i < k) items)))
        in
        let keep = if keep > 1 && head_len keep > width then 1 else keep in
        if keep > 0 then
          let first = List.filteri (fun i _ -> i < keep) items in
          let rest = List.filteri (fun i _ -> i >= keep) items in
          let before = List.filteri (fun i _ -> i < keep - 1) first in
          match List.nth first (keep - 1) with
          (* A binding vector with a comment inside it — [(let [a 1 ; first
             b 2] ...)] — goes a pair to a line, each line carrying its pair's
             source line, so a comment after a binding stays on it. *)
          | { Form.v = Form.Vec vs; _ } as v
            when keep > 1 && inside v && List.length vs mod 2 = 0 ->
            let lead = o ^ String.concat " " (List.map (flat spell) before) ^ " [" in
            let pad = String.make (col + String.length lead) ' ' in
            let rec pairs k = function
              | (a : Form.t) :: b :: more ->
                Source_text.tag a.loc.Loc.line
                  ((if k = 0 then lead else pad) ^ flat spell a ^ " " ^ flat spell b)
                :: pairs (k + 1) more
              | _ -> []
            in
            let ps = pairs 0 vs in
            let np = List.length ps in
            List.mapi (fun i l -> if i = np - 1 then l ^ "]" else l) ps
            @ List.concat_map (placed (col + 2)) rest
          | _ ->
            (o ^ String.concat " " (List.map (flat spell) first))
            :: List.concat_map (placed (col + 2)) rest
        else
          match items with
          | [] -> [ o ]
          | x :: xs ->
            (match layout spell (col + 1) x with
             | first :: more ->
               let tags, body = Source_text.untag first in
               List.fold_left (fun l t -> Source_text.tag t l) (o ^ body) tags :: more
             | [] -> [ o ])
            @ List.concat_map (placed (col + 1)) xs
      in
      let n = List.length lines in
      List.mapi (fun i l -> if i = n - 1 then l ^ c else l) lines
    in
    match f.v with
    | Form.List (({ v = Form.Sym h; _ }) :: _ as items) ->
      bracket "(" ")" items ~keep:(1 + min (kept h) (List.length items - 1))
    | Form.List items -> bracket "(" ")" items ~keep:0
    | Form.Vec items -> bracket "[" "]" items ~keep:0
    | Form.Map items -> bracket "{" "}" items ~keep:0
    | _ -> [ one ]

(** A whole file, with [source]'s comments and spellings when given. *)
let program ?source (fs : Form.t list) : string =
  let spell =
    match source with Some src -> Source_text.spelling src | None -> fun _ -> None
  in
  let cs = match source with Some src -> Source_text.comments src | None -> [] in
  let inside (f : Form.t) =
    List.exists
      (fun (c : Source_text.comment) ->
         f.loc.Loc.line <= c.line && c.line < f.loc.Loc.eline)
      cs
  in
  let text =
    String.concat "\n\n"
      (List.map
         (fun (f : Form.t) ->
            String.concat "\n"
              (match layout ~inside spell 0 f with
               | first :: rest -> Source_text.tag f.loc.Loc.line first :: rest
               | [] -> []))
         fs)
    ^ "\n"
  in
  Source_text.weave ~starts:(Source_text.form_starts fs) cs text