A let in .fln is always flat and a line indented under one is refused, the printer renames a let's name a later statement means otherwise or puts the let in a do: block, and a one-argument and/or prints as its argument
This commit is contained in:
parent
d991e1986c
commit
0b80c1956f
4
TODO.org
4
TODO.org
@ -300,10 +300,6 @@ on its own.
|
||||
Decided 2026-09-25: a match over a dyn takes keyword arms, meaning (= d :k); = and !=
|
||||
compare bools, and a match over a bool takes true/false arms, exhaustive without _.
|
||||
|
||||
** NEXT The .fln printer writes a flat let where the scope does not matter
|
||||
Decided 2026-09-25: a let whose name no later statement of its block mentions prints
|
||||
flat, not as a nested block; a one-argument and/or prints as its argument.
|
||||
|
||||
** WAIT ML-style patterns
|
||||
Held 2026-09-25 as a future direction, like the JS backend: nested destructuring,
|
||||
guards, or-patterns, literals at any depth, exhaustiveness over the nesting.
|
||||
|
||||
@ -69,6 +69,158 @@ let rec same (a : Form.t) (b : Form.t) =
|
||||
|
||||
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 mentions 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. *)
|
||||
|
||||
(* 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
|
||||
| _ -> ()
|
||||
|
||||
let fresh n =
|
||||
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 (); c)
|
||||
in
|
||||
go 2
|
||||
|
||||
let prefixed pre s =
|
||||
String.length s > String.length pre && String.sub s 0 (String.length pre) = pre
|
||||
|
||||
(* The names a binding target binds. A struct pattern's [.field] binds
|
||||
[field]; its other symbols count as names too, which is only caution. *)
|
||||
let rec binders (t : Form.t) acc =
|
||||
match t.v with
|
||||
| Form.Sym "&" -> acc
|
||||
| Form.Sym s when s <> "" && s.[0] = '.' -> String.sub s 1 (String.length s - 1) :: acc
|
||||
| Form.Sym s -> s :: acc
|
||||
| Form.List l | Form.Vec l | Form.Map l -> List.fold_left (fun a x -> binders x a) acc l
|
||||
| _ -> acc
|
||||
|
||||
(* Whether [f] refers to [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 the one case this cannot 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. Only
|
||||
a plain name or an array pattern counts as rebinding; a struct pattern's
|
||||
names are left to [mentions]. *)
|
||||
let rec refers n (f : Form.t) =
|
||||
let rec rebinds (t : Form.t) =
|
||||
match t.v with
|
||||
| Form.Sym s -> s = n
|
||||
| Form.Vec l -> List.exists rebinds l
|
||||
| _ -> false
|
||||
in
|
||||
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 (rebinds 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
|
||||
|
||||
let rec spells n (f : Form.t) =
|
||||
match f.v with
|
||||
| Form.Sym s -> mentions n f || s = "." ^ n
|
||||
| Form.List l | Form.Vec l | Form.Map l -> List.exists (spells n) l
|
||||
| _ -> false
|
||||
|
||||
(* [f] with [n] renamed [n'], or [None] where the rename cannot be trusted: a
|
||||
quoted [n] is data, [n/x] names a package, and in a braced form [.n] may
|
||||
bind [n] as well as name a field. *)
|
||||
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.Map _ when spells n f -> None
|
||||
| Form.List l -> Option.map (fun l -> { f with v = Form.List l }) (rename_all n n' l)
|
||||
| Form.Vec l -> Option.map (fun l -> { f with v = Form.Vec l }) (rename_all n n' l)
|
||||
| _ -> Some f
|
||||
|
||||
and rename_all n n' l =
|
||||
List.fold_right
|
||||
(fun x acc -> match rename n n' x, acc with
|
||||
| Some y, Some ys -> Some (y :: ys)
|
||||
| _ -> None)
|
||||
l (Some [])
|
||||
|
||||
(* [n] renamed [n'] in the [let] [(let [t v ...] 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 List.mem n (binders t []) ->
|
||||
(match t.v with
|
||||
| Form.Sym _ | Form.Vec _ ->
|
||||
(match rename n n' t, rename_all n n' rest, rename_all n n' body with
|
||||
| Some t', Some rest', Some body' -> Some (t' :: v :: rest', body')
|
||||
| _ -> None)
|
||||
| _ -> 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] mentions 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 ->
|
||||
let names =
|
||||
List.sort_uniq compare
|
||||
(List.concat_map (fun t -> binders t []) (List.filteri (fun i _ -> i mod 2 = 0) bs))
|
||||
in
|
||||
let clash = List.filter (fun n -> List.exists (refers n) rest) names in
|
||||
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
|
||||
@ -94,7 +246,7 @@ let rec expr (f : Form.t) : string * int =
|
||||
| Form.Vec xs -> ("[" ^ vec_text xs ^ "]", 10)
|
||||
| Form.Map xs -> ("{" ^ map_text xs ^ "}", 10)
|
||||
| Form.List [] -> ("()", 10)
|
||||
| Form.List (h :: args) -> list f h args
|
||||
| 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 =)"
|
||||
@ -166,6 +318,8 @@ and list _f h args =
|
||||
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
|
||||
@ -331,16 +485,33 @@ let sugar_heads =
|
||||
"handler-case"; "handler-bind"; "restart-case"; "return"; "defer"; "do";
|
||||
"quasiquote"; "update" ]
|
||||
|
||||
let rec block n (fs : Form.t list) : string list =
|
||||
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
|
||||
|
||||
(* [(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 ~last:true x
|
||||
| x :: rest -> stmt n ~last:false x @ go rest
|
||||
| [ 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 ~last (f : Form.t) : string list =
|
||||
let ls = match sugar n ~last f with Some ls -> ls | None -> plain n f in
|
||||
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
|
||||
@ -369,7 +540,12 @@ and plain n (f : Form.t) : string list =
|
||||
| Form.Sym s, [] when name_ok s && not (List.mem s reserved) -> s ^ ":"
|
||||
| _ -> head_text h ^ "(" ^ commas fixed ^ "):"
|
||||
in
|
||||
[ ind n ^ guard opener ] @ block (n + 2) rest
|
||||
let seq =
|
||||
match h.v with
|
||||
| Form.Sym ("do" | "loop" | "defmacro" | "defmethod") -> true
|
||||
| _ -> false
|
||||
in
|
||||
[ ind n ^ guard opener ] @ block ~seq (n + 2) rest
|
||||
| _ when n + String.length text > width && fst (expr f) = text ->
|
||||
wrapped n "" f
|
||||
| _ -> one)
|
||||
@ -438,13 +614,13 @@ and label_of = function
|
||||
| ({ Form.v = Form.Kw k; _ }) :: rest when kw_ok k -> (":" ^ k ^ " ", rest)
|
||||
| rest -> ("", rest)
|
||||
|
||||
and sugar n ~last (f : Form.t) : string list option =
|
||||
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 ~last prs body))
|
||||
| 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) ]
|
||||
@ -675,10 +851,9 @@ and handler_clauses n cls =
|
||||
let cs = List.map clause cls in
|
||||
if List.mem None cs then None else Some (List.concat_map Option.get cs)
|
||||
|
||||
(* A [let] last in its block reads to the block's end, so it is written flat.
|
||||
One with siblings after it takes its body as an indented block under the
|
||||
first binding, and the rest of the bindings go inside that block. *)
|
||||
and let_lines n ~last prs body =
|
||||
(* 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
|
||||
@ -693,15 +868,7 @@ and let_lines n ~last prs body =
|
||||
| [] -> []
|
||||
in
|
||||
let lines n b = let p, v = bind b in tagged b (value_lines n p v) in
|
||||
if last then List.concat_map (lines n) prs @ block n body
|
||||
else
|
||||
match prs with
|
||||
| b :: rest ->
|
||||
let p, v = bind b in
|
||||
tagged b [ ind n ^ p ^ " = " ^ at 0 v ]
|
||||
@ List.concat_map (lines (n + 2)) rest
|
||||
@ block (n + 2) body
|
||||
| [] -> block n body
|
||||
List.concat_map (lines n) prs @ block n body
|
||||
|
||||
(** A whole file: top-level forms with a blank line between them. *)
|
||||
let program ?source (fs : Form.t list) : string =
|
||||
@ -714,10 +881,17 @@ let program ?source (fs : Form.t list) : string =
|
||||
(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;
|
||||
note_used x;
|
||||
String.concat "\n" (stmt 0 x)
|
||||
in
|
||||
let rec go = function
|
||||
| [] -> []
|
||||
| [ x ] -> [ String.concat "\n" (stmt 0 ~last:true x) ]
|
||||
| x :: rest -> String.concat "\n" (stmt 0 ~last:false x) :: go rest
|
||||
| [ 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"
|
||||
|
||||
@ -1118,10 +1118,13 @@ and let_stmt (s : st) : Form.t list =
|
||||
make (target :: v :: bs) body
|
||||
| _ -> make [ target; v ] body
|
||||
in
|
||||
if (peek p).tok = INDENT then begin
|
||||
let f = merged (block s ~after:"let") in
|
||||
f :: stmts s
|
||||
end
|
||||
(* A let has no block: its name lasts to the end of the block it is in. *)
|
||||
if (peek p).tok = INDENT then
|
||||
failk "let-block" (peek_at p 1).loc
|
||||
"this line is indented under let %s, which takes no block. A let's \
|
||||
name lasts to the end of the block the let is in, so the lines after \
|
||||
it go at the let's column"
|
||||
(text_of target)
|
||||
else [ merged (stmts s) ]
|
||||
|
||||
and stmt (s : st) : Form.t =
|
||||
|
||||
@ -175,8 +175,14 @@ Each item: the proposal, then the reason in one line.
|
||||
|
||||
- **`let x = v`** scopes to the end of its block and reads as
|
||||
`(let [x v] rest…)`. Consecutive `let`s merge into one binding vector.
|
||||
`let x = v` followed by a deeper-indented block scopes to that block only,
|
||||
which is how the printer writes a `let` that has siblings after it.
|
||||
A `let` is always flat: a line indented deeper under `let x = v` is
|
||||
refused. To end a `let`'s scope early, put it in a `do:` block.
|
||||
The printer writes every `let` flat. A `let` with statements after it
|
||||
takes them into its body; when one of them means an outer name the `let`
|
||||
rebinds, the `let`'s is renamed (`x` to `x-2`, a name the top-level form
|
||||
does not use). Where a rename cannot be trusted (the name quoted, or in a
|
||||
struct pattern or braces), and at the top level, among a call's arguments
|
||||
and in a quasiquote, the `let` goes in a `do:` block instead.
|
||||
Destructuring: `let {.x .y} = p`, `let [head & tail] = xs`. (`defer` is
|
||||
function-scoped, not let-scoped, `TODO.org` "defer may be written in a let",
|
||||
so merging never moves a cleanup.) **Built**; `let x =` with the value as an
|
||||
@ -337,8 +343,13 @@ Each step lands on its own, with `dune test --root .` green.
|
||||
3. **The printer**, `Form.t` → indented text, and a `flan convert` command.
|
||||
**Test:** for every corpus file, read with parens, print indented, read
|
||||
indented; the forms must be equal to the first read, after one normalisation:
|
||||
a `let` whose whole body is another `let` counts as equal to the merged
|
||||
`let`. That covers 394 files and runs on readers alone, so it's fast.
|
||||
every name a `let` binds is renamed through its scope to one numbered by
|
||||
binding order; then, in a body run in order, a `let` counts as equal to
|
||||
itself taking in the later statements of the body; `(do x)` with `x` a
|
||||
`let` counts as `x`; a `let` whose whole body is another `let` counts as
|
||||
equal to the merged `let`; `(and x)` and `(or x)` count as `x`. Taking in
|
||||
and the one-argument `and` stop at a quote or quasiquote. That covers 394
|
||||
files and runs on readers alone, so it's fast.
|
||||
4. **The dev loop.** Code-carrying wire ops (`eval`, `eval-expr`,
|
||||
`macroexpand`, `set`) get an explicit `:syntax` field instead of guessing
|
||||
from `:file`. The `:file` guess breaks for `<repl>`/`<inspect>` origins and
|
||||
|
||||
@ -31,8 +31,8 @@ fn insertion-sort(coll: [$t]) -> () where ordered?($t)
|
||||
let j = i
|
||||
while j > 0 and coll[j] < coll[dec(j)]
|
||||
let temp = coll[j]
|
||||
coll[j] = coll[dec(j)]
|
||||
coll[dec(j)] = temp
|
||||
coll[j] = coll[dec(j)]
|
||||
coll[dec(j)] = temp
|
||||
--(j)
|
||||
++(i)
|
||||
|
||||
@ -41,10 +41,12 @@ fn main() -> i32 = 0
|
||||
comment:
|
||||
insertion-sort([\I \N \S \E \R \T \I \O \N \S \O \R \T])
|
||||
insertion-sort(slice([6 2 4 9 1 9 4 5], 0, 8))
|
||||
let str = bytes("INSERTIONSORT")
|
||||
do:
|
||||
let str = bytes("INSERTIONSORT")
|
||||
insertion-sort(str)
|
||||
println(str)
|
||||
let str = bytes("SELECTIONSORT")
|
||||
do:
|
||||
let str = bytes("SELECTIONSORT")
|
||||
selection-sort(str)
|
||||
println(str)
|
||||
find-match("aababba", "abba")
|
||||
|
||||
@ -59,20 +59,20 @@ fn settle(row: i32, col: i32) -> ()
|
||||
velocity[row, col] = 0.0
|
||||
return
|
||||
let left? = col > 0 and 0 == grid[y, col - 1]
|
||||
let right? = col < cols - 1 and 0 == grid[y, col + 1]
|
||||
if left? or right?
|
||||
let side =
|
||||
if not left?
|
||||
1
|
||||
elif not right?
|
||||
-1
|
||||
else
|
||||
if f32(rand()) < 0.5 then 1 else -1
|
||||
grid[y, col + side] = grid[row, col]
|
||||
grid[row, col] = 0
|
||||
velocity[y, col + side] = vel
|
||||
velocity[row, col] = 0.0
|
||||
return
|
||||
let right? = col < cols - 1 and 0 == grid[y, col + 1]
|
||||
if left? or right?
|
||||
let side =
|
||||
if not left?
|
||||
1
|
||||
elif not right?
|
||||
-1
|
||||
else
|
||||
if f32(rand()) < 0.5 then 1 else -1
|
||||
grid[y, col + side] = grid[row, col]
|
||||
grid[row, col] = 0
|
||||
velocity[y, col + side] = vel
|
||||
velocity[row, col] = 0.0
|
||||
return
|
||||
y = y - 1
|
||||
velocity[row, col] = 0.0
|
||||
|
||||
|
||||
@ -3,7 +3,7 @@
|
||||
|
||||
Four parts. Two programs hand-converted from paren to indented must read to
|
||||
the same forms. Every corpus file must survive paren -> printed indented ->
|
||||
read indented unchanged, up to the one merge the spec allows. A table pins
|
||||
read indented unchanged, up to the normalisation the spec allows. A table pins
|
||||
the lexical edge cases and the refusals, with their kinds. And a program in
|
||||
each syntax importing a package in the other builds and runs the same on
|
||||
both backends. *)
|
||||
@ -49,23 +49,150 @@ let describe_diff a b =
|
||||
(Form.to_string w) w.loc.Loc.line w.loc.Loc.col
|
||||
| None -> "equal"
|
||||
|
||||
(* A [let] whose whole body is another [let] is the merged [let]: spec §4
|
||||
step 3's one normalisation. Flan's [let] binds in order, so the two mean
|
||||
the same thing. *)
|
||||
let rec norm (f : Form.t) : Form.t =
|
||||
let v =
|
||||
match f.v with
|
||||
| Form.List (({ v = Form.Sym "let"; _ } as h) :: { v = Form.Vec bs; loc } :: body) ->
|
||||
(match List.map norm body with
|
||||
| [ { v = Form.List ({ v = Form.Sym "let"; _ } :: { v = Form.Vec bs2; _ } :: body2); _ } ] ->
|
||||
Form.List (h :: Form.make (Form.Vec (List.map norm bs @ bs2)) loc :: body2)
|
||||
| body -> Form.List (h :: Form.make (Form.Vec (List.map norm bs)) loc :: body))
|
||||
| Form.List l -> Form.List (List.map norm l)
|
||||
| Form.Vec l -> Form.Vec (List.map norm l)
|
||||
| Form.Map l -> Form.Map (List.map norm l)
|
||||
| v -> v
|
||||
(* Spec §4 step 3's normalisation. Each rule keeps the meaning.
|
||||
|
||||
First every name a [let] binds is renamed, through its scope, to one
|
||||
numbered in the order the binders come: so two forms that differ only in
|
||||
what their [let]s call things compare equal, and one where a name was
|
||||
captured does not. Then, where statements are a body run in order, a
|
||||
[let] takes in the statements after it (the printer's flat [let]; with
|
||||
every [let] name unique by now, nothing after it can mean one of them). A
|
||||
[(do x)] whose [x] is a [let] is [x], a [let] whose whole body is another
|
||||
[let] is the merged [let], and [(and x)] and [(or x)] are [x]. The flat
|
||||
[let] and the one-argument [and] stop at a quote or quasiquote: data, or
|
||||
a template whose unquotes could name anything. *)
|
||||
|
||||
(* The names a binding target binds; [.field] in a struct pattern binds
|
||||
[field]. *)
|
||||
let rec binders (t : Form.t) acc =
|
||||
match t.v with
|
||||
| Form.Sym "&" -> acc
|
||||
| Form.Sym s when s <> "" && s.[0] = '.' -> String.sub s 1 (String.length s - 1) :: acc
|
||||
| Form.Sym s -> s :: acc
|
||||
| Form.List l | Form.Vec l | Form.Map l -> List.fold_left (fun a x -> binders x a) acc l
|
||||
| _ -> acc
|
||||
|
||||
let canon (f : Form.t) : Form.t =
|
||||
let k = ref 0 in
|
||||
let look env s =
|
||||
match List.assoc_opt s env with
|
||||
| Some c -> c
|
||||
| None ->
|
||||
(* [x.y], a field path on a bound [x]. *)
|
||||
match String.index_opt s '.' with
|
||||
| Some i when i > 0 ->
|
||||
(match List.assoc_opt (String.sub s 0 i) env with
|
||||
| Some c -> c ^ String.sub s i (String.length s - i)
|
||||
| None -> s)
|
||||
| _ -> s
|
||||
in
|
||||
{ f with v }
|
||||
let rec go env (f : Form.t) =
|
||||
let v =
|
||||
match f.v with
|
||||
| Form.Sym s -> Form.Sym (look env s)
|
||||
(* Quoted data keeps its names: renaming them would hide a printer
|
||||
that renamed them too. *)
|
||||
| Form.List ({ v = Form.Sym ("quote" | "quasiquote"); _ } :: _) -> f.v
|
||||
| Form.List (({ v = Form.Sym "let"; _ } as h) :: ({ v = Form.Vec bs; _ } as bv) :: body) ->
|
||||
let rec binds env acc = function
|
||||
| t :: v :: rest ->
|
||||
let v' = go env v in
|
||||
let env' =
|
||||
List.fold_left (fun e n -> incr k; (n, "%" ^ string_of_int !k) :: e)
|
||||
env (binders t [])
|
||||
in
|
||||
binds env' (v' :: go env' t :: acc) rest
|
||||
| rest -> (env, List.rev_append acc (List.map (go env) rest))
|
||||
in
|
||||
let env', bs' = binds env [] bs in
|
||||
Form.List (h :: { bv with v = Form.Vec bs' } :: List.map (go env') body)
|
||||
| Form.List l -> Form.List (List.map (go env) l)
|
||||
| Form.Vec l -> Form.Vec (List.map (go env) l)
|
||||
| Form.Map l -> Form.Map (List.map (go env) l)
|
||||
| v -> v
|
||||
in
|
||||
{ f with v }
|
||||
in
|
||||
go [] f
|
||||
|
||||
(* Where the statements of a body start, for a head whose trailing arguments
|
||||
are a body run in order. *)
|
||||
let body_start (l : Form.t list) =
|
||||
let label k = match List.nth_opt l 1 with
|
||||
| Some { Form.v = Form.Kw _; _ } -> k + 1 | _ -> k in
|
||||
match l with
|
||||
| { Form.v = Form.Sym h; _ } :: _ ->
|
||||
(match h with
|
||||
| "do" | "defer" -> Some 1
|
||||
| "let" | "when" | "fn" | "loop" -> Some 2
|
||||
| "while" | "until" | "dotimes" -> Some (label 2)
|
||||
| "defmacro" -> Some 3
|
||||
| "defmethod" -> Some 4
|
||||
| "defn" | "defn-" ->
|
||||
Some (match List.nth_opt l 4 with
|
||||
| Some { Form.v = Form.Map _; _ } -> 5 | _ -> 4)
|
||||
| _ -> None)
|
||||
| _ -> None
|
||||
|
||||
let is_let (f : Form.t) =
|
||||
match f.v with Form.List ({ v = Form.Sym "let"; _ } :: _) -> true | _ -> false
|
||||
|
||||
let rec shape ?(q = false) (f : Form.t) : Form.t =
|
||||
let q = q || (match f.v with
|
||||
| Form.List ({ v = Form.Sym ("quote" | "quasiquote"); _ } :: _) -> true | _ -> false) in
|
||||
let sh = shape ~q in
|
||||
(* A body's statements, each [let] taking in the ones after it. *)
|
||||
let rec stmts = function
|
||||
| [] -> []
|
||||
| x :: (_ :: _ as rest) when not q ->
|
||||
(match (sh x).v with
|
||||
| Form.List (({ v = Form.Sym "let"; _ } as h) :: ({ v = Form.Vec (_ :: _); _ } as bv)
|
||||
:: (_ :: _ as body)) ->
|
||||
[ sh { x with v = Form.List (h :: bv :: (body @ rest)) } ]
|
||||
| _ -> sh x :: stmts rest)
|
||||
| x :: rest -> sh x :: stmts rest
|
||||
in
|
||||
let seq_list l =
|
||||
match body_start l with
|
||||
| Some k when List.length l > k ->
|
||||
List.map sh (List.filteri (fun i _ -> i < k) l)
|
||||
@ stmts (List.filteri (fun i _ -> i >= k) l)
|
||||
| _ -> List.map sh l
|
||||
in
|
||||
(* Handler and restart clauses: [(name [v] body ...)]. *)
|
||||
let clause (c : Form.t) =
|
||||
match c.v with
|
||||
| Form.List (n :: p :: body) -> { c with v = Form.List (sh n :: sh p :: stmts body) }
|
||||
| _ -> sh c
|
||||
in
|
||||
match f.v with
|
||||
| Form.List [ { v = Form.Sym ("and" | "or"); _ }; x ] when not q -> sh x
|
||||
| _ ->
|
||||
let v =
|
||||
match f.v with
|
||||
| Form.List (({ v = Form.Sym "let"; _ } as h) :: { v = Form.Vec bs; loc } :: body) ->
|
||||
(match stmts body with
|
||||
| [ { v = Form.List ({ v = Form.Sym "let"; _ } :: { v = Form.Vec bs2; _ } :: body2); _ } ] ->
|
||||
Form.List (h :: Form.make (Form.Vec (List.map sh bs @ bs2)) loc :: body2)
|
||||
| body -> Form.List (h :: Form.make (Form.Vec (List.map sh bs)) loc :: body))
|
||||
| Form.List (({ v = Form.Sym "handler-case"; _ } as h) :: body :: ({ v = Form.Vec cls; _ } as cv) :: more) ->
|
||||
Form.List (h :: sh body :: { cv with v = Form.Vec (List.map clause cls) }
|
||||
:: List.map sh more)
|
||||
| Form.List (({ v = Form.Sym "handler-bind"; _ } as h) :: ({ v = Form.Vec cls; _ } as cv) :: body) ->
|
||||
Form.List (h :: { cv with v = Form.Vec (List.map clause cls) } :: stmts body)
|
||||
| Form.List (({ v = Form.Sym "restart-case"; _ } as h) :: body :: cls) ->
|
||||
Form.List (h :: sh body :: List.map clause cls)
|
||||
| Form.List l ->
|
||||
(match seq_list l with
|
||||
| [ { v = Form.Sym "do"; _ }; x ] when is_let x -> x.v
|
||||
| l -> Form.List l)
|
||||
| Form.Vec l -> Form.Vec (List.map sh l)
|
||||
| Form.Map l -> Form.Map (List.map sh l)
|
||||
| v -> v
|
||||
in
|
||||
{ f with v }
|
||||
|
||||
let norm f = shape (canon f)
|
||||
|
||||
let diag_text = function
|
||||
| Loc.Error d -> Printf.sprintf "%s %d:%d %s" d.Loc.kind d.dloc.Loc.line d.dloc.Loc.col d.dmsg
|
||||
@ -76,6 +203,9 @@ let diag_text = function
|
||||
let pair flan fln =
|
||||
match Reader.read_file flan, Source.read_file fln with
|
||||
| a, b ->
|
||||
(* Normalised: a hand conversion writes a let flat where its scope does
|
||||
not matter, as the printer does. *)
|
||||
let a = List.map norm a and b = List.map norm b in
|
||||
if not (same_forms a b) then
|
||||
fail "%s and %s read differently: %s" flan fln (describe_diff a b)
|
||||
| exception e -> fail "%s / %s: %s" flan fln (diag_text e)
|
||||
@ -112,13 +242,15 @@ let starts_of (fs : Form.t list) =
|
||||
let rec walk (f : Form.t) =
|
||||
(* Outermost first among forms starting at one place: [x = v] and its
|
||||
[x] start together, and the statement is what a comment is about. *)
|
||||
let t = Form.to_string (norm f) in
|
||||
let t = Form.to_string f in
|
||||
out := ((f.loc.Loc.line, f.loc.Loc.col, - String.length t), t) :: !out;
|
||||
match f.v with
|
||||
| Form.List l | Form.Vec l | Form.Map l -> List.iter walk l
|
||||
| _ -> ()
|
||||
in
|
||||
List.iter walk fs;
|
||||
(* The normalised forms: a [let] a flat line extended is, on both sides,
|
||||
the one that holds what now follows it. *)
|
||||
List.iter walk (List.map norm fs);
|
||||
List.map (fun ((l, c, _), t) -> (l, c, t)) (List.sort compare !out)
|
||||
|
||||
let attachments src forms =
|
||||
@ -350,7 +482,8 @@ let () =
|
||||
(* Statements. *)
|
||||
reads "lets merge" "fn f() -> i32\n let a = 1\n let b = 2\n a + b"
|
||||
"(defn f [] i32 (let [a 1 b 2] (+ a b)))";
|
||||
reads "let with a block" "let a = 1\n a\nb" "(let [a 1] a)\nb";
|
||||
refuses "let with a block" "let a = 1\n a\nb" "indent/let-block" "go at the let's column";
|
||||
reads "flat let" "let a = 1\na\nb" "(let [a 1] a b)";
|
||||
reads "elif" "if a\n 1\nelif b\n 2\nelse\n 3" "(cond a 1 b 2 :else 3)";
|
||||
reads "one-line if" "x = if a then 1 else 2" "(set x (if a 1 2))";
|
||||
reads "assignment ops" "a[i] += 1" "(set (at a i) (+ (at a i) 1))";
|
||||
@ -408,6 +541,8 @@ let () =
|
||||
reads "one-line quote" "defmacro(m, [x]):\n quote ~x + 1"
|
||||
"(defmacro m [x] (quasiquote (+ (unquote x) 1)))";
|
||||
reads "typed let" "let x: i32 = 5\nx" "(let [x (the i32 5)] x)";
|
||||
refuses "a let takes no block" "fn f() -> ()\n let x = 1\n g(x)\n h(x)"
|
||||
"indent/let-block" "go at the let's column";
|
||||
(* And back: the printer writes the idioms. *)
|
||||
let prints name src want =
|
||||
match Reader.read_all ~file:"<p>" src with
|
||||
@ -427,6 +562,49 @@ let () =
|
||||
prints "a statement argument makes a block" "(foo 1 (set x 2))" "foo(1):\n x = 2";
|
||||
prints "no arguments before the block" "(comment (f))" "comment:\n f()";
|
||||
prints "typed let" "(defn f [] i32 (let [x (the i32 5)] x))" "let x: i32 = 5";
|
||||
(* A let is always flat: it takes in the rest of its block. *)
|
||||
prints "flat let" "(defn f [] () (let [j 1] (g j)) (h))" " let j = 1\n g(j)\n h()";
|
||||
prints "a chain of lets, all flat" "(defn f [] () (let [a 1] (let [b 2] (g b)) (k a)) (h))"
|
||||
" let a = 1\n let b = 2\n g(b)\n k(a)\n h()";
|
||||
(* A later statement that means an outer name of the same spelling: the
|
||||
let's own is renamed. *)
|
||||
prints "a later outer name of the same spelling renames the let's"
|
||||
"(defn f [x i32] () (let [x 1] (g x)) (h x))" " let x-2 = 1\n g(x-2)\n h(x)";
|
||||
prints "the inner let of a chain renamed"
|
||||
"(defn f [] () (let [a 1] (let [b 2] (g b)) (h b)))" " let a = 1\n let b-2 = 2\n g(b-2)\n h(b)";
|
||||
prints "the binding's own value keeps the outer name"
|
||||
"(defn f [x i32] () (let [x (+ x 1)] (g x)) (h x))" " let x-2 = x + 1\n g(x-2)\n h(x)";
|
||||
prints "a later binding's value takes the new name"
|
||||
"(defn f [x i32] () (let [x 1 y (+ x 1)] (g y)) (h x))"
|
||||
" let x-2 = 1\n let y = x-2 + 1\n g(y)\n h(x)";
|
||||
prints "the new name is one the function does not use"
|
||||
"(defn f [x i32] () (let [x 1] (g x x-2)) (h x))" " let x-3 = 1\n g(x-3, x-2)\n h(x)";
|
||||
prints "a later let of the same name is no mention"
|
||||
"(defn f [] () (let [a 1] (g a)) (let [a 2] (k a)))" " let a = 1\n g(a)\n let a = 2\n k(a)";
|
||||
prints "unless its value uses the name"
|
||||
"(defn f [a i32] () (let [a 1] (g a)) (let [a (+ a 1)] (k a)))"
|
||||
" let a-2 = 1\n g(a-2)\n let a = a + 1\n k(a)";
|
||||
prints "a destructured name renamed alone" "(defn f [] () (let [[p q] v] (g p q)) (h q))"
|
||||
" let [p q-2] = v\n g(p, q-2)\n h(q)";
|
||||
prints "a qualified name counts" "(defn f [] () (let [p (pt)] (g p)) (h p/x))"
|
||||
" let p-2 = pt()\n g(p-2)\n h(p/x)";
|
||||
prints "a quoted name later counts" "(defn f [] () (let [a 1] (g a)) (h 'a))"
|
||||
" let a-2 = 1\n g(a-2)\n h('a)";
|
||||
(* Where a rename cannot be trusted, a do: block holds the let. *)
|
||||
prints "a quoted name inside is not renamed" "(defn f [] () (let [a 1] (g 'a)) (h a))"
|
||||
" do:\n let a = 1\n g('a)\n h(a)";
|
||||
prints "a struct pattern is not renamed"
|
||||
"(defn f [x i32] () (let [{.x .y} p] (g y)) (h x))" " do:\n let {.x .y} = p\n g(y)\n h(x)";
|
||||
prints "a braced .name inside is not renamed"
|
||||
"(defn f [x i32] () (let [x 1] (g (P {.x x}))) (h x))" " do:\n let x = 1\n";
|
||||
prints "in a quasiquote" "(defmacro m [x] (quasiquote (do (let [a 1] (g a)) (h ~x))))"
|
||||
" do:\n let a = 1\n g(a)\n h(~x)";
|
||||
prints "among a call's arguments" "(foo 1 (let [a 1] (g a)) (set x 2))"
|
||||
"foo(1):\n do:\n let a = 1\n g(a)\n x = 2";
|
||||
prints "at the top level" "(let [a 1] (g a))\n(h)" "do:\n let a = 1\n g(a)\n\nh()";
|
||||
prints "one-argument and" "(defn f [] () (while (and (< i n)) (g)))" " while i < n\n";
|
||||
prints "one-argument or" "(defn f [] () (when (or c) (g)))" " if c\n";
|
||||
prints "one-argument and in a quasiquote" "(defmacro m [x] (quasiquote (and ~x)))" "and(~x)";
|
||||
prints "do in an arm is a block" "(defn f [] () (match s _ (do (a) (b))))" "_ ->\n a()";
|
||||
prints "hex spelling" "(def c dyn 0xFFF00FFF)" "0xFFF00FFF";
|
||||
prints "own-line comment above its form" "(defn f [] ()\n ;; why\n (g))" " ;; why\n g()";
|
||||
|
||||
Loading…
x
Reference in New Issue
Block a user