JosephFerano/flan
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity
flan/lib/indent_printer.ml

726 lines
29 KiB
OCaml
Raw Blame History

(** [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
| _ -> 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 ->
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" ]
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 "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
Reference in New Issue View Git Blame Copy Permalink