1008 lines
42 KiB
OCaml
1008 lines
42 KiB
OCaml
(** [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
|
|
(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)
|
|
(* [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)
|
|
| _ ->
|
|
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_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;
|
|
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 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 ^ ":"
|
|
| _ -> 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
|
|
| _ -> [ 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 (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
|
|
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; _ } 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 ^ " = " ^ 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] 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 ->
|
|
("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 ] -> [ top x ]
|
|
| x :: rest -> top (if let_sugar x then in_do x else 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
|