From 0b80c1956fcc8042f5db213bb2c5e455f0ab61ae Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Fri, 25 Sep 2026 21:41:59 +0700 Subject: [PATCH 1/3] 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 --- TODO.org | 4 - lib/indent_printer.ml | 222 +++++++++++++++++++++++++++++++++---- lib/indent_reader.ml | 11 +- spec-syntax.md | 19 +++- test/syntax/algorithms.fln | 10 +- test/syntax/sand.fln | 28 ++--- test/test_syntax.ml | 218 ++++++++++++++++++++++++++++++++---- 7 files changed, 438 insertions(+), 74 deletions(-) diff --git a/TODO.org b/TODO.org index 35c7ec6a..dc07b62f 100644 --- a/TODO.org +++ b/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. diff --git a/lib/indent_printer.ml b/lib/indent_printer.ml index 3b7b2512..ffbc2440 100644 --- a/lib/indent_printer.ml +++ b/lib/indent_printer.ml @@ -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" diff --git a/lib/indent_reader.ml b/lib/indent_reader.ml index 2f8ad73f..2d7c5b0a 100644 --- a/lib/indent_reader.ml +++ b/lib/indent_reader.ml @@ -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 = diff --git a/spec-syntax.md b/spec-syntax.md index 1da02171..25c33d49 100644 --- a/spec-syntax.md +++ b/spec-syntax.md @@ -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 ``/`` origins and diff --git a/test/syntax/algorithms.fln b/test/syntax/algorithms.fln index 90b0262b..f4f41e9b 100644 --- a/test/syntax/algorithms.fln +++ b/test/syntax/algorithms.fln @@ -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") diff --git a/test/syntax/sand.fln b/test/syntax/sand.fln index 1efab947..00c5bd9c 100644 --- a/test/syntax/sand.fln +++ b/test/syntax/sand.fln @@ -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 diff --git a/test/test_syntax.ml b/test/test_syntax.ml index 6b83e947..f2167828 100644 --- a/test/test_syntax.ml +++ b/test/test_syntax.ml @@ -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:"

" 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()"; From 55ab1a98ae012544a13a896a1e014264390007a6 Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Fri, 25 Sep 2026 22:39:50 +0700 Subject: [PATCH 2/3] A macro whose definition splices its body into a do, and comment, count as bodies run in order where the .fln printer writes a let flat, and a struct-pattern let renames and flattens like a plain one --- bin/main.ml | 3 +- lib/body_macros.ml | 132 ++++++++++++++++++++++ lib/indent_printer.ml | 217 ++++++++++++++++++++++++------------- spec-syntax.md | 15 ++- test/syntax/algorithms.fln | 14 +-- test/test_syntax.ml | 78 ++++++++++--- 6 files changed, 357 insertions(+), 102 deletions(-) create mode 100644 lib/body_macros.ml diff --git a/bin/main.ml b/bin/main.ml index baa14c73..95a2c844 100644 --- a/bin/main.ml +++ b/bin/main.ml @@ -337,7 +337,8 @@ let () = if Flan.Source.is_indented path then print_string (Flan.Paren_printer.program ~source forms) else - match Flan.Indent_printer.program ~source forms with + let macros = Flan.Body_macros.table ~file:path forms in + match Flan.Indent_printer.program ~source ~macros forms with | text -> print_string text | exception Flan.Indent_printer.Unprintable (f, why) -> Flan.Loc.failk "convert/unprintable" f.Flan.Form.loc diff --git a/lib/body_macros.ml b/lib/body_macros.ml new file mode 100644 index 00000000..28dd6084 --- /dev/null +++ b/lib/body_macros.ml @@ -0,0 +1,132 @@ +(** Which macros take a body run in order, and at which argument it starts. + + Read off each macro's definition: a macro whose rest parameter is spliced, + whole or from a fixed index on, only into places whose forms run in order + — a [do], the body of a [let], [fn], [when], [while] or [loop], or the body + of another such macro — takes a body there. [comment] counts too: nothing + in it runs. The indented printer lets a [let] in such a body take in the + statements after it, as it does in a [do]. + + What a macro does with its arguments outside its templates (a guard that + counts them, say) is not looked at. *) + +type t = (string, int) Hashtbl.t + +(* Core forms whose trailing arguments are a body run in order, and how many + arguments come before it. *) +let core = [ ("do", 0); ("let", 1); ("fn", 1); ("when", 1); ("while", 1); ("loop", 1); + ("defer", 0); ("with-allocator", 1) ] + +let lookup (known : string -> int option) h = + match List.assoc_opt h core with Some k -> Some k | None -> known h + +(* The argument index the body starts at, from [(defmacro name [p ... & r] + body ...)]; [None] when it does not take one. *) +let of_defmacro ~(known : string -> int option) (f : Form.t) : (string * int) option = + match f.v with + | Form.List ({ v = Form.Sym "defmacro"; _ } :: { v = Form.Sym "comment"; _ } :: _) -> + Some ("comment", 0) + | Form.List ({ v = Form.Sym "defmacro"; _ } :: { v = Form.Sym name; _ } + :: { v = Form.Vec ps; _ } :: body) -> + let rec split fixed = function + | { Form.v = Form.Sym "&"; _ } :: [ { Form.v = Form.Sym r; _ } ] -> Some (fixed, r) + | { Form.v = Form.Sym "&"; _ } :: _ -> None + | _ :: rest -> split (fixed + 1) rest + | [] -> None + in + (match split 0 ps with + | None -> None + | Some (fixed, r) -> + let rec mentions (f : Form.t) = + match f.v with + | Form.Sym s -> s = r + | Form.List l | Form.Vec l | Form.Map l -> List.exists mentions l + | _ -> false + in + (* Each splice of the rest parameter: [Some k] when it splices from + argument [k] of the rest on into a place run in order. *) + let starts = ref [] and bad = ref false in + let splice_from (e : Form.t) = + match e.v with + | Form.Sym s when s = r -> Some 0 + | Form.List [ { v = Form.Sym "form-rest"; _ }; { v = Form.Sym s; _ }; + { v = Form.Int k; _ } ] when s = r -> Some (Int64.to_int k) + | _ -> None + in + let rec template (f : Form.t) = + match f.v with + | Form.List ({ v = Form.Sym "unquote"; _ } :: e) -> + (* [~(at r i)] reads one argument, which is fine before the body + and not in it; the check is made once the body's start is + known. Anything else of [r] under an unquote is not followed. *) + List.iter + (fun (e : Form.t) -> + match e.v with + | Form.List [ { v = Form.Sym "at"; _ }; { v = Form.Sym s; _ }; + { v = Form.Int i; _ } ] when s = r -> + starts := `Read (Int64.to_int i) :: !starts + | _ -> if mentions e then bad := true) + e + | Form.List l -> + let head = match l with { v = Form.Sym h; _ } :: _ -> Some h | _ -> None in + List.iteri + (fun i (x : Form.t) -> + match x.v with + | Form.List [ { v = Form.Sym "unquote-splicing"; _ }; e ] -> + (match splice_from e, Option.bind head (lookup known) with + | Some k, Some b when i >= b + 1 -> starts := `Body k :: !starts + | Some _, _ -> bad := true + | None, _ -> if mentions e then bad := true) + | _ -> template x) + l + | Form.Vec l | Form.Map l -> List.iter template l + | _ -> () + in + let rec code (f : Form.t) = + match f.v with + | Form.List [ { v = Form.Sym "quasiquote"; _ }; x ] -> template x + | Form.List l | Form.Vec l | Form.Map l -> List.iter code l + | _ -> () + in + List.iter code body; + let bodies = List.filter_map (function `Body k -> Some k | _ -> None) !starts in + let reads = List.filter_map (function `Read i -> Some i | _ -> None) !starts in + match bodies with + | k :: more when (not !bad) && List.for_all (( = ) k) more + && List.for_all (fun i -> i < k) reads -> + Some (name, fixed + k) + | _ -> None) + | _ -> None + +let add (tbl : t) ~qualify ~known forms = + let local = Hashtbl.create 8 in + List.iter + (fun f -> + match of_defmacro ~known:(fun h -> + match Hashtbl.find_opt local h with Some k -> Some k | None -> known h) f with + | Some (name, k) -> Hashtbl.replace local name k; Hashtbl.replace tbl (qualify name) k + | None -> ()) + forms + +(** The prelude's macros, those of the packages [forms] imports (qualified + by their alias) and [forms]' own. An import that cannot be found or read + adds nothing. *) +let table ?file (forms : Form.t list) : t = + let tbl = Hashtbl.create 32 in + let prelude = try Reader.read_all ~file:Prelude.file Prelude.source with _ -> [] in + add tbl ~qualify:Fun.id ~known:(fun _ -> None) prelude; + let known h = Hashtbl.find_opt tbl h in + (match file with + | None -> () + | Some file -> + List.iter + (fun (alias, path, loc) -> + try + let d = Load.resolve_dir ~file loc path in + let files = if Sys.is_directory d then Load.source_entries d else [ d ] in + let fs = List.concat_map Source.read_file files in + add tbl ~qualify:(fun n -> alias ^ "/" ^ n) ~known fs + with _ -> ()) + (Load.imports_of forms)); + add tbl ~qualify:Fun.id ~known forms; + tbl diff --git a/lib/indent_printer.ml b/lib/indent_printer.ml index ffbc2440..da818b98 100644 --- a/lib/indent_printer.ml +++ b/lib/indent_printer.ml @@ -86,13 +86,17 @@ let in_quasi (f : Form.t) k = (* 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 + 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 (Hashtbl.create 1) + (* 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 @@ -115,17 +119,50 @@ let fresh n = 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 +let dotted s = String.length s > 1 && s.[0] = '.' -(* Whether [f] refers to [n]: the name, or a field path or qualified name +let all f l = + List.fold_right + (fun x acc -> match f x, acc with Some y, Some ys -> Some (y :: ys) | _ -> None) + l (Some []) + +(* A struct pattern's entries as [name .field] pairs, in order: [.x] is + [x .x], and [:keys [x y]] is [x .x y .y] ([Parse.dmap]). [None] for a + shape [Parse] refuses. *) +let struct_pairs (items : Form.t list) = + let rec go = function + | [] -> Some [] + | ({ Form.v = Form.Sym s; _ } as f) :: rest when dotted s -> + let n = String.sub s 1 (String.length s - 1) in + Option.map (fun r -> ({ f with v = Form.Sym n }, f) :: r) (go rest) + | { Form.v = Form.Kw "keys"; _ } :: { Form.v = Form.Vec ns; _ } :: rest -> + Option.bind + (all (fun (n : Form.t) -> match n.v with + | Form.Sym s -> Some (n, { n with v = Form.Sym ("." ^ s) }) + | _ -> None) ns) + (fun ps -> Option.map (fun r -> ps @ r) (go rest)) + | pat :: ({ Form.v = Form.Sym s; _ } as f) :: rest when dotted s -> + Option.map (fun r -> (pat, f) :: r) (go rest) + | _ -> None + in + go items + +(* The names a binding target binds, or [None] for a target [Parse] would + refuse. *) +let rec pat_names (t : Form.t) : string list option = + match t.v with + | Form.Sym s -> Some [ s ] + | Form.Vec l -> + Option.map List.concat + (all (fun (x : Form.t) -> if x.v = Form.Sym "&" then Some [] else pat_names x) l) + | Form.Map l -> + Option.bind (struct_pairs l) (fun ps -> + Option.map List.concat (all (fun (p, _) -> pat_names p) ps)) + | _ -> None + +let binds n t = match pat_names t with Some ns -> List.mem n ns | None -> false + +(* Whether [f] mentions [n]: the name, or a field path or qualified name starting with it. Any occurrence counts, a quoted one or one under an unquote included. A macro whose expansion names a variable its call does not spell is the one case this cannot see. *) @@ -136,20 +173,12 @@ let rec mentions n (f : Form.t) = | _ -> 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 a = ...] of the same name is a new [a], not the one before it. *) 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 :: v :: rest -> refers n v || ((not (binds n t)) && go rest) | [ t ] -> refers n t | [] -> List.exists (refers n) body in @@ -157,15 +186,26 @@ let rec refers n (f : Form.t) = | 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 +(* 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 in a braced form [.n] may - bind [n] as well as name a field. *) +(* [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' } @@ -174,29 +214,35 @@ let rec rename n n' (f : Form.t) : Form.t option = 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) + | 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 -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]. *) +(* [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 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) + | 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) @@ -204,21 +250,23 @@ let rename_let n n' (bs : Form.t list) (body : Form.t list) = 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. *) + [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 -> - 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)) }) + Option.bind + (all pat_names (List.filteri (fun i _ -> i mod 2 = 0) bs)) + (fun names -> + let clash = + List.filter (fun n -> List.exists (refers n) rest) + (List.sort_uniq compare (List.concat 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 ───────────────────────────────────────────────────── *) @@ -436,7 +484,7 @@ let stmts_of (f : Form.t) = | _ -> [ f ] (* Heads whose trailing arguments are a body, and how many come before it. *) -let body_split (h : Form.t) args = +let body_guess (h : Form.t) args = match h.v with | Form.Sym s -> let base = @@ -480,17 +528,38 @@ let body_split (h : Form.t) args = else None) | _ -> None -let sugar_heads = - [ "let"; "set"; "if"; "when"; "cond"; "while"; "until"; "dotimes"; "match"; - "handler-case"; "handler-bind"; "restart-case"; "return"; "defer"; "do"; - "quasiquote"; "update" ] - let let_sugar (f : Form.t) = match f.v with | Form.List ({ v = Form.Sym "let"; _ } :: { v = Form.Vec bs; _ } :: _ :: _) -> (match pairs bs with None | Some [] -> false | Some _ -> true) | _ -> false +(* [Some (k, seq)]: the arguments from [k] on print as a block, and [seq] + when that block is a body run in order ([Body_macros]), whose start the + definition gives rather than the guess. *) +let body_split (h : Form.t) args = + match body_guess h args, h.v with + | None, Form.Sym s -> + (* A body with a [let] in it is written as a block, where the [let] can + be flat. *) + (match Hashtbl.find_opt !macros s with + | Some b when List.exists let_sugar (List.filteri (fun i _ -> i >= b) args) -> + Some (b, true) + | _ -> 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 s with + | Some b, _ | None, Some b when b < n -> Some (b, true) + | _ -> Some (k, List.mem s [ "defmacro"; "defmethod" ])) + | Some k, _ -> Some (k, false) + +let sugar_heads = + [ "let"; "set"; "if"; "when"; "cond"; "while"; "until"; "dotimes"; "match"; + "handler-case"; "handler-bind"; "restart-case"; "return"; "defer"; "do"; + "quasiquote"; "update" ] + + (* [(do x)]: printed as [do:] and [x] as the one statement of its block. *) let in_do (x : Form.t) = { x with v = Form.List [ Form.make (Form.Sym "do") x.loc; x ] } @@ -530,7 +599,7 @@ and plain n (f : Form.t) : string list = match f.v with | Form.List (h :: args) when args <> [] -> (match body_split h args with - | Some k when k < List.length args -> + | 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 = @@ -540,11 +609,6 @@ 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 - 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 @@ -766,7 +830,9 @@ and sugar n (f : Form.t) : string list option = (match body with | [] -> Some [ head ] | [ x ] when (match x.v with - | Form.List ({ v = Form.Sym h; _ } :: _) -> not (List.mem h sugar_heads) + | Form.List (({ v = Form.Sym h; _ } as hf) :: args) -> + (* A call that takes a block is a statement, not a value. *) + not (List.mem h sugar_heads) && body_split hf args = None | _ -> true) && String.length head + 3 + String.length (at 0 x) <= width && not (!inside f) -> @@ -870,8 +936,11 @@ and let_lines n prs body = let lines n b = let p, v = bind b in tagged b (value_lines n p v) in List.concat_map (lines n) prs @ block n body -(** A whole file: top-level forms with a blank line between them. *) -let program ?source (fs : Form.t list) : string = +(** A whole file: top-level forms with a blank line between them. [macros] + is [Body_macros.table] of the file; without it, the prelude's and the + file's own macros are known and no imported package's. *) +let program ?source ?macros:m (fs : Form.t list) : string = + macros := (match m with Some m -> m | None -> Body_macros.table fs); spelling := (match source with Some src -> Source_text.spelling src | None -> fun _ -> None); let cs = match source with Some src -> Source_text.comments src | None -> [] in diff --git a/spec-syntax.md b/spec-syntax.md index 25c33d49..0c56e710 100644 --- a/spec-syntax.md +++ b/spec-syntax.md @@ -180,9 +180,15 @@ Each item: the proposal, then the reason in one line. 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. + does not use; a struct pattern is written as `{x-2 .x}` pairs). A macro's + body counts as statements run in order when its definition splices its + rest parameter only into a `do`, a `let`/`fn`/`when`/`while`/`loop` body or + another such macro's body; `comment` counts too. Where a rename cannot be + trusted (the name quoted, qualified as `x/y`, or called as `x(...)`), and + at the top level, among a call's other arguments and in a quasiquote, the + `let` goes in a `do:` block instead. One case this cannot see: a macro + whose expansion names a variable its call does not spell can pick up a + `let`'s name that now reaches further. 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 @@ -345,7 +351,8 @@ Each step lands on its own, with `dune test --root .` green. indented; the forms must be equal to the first read, after one normalisation: 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 + itself taking in the later statements of the body (a macro's body by the + same rule as the printer's); `(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 diff --git a/test/syntax/algorithms.fln b/test/syntax/algorithms.fln index f4f41e9b..2c0e7310 100644 --- a/test/syntax/algorithms.fln +++ b/test/syntax/algorithms.fln @@ -41,13 +41,11 @@ 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)) - do: - let str = bytes("INSERTIONSORT") - insertion-sort(str) - println(str) - do: - let str = bytes("SELECTIONSORT") - selection-sort(str) - println(str) + let str = bytes("INSERTIONSORT") + insertion-sort(str) + println(str) + let str = bytes("SELECTIONSORT") + selection-sort(str) + println(str) find-match("aababba", "abba") :- diff --git a/test/test_syntax.ml b/test/test_syntax.ml index f2167828..2d4099b1 100644 --- a/test/test_syntax.ml +++ b/test/test_syntax.ml @@ -62,15 +62,36 @@ let describe_diff a b = [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 = +(* A binding target with every struct pattern written as [name .field] + pairs: [{.x}] and [{:keys [x]}] are [{x .x}] (Parse.dmap). *) +let rec pairs_pat (t : Form.t) : Form.t = + let dotted s = String.length s > 1 && s.[0] = '.' in + let rec items = function + | ({ Form.v = Form.Sym s; _ } as f) :: rest when dotted s -> + { f with v = Form.Sym (String.sub s 1 (String.length s - 1)) } :: f :: items rest + | { Form.v = Form.Kw "keys"; _ } :: { Form.v = Form.Vec ns; _ } :: rest -> + List.concat_map + (fun (n : Form.t) -> match n.v with + | Form.Sym x -> [ n; { n with v = Form.Sym ("." ^ x) } ] + | _ -> [ n ]) + ns + @ items rest + | pat :: f :: rest -> pairs_pat pat :: f :: items rest + | rest -> rest + in 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 + | Form.Vec l -> { t with v = Form.Vec (List.map pairs_pat l) } + | Form.Map l -> { t with v = Form.Map (items l) } + | _ -> t + +(* The names a target so written binds, in order. *) +let rec binders (t : Form.t) = + match t.v with + | Form.Sym "&" -> [] + | Form.Sym s -> [ s ] + | Form.Vec l -> List.concat_map binders l + | Form.Map l -> List.concat (List.filteri (fun i _ -> i mod 2 = 0) (List.map binders l)) + | _ -> [] let canon (f : Form.t) : Form.t = let k = ref 0 in @@ -97,9 +118,10 @@ let canon (f : Form.t) : Form.t = let rec binds env acc = function | t :: v :: rest -> let v' = go env v in + let t = pairs_pat t in let env' = List.fold_left (fun e n -> incr k; (n, "%" ^ string_of_int !k) :: e) - env (binders t []) + env (binders t) in binds env' (v' :: go env' t :: acc) rest | rest -> (env, List.rev_append acc (List.map (go env) rest)) @@ -115,6 +137,9 @@ let canon (f : Form.t) : Form.t = in go [] f +(* The macros of the file being compared ([Body_macros.table]). *) +let macros : Body_macros.t ref = ref (Hashtbl.create 1) + (* 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) = @@ -131,7 +156,10 @@ let body_start (l : Form.t list) = | "defn" | "defn-" -> Some (match List.nth_opt l 4 with | Some { Form.v = Form.Map _; _ } -> 5 | _ -> 4) - | _ -> None) + | h -> + (match List.assoc_opt h Body_macros.core with + | Some k -> Some (k + 1) + | None -> Option.map (fun k -> k + 1) (Hashtbl.find_opt !macros h))) | _ -> None let is_let (f : Form.t) = @@ -203,6 +231,7 @@ let diag_text = function let pair flan fln = match Reader.read_file flan, Source.read_file fln with | a, b -> + macros := Body_macros.table ~file:flan a; (* 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 @@ -342,7 +371,8 @@ let () = | exception Loc.Error _ -> () (* not a program the paren reader takes *) | forms -> let source = In_channel.with_open_bin path In_channel.input_all in - match Indent_printer.program ~source forms with + macros := Body_macros.table ~file:path forms; + match Indent_printer.program ~source ~macros:!macros forms with | exception Indent_printer.Unprintable (f, why) -> fail "round trip %s: %s at %d:%d" path why f.loc.Loc.line f.loc.Loc.col | text -> @@ -593,10 +623,28 @@ let () = (* 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 "a call of the name inside is not renamed" "(defn f [] () (let [len 1] (len v)) (h len))" + " do:\n let len = 1\n len(v)\n h(len)"; + (* A struct pattern renames as pairs, so the field keeps its name. *) + prints "a struct pattern renamed" + "(defn f [x i32] () (let [{.x .y} p] (g x y)) (h x))" " let {x-2 .x y .y} = p\n g(x-2, y)\n h(x)"; + prints "a :keys pattern renamed" + "(defn f [x i32] () (let [{:keys [x y]} p] (g x y)) (h x))" " let {x-2 .x y .y} = p\n g(x-2, y)\n h(x)"; + prints "a struct pattern that binds none of them stays" + "(defn f [x i32] () (let [{.y .z} p] (g y)) (h x))" " let {.y .z} = p\n g(y)\n h(x)"; + prints "a later struct pattern rebinding the name is no mention" + "(defn f [] () (let [x 1] (g x)) (let [{.x} p] (k x)))" " let x = 1\n g(x)\n let {.x} = p\n k(x)"; + prints "a struct literal inside is renamed" + "(defn f [x i32] () (let [x 1] (g (P {.x x}))) (h x))" " let x-2 = 1\n g(P{.x x-2})\n h(x)"; + (* A macro whose body its definition splices into a do is a body run in + order; one that splices it anywhere else is not. *) + prints "a macro's in-order body" + "(defmacro twice [n & body] `(do ~@body ~@body))\n(defn f [] () (twice 2 (let [a 1] (g a)) (h)))" + " twice(2):\n let a = 1\n g(a)\n h()"; + prints "a macro's list of arguments" + "(defmacro listed [& xs] `(list ~@xs))\n(defn f [] () (listed (let [a 1] (g a)) (set x 2)))" + " listed:\n do:\n let a = 1\n g(a)\n x = 2"; + prints "comment is a body in order" "(comment (let [a 1] (g a)) (h))" "comment:\n let a = 1\n g(a)\n h()"; 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))" From 0e26af21076f1835382453bc9c69c92243fdd849 Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Fri, 25 Sep 2026 23:00:27 +0700 Subject: [PATCH 3/3] A macro body counts as run in order only when nothing outside its templates depends on how the body splits into arguments, a let whose longer scope would reach a macro naming it stays in a do: block, and converted programs with shadowed names and macro bodies print what their paren originals print --- lib/body_macros.ml | 252 +++++++++++++++++++++------------- lib/indent_printer.ml | 50 +++++-- spec-syntax.md | 10 +- test/syntax/flat/capture.flan | 6 + test/syntax/flat/macros.flan | 46 +++++++ test/syntax/flat/shadows.flan | 85 ++++++++++++ test/test_syntax.ml | 71 +++++++++- 7 files changed, 412 insertions(+), 108 deletions(-) create mode 100644 test/syntax/flat/capture.flan create mode 100644 test/syntax/flat/macros.flan create mode 100644 test/syntax/flat/shadows.flan diff --git a/lib/body_macros.ml b/lib/body_macros.ml index 28dd6084..f03c0d9d 100644 --- a/lib/body_macros.ml +++ b/lib/body_macros.ml @@ -1,121 +1,185 @@ -(** Which macros take a body run in order, and at which argument it starts. +(** What the indented printer needs to know of macros: which take a body run + in order and at which argument it starts, and which names their + expansions spell. - Read off each macro's definition: a macro whose rest parameter is spliced, - whole or from a fixed index on, only into places whose forms run in order - — a [do], the body of a [let], [fn], [when], [while] or [loop], or the body - of another such macro — takes a body there. [comment] counts too: nothing - in it runs. The indented printer lets a [let] in such a body take in the - statements after it, as it does in a [do]. + A body is read off the macro's definition. A macro whose rest parameter + is spliced, whole or from a fixed index on, only into places whose forms + run in order — a [do], the body of a [let], [fn], [when], [while] or + [loop], or the body of another such macro — takes a body there, provided + nothing else of it depends on how the body is split into arguments: out + of its templates the rest parameter may only be counted against the + body's start ([(< (length r) 1)]), read before the body ([(at r 0)] when + the body starts at 1), or have the body's first form tested with a + predicate ([(form-empty-list? (at r 0))]), since a [let] taking in the + forms after it changes how many there are and nothing about the first. + [comment] counts too: nothing in it runs. The printer lets a [let] in such + a body take in the statements after it, as it does in a [do]. - What a macro does with its arguments outside its templates (a guard that - counts them, say) is not looked at. *) + The names a template spells outside its unquotes are what its expansion + can refer to without its call spelling them: a [let] of one of those + names is not given a longer scope over a call of that macro. *) -type t = (string, int) Hashtbl.t +type t = { + bodies : (string, int) Hashtbl.t; (** called name -> argument the body starts at *) + names : (string, string list) Hashtbl.t; (** called name -> names its templates spell *) +} + +let create () = { bodies = Hashtbl.create 32; names = Hashtbl.create 64 } (* Core forms whose trailing arguments are a body run in order, and how many arguments come before it. *) let core = [ ("do", 0); ("let", 1); ("fn", 1); ("when", 1); ("while", 1); ("loop", 1); ("defer", 0); ("with-allocator", 1) ] -let lookup (known : string -> int option) h = - match List.assoc_opt h core with Some k -> Some k | None -> known h +let body_start (t : t) h = + match List.assoc_opt h core with Some k -> Some k | None -> Hashtbl.find_opt t.bodies h -(* The argument index the body starts at, from [(defmacro name [p ... & r] - body ...)]; [None] when it does not take one. *) -let of_defmacro ~(known : string -> int option) (f : Form.t) : (string * int) option = +(* The names a template spells outside its unquotes. *) +let rec template_names (f : Form.t) acc = match f.v with - | Form.List ({ v = Form.Sym "defmacro"; _ } :: { v = Form.Sym "comment"; _ } :: _) -> - Some ("comment", 0) - | Form.List ({ v = Form.Sym "defmacro"; _ } :: { v = Form.Sym name; _ } - :: { v = Form.Vec ps; _ } :: body) -> + | Form.List ({ v = Form.Sym ("unquote" | "unquote-splicing"); _ } :: _) -> acc + | Form.Sym s -> s :: acc + | Form.List l | Form.Vec l | Form.Map l -> List.fold_left (fun a x -> template_names x a) acc l + | _ -> acc + +let rec templates (f : Form.t) acc = + match f.v with + | Form.List [ { v = Form.Sym "quasiquote"; _ }; x ] -> x :: acc + | Form.List l | Form.Vec l | Form.Map l -> List.fold_left (fun a x -> templates x a) acc l + | _ -> acc + +(* The argument index the body of [(defmacro name [p ... & r] body ...)] + starts at, or [None]. [known] gives another macro's. *) +let body_of ~(known : string -> int option) name ps body : int option = + if name = "comment" then Some 0 + else let rec split fixed = function | { Form.v = Form.Sym "&"; _ } :: [ { Form.v = Form.Sym r; _ } ] -> Some (fixed, r) | { Form.v = Form.Sym "&"; _ } :: _ -> None | _ :: rest -> split (fixed + 1) rest | [] -> None in - (match split 0 ps with - | None -> None - | Some (fixed, r) -> - let rec mentions (f : Form.t) = - match f.v with - | Form.Sym s -> s = r - | Form.List l | Form.Vec l | Form.Map l -> List.exists mentions l - | _ -> false - in - (* Each splice of the rest parameter: [Some k] when it splices from - argument [k] of the rest on into a place run in order. *) - let starts = ref [] and bad = ref false in - let splice_from (e : Form.t) = - match e.v with - | Form.Sym s when s = r -> Some 0 - | Form.List [ { v = Form.Sym "form-rest"; _ }; { v = Form.Sym s; _ }; - { v = Form.Int k; _ } ] when s = r -> Some (Int64.to_int k) - | _ -> None - in - let rec template (f : Form.t) = - match f.v with - | Form.List ({ v = Form.Sym "unquote"; _ } :: e) -> - (* [~(at r i)] reads one argument, which is fine before the body - and not in it; the check is made once the body's start is - known. Anything else of [r] under an unquote is not followed. *) - List.iter - (fun (e : Form.t) -> - match e.v with - | Form.List [ { v = Form.Sym "at"; _ }; { v = Form.Sym s; _ }; - { v = Form.Int i; _ } ] when s = r -> - starts := `Read (Int64.to_int i) :: !starts - | _ -> if mentions e then bad := true) - e - | Form.List l -> - let head = match l with { v = Form.Sym h; _ } :: _ -> Some h | _ -> None in - List.iteri - (fun i (x : Form.t) -> - match x.v with - | Form.List [ { v = Form.Sym "unquote-splicing"; _ }; e ] -> - (match splice_from e, Option.bind head (lookup known) with - | Some k, Some b when i >= b + 1 -> starts := `Body k :: !starts - | Some _, _ -> bad := true - | None, _ -> if mentions e then bad := true) - | _ -> template x) - l - | Form.Vec l | Form.Map l -> List.iter template l - | _ -> () - in - let rec code (f : Form.t) = - match f.v with - | Form.List [ { v = Form.Sym "quasiquote"; _ }; x ] -> template x - | Form.List l | Form.Vec l | Form.Map l -> List.iter code l - | _ -> () - in - List.iter code body; - let bodies = List.filter_map (function `Body k -> Some k | _ -> None) !starts in - let reads = List.filter_map (function `Read i -> Some i | _ -> None) !starts in - match bodies with - | k :: more when (not !bad) && List.for_all (( = ) k) more - && List.for_all (fun i -> i < k) reads -> - Some (name, fixed + k) - | _ -> None) - | _ -> None + match split 0 ps with + | None -> None + | Some (fixed, r) -> + let is_r (f : Form.t) = f.v = Form.Sym r in + let rec mentions (f : Form.t) = + match f.v with + | Form.Sym s -> s = r + | Form.List l | Form.Vec l | Form.Map l -> List.exists mentions l + | _ -> false + in + let int (f : Form.t) = match f.v with Form.Int i -> Some (Int64.to_int i) | _ -> None in + let at_r (f : Form.t) = + match f.v with + | Form.List [ { v = Form.Sym "at"; _ }; x; i ] when is_r x -> int i + | _ -> None + in + let bodies = ref [] and reads = ref [] and bad = ref false in + (* Splices of [r] in a template, each where it lands. *) + let splice_from (e : Form.t) = + match e.v with + | Form.Sym s when s = r -> Some 0 + | Form.List [ { v = Form.Sym "form-rest"; _ }; x; k ] when is_r x -> int k + | _ -> None + in + let lookup h = match List.assoc_opt h core with Some k -> Some k | None -> known h in + let rec template (f : Form.t) = + match f.v with + | Form.List [ { v = Form.Sym "unquote"; _ }; e ] -> + (match at_r e with + | Some i -> reads := i :: !reads + | None -> if mentions e then bad := true) + | Form.List [ { v = Form.Sym "unquote-splicing"; _ }; e ] -> + (* Anywhere but in a list's items: a vector, a map. *) + if mentions e then bad := true + | Form.List l -> + let head = match l with { v = Form.Sym h; _ } :: _ -> Some h | _ -> None in + (* A label after while, until or dotimes comes before the test. *) + let label = + match head, l with + | Some ("while" | "until" | "dotimes"), _ :: { v = Form.Kw _; _ } :: _ -> 1 + | _ -> 0 + in + List.iteri + (fun i (x : Form.t) -> + match x.v with + | Form.List [ { v = Form.Sym "unquote-splicing"; _ }; e ] -> + (match splice_from e, Option.bind head lookup with + | Some k, Some b when i >= b + 1 + label -> bodies := k :: !bodies + | _ -> if mentions e then bad := true) + | _ -> template x) + l + | Form.Vec l | Form.Map l -> + List.iter + (fun (x : Form.t) -> + match x.v with + | Form.List [ { v = Form.Sym "unquote-splicing"; _ }; e ] -> + if mentions e then bad := true + | _ -> template x) + l + | _ -> () + in + (* The macro's own code, out of its templates: [r] only counted, read + before the body, or its first form tested. [k] is the body's start + within [r], known once the templates are read. *) + let rec code k (f : Form.t) = + match f.v with + | Form.List [ { v = Form.Sym "quasiquote"; _ }; x ] -> template x + | Form.Sym s when s = r -> bad := true + | Form.List [ { v = Form.Sym ("<" | ">=" | "=" | "<=" | ">"); _ }; a; b ] -> + (match a.v, b.v with + | Form.List [ { v = Form.Sym "length"; _ }; x ], _ when is_r x -> + (match int b with Some c when c <= k + 1 -> () | _ -> code k b; bad := true) + | _, Form.List [ { v = Form.Sym "length"; _ }; x ] when is_r x -> + (match int a with Some c when c <= k + 1 -> () | _ -> code k a; bad := true) + | _ -> code k a; code k b) + | Form.List [ { v = Form.Sym p; _ }; e ] + when String.length p > 1 && p.[String.length p - 1] = '?' && at_r e <> None -> + (match at_r e with Some i when i <= k -> () | _ -> bad := true) + | Form.List _ when at_r f <> None -> + (match at_r f with Some i when i < k -> () | _ -> bad := true) + | Form.List l | Form.Vec l | Form.Map l -> List.iter (code k) l + | _ -> () + in + (* The templates first, for [k]; then the rest of the code against it. *) + List.iter (fun t -> template t) (List.fold_left (fun a x -> templates x a) [] body); + match !bodies with + | k :: more when (not !bad) && List.for_all (( = ) k) more + && List.for_all (fun i -> i < k) !reads -> + List.iter (code k) body; + if !bad then None else Some (fixed + k) + | _ -> None -let add (tbl : t) ~qualify ~known forms = +let add (t : t) ~qualify forms = let local = Hashtbl.create 8 in List.iter - (fun f -> - match of_defmacro ~known:(fun h -> - match Hashtbl.find_opt local h with Some k -> Some k | None -> known h) f with - | Some (name, k) -> Hashtbl.replace local name k; Hashtbl.replace tbl (qualify name) k - | None -> ()) + (fun (f : Form.t) -> + match f.v with + | Form.List ({ v = Form.Sym "defmacro"; _ } :: { v = Form.Sym name; _ } + :: { v = Form.Vec ps; _ } :: body) -> + let known h = + match Hashtbl.find_opt local h with + | Some k -> Some k + | None -> Hashtbl.find_opt t.bodies h + in + Hashtbl.replace t.names (qualify name) + (List.fold_left (fun a x -> template_names x a) [] + (List.fold_left (fun a x -> templates x a) [] body)); + (match body_of ~known name ps body with + | Some k -> Hashtbl.replace local name k; Hashtbl.replace t.bodies (qualify name) k + (* A definition of the same name as a prelude macro replaces it. *) + | None -> Hashtbl.remove local name; Hashtbl.remove t.bodies (qualify name)) + | _ -> ()) forms (** The prelude's macros, those of the packages [forms] imports (qualified by their alias) and [forms]' own. An import that cannot be found or read adds nothing. *) let table ?file (forms : Form.t list) : t = - let tbl = Hashtbl.create 32 in + let t = create () in let prelude = try Reader.read_all ~file:Prelude.file Prelude.source with _ -> [] in - add tbl ~qualify:Fun.id ~known:(fun _ -> None) prelude; - let known h = Hashtbl.find_opt tbl h in + add t ~qualify:Fun.id prelude; (match file with | None -> () | Some file -> @@ -125,8 +189,8 @@ let table ?file (forms : Form.t list) : t = let d = Load.resolve_dir ~file loc path in let files = if Sys.is_directory d then Load.source_entries d else [ d ] in let fs = List.concat_map Source.read_file files in - add tbl ~qualify:(fun n -> alias ^ "/" ^ n) ~known fs + add t ~qualify:(fun n -> alias ^ "/" ^ n) fs with _ -> ()) (Load.imports_of forms)); - add tbl ~qualify:Fun.id ~known forms; - tbl + add t ~qualify:Fun.id forms; + t diff --git a/lib/indent_printer.ml b/lib/indent_printer.ml index da818b98..844f2dda 100644 --- a/lib/indent_printer.ml +++ b/lib/indent_printer.ml @@ -95,7 +95,7 @@ let in_quasi (f : Form.t) k = (* 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 (Hashtbl.create 1) +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. *) @@ -109,10 +109,16 @@ let rec note_used (f : Form.t) = | 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 (); c) + if Hashtbl.mem used c then go (i + 1) + else (Hashtbl.replace used c (); Hashtbl.replace made c n; c) in go 2 @@ -165,7 +171,8 @@ let binds n t = match pat_names t with Some ns -> List.mem n ns | None -> false (* Whether [f] mentions [n]: the name, or a field path or qualified name starting with it. Any occurrence counts, a quoted one or one under an unquote included. A macro whose expansion names a variable its call does - not spell is the one case this cannot see. *) + 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 @@ -258,10 +265,23 @@ let flatten (f : Form.t) (rest : Form.t list) = Option.bind (all pat_names (List.filteri (fun i _ -> i mod 2 = 0) bs)) (fun names -> - let clash = - List.filter (fun n -> List.exists (refers n) rest) - (List.sort_uniq compare (List.concat 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 @@ -542,14 +562,25 @@ let body_split (h : Form.t) args = | 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 s with + (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) - | _ -> None) + | _ -> + (* 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 s with + (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) @@ -954,6 +985,7 @@ let program ?source ?macros:m (fs : Form.t list) : string = that is not last goes in a [do:] block. *) let top x = Hashtbl.reset used; + Hashtbl.reset made; note_used x; String.concat "\n" (stmt 0 x) in diff --git a/spec-syntax.md b/spec-syntax.md index 8356c938..5f05b1ef 100644 --- a/spec-syntax.md +++ b/spec-syntax.md @@ -187,9 +187,13 @@ Each item: the proposal, then the reason in one line. another such macro's body; `comment` counts too. Where a rename cannot be trusted (the name quoted, qualified as `x/y`, or called as `x(...)`), and at the top level, among a call's other arguments and in a quasiquote, the - `let` goes in a `do:` block instead. One case this cannot see: a macro - whose expansion names a variable its call does not spell can pick up a - `let`'s name that now reaches further. + `let` goes in a `do:` block instead, and so does one whose longer scope + would reach a call of a macro whose template names the `let`'s name. A + macro's body counts only if nothing but its templates depends on how the + body splits into arguments (a count against the body's start, a predicate + on its first form). One case this cannot see: a macro defined nowhere the + printer reads (not the prelude, the file or an imported package) whose + expansion names a variable its call does not spell. 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 diff --git a/test/syntax/flat/capture.flan b/test/syntax/flat/capture.flan new file mode 100644 index 00000000..99916cf7 --- /dev/null +++ b/test/syntax/flat/capture.flan @@ -0,0 +1,6 @@ +(defmacro show-it [] `(println it)) +(defn main [] i32 + (let [it 1] + (let [it 2] (show-it)) + (show-it)) + 0) diff --git a/test/syntax/flat/macros.flan b/test/syntax/flat/macros.flan new file mode 100644 index 00000000..c76b1965 --- /dev/null +++ b/test/syntax/flat/macros.flan @@ -0,0 +1,46 @@ +;; Macro bodies the .fln printer must classify from their definitions: +;; test_syntax converts this file, runs both and wants the same output. + +;; Counts its body forms: a let taking in the form after it would change the +;; count, so the body is not one a let may be flattened in. +(defmacro counted [& body] + (let [two (= (length body) 2)] + `(do (println ~(if two (Form.Sym {.s "true"}) (Form.Sym {.s "false"}))) ~@body))) + +;; Replaces the prelude's unless, and counts too. +(defmacro unless [& args] + (let [two (= (length args) 3)] + `(do (println ~(if two (Form.Sym {.s "true"}) (Form.Sym {.s "false"}))) ~@(form-rest args 1)))) + +;; The body once in a do and once as a vector's elements. +(defmacro vtwice [& body] + `(do ~@body (println (length [~@body])))) + +;; The first body form is the loop's test. +(defmacro labelled [& body] + `(while :l ~@body)) + +;; A guard that only asks whether there is a body: a body run in order. +(defmacro guarded [& args] + (if (< (length args) 1) + `(do) + `(do ~@args))) + +(defn main [] i32 + (counted + (let [x 1] (println x)) + (println 2)) + (unless false + (let [y 3] (println y)) + (println 4)) + (vtwice + (let [z 5] (println z) z) + 6) + (labelled + (let [go false] go) + (println 9)) + (let [g 0] + (guarded + (let [g 1] (println g)) + (println g))) + 0) diff --git a/test/syntax/flat/shadows.flan b/test/syntax/flat/shadows.flan new file mode 100644 index 00000000..87dd7fa0 --- /dev/null +++ b/test/syntax/flat/shadows.flan @@ -0,0 +1,85 @@ +(defstruct P [x i32 y i32]) +(defn app [g (Fn [i32] i32) v i32] i32 (g v)) + +(defn shadow-chain [] () + (let [x 1] + (let [x (+ x 10)] + (println x)) + (println x) + (let [x (+ x 100)] + (println x) + (let [x (* x 2)] (println x)) + (println x)) + (println x))) + +(defn closes [] i32 + (let [x 1] + (let [x 5] + (println x)) + (let [f 0] + (app (fn [y] (+ x y)) (+ f 2))))) + +(defn loopy [] () + (let [i 0] + (while (< i 5) + (let [i (* i 100)] + (println i)) + (set i (+ i 1)) + (when (= i 3) (continue)) + (println i)))) + +(defn loopr [] i32 + (loop [n 0 acc 0] + (let [n (* n 2)] + (println n)) + (if (< n 4) (recur (+ n 1) (+ acc n)) acc))) + +(defn ret [a i32] i32 + (let [a (+ a 1)] + (println a)) + (when (> a 3) + (let [a 0] (println a)) + (return a)) + (let [a (- a 1)] (println a)) + a) + +(defn deferring [] () + (let [x 1] + (let [x 2] + (defer (println x))) + (defer (println x)) + (println "body"))) + +(defn destr [] () + (let [p (P {.x 3 .y 4}) x 100] + (let [{.x .y} p] + (println (+ x y))) + (println x) + (let [{:keys [x]} p] + (println x)) + (println x) + (let [[a b] [x 7]] + (println a)) + (println x))) + +(defn dos [c bool] i32 + (let [v 0] + (if c + (do (let [v 5] (println v)) (println v)) + (do (let [v 6] (println v)) (println v))) + (unless c (let [v 9] (println v)) (println v)) + (when c (let [v 8] (println v)) (println v)) + v)) + +(defn main [] i32 + (shadow-chain) + (println (closes)) + (loopy) + (println (loopr)) + (println (ret 5)) + (println (ret 1)) + (deferring) + (destr) + (println (dos true)) + (println (dos false)) + 0) diff --git a/test/test_syntax.ml b/test/test_syntax.ml index ff748c81..611a2161 100644 --- a/test/test_syntax.ml +++ b/test/test_syntax.ml @@ -138,7 +138,7 @@ let canon (f : Form.t) : Form.t = go [] f (* The macros of the file being compared ([Body_macros.table]). *) -let macros : Body_macros.t ref = ref (Hashtbl.create 1) +let macros : Body_macros.t ref = ref (Body_macros.create ()) (* Where the statements of a body start, for a head whose trailing arguments are a body run in order. *) @@ -159,7 +159,7 @@ let body_start (l : Form.t list) = | h -> (match List.assoc_opt h Body_macros.core with | Some k -> Some (k + 1) - | None -> Option.map (fun k -> k + 1) (Hashtbl.find_opt !macros h))) + | None -> Option.map (fun k -> k + 1) (Hashtbl.find_opt !macros.bodies h))) | _ -> None let is_let (f : Form.t) = @@ -654,6 +654,40 @@ let () = "(defmacro listed [& xs] `(list ~@xs))\n(defn f [] () (listed (let [a 1] (g a)) (set x 2)))" " listed:\n do:\n let a = 1\n g(a)\n x = 2"; prints "comment is a body in order" "(comment (let [a 1] (g a)) (h))" "comment:\n let a = 1\n g(a)\n h()"; + prints "a later lambda keeps the outer name" + "(defn f [] i32 (let [x 1] (let [x 5] (g x)) (app (fn [y] (+ x y)) 2)))" + " let x = 1\n let x-2 = 5\n g(x-2)\n app(fn(y) = x + y, 2)"; + prints "a renamed name renamed again counts on" + "(defn f [] () (let [x 1] (let [x 2] (let [x 3] (g x)) (g x)) (g x)))" + " let x = 1\n let x-2 = 2\n let x-3 = 3\n g(x-3)\n g(x-2)\n g(x)"; + prints "a macro that names the let's name keeps its scope" + "(defmacro show-it [] `(println it))\n(defn f [] () (let [it 1] (let [it 2] (show-it)) (show-it)))" + " let it = 1\n do:\n let it = 2\n show-it()\n show-it()"; + (* Which macros take a body run in order, read off their definitions. *) + let body name src want = + let t = Body_macros.table (Reader.read_all ~file:"" src) in + let got = Hashtbl.find_opt t.Body_macros.bodies name in + if got <> want then + fail "%s: body at %s, wanted %s" name + (match got with Some k -> string_of_int k | None -> "none") + (match want with Some k -> string_of_int k | None -> "none") + in + body "twice" "(defmacro twice [n & b] `(do ~@b ~@b))" (Some 1); + body "tail" "(defmacro tail [& a] `(let [x ~(at a 0)] ~@(form-rest a 1)))" (Some 1); + body "nested" "(defmacro inner [& b] `(do ~@b))\n(defmacro nested [& b] `(inner ~@b))" (Some 0); + body "listed" "(defmacro listed [& b] `(list ~@b))" None; + body "vtwice" "(defmacro vtwice [& b] `(do ~@b (println (length [~@b]))))" None; + body "counted" "(defmacro counted [& b] (let [n (length b)] `(do ~n ~@b)))" None; + body "counts" "(defmacro counts [& b] (if (= (length b) 2) `(do) `(do ~@b)))" None; + body "guarded" "(defmacro guarded [& b] (if (< (length b) 1) `(do) `(do ~@b)))" (Some 0); + body "labelled" "(defmacro labelled [& b] `(while :l ~@b))" None; + body "labelled-test" "(defmacro labelled-test [& b] `(while :l true ~@b))" (Some 0); + body "reads-body" "(defmacro reads-body [& b] `(do ~(at b 0) ~@b))" None; + body "unless" "" (Some 1); + body "comment" "" (Some 0); + body "with-drawing" + "(defmacro with-drawing [& args]\n (if (or (< (length args) 1) (and (= (length args) 1) (form-empty-list? (at args 0))))\n `(takes-a-body)\n `(do (begin) ~@args (end))))" + (Some 0); 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))" @@ -907,8 +941,41 @@ let run_both path want = (if x86 then " --x86" else "") text code want) [ false; true ] +(* A program and its conversion print the same: the flat lets, the renames + and the macro bodies they rest on keep what each name means. *) +let run_converted path = + let run p = + let exe = Filename.concat scratch + (Printf.sprintf "flan-flat-%s-%d" (Filename.basename p) (Unix.getpid ())) in + let prog, csrcs, lflags = Test_support.linked p in + ignore (Build.executable ~opts:Build.default ~csrcs ~lflags prog ~out:exe); + let out = exe ^ ".out" in + let code = Sys.command (Filename.quote exe ^ " > " ^ Filename.quote out ^ " 2>&1") in + let text = In_channel.with_open_bin out In_channel.input_all in + (try Sys.remove out; Sys.remove exe with Sys_error _ -> ()); + (code, text) + in + match + let forms = Reader.read_file path in + let source = In_channel.with_open_bin path In_channel.input_all in + let macros = Body_macros.table ~file:path forms in + let fln = Filename.concat scratch + (Printf.sprintf "%d-%s.fln" (Unix.getpid ()) (Filename.remove_extension (Filename.basename path))) in + Out_channel.with_open_bin fln (fun oc -> + output_string oc (Indent_printer.program ~source ~macros forms)); + let a = run path and b = run fln in + (try Sys.remove fln with Sys_error _ -> ()); + (a, b) + with + | exception e -> fail "%s converted: %s" path (diag_text e) + | ((0, a), (0, b)) when a = b -> () + | ((c, a), (d, b)) -> + fail "%s printed %S (exit %d), and converted %S (exit %d)" path a c b d + let () = if Test_support.have "clang" then begin + List.iter run_converted + [ "syntax/flat/shadows.flan"; "syntax/flat/macros.flan"; "syntax/flat/capture.flan" ]; run_both "syntax/mixed/main.flan" "12\n12\n0\n55\n"; run_both "syntax/mixed/main.fln" "25\n7\nfar\n3\n" end