1658 lines
69 KiB
OCaml
1658 lines
69 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
|
|
|
|
(* While [hole_lines] looks for where a lambda sits in a line, the lambda is
|
|
printed as [hole_sym], at a lambda's level. *)
|
|
let hole = ref false
|
|
let hole_sym = "\003lambda\003"
|
|
|
|
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
|
|
|
|
(* [f] as a comparison chain that mixes < with <=, or > with >=: its operands
|
|
and operators, when the reader would read the chain back as [f] itself.
|
|
The candidate is rebuilt by the reader's own [cmp_chain] and compared up to
|
|
the names its [let]s bind, so an [and] of tests that only looks like a
|
|
chain, or a [let] the reader would not have made, prints as it is. *)
|
|
let chain_of (f : Form.t) =
|
|
let rec eq env (a : Form.t) (b : Form.t) =
|
|
match a.v, b.v with
|
|
| Form.Sym x, Form.Sym y ->
|
|
(match List.assoc_opt x env with
|
|
| Some y' -> y = y'
|
|
| None -> x = y && not (List.exists (fun (_, y') -> y' = y) env))
|
|
| Form.List ({ v = Form.Sym "let"; _ } :: { v = Form.Vec bx; _ } :: xs),
|
|
Form.List ({ v = Form.Sym "let"; _ } :: { v = Form.Vec by; _ } :: ys) ->
|
|
let rec binds env bx by =
|
|
match bx, by with
|
|
| ({ Form.v = Form.Sym tx; _ }) :: vx :: bx', ({ Form.v = Form.Sym ty; _ }) :: vy :: by' ->
|
|
if eq env vx vy then binds ((tx, ty) :: env) bx' by' else None
|
|
| [], [] -> Some env
|
|
| _ -> None
|
|
in
|
|
(match binds env bx by with
|
|
| Some env -> List.length xs = List.length ys && List.for_all2 (eq env) xs ys
|
|
| None -> false)
|
|
| Form.List xs, Form.List ys | Form.Vec xs, Form.Vec ys | Form.Map xs, Form.Map ys ->
|
|
List.length xs = List.length ys && List.for_all2 (eq env) xs ys
|
|
| x, y -> x = y
|
|
in
|
|
let subst env (x : Form.t) =
|
|
match x.v with
|
|
| Form.Sym s -> Option.value (List.assoc_opt s env) ~default:x
|
|
| _ -> x
|
|
in
|
|
(* The tests, left to right, with each bound name replaced by its value. *)
|
|
let rec tests env (f : Form.t) =
|
|
match f.v with
|
|
| Form.List [ { v = Form.Sym "let"; _ }; { v = Form.Vec bs; _ }; body ] ->
|
|
let rec binds env = function
|
|
| ({ Form.v = Form.Sym t; _ }) :: v :: rest -> binds ((t, subst env v) :: env) rest
|
|
| [] -> Some env
|
|
| _ -> None
|
|
in
|
|
Option.bind (binds env bs) (fun env -> tests env body)
|
|
| Form.List ({ v = Form.Sym "and"; _ } :: (_ :: _ :: _ as cs)) ->
|
|
List.fold_left
|
|
(fun acc c -> Option.bind acc (fun l -> Option.map (( @ ) l) (tests env c)))
|
|
(Some []) cs
|
|
| Form.List [ { v = Form.Sym op; _ }; a; b ] when R.cmp_dir op <> None ->
|
|
Some [ (op, subst env a, subst env b) ]
|
|
| _ -> None
|
|
in
|
|
let rec linked = function
|
|
| (_, _, b) :: ((_, a, _) :: _ as rest) -> eq [] b a && linked rest
|
|
| _ -> true
|
|
in
|
|
(* In a template the paren text spells a [~cmp] name as the unquoted call
|
|
that makes it, [~(Form.Sym {.s "~cmp1"})]: read it as the name. *)
|
|
let rec unwrap (x : Form.t) =
|
|
match x.v with
|
|
| Form.List [ { v = Form.Sym "unquote"; _ };
|
|
{ v = Form.List [ { v = Form.Sym "Form.Sym"; _ };
|
|
{ v = Form.Map [ { v = Form.Sym ".s"; _ };
|
|
{ v = Form.Str n; _ } ]; _ } ]; _ } ]
|
|
when String.length n > 4 && String.sub n 0 4 = "~cmp" -> { x with v = Form.Sym n }
|
|
| Form.List l -> { x with v = Form.List (List.map unwrap l) }
|
|
| Form.Vec l -> { x with v = Form.Vec (List.map unwrap l) }
|
|
| _ -> x
|
|
in
|
|
match f.v with
|
|
| Form.List ({ v = Form.Sym ("and" | "let"); _ } :: _) ->
|
|
let f = unwrap f in
|
|
(match tests [] f with
|
|
| Some (((op1, x0, _) :: _ :: _) as ts)
|
|
when linked ts
|
|
&& List.for_all (fun (op, _, _) -> R.cmp_dir op = R.cmp_dir op1) ts
|
|
&& List.exists (fun (op, _, _) -> op <> op1) ts ->
|
|
let xs = x0 :: List.map (fun (_, _, b) -> b) ts in
|
|
let ops = List.map (fun (op, _, _) -> op) ts in
|
|
let n = ref 0 in
|
|
let fresh () = incr n; Printf.sprintf "~cmp%d" !n in
|
|
if eq [] f (R.cmp_chain ~fresh f.loc xs ops) then Some (xs, ops) else None
|
|
| _ -> None)
|
|
| _ -> None
|
|
|
|
let is_chain f = chain_of f <> None
|
|
|
|
(* 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 && not (is_chain f) ->
|
|
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: 13 an atom
|
|
or bracket, 12 a postfix chain, 11 a prefix [-] or [~~], 1-10 binary, 3
|
|
[not], 0 a one-line [if] or a lambda. *)
|
|
(* The operator a head prints as: [=] is [==], and the bit words are the
|
|
operators the reader turns into them. *)
|
|
let infix_op = function
|
|
| "=" -> "==" | "bit-and" -> "&&" | "bit-or" -> "||" | "bit-xor" -> "^^"
|
|
| s -> s
|
|
|
|
let rec expr (f : Form.t) : string * int =
|
|
match f.v with
|
|
| Form.Sym s when !hole && s = hole_sym -> (s, 0)
|
|
| Form.Sym s -> sym f s
|
|
| Form.Kw k ->
|
|
if kw_ok k then (":" ^ k, 13) 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 11 else 13)
|
|
| Form.UInt (_, s) -> (s, 13)
|
|
| 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 11 else 13)
|
|
| Form.Str s -> ("\"" ^ Form.escape s ^ "\"", 13)
|
|
| Form.Byte b -> (Form.byte_repr b, 13)
|
|
| Form.Vec xs -> ("[" ^ vec_text xs ^ "]", 13)
|
|
| Form.Map xs -> ("{" ^ map_text xs ^ "}", 13)
|
|
| Form.List [] -> ("()", 13)
|
|
| Form.List _ when is_chain f ->
|
|
let xs, ops = Option.get (chain_of f) in
|
|
let lvl = Option.get (R.binop_level (List.hd ops)) in
|
|
let ts = List.map (at (lvl + 1)) xs in
|
|
(List.hd ts
|
|
^ String.concat "" (List.map2 (fun op t -> " " ^ op ^ " " ^ t) ops (List.tl ts)),
|
|
lvl)
|
|
| 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, 13)
|
|
else if name_ok s then (s, 13)
|
|
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 >= 11) 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 >= 11) ts then String.concat " " (List.map fst ts)
|
|
else
|
|
let rec pairs = function
|
|
| (k, kl) :: (v, _) :: rest ->
|
|
((if kl < 11 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 12 h
|
|
|
|
and list f h args =
|
|
let call () = (head_text h ^ "(" ^ commas args ^ ")", 12) in
|
|
match h.v, args with
|
|
| Form.Sym "quote", [ x ] -> ("'" ^ Form.to_source x, 13)
|
|
(* [~~] is bit-not, so an unquote of anything that starts with [~] is
|
|
parenthesised: [~(~x)]. *)
|
|
| Form.Sym "unquote", [ x ] ->
|
|
let t = at 13 x in
|
|
((if t <> "" && t.[0] = '~' then "~(" ^ t ^ ")" else "~" ^ t), 13)
|
|
| Form.Sym "unquote-splicing", [ x ] -> ("~@" ^ at 13 x, 13)
|
|
| Form.Sym s, _ :: _ :: _
|
|
when R.is_binop (infix_op s) && s <> "==" && s <> "??"
|
|
&& not (s = "!=" && List.length args > 2) ->
|
|
let op = infix_op 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' :: _ :: _ :: _) -> (match h'.v with Form.Sym s' -> infix_op s' = op | _ -> false) || lvl = 4
|
|
| _ -> false
|
|
in
|
|
let ft = if fl < lvl || (fl = lvl && same) then paren ft else ft in
|
|
(* [(a and b) or c]: the parentheses precedence makes optional are
|
|
written, as most readers expect them. *)
|
|
let and_in_or (x : Form.t) t =
|
|
match x.v with
|
|
| Form.List ({ v = Form.Sym "and"; _ } :: _ :: _ :: _) when s = "or" && t.[0] <> '(' -> paren t
|
|
| _ -> t
|
|
in
|
|
let ft = and_in_or first ft in
|
|
(String.concat (" " ^ op ^ " ")
|
|
(ft :: List.map (fun x -> and_in_or x (at (lvl + 1) x)) rest), lvl)
|
|
| Form.Sym "-", [ x ] ->
|
|
let t, l = expr x in
|
|
if l >= 12 && t <> "" && R.is_neg_char t.[0] then ("-" ^ t, 11)
|
|
else ("-(" ^ at 0 x ^ ")", 12)
|
|
| Form.Sym "not", [ x ] -> ("not " ^ at 3 x, 3)
|
|
| Form.Sym ("bit-not" | "~~"), [ x ] -> ("~~" ^ at 11 x, 11)
|
|
(* [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 12 t ^ "[" ^ commas idx ^ "]", 12)
|
|
| 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 >= 12
|
|
&& (match t.v with
|
|
| Form.Byte _ -> false
|
|
| Form.Sym x -> name_ok x && not (String.contains x '.') && not (R.capitalised x)
|
|
(* A field of a field chains: [w.x.count]. *)
|
|
| Form.List [ { v = Form.Sym f; _ }; _ ]
|
|
when String.length f > 1 && f.[0] = '.' && tt <> "" && tt.[0] <> '.' ->
|
|
String.length tt > 0 && not (String.contains tt ' ')
|
|
| _ ->
|
|
let c = tt.[String.length tt - 1] in
|
|
c = ')' || c = ']' || c = '}' || c = '"')
|
|
in
|
|
if glued then (tt ^ s, 12) else call ()
|
|
| Form.Sym s, [ ({ v = Form.Map _; _ } as m) ] when name_ok s && R.capitalised s ->
|
|
(s ^ fst (expr m), 12)
|
|
| Form.Sym "the", _ when (match typed_lambda f with Some (_, [ _ ]) -> true | _ -> false) ->
|
|
(match typed_lambda f with
|
|
| Some (head, [ body ]) -> (head ^ " => " ^ unit_text body, 0)
|
|
| _ -> assert false)
|
|
| Form.Sym "fn", [ { v = Form.Vec ps; _ }; body ] when List.for_all sym_param ps ->
|
|
("fn(" ^ commas ps ^ ") => " ^ unit_text body, 0)
|
|
| Form.Sym "if", [ c; a; b ] ->
|
|
("if " ^ at 1 c ^ " then " ^ inline_text ~lvl:1 a ^ " else " ^ inline_text b, 0)
|
|
(* A used when is a value, [when c then a]. *)
|
|
| Form.Sym "when", [ c; a ] -> ("when " ^ at 1 c ^ " then " ^ inline_text a, 0)
|
|
| Form.Sym "if-let", ({ v = Form.Vec [ _; _ ]; _ } as hd) :: a :: ([] | [ _ ] as b) ->
|
|
(if_let_head hd ^ " then " ^ inline_text ~lvl:1 a
|
|
^ (match b with [ b ] -> " else " ^ inline_text b | _ -> ""), 0)
|
|
| _ -> call ()
|
|
|
|
(* [if let P = v], the head (if-let [P v] ...) is written with. *)
|
|
and if_let_head (hd : Form.t) =
|
|
match hd.v with
|
|
| Form.Vec [ pat; v ] -> "if let " ^ at 11 pat ^ " = " ^ at 1 v
|
|
| _ -> assert false
|
|
|
|
(* A one-line slot's text — an arm's value, a then or an else, what follows
|
|
defer: the statements that fit on a line are written as statements,
|
|
everything else as a value. [lvl] is what a value in the slot needs. *)
|
|
and inline_text ?(lvl = 0) (f : Form.t) =
|
|
match f.v with
|
|
(* In a one-line slot a bare [()] reads as [(do)]; the value [()] is
|
|
written [(())]. *)
|
|
| Form.List [] -> "(())"
|
|
| Form.List [ { v = Form.Sym "do"; _ } ] -> "()"
|
|
| Form.List [ { v = Form.Sym (("break" | "continue" | "return") as w); _ } ] -> w
|
|
| Form.List [ { v = Form.Sym (("break" | "continue") as w); _ }; { v = Form.Kw k; _ } ]
|
|
when kw_ok k ->
|
|
w ^ " :" ^ k
|
|
| Form.List [ { v = Form.Sym "return"; _ }; v ] -> "return " ^ at (max lvl 1) v
|
|
| Form.List [ { v = Form.Sym "set"; _ }; t; v ] -> assign_text ~lvl t v
|
|
| Form.List [ { v = Form.Sym "update"; _ }; t; { v = Form.Sym (("+" | "-" | "*" | "/") as op); _ }; w ]
|
|
when not (R.simple_place t) ->
|
|
at 12 t ^ " " ^ op ^ "= " ^ at (max lvl 1) w
|
|
| _ -> at lvl f
|
|
|
|
(* A body after [=]: [()] there reads as [(do)]. *)
|
|
and unit_text (f : Form.t) =
|
|
match f.v with
|
|
| Form.List [] -> "(())"
|
|
| Form.List [ { v = Form.Sym "do"; _ } ] -> "()"
|
|
| _ -> at 0 f
|
|
|
|
(* [t = v], or [t += w] when [v] is [(+ t w)]. *)
|
|
and assign_text ?(lvl = 0) t v =
|
|
let tt = at 12 t in
|
|
match v.v with
|
|
| Form.List [ { v = Form.Sym (("+" | "-" | "*" | "/") as op); _ }; a; w ]
|
|
when same a t && R.simple_place t ->
|
|
tt ^ " " ^ op ^ "= " ^ at (max lvl 1) w
|
|
| _ -> tt ^ " = " ^ at (max lvl 1) v
|
|
|
|
and sym_param (p : Form.t) =
|
|
match p.v with Form.Sym s -> name_ok s | _ -> false
|
|
|
|
(* [(the (Fn [C dyn] R) (fn [a b] ...))] as [fn(a: C, b) -> R], the typed
|
|
lambda it reads from; [None] for any other shape. *)
|
|
and typed_lambda (f : Form.t) =
|
|
let rec tyt (t : Form.t) =
|
|
match t.v with
|
|
| Form.List [ { v = Form.Sym (("Fn" | "CFn") as h); _ }; { v = Form.Vec ps; _ }; r ] ->
|
|
h ^ "(" ^ String.concat ", " (List.map tyt ps) ^ ") -> " ^ tyt r
|
|
| _ -> at 12 t
|
|
in
|
|
match f.v with
|
|
| Form.List [ { v = Form.Sym "the"; _ };
|
|
{ v = Form.List [ { v = Form.Sym "Fn"; _ }; { v = Form.Vec ts; _ }; r ]; _ };
|
|
{ v = Form.List ({ v = Form.Sym "fn"; _ } :: { v = Form.Vec ps; _ } :: body); _ } ]
|
|
when List.length ts = List.length ps && List.for_all sym_param ps && body <> [] ->
|
|
let one (n : Form.t) (t : Form.t) =
|
|
if is_sym "dyn" t then fst (expr n) else fst (expr n) ^ ": " ^ tyt t
|
|
in
|
|
Some ("fn(" ^ String.concat ", " (List.map2 one ps ts) ^ ") -> " ^ tyt r, body)
|
|
| _ -> None
|
|
|
|
(* A type after [:] or [->]: the function-type arrow at the top, a postfix
|
|
term below it. *)
|
|
let rec ty (f : Form.t) =
|
|
match f.v with
|
|
| Form.List [ { v = Form.Sym (("Fn" | "CFn") as h); _ }; { v = Form.Vec ps; _ }; r ] ->
|
|
h ^ "(" ^ commas ps ^ ") -> " ^ ty r
|
|
| _ -> at 12 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. *)
|
|
(* The file's own class names, which are types and lowercase. Set by
|
|
[program]. *)
|
|
let classes : string list ref = ref []
|
|
|
|
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
|
|
|| List.mem t !classes
|
|
| Form.List [] | Form.List ({ v = Form.Sym _; _ } :: _) | Form.Vec _ -> true
|
|
| _ -> false
|
|
|
|
let rec pairs = function
|
|
| a :: b :: rest -> Option.map (fun r -> (a, b) :: r) (pairs rest)
|
|
| [] -> Some []
|
|
| [ _ ] -> None
|
|
|
|
(* [(a: i32, b)] from [[a i32 b dyn]], when every name is a plain name. *)
|
|
let params_text ?(shaped = false) (ps : Form.t list) =
|
|
match pairs ps with
|
|
| None -> None
|
|
| Some prs ->
|
|
if List.for_all
|
|
(fun ((n : Form.t), t) ->
|
|
(match n.v with Form.Sym x -> def_name x | _ -> false)
|
|
&& ((not shaped) || is_sym "dyn" t || type_shaped t))
|
|
prs
|
|
then
|
|
Some
|
|
(String.concat ", "
|
|
(List.map
|
|
(fun ((n : Form.t), t) ->
|
|
let n = fst (expr n) in
|
|
if is_sym "dyn" t then n else n ^ ": " ^ ty t)
|
|
prs))
|
|
else None
|
|
|
|
(* ── Statements ────────────────────────────────────────────────────── *)
|
|
|
|
let ind n = String.make n ' '
|
|
|
|
let lead_word text =
|
|
let n = String.length text in
|
|
let rec go i = if i < n && not (Reader.is_delimiter text.[i]) then go (i + 1) else i in
|
|
let i = go 0 in
|
|
(String.sub text 0 i, i = n || text.[i] = ' ')
|
|
|
|
(* A statement whose text leads with a reserved word, parenthesised. *)
|
|
let guard text =
|
|
let w, spaced = lead_word text in
|
|
(* [data = 3]: a name being assigned is read as one, header word or not. *)
|
|
let assigned =
|
|
let k = String.length w + 1 in
|
|
List.exists
|
|
(fun op ->
|
|
let o = op ^ " " in
|
|
String.length text >= k + String.length o
|
|
&& String.sub text k (String.length o) = o)
|
|
[ "="; "+="; "-="; "*="; "/=" ]
|
|
in
|
|
if spaced && List.mem w reserved && not assigned then paren text else text
|
|
|
|
let stmts_of (f : Form.t) =
|
|
match f.v with
|
|
| Form.List ({ v = Form.Sym "do"; _ } :: (_ :: _ :: _ as ss)) -> ss
|
|
| _ -> [ f ]
|
|
|
|
(* Heads whose trailing arguments are a body, and how many come before it. *)
|
|
let body_guess (h : Form.t) args =
|
|
match h.v with
|
|
| Form.Sym s ->
|
|
let base =
|
|
match String.rindex_opt s '/' with
|
|
| Some i -> String.sub s (i + 1) (String.length s - i - 1)
|
|
| None -> s
|
|
in
|
|
let lead = List.length (List.filter (fun (a : Form.t) ->
|
|
match a.v with Form.List _ -> false | _ -> true) args) in
|
|
(match base with
|
|
| "comment" | "do" -> Some 0
|
|
| "unless" -> Some 1
|
|
| "defmacro" -> Some 2
|
|
| "defmethod" -> Some 3
|
|
| _ ->
|
|
(* A with- macro, or any call whose last argument is a statement —
|
|
a let, a while, 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 _ when is_chain a -> false
|
|
| Form.List ({ v = Form.Sym h; _ } :: _) ->
|
|
List.mem h [ "let"; "set"; "when"; "if-let"; "unless"; "cond"; "while";
|
|
"until"; "dotimes"; "match"; "handler-case";
|
|
"handler-bind"; "restart-case"; "return"; "defer";
|
|
"do"; "break"; "continue" ]
|
|
| _ -> false
|
|
in
|
|
let is_with = String.length base > 5 && String.sub base 0 5 = "with-" in
|
|
let last_stmt =
|
|
match List.rev args with a :: _ -> stmt_like a | [] -> false
|
|
in
|
|
ignore lead;
|
|
let k = ref 0 in
|
|
List.iteri
|
|
(fun i (a : Form.t) ->
|
|
match a.v with Form.List (_ :: _) -> () | _ -> k := i + 1)
|
|
args;
|
|
(* The block starts at the first statement among the trailing lists,
|
|
so what comes before it — an if's test — stays in the parentheses:
|
|
[if(c):] rather than the test as the block's first line. *)
|
|
let first_stmt =
|
|
let rec go i = function
|
|
| [] -> None
|
|
| a :: rest -> if i >= !k && stmt_like a then Some i else go (i + 1) rest
|
|
in
|
|
go 0 args
|
|
in
|
|
if is_with then Some !k
|
|
else if last_stmt then Some (Option.value first_stmt ~default:!k)
|
|
else
|
|
(* A statement anywhere among the trailing lists makes them a body. *)
|
|
match first_stmt with Some _ -> Some !k | None -> None)
|
|
| _ -> None
|
|
|
|
let let_sugar (f : Form.t) =
|
|
match f.v with
|
|
| Form.List ({ v = Form.Sym "let"; _ } :: { v = Form.Vec bs; _ } :: _ :: _)
|
|
when not (is_chain f) ->
|
|
(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"; "if-let"; "cond"; "while"; "until"; "dotimes"; "match";
|
|
"handler-case"; "handler-bind"; "restart-case"; "return"; "defer"; "do";
|
|
"quasiquote"; "update" ]
|
|
|
|
|
|
(* [(do x)]: printed as [do:] and [x] as the one statement of its block. *)
|
|
let in_do (x : Form.t) = { x with v = Form.List [ Form.make (Form.Sym "do") x.loc; x ] }
|
|
|
|
(* [seq] when the block is a body run in order, where a [let] may take in
|
|
the statements after it. Not for the arguments of a call that happen to
|
|
print as a block, whose count that would change. *)
|
|
let rec block ?(seq = true) n (fs : Form.t list) : string list =
|
|
let rec go = function
|
|
| [] -> []
|
|
| [ x ] -> stmt n x
|
|
| x :: rest when let_sugar x ->
|
|
(match (if seq && !quasi = 0 then flatten x rest else None) with
|
|
| Some x' -> stmt n x'
|
|
| None -> stmt n (in_do x) @ go rest)
|
|
| x :: rest -> stmt n x @ go rest
|
|
in
|
|
go fs
|
|
|
|
and stmt n (f : Form.t) : string list =
|
|
in_quasi f @@ fun () ->
|
|
let ls = match sugar n f with Some ls -> ls | None -> plain n f in
|
|
(* The first line carries the line the form came from, for
|
|
[Source_text.weave] to put the comments back by. *)
|
|
match ls with
|
|
| first :: rest -> Source_text.tag f.loc.Loc.line first :: rest
|
|
| [] -> []
|
|
|
|
and plain n (f : Form.t) : string list =
|
|
let text =
|
|
match f.v with
|
|
| Form.List [] -> "(())"
|
|
| Form.List [ { v = Form.Sym "do"; _ } ] -> "()"
|
|
| Form.Sym s when List.mem s reserved -> paren s
|
|
| _ -> guard (fst (expr f))
|
|
in
|
|
let one = [ ind n ^ text ] in
|
|
match f.v with
|
|
| Form.List (h :: args) when args <> [] ->
|
|
(match body_split h args with
|
|
| Some (k, seq) when k < List.length args ->
|
|
let fixed = List.filteri (fun i _ -> i < k) args in
|
|
let rest = List.filteri (fun i _ -> i >= k) args in
|
|
let opener =
|
|
match h.v, fixed with
|
|
(* No arguments before the block: [comment:] rather than
|
|
[comment():], the author's decision 85. *)
|
|
| Form.Sym s, [] when name_ok s && not (List.mem s reserved) -> s ^ ":"
|
|
(* A header word glued to its parenthesis is the fallback call,
|
|
[if(c):], so it needs no parentheses of its own. *)
|
|
| Form.Sym s, _ :: _ when List.mem s reserved -> s ^ "(" ^ commas fixed ^ "):"
|
|
| _ -> head_text h ^ "(" ^ commas fixed ^ "):"
|
|
in
|
|
[ ind n ^ guard opener ] @ block ~seq (n + 2) rest
|
|
| _ ->
|
|
match hole_lines ~guarded:true n "" f with
|
|
| Some ls -> ls
|
|
| None ->
|
|
if n + String.length text > width && fst (expr f) = text then wrapped n "" f
|
|
else 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 (infix_op s)) && s <> "bit-not"
|
|
&& not (String.length s > 1 && s.[0] = '.')
|
|
| _ -> false) ->
|
|
let open_ = prefix ^ head_text h ^ "(" in
|
|
let col = n + String.length open_ in
|
|
let items = comma_items args in
|
|
let rec go line acc = function
|
|
| [] -> List.rev ((line ^ ")") :: acc)
|
|
| [ t ] ->
|
|
if String.length line = col || String.length line + String.length t + 1 <= width
|
|
then go (line ^ t) acc []
|
|
else
|
|
let line = String.sub line 0 (String.length line - 1) in
|
|
go (ind col ^ t) (line :: acc) []
|
|
| t :: rest ->
|
|
let piece = t ^ "," in
|
|
if String.length line = col || String.length line + String.length piece <= width
|
|
then go (line ^ piece ^ " ") acc rest
|
|
else
|
|
let line = String.sub line 0 (String.length line - 1) in
|
|
go (ind col ^ piece ^ " ") (line :: acc) rest
|
|
in
|
|
(* The last item on a line carries a trailing space; the break drops it. *)
|
|
let lines = go (ind n ^ open_) [] items in
|
|
List.map (fun l ->
|
|
let k = String.length l in
|
|
if k > 0 && l.[k - 1] = ' ' then String.sub l 0 (k - 1) else l) lines
|
|
(* A vector literal too long for its line, filled to the width, with the
|
|
separator [vec_text] chose. *)
|
|
| Form.Vec (_ :: _ :: _ as xs) ->
|
|
let open_ = prefix ^ "[" in
|
|
let col = n + String.length open_ in
|
|
let ts = List.map expr xs in
|
|
let sep = if List.for_all (fun (_, l) -> l >= 11) ts then "" else "," in
|
|
let rec go line acc = function
|
|
| [] -> List.rev ((line ^ "]") :: acc)
|
|
| (t, _) :: rest ->
|
|
let piece = if rest = [] then t else t ^ sep in
|
|
if String.length line = col || String.length line + String.length piece + 1 <= width
|
|
then go (line ^ piece ^ (if rest = [] then "" else " ")) acc rest
|
|
else
|
|
let line = String.sub line 0 (String.length line - 1) in
|
|
go (ind col ^ piece ^ (if rest = [] then "" else " ")) (line :: acc) rest
|
|
in
|
|
go (ind n ^ open_) [] ts
|
|
| _ -> [ ind n ^ prefix ^ at 0 f ]
|
|
|
|
(* A lambda as its header, [fn(a, b)] or [fn(a: C) -> R], and its body. *)
|
|
and lambda_parts (f : Form.t) =
|
|
match typed_lambda f with
|
|
| Some _ as l -> l
|
|
| None ->
|
|
match f.v with
|
|
| Form.List ({ v = Form.Sym "fn"; _ } :: { v = Form.Vec ps; _ } :: (_ :: _ as body))
|
|
when List.for_all sym_param ps ->
|
|
Some ("fn(" ^ commas ps ^ ")", body)
|
|
| _ -> None
|
|
|
|
(* A lambda body that reads better as a block under [=>] than on the line:
|
|
several statements, or one that is a statement. *)
|
|
and block_body (body : Form.t list) =
|
|
match body with
|
|
| [ { v = Form.List ({ v = Form.Sym h; _ } :: _); _ } ] ->
|
|
List.mem h sugar_heads && h <> "if" && h <> "update"
|
|
| [ _ ] -> false
|
|
| _ -> true
|
|
|
|
(* A lambda that takes a block: one whose body does, or has a comment in
|
|
it, or holds a lambda that takes one. *)
|
|
and wants_block (l : Form.t) body =
|
|
let rec holds (x : Form.t) =
|
|
match lambda_parts x with
|
|
| Some (_, b) -> wants_block x b
|
|
| None ->
|
|
match x.v with
|
|
| Form.List ({ v = Form.Sym ("quote" | "quasiquote"); _ } :: _) -> false
|
|
| Form.List xs | Form.Vec xs | Form.Map xs -> List.exists holds xs
|
|
| _ -> false
|
|
in
|
|
block_body body || !inside l || List.exists holds body
|
|
|
|
(* A block under [=>]: a body that is one [do] is its statements, written
|
|
straight under the header rather than in a [do:] of their own. *)
|
|
and lambda_block n body =
|
|
match body with
|
|
| [ { Form.v = Form.List ({ v = Form.Sym "do"; _ } :: (_ :: _ :: _ as ss)); _ } ] -> block (n + 2) ss
|
|
| _ -> block (n + 2) body
|
|
|
|
(* A line holding a lambda that takes its block there: [prefix] and the
|
|
line's text up to the lambda, [fn(x) =>], the block under it, and what
|
|
followed the lambda on the line at the end of the block's last line. The
|
|
reader ends a block inside brackets where they close, so the lambda must
|
|
be the last thing in its brackets: what follows it starts with a closer.
|
|
Each lambda in [f], outside the others, is tried in turn, a lambda that
|
|
wants a block (several statements, a statement, a comment inside) or any
|
|
when the line is too long; its place is found by printing the line with
|
|
a placeholder where it stands. [guarded]: the text is a statement's. *)
|
|
and hole_lines ?(guarded = false) n prefix (f : Form.t) =
|
|
let rec cands (x : Form.t) =
|
|
if lambda_parts x <> None then [ x ]
|
|
else
|
|
match x.v with
|
|
| Form.List ({ v = Form.Sym ("quote" | "quasiquote"); _ } :: _) -> []
|
|
| Form.List xs | Form.Vec xs | Form.Map xs -> List.concat_map cands xs
|
|
| _ -> []
|
|
in
|
|
let inner =
|
|
match f.v with
|
|
| Form.List xs | Form.Vec xs | Form.Map xs -> List.concat_map cands xs
|
|
| _ -> []
|
|
in
|
|
if inner = [] then None
|
|
else
|
|
let long = lazy (n + String.length prefix + String.length (fst (expr f)) > width) in
|
|
let rec subst (l : Form.t) (x : Form.t) =
|
|
if x == l then Form.make (Form.Sym hole_sym) l.loc
|
|
else
|
|
match x.v with
|
|
| Form.List xs -> { x with v = Form.List (List.map (subst l) xs) }
|
|
| Form.Vec xs -> { x with v = Form.Vec (List.map (subst l) xs) }
|
|
| Form.Map xs -> { x with v = Form.Map (List.map (subst l) xs) }
|
|
| _ -> x
|
|
in
|
|
let find t =
|
|
let k = String.length hole_sym in
|
|
let rec go i =
|
|
if i + k > String.length t then None
|
|
else if String.sub t i k = hole_sym then Some i
|
|
else go (i + 1)
|
|
in
|
|
go 0
|
|
in
|
|
let rec try_ = function
|
|
| [] -> None
|
|
| (l : Form.t) :: rest ->
|
|
let head, body = Option.get (lambda_parts l) in
|
|
if not (wants_block l body || Lazy.force long) then try_ rest
|
|
else begin
|
|
hole := true;
|
|
let t =
|
|
Fun.protect ~finally:(fun () -> hole := false)
|
|
(fun () -> fst (expr (subst l f)))
|
|
in
|
|
let t = if guarded then guard t else t in
|
|
match find t with
|
|
| Some i
|
|
when (let j = i + String.length hole_sym in
|
|
j < String.length t && (t.[j] = ')' || t.[j] = ']' || t.[j] = '}')) ->
|
|
let j = i + String.length hole_sym in
|
|
let post = String.sub t j (String.length t - j) in
|
|
let ls = lambda_block n body in
|
|
let ls =
|
|
match List.rev ls with
|
|
| last :: before -> List.rev ((last ^ post) :: before)
|
|
| [] -> ls
|
|
in
|
|
Some ((ind n ^ prefix ^ String.sub t 0 i ^ head ^ " =>") :: ls)
|
|
| _ -> try_ rest
|
|
end
|
|
in
|
|
try_ inner
|
|
|
|
(* [prefix = fn(a) =>] or [prefix = f(x, fn(a) =>] and a lambda's block,
|
|
when the value is a lambda that takes one or ends a bracket with one. *)
|
|
and lambda_value n prefix (v : Form.t) =
|
|
match lambda_parts v with
|
|
| Some (head, body)
|
|
when wants_block v body
|
|
|| n + String.length prefix + 3 + String.length (fst (expr v)) > width ->
|
|
Some ((ind n ^ prefix ^ " = " ^ head ^ " =>") :: lambda_block n body)
|
|
| _ -> hole_lines n (prefix ^ " = ") v
|
|
|
|
(* [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
|
|
match lambda_value n prefix v with
|
|
| Some ls -> ls
|
|
| None ->
|
|
if n + String.length inline <= width then [ ind n ^ inline ]
|
|
else
|
|
match v.v with
|
|
| _ when is_chain v -> [ ind n ^ inline ]
|
|
| Form.List ({ v = Form.Sym h; _ } :: _)
|
|
when not (List.mem h sugar_heads || h = "fn" || h = "if") ->
|
|
wrapped n (prefix ^ " = ") v
|
|
| Form.List (_ :: _) -> [ ind n ^ prefix ^ " =" ] @ block (n + 2) (stmts_of v)
|
|
| Form.Vec (_ :: _ :: _) -> wrapped n (prefix ^ " = ") v
|
|
| _ -> [ ind n ^ inline ]
|
|
|
|
and slot n (f : Form.t) = block n (stmts_of f)
|
|
|
|
(* Whether an else is a chain the reader makes of an [elif let]: an if-let,
|
|
or an [if] whose own else is one. *)
|
|
and has_let_else (x : Form.t) =
|
|
match x.v with
|
|
| Form.List ({ v = Form.Sym "if-let"; _ } :: { v = Form.Vec [ _; _ ]; _ } :: _ :: ([] | [ _ ])) -> true
|
|
| Form.List [ { v = Form.Sym "if"; _ }; _; _; r ] -> has_let_else r
|
|
| _ -> false
|
|
|
|
(* Such a chain as the elif and else clauses at column [n]. A [when] at its
|
|
end is an [elif] with no else after it, which is how the reader reads one
|
|
back. *)
|
|
and let_chain n (x : Form.t) =
|
|
let i = ind n in
|
|
let tag (x : Form.t) l = Source_text.tag x.loc.Loc.line l in
|
|
match x.v with
|
|
| Form.List ({ v = Form.Sym "if-let"; _ } :: ({ v = Form.Vec [ _; _ ]; _ } as hd) :: a
|
|
:: ([] | [ _ ] as r)) ->
|
|
(tag x (i ^ "el" ^ if_let_head hd) :: slot (n + 2) a)
|
|
@ (match r with [ r ] -> let_chain n r | _ -> [])
|
|
(* Past an [elif let] every clause nests, so an [if] here is an [elif]
|
|
whether or not another let follows. *)
|
|
| Form.List [ { v = Form.Sym "if"; _ }; c; a; r ] ->
|
|
(tag c (i ^ "elif " ^ at 1 c) :: slot (n + 2) a) @ let_chain n r
|
|
| Form.List ({ v = Form.Sym "when"; _ } :: c :: (_ :: _ as body)) ->
|
|
tag c (i ^ "elif " ^ at 1 c) :: block (n + 2) body
|
|
| _ -> tag x (i ^ "else") :: slot (n + 2) x
|
|
|
|
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))
|
|
when not (is_chain f) ->
|
|
(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 && lambda_value n (guard (at 12 t)) v = None
|
|
then Some [ line ]
|
|
else Some (value_lines n (guard (at 12 t)) v)
|
|
| Form.List [ { v = Form.Sym "if"; _ }; c; a; b ] ->
|
|
let simple (x : Form.t) =
|
|
match x.v with
|
|
| Form.List ({ v = Form.Sym ("return" | "set" | "break" | "continue"); _ } :: _) -> true
|
|
| Form.List ({ v = Form.Sym h; _ } :: _) -> not (List.mem h sugar_heads)
|
|
| _ -> true
|
|
in
|
|
(* An else that is another if with an else chains on the line:
|
|
[if a then x else if b then y else z]. *)
|
|
let rec chain (x : Form.t) =
|
|
match x.v with
|
|
| Form.List [ { v = Form.Sym "if"; _ }; _; a; b ] -> simple a && chain b
|
|
| _ -> simple x
|
|
in
|
|
let line = i ^ fst (expr f) in
|
|
if has_let_else b then
|
|
Some (((i ^ "if " ^ at 1 c) :: slot (n + 2) a) @ let_chain n b)
|
|
else
|
|
if simple a && chain b && String.length line <= width && not (!inside f)
|
|
then Some [ line ]
|
|
else
|
|
Some
|
|
([ i ^ "if " ^ at 1 c ] @ slot (n + 2) a
|
|
@ [ Source_text.tag b.loc.Loc.line (i ^ "else") ] @ slot (n + 2) b)
|
|
| Form.List ({ v = Form.Sym "when"; _ } :: c :: (_ :: _ as body)) ->
|
|
Some ((i ^ "if " ^ at 1 c) :: block (n + 2) body)
|
|
(* [if let P = v] and its block; an else that is a cond is its elif
|
|
chain, which is what the reader makes of one. *)
|
|
| Form.List
|
|
({ v = Form.Sym "if-let"; _ } :: ({ v = Form.Vec [ _; _ ]; _ } as hd) :: a
|
|
:: ([] | [ _ ] as 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 && List.for_all simple b && String.length line <= width
|
|
&& not (!inside f)
|
|
then Some [ line ]
|
|
else
|
|
let head = (i ^ if_let_head hd) :: slot (n + 2) a in
|
|
(match b with
|
|
| [] -> Some head
|
|
| [ e ] when has_let_else e -> Some (head @ let_chain n e)
|
|
| [ ({ v = Form.List ({ v = Form.Sym "cond"; _ } :: args); _ } as e) ] ->
|
|
(match pairs args with
|
|
| Some (_ :: _ as 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
|
|
Some
|
|
(head
|
|
@ List.concat_map
|
|
(fun ((c : Form.t), b) ->
|
|
Source_text.tag c.loc.Loc.line (i ^ "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 -> []))
|
|
| _ ->
|
|
Some (head @ [ Source_text.tag e.loc.Loc.line (i ^ "else") ] @ slot (n + 2) e))
|
|
| [ e ] ->
|
|
Some (head @ [ Source_text.tag e.loc.Loc.line (i ^ "else") ] @ slot (n + 2) e)
|
|
| _ -> None)
|
|
| Form.List ({ v = Form.Sym "cond"; _ } :: args) ->
|
|
(match pairs args with
|
|
| None -> None
|
|
| Some prs ->
|
|
let tests, else_ =
|
|
match List.rev prs with
|
|
| (k, e) :: rest when is_else k -> (List.rev rest, Some (k, e))
|
|
| _ -> (prs, None)
|
|
in
|
|
if List.length tests < 2 then None
|
|
else
|
|
Some
|
|
(List.concat
|
|
(List.mapi
|
|
(fun j (c, b) ->
|
|
(* Each test's line carries the test's own line, so a
|
|
comment written above a clause stays above it. *)
|
|
Source_text.tag (c : Form.t).loc.Loc.line
|
|
(i ^ (if j = 0 then "if " else "elif ") ^ at 1 c)
|
|
:: slot (n + 2) b)
|
|
tests)
|
|
@ (match else_ with
|
|
| Some ((k : Form.t), e) ->
|
|
Source_text.tag k.loc.Loc.line (i ^ "else") :: slot (n + 2) e
|
|
| None -> [])))
|
|
| Form.List ({ v = Form.Sym (("while" | "until") as w); _ } :: rest) ->
|
|
let lbl, rest = label_of rest in
|
|
(match rest with
|
|
| c :: (_ :: _ as body) -> Some ((i ^ w ^ " " ^ lbl ^ at 0 c) :: block (n + 2) body)
|
|
| _ -> None)
|
|
| Form.List ({ v = Form.Sym "dotimes"; _ } :: rest) ->
|
|
let lbl, rest = label_of rest in
|
|
(* The variable is a name, or in a template an unquote, [for ~i in ...]. *)
|
|
let var (f : Form.t) =
|
|
match f.v with
|
|
| Form.Sym v when def_name v && v <> "in" -> Some v
|
|
| Form.List [ { v = Form.Sym "unquote"; _ }; _ ] -> Some (fst (expr f))
|
|
| _ -> None
|
|
in
|
|
(match rest with
|
|
| { v = Form.Vec (vf :: bs); _ } :: (_ :: _ as body)
|
|
when var vf <> None && bs <> [] && List.length bs <= 3 ->
|
|
let v = Option.get (var vf) in
|
|
Some
|
|
((i ^ "for " ^ lbl ^ v ^ " in range(" ^ commas bs ^ ")") :: block (n + 2) body)
|
|
| _ -> None)
|
|
| Form.List [ { v = Form.Sym "return"; _ } ] -> Some [ i ^ "return" ]
|
|
| Form.List [ { v = Form.Sym "return"; _ }; v ] ->
|
|
(match hole_lines n "return " v with
|
|
| Some ls -> Some ls
|
|
| None -> 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 11 pat in
|
|
let line = ind (n + 2) ^ pt ^ " -> " ^ inline_text body in
|
|
match body.v with
|
|
| Form.List ({ v = Form.Sym "do"; _ } :: _ :: _ :: _) ->
|
|
(ind (n + 2) ^ pt ^ " ->") :: slot (n + 4) body
|
|
| Form.List (_ :: _) when String.length line > width ->
|
|
(ind (n + 2) ^ pt ^ " ->") :: slot (n + 4) body
|
|
| _ -> [ line ])
|
|
prs))
|
|
| Form.List [ { v = Form.Sym "handler-case"; _ }; body; { v = Form.Vec cls; _ } ]
|
|
when cls <> [] ->
|
|
Option.map
|
|
(fun cl -> ((i ^ "handler-case") :: slot (n + 2) body) @ cl)
|
|
(handler_clauses n cls)
|
|
| Form.List ({ v = Form.Sym "handler-bind"; _ } :: { v = Form.Vec cls; _ } :: (_ :: _ as body))
|
|
when cls <> [] ->
|
|
Option.map
|
|
(fun cl -> ((i ^ "handler-bind") :: block (n + 2) body) @ cl)
|
|
(handler_clauses n cls)
|
|
| Form.List ({ v = Form.Sym "restart-case"; _ } :: body :: (_ :: _ as cls)) ->
|
|
let clause (c : Form.t) =
|
|
match c.v with
|
|
| Form.List ({ v = Form.Sym r; _ } :: { v = Form.Vec ps; _ } :: (_ :: _ as b))
|
|
when def_name r ->
|
|
let report, b =
|
|
match b with
|
|
| { v = Form.Kw "report"; _ } :: ({ v = Form.Str _; _ } as t) :: (_ :: _ as rest) ->
|
|
(" " ^ fst (expr t), rest)
|
|
| _ -> ("", b)
|
|
in
|
|
Option.map
|
|
(fun pt -> (i ^ "restart " ^ r ^ "(" ^ pt ^ ")" ^ report) :: block (n + 2) b)
|
|
(params_text ps)
|
|
| _ -> None
|
|
in
|
|
let cs = List.map clause cls in
|
|
if List.mem None cs then None
|
|
else
|
|
Some (((i ^ "restart-case") :: slot (n + 2) body)
|
|
@ List.concat_map Option.get cs)
|
|
| Form.List [ { v = Form.Sym "quasiquote"; _ }; x ] ->
|
|
Some ((i ^ "quote") :: slot (n + 2) x)
|
|
| _ when (match lambda_parts f with Some (_, body) -> wants_block f body | None -> false) ->
|
|
let head, body = Option.get (lambda_parts f) in
|
|
Some ((i ^ head ^ " =>") :: lambda_block n body)
|
|
| Form.List ({ v = Form.Sym (("defn" | "defn-") as d); _ } :: { v = Form.Sym name; _ }
|
|
:: { v = Form.Vec ps; _ } :: ret :: body)
|
|
when def_name name ->
|
|
(match params_text ~shaped:true ps with
|
|
| None -> None
|
|
| Some pt ->
|
|
let where_, body =
|
|
match body with
|
|
| { v = Form.Map [ { v = Form.Kw "where"; _ }; x ]; _ } :: rest ->
|
|
let preds =
|
|
match x.v with
|
|
| Form.Vec (_ :: _ :: _ as xs) -> commas xs
|
|
| _ -> at 0 x
|
|
in
|
|
(" where " ^ preds, rest)
|
|
| _ -> ("", body)
|
|
in
|
|
let head =
|
|
i ^ (if d = "defn" then "fn " else "fn- ") ^ name ^ "(" ^ pt ^ ")"
|
|
(* [_] is what the reader makes of no arrow at all. *)
|
|
^ (match ret.v with Form.Sym "_" -> "" | _ -> " -> " ^ ty ret)
|
|
^ where_
|
|
in
|
|
(match body with
|
|
| [] -> Some [ head ]
|
|
| [ x ] when (match x.v with
|
|
| Form.List (({ v = Form.Sym h; _ } as hf) :: args) ->
|
|
(* A call that takes a block is a statement, not a value. *)
|
|
not (List.mem h sugar_heads) && body_split hf args = None
|
|
&& lambda_value (n + 2) "" x = None
|
|
| _ -> lambda_value (n + 2) "" x = None)
|
|
&& String.length head + 3 + String.length (at 0 x) <= width
|
|
&& not (!inside f) ->
|
|
Some [ head ^ " = " ^ unit_text x ]
|
|
| _ -> Some (head :: block (n + 2) body)))
|
|
| Form.List ({ v = Form.Sym (("def" | "defonce" | "defconst") as d); _ }
|
|
:: { v = Form.Sym name; _ } :: rest)
|
|
when def_name name ->
|
|
(* A global [def] is a top-level [let]; nested, where a let is local, it
|
|
keeps the fallback. *)
|
|
let w = match d with "def" -> "let" | "defonce" -> "once" | _ -> "const" in
|
|
let pre = i ^ w ^ " " ^ name in
|
|
(match d, rest with
|
|
| "def", _ when n > 0 -> None
|
|
| "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 "defmacro"; _ } :: { v = Form.Sym name; _ }
|
|
:: { v = Form.Vec ps; _ } :: (_ :: _ as body))
|
|
when def_name name ->
|
|
(* A parameter is a name, a destructuring vector, or & and the rest's
|
|
name, last. *)
|
|
let rec go = function
|
|
| [] -> Some []
|
|
| [ { Form.v = Form.Sym "&"; _ }; { Form.v = Form.Sym r; _ } ] when def_name r ->
|
|
Some [ "& " ^ r ]
|
|
| { Form.v = Form.Sym x; _ } :: rest when def_name x && x <> "&" ->
|
|
Option.map (fun r -> x :: r) (go rest)
|
|
| ({ Form.v = Form.Vec _; _ } as v) :: rest ->
|
|
Option.map (fun r -> fst (expr v) :: r) (go rest)
|
|
| _ -> None
|
|
in
|
|
Option.map
|
|
(fun pt ->
|
|
(i ^ "macro " ^ name ^ "(" ^ String.concat ", " pt ^ ")") :: block (n + 2) body)
|
|
(go ps)
|
|
| Form.List ({ v = Form.Sym (("defstruct" | "defunion") as d); _ }
|
|
:: { v = Form.Sym name; _ } :: rest)
|
|
when def_name name
|
|
&& (match d, rest with
|
|
| _, [ { v = Form.Vec _; _ } ] -> true
|
|
(* [(defstruct N :parent P [])] keeps the fallback: no field lines
|
|
reads as the form with no vector. *)
|
|
| "defstruct", [ { v = Form.Kw "parent"; _ }; { v = Form.Sym pn; _ } ]
|
|
| "defstruct", [ { v = Form.Kw "parent"; _ }; { v = Form.Sym pn; _ };
|
|
{ v = Form.Vec (_ :: _); _ } ] ->
|
|
def_name pn
|
|
| _ -> false) ->
|
|
let parent, fs =
|
|
match rest with
|
|
| [ { v = Form.Vec fs; _ } ] -> ("", fs)
|
|
| [ _; pf ] -> (" :parent " ^ ty pf, [])
|
|
| [ _; pf; { v = Form.Vec fs; _ } ] -> (" :parent " ^ ty pf, fs)
|
|
| _ -> assert false
|
|
in
|
|
(* One line when it fits, [struct Pt(x: i32, y: i32)], and a line per
|
|
field otherwise. *)
|
|
let one =
|
|
match fs, params_text fs with
|
|
| _ :: _, Some pt ->
|
|
let line =
|
|
i ^ (if d = "defstruct" then "struct " else "union ") ^ name ^ "(" ^ pt ^ ")" ^ parent
|
|
in
|
|
if String.length line <= width && not (!inside f) then Some [ line ] else None
|
|
| _ -> None
|
|
in
|
|
(match pairs fs with
|
|
| _ when one <> None -> one
|
|
| Some prs when List.for_all (fun ((f : Form.t), _) ->
|
|
match f.v with Form.Sym x -> def_name x | _ -> false) prs ->
|
|
Some
|
|
((i ^ (if d = "defstruct" then "struct " else "union ") ^ name ^ parent)
|
|
:: List.map
|
|
(fun ((f : Form.t), t) ->
|
|
let fname = fst (expr f) in
|
|
Source_text.tag f.loc.Loc.line
|
|
(ind (n + 2) ^ if is_sym "dyn" t then fname else fname ^ ": " ^ ty t))
|
|
prs)
|
|
| _ -> None)
|
|
| Form.List [ { v = Form.Sym "defclass"; _ }; { v = Form.Sym name; _ }; { v = Form.Vec ss; _ } ]
|
|
when def_name name ->
|
|
(* A name, and the type after it when the next item is shaped like one:
|
|
read back, the slots are the same items in the same order. *)
|
|
let rec walk = function
|
|
| [] -> Some []
|
|
| ({ Form.v = Form.Sym x; _ } as xf) :: t :: rest when def_name x && type_shaped t ->
|
|
Option.map (fun r -> (xf, Some t) :: r) (walk rest)
|
|
| ({ Form.v = Form.Sym x; _ } as xf) :: rest when def_name x ->
|
|
Option.map (fun r -> (xf, None) :: r) (walk rest)
|
|
| _ -> None
|
|
in
|
|
let slots = walk ss in
|
|
Option.map
|
|
(fun sl ->
|
|
let one (x, t) =
|
|
fst (expr x) ^ match t with Some t -> ": " ^ ty t | None -> ""
|
|
in
|
|
let line = i ^ "class " ^ name ^ "(" ^ String.concat ", " (List.map one sl) ^ ")" in
|
|
if sl = [] then [ i ^ "class " ^ name ]
|
|
else if String.length line <= width && not (!inside f) then [ line ]
|
|
else
|
|
(i ^ "class " ^ name)
|
|
:: List.map (fun ((x : Form.t), t) ->
|
|
Source_text.tag x.loc.Loc.line (ind (n + 2) ^ one (x, t))) sl)
|
|
slots
|
|
| Form.List [ { v = Form.Sym "defgeneric"; _ }; { v = Form.Sym name; _ };
|
|
{ v = Form.Vec ps; _ }; r ]
|
|
when def_name name && List.for_all sym_param ps && not (is_sym "_" r) ->
|
|
Some [ i ^ "generic " ^ name ^ "(" ^ commas ps ^ ") -> " ^ ty r ]
|
|
| Form.List ({ v = Form.Sym "defmulti"; _ } :: { v = Form.Sym name; _ }
|
|
:: { v = Form.Vec ps; _ } :: r :: (_ :: _ as body))
|
|
when def_name name && List.for_all sym_param ps && not (is_sym "_" r) ->
|
|
Some (fn_like n f (i ^ "multi " ^ name ^ "(" ^ commas ps ^ ") -> " ^ ty r) body)
|
|
| Form.List ({ v = Form.Sym "defmethod"; _ } :: { v = Form.Sym name; _ } :: key
|
|
:: { v = Form.Vec ps; _ } :: (_ :: _ as body))
|
|
when def_name name && List.for_all sym_param ps ->
|
|
(* A class written as the first parameter's type; any other value, and a
|
|
class with no parameter to hang it on, after when. *)
|
|
let head =
|
|
match key.v, ps with
|
|
| Form.Sym k, p0 :: rest when k <> "true" && k <> "false" && name_ok k ->
|
|
Some ("(" ^ fst (expr p0) ^ ": " ^ ty key
|
|
^ String.concat "" (List.map (fun p -> ", " ^ fst (expr p)) rest) ^ ")")
|
|
| (Form.Kw _ | Form.Str _ | Form.Int _ | Form.Sym _), _ ->
|
|
Some ("(" ^ commas ps ^ ") when " ^ at 12 key)
|
|
| _ -> None
|
|
in
|
|
Option.map (fun h -> fn_like n f (i ^ "method " ^ name ^ h) body) head
|
|
| Form.List [ { v = Form.Sym "defalias"; _ }; { v = Form.Sym name; _ }; t ]
|
|
when def_name name && type_shaped t ->
|
|
Some [ i ^ "type " ^ name ^ " = " ^ ty t ]
|
|
| Form.List [ { v = Form.Sym "defdata"; _ }; { v = Form.Sym name; _ }; { v = Form.Vec cs; _ } ]
|
|
when def_name name ->
|
|
let case (c : Form.t) =
|
|
Option.map (Source_text.tag c.loc.Loc.line) @@
|
|
match c.v with
|
|
| Form.Sym s when def_name s -> Some s
|
|
| Form.List [ { v = Form.Sym s; _ }; { v = Form.Vec ps; _ } ] when def_name s ->
|
|
Option.map (fun pt -> s ^ "(" ^ pt ^ ")") (params_text ps)
|
|
| _ -> None
|
|
in
|
|
let cs = List.map case cs in
|
|
if List.mem None cs then None
|
|
else
|
|
Some ((i ^ "data " ^ name)
|
|
:: List.map (fun c ->
|
|
let tags, body = Source_text.untag (Option.get c) in
|
|
List.fold_left (fun l t -> Source_text.tag t l) (ind (n + 2) ^ body) tags) cs)
|
|
| Form.List [ { v = Form.Sym "defenum"; _ }; { v = Form.Sym name; _ }; { v = Form.Vec ms; _ } ]
|
|
when def_name name ->
|
|
let rec members = function
|
|
| ({ Form.v = Form.Sym m; _ } as mf) :: ({ Form.v = Form.Int _ | Form.UInt _; _ } as v) :: rest
|
|
when def_name m ->
|
|
Option.map (fun r -> (mf.loc.Loc.line, m ^ " = " ^ fst (expr v)) :: r) (members rest)
|
|
| ({ Form.v = Form.Sym m; _ } as mf) :: rest when def_name m ->
|
|
Option.map (fun r -> (mf.loc.Loc.line, m) :: r) (members rest)
|
|
| [] -> Some []
|
|
| _ -> None
|
|
in
|
|
Option.map
|
|
(fun ms ->
|
|
(i ^ "enum " ^ name)
|
|
:: List.map (fun (l, m) -> Source_text.tag l (ind (n + 2) ^ m)) ms)
|
|
(members ms)
|
|
| Form.List [ { v = Form.Sym "import"; _ }; { v = Form.Sym a; _ }; ({ v = Form.Str _; _ } as p) ]
|
|
when def_name a ->
|
|
Some [ i ^ "import " ^ a ^ " " ^ fst (expr p) ]
|
|
| _ -> None
|
|
|
|
and is_else (f : Form.t) = match f.v with Form.Kw "else" -> true | _ -> false
|
|
|
|
(* A header and its body: [head = value] when the body is one value that
|
|
fits the line, else the block under it, as a [fn]'s. *)
|
|
and fn_like n (f : Form.t) head body =
|
|
match body with
|
|
| [ x ] when (match x.v with
|
|
| Form.List (({ v = Form.Sym h; _ } as hf) :: args) ->
|
|
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) ->
|
|
[ head ^ " = " ^ unit_text x ]
|
|
| _ -> head :: block (n + 2) body
|
|
|
|
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 12 t ^ "(" ^ v ^ ")") :: block (n + 2) b)
|
|
| _ -> None
|
|
in
|
|
let cs = List.map clause cls in
|
|
if List.mem None cs then None else Some (List.concat_map Option.get cs)
|
|
|
|
(* A [let] is always written flat: [block] has made it the last statement of
|
|
its block, so its body is the rest of the block. *)
|
|
and let_lines n prs body =
|
|
(* [(let [x (the T v)])] is [let x: T = v]. *)
|
|
let bind ((t : Form.t), (v : Form.t)) =
|
|
match t.v, v.v with
|
|
| Form.Sym x, Form.List [ { v = Form.Sym "the"; _ }; ty_; w ]
|
|
when def_name x && typed_lambda v = None ->
|
|
("let " ^ x ^ ": " ^ ty ty_, w)
|
|
| _ -> ("let " ^ guard (at 11 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
|
|
(* A let whose body starts with another is one run of bindings: the reader
|
|
merges the two back whichever way they are written. *)
|
|
let rec absorb prs body =
|
|
match body with
|
|
| x :: rest when let_sugar x && !quasi = 0 ->
|
|
(match if rest = [] then Some x else flatten x rest with
|
|
| Some { v = Form.List (_ :: { v = Form.Vec bs; _ } :: inner); _ } ->
|
|
(match pairs bs with
|
|
| Some ps -> absorb (prs @ ps) inner
|
|
| None -> (prs, body))
|
|
| _ -> (prs, body))
|
|
| _ -> (prs, body)
|
|
in
|
|
let prs, body = absorb prs body in
|
|
let lines n b = let p, v = bind b in tagged b (value_lines n p v) in
|
|
(* A binding that fits a line with a short value joins a group: the ones
|
|
after the first go on the lines under it, lined up with its name. *)
|
|
let short n b =
|
|
let p, v = bind b in
|
|
match value_lines n p v with
|
|
| [ l ] when String.length (at 0 v) <= 40 && not (!inside v) -> Some (tagged b [ l ])
|
|
| _ -> None
|
|
in
|
|
let under b =
|
|
let p, v = bind b in
|
|
let p = String.sub p 4 (String.length p - 4) in
|
|
match value_lines (n + 4) p v with
|
|
| [ l ] when String.length (at 0 v) <= 40 && not (!inside v) -> Some (tagged b [ l ])
|
|
| _ -> None
|
|
in
|
|
let rec emit = function
|
|
| [] -> []
|
|
| b :: rest ->
|
|
(match short n b with
|
|
| None -> lines n b @ emit rest
|
|
| Some first ->
|
|
let rec group acc = function
|
|
| b' :: rest' as all ->
|
|
(match under b' with
|
|
| Some l -> group (acc @ l) rest'
|
|
| None -> (acc, all))
|
|
| [] -> (acc, [])
|
|
in
|
|
let more, rest = group [] rest in
|
|
first @ more @ emit rest)
|
|
in
|
|
emit prs @ block n body
|
|
|
|
(* A .flan file that uses [loop] or [recur] has no indented spelling: the
|
|
indented syntax loops with [while], [until], [dotimes] and [for]. The
|
|
refusal names every line, so the file is rewritten in one pass. *)
|
|
let refuse_loops (fs : Form.t list) =
|
|
match R.loop_forms fs with
|
|
| [] -> ()
|
|
| (first : Form.t) :: rest as uses ->
|
|
let word (f : Form.t) =
|
|
match f.v with Form.List ({ v = Form.Sym w; _ } :: _) -> w | _ -> "loop"
|
|
in
|
|
let lines = List.sort_uniq compare (List.map (fun (f : Form.t) -> f.loc.Loc.line) uses) in
|
|
let notes = List.map (fun (f : Form.t) -> Loc.note f.loc (word f ^ " is here")) rest in
|
|
Loc.failk ~notes "convert/no-loop" first.loc
|
|
"this file uses loop or recur on line%s %s. The indented syntax \
|
|
has neither. Rewrite each one in the .flan file as a while or until \
|
|
over let variables it changes, then convert again:\n\n\
|
|
\ (let [i 0 total 0]\n\
|
|
\ (while (< i 10)\n\
|
|
\ (set total (+ total i))\n\
|
|
\ (set i (+ i 1))))"
|
|
(if List.length lines = 1 then "" else "s")
|
|
(match List.rev_map string_of_int lines with
|
|
| last :: (_ :: _ as before) ->
|
|
String.concat ", " (List.rev before) ^ " and " ^ last
|
|
| ls -> String.concat "" ls)
|
|
|
|
(** 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 =
|
|
refuse_loops fs;
|
|
macros := (match m with Some m -> m | None -> Body_macros.table fs);
|
|
classes :=
|
|
List.filter_map
|
|
(fun (f : Form.t) ->
|
|
match f.v with
|
|
| Form.List [ { v = Form.Sym "defclass"; _ }; { v = Form.Sym c; _ }; _ ] -> Some c
|
|
| _ -> None)
|
|
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 [let] at the top level is a global, so a local one 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 :: rest -> (x, top (if let_sugar x then in_do x else x)) :: go rest
|
|
in
|
|
let text =
|
|
try Source_text.join_top (go fs) ^ "\n"
|
|
with e -> spelling := (fun _ -> None); inside := (fun _ -> false); raise e
|
|
in
|
|
spelling := (fun _ -> None);
|
|
inside := (fun _ -> false);
|
|
classes := [];
|
|
(* 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
|