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

@@ -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

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

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
+let dotted s = String.length s > 1 && s.[0] = '.'
-   [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
+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
+   [let a = ...] of the same name is a new [a], not the one before it. *)
-   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 :: 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) =
+(* A binding target with [n] renamed [n']. A struct pattern that binds [n]
-  match f.v with
+   is written out as pairs, so the field keeps its name. *)
-  | Form.Sym s -> mentions n f || s = "." ^ n
+let rec rename_pat n n' (t : Form.t) : Form.t option =
-  | Form.List l | Form.Vec l | Form.Map l -> List.exists (spells n) l
+  match t.v with
-  | _ -> false
+  | 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
+(* [f] with [n] renamed [n'], or [None] where the rename cannot be trusted:
-   quoted [n] is data, [n/x] names a package, and in a braced form [.n] may
+   a quoted [n] is data, [n/x] names a package, and [(n ...)] may call a
-   bind [n] as well as name a field. *)
+   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 ({ v = Form.Sym s; _ } :: _) when s = n -> None
-  | Form.List l -> Option.map (fun l -> { f with v = Form.List l }) (rename_all n n' l)
+  | Form.List (({ v = Form.Sym "let"; _ } as h) :: ({ v = Form.Vec bs; _ } as bv) :: body) ->
-  | Form.Vec l -> Option.map (fun l -> { f with v = Form.Vec l }) (rename_all n n' l)
+    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 =
+(* [n] renamed [n'] in a [let]'s bindings [bs] and [body], from the binding
-  List.fold_right
+   that binds it on: the values up to and including that binding's see the
-    (fun x acc -> match rename n n' x, acc with
+   outer [n]. *)
-       | 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 []) ->
+    | t :: v :: rest when binds n t ->
-      (match t.v with
+      (* From here on, the rest reads as a [let] of its own. *)
-       | Form.Sym _ | Form.Vec _ ->
+      (match rename_pat n n' t,
-         (match rename n n' t, rename_all n n' rest, rename_all n n' body with
+             rename n n' { t with v = Form.List (Form.make (Form.Sym "let") t.loc
-          | Some t', Some rest', Some body' -> Some (t' :: v :: rest', body')
+                                                 :: Form.make (Form.Vec rest) t.loc :: body) } with
-          | _ -> None)
+       | 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 =
+    Option.bind
-      List.sort_uniq compare
+      (all pat_names (List.filteri (fun i _ -> i mod 2 = 0) bs))
-        (List.concat_map (fun t -> binders t []) (List.filteri (fun i _ -> i mod 2 = 0) bs))
+      (fun names ->
-    in
+         let clash =
-    let clash = List.filter (fun n -> List.exists (refers n) rest) names in
+           List.filter (fun n -> List.exists (refers n) rest)
-    List.fold_left
+             (List.sort_uniq compare (List.concat names))
-      (fun acc n -> Option.bind acc (fun (bs, body) -> rename_let n (fresh n) bs body))
+         in
-      (Some (bs, body)) clash
+         List.fold_left
-    |> Option.map (fun (bs, body) ->
+           (fun acc n -> Option.bind acc (fun (bs, body) -> rename_let n (fresh n) bs body))
-        { f with v = Form.List (h :: { bv with v = Form.Vec bs } :: (body @ rest)) })
+           (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. *)
+(** A whole file: top-level forms with a blank line between them. [macros]
-let program ?source (fs : Form.t list) : string =
+    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

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
+  does not use; a struct pattern is written as `{x-2 .x}` pairs). A macro's
-  struct pattern or braces), and at the top level, among a call's arguments
+  body counts as statements run in order when its definition splices its
-  and in a quasiquote, the `let` goes in a `do:` block instead.
+  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

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")
-    let str = bytes("INSERTIONSORT")
+  insertion-sort(str)
-    insertion-sort(str)
+  println(str)
-    println(str)
+  let str = bytes("SELECTIONSORT")
-  do:
+  selection-sort(str)
-    let str = bytes("SELECTIONSORT")
+  println(str)
-    selection-sort(str)
-    println(str)
   find-match("aababba", "abba")
   :-

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
+(* A binding target with every struct pattern written as [name .field]
-   [field]. *)
+   pairs: [{.x}] and [{:keys [x]}] are [{x .x}] (Parse.dmap). *)
-let rec binders (t : Form.t) acc =
+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.Vec l -> { t with v = Form.Vec (List.map pairs_pat l) }
-  | Form.Sym s when s <> "" && s.[0] = '.' -> String.sub s 1 (String.length s - 1) :: acc
+  | Form.Map l -> { t with v = Form.Map (items l) }
-  | Form.Sym s -> s :: acc
+  | _ -> t
-  | Form.List l | Form.Vec l | Form.Map l -> List.fold_left (fun a x -> binders x a) acc l
+
-  | _ -> acc
+(* 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"
+  prints "a call of the name inside is not renamed" "(defn f [] () (let [len 1] (len v)) (h len))"
-    "(defn f [x i32] () (let [{.x .y} p] (g y)) (h x))" "  do:\n    let {.x .y} = p\n    g(y)\n  h(x)";
+    "  do:\n    let len = 1\n    len(v)\n  h(len)";
-  prints "a braced .name inside is not renamed"
+  (* A struct pattern renames as pairs, so the field keeps its name. *)
-    "(defn f [x i32] () (let [x 1] (g (P {.x x}))) (h x))" "  do:\n    let x = 1\n";
+  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))"