JosephFerano/flan
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Merge branch 'master' into worktree-agent-a37bbb17fdd22924a

Browse Source
This commit is contained in:
Joseph Ferano 2026-09-25 16:35:58 +07:00
commit a95b4c288e
12 changed files with 889 additions and 115 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
bin/main.ml
View File

@ -328,17 +328,15 @@ let () =
|> List.iter (fun f -> print_endline (Flan.Form.to_string f))))
files
(* The other syntax, on stdout: a .flan file printed indented, a .fln file
printed with parentheses. Comments are not forms, so they do not carry
over. *)
printed with parentheses, comments and number spellings kept both
ways. *)
| [ _; "convert"; path ] ->
with_errors path (fun () ->
let forms = Flan.Source.read_file path in
let source = In_channel.with_open_bin path In_channel.input_all in
if Flan.Source.is_indented path then
print_string
(String.concat "\n\n" (List.map (fun f -> Flan.Form.pretty f) forms)
^ "\n")
print_string (Flan.Paren_printer.program ~source forms)
else
let source = In_channel.with_open_bin path In_channel.input_all in
match Flan.Indent_printer.program ~source forms with
| text -> print_string text
| exception Flan.Indent_printer.Unprintable (f, why) ->

81
emacs/flan.el
View File

@ -2579,7 +2579,8 @@ breakpoint is marked from the editor, without editing the buffer\"."
;; buffer-file-name so an error points at the file being edited
;; rather than at the daemon's placeholder.
(append
(list :op "eval" :code code :file (or buffer-file-name "<buffer>"))
(list :op "eval" :code code :file (or buffer-file-name "<buffer>")
:syntax (flan--syntax))
(when pause
(list :pause (flan--wire-position (car pause))))))))
;; END as the place a value could go. Every caller of this sends a
@ -2615,27 +2616,35 @@ columns already were, because a top-level form starts at column 1."
(concat (make-string (1- (line-number-at-pos start)) ?\n)
(buffer-substring-no-properties start end)))
(defun flan--syntax ()
"The `:syntax' of code sent from this buffer: the indented reader's for a
.fln file, the paren reader's for anything else. Sent explicitly because the
daemon cannot tell from `:file' — an expansion shown in parens is sent back
under the name of the .fln file it came from."
(if (and buffer-file-name (string-suffix-p ".fln" buffer-file-name))
"indented"
"paren"))
(defvar flan--code-fields nil
"Extra request fields for the code a command is about to send: its
`:syntax', and `:line'/`:col' when it is sent from the middle of a line.")
(defun flan--text-at (start end)
"The buffer text from START to END, on the line AND column it is written at.
"The buffer text from START to END, and where it starts, as
(TEXT :syntax S :line L :col C).
`flan--text' pads lines only, and says why it needs nothing more: a
top-level form starts at column 1, so the columns already agreed. A macro
call does not. It is written somewhere inside a `defn', and a refusal the
daemon reports against it — a macro that never settles is the one that
happens — carries a column that would otherwise be measured from the start of
the snippet and drawn at the start of the line.
Leading newlines and leading spaces are both whitespace the reader skips, so
padding with each is the whole fix. Byte columns, for the reason
`flan--wire-position' gives: the reader walks the source a byte at a time,
and a space is one byte, so a byte count is exactly how many to write."
Sent unpadded, with its line and column as fields: the daemon starts its
reader there, so every location in a reply is the buffer's own. Padding
with spaces, which this used to do, cannot work for the indented syntax,
where leading spaces are an indentation. Byte columns, for the reason
`flan--wire-position' gives."
(save-excursion
(goto-char start)
(concat (make-string (1- (line-number-at-pos start)) ?\n)
(make-string (- (position-bytes start)
(position-bytes (line-beginning-position)))
?\s)
(buffer-substring-no-properties start end))))
(list (buffer-substring-no-properties start end)
:syntax (flan--syntax)
:line (line-number-at-pos start)
:col (1+ (- (position-bytes start)
(position-bytes (line-beginning-position)))))))
(defun flan--defun-bounds ()
"Bounds of the top-level form containing or preceding point, as (START . END)."
@ -2799,15 +2808,18 @@ why one `C-u' and two mean the same thing here.
`flan--text-at' rather than `flan--text': an expression is not a top-level
form and does not start at column 1, so a refusal the daemon reports against
it carries a column measured from the start of the snippet. Padding both ways
is what puts the error overlay on the character it is about — and the overlay
this draws on success would otherwise be competing with one drawn at line 1."
it carries a column measured from the start of the snippet unless the request
says where the snippet starts. The `:line' and `:col' fields it sends are what
put the error overlay on the character it is about — and the overlay this
draws on success would otherwise be competing with one drawn at line 1."
(flan--report
(flan--request
(append
(list :op "eval-expr" :code (flan--text-at start end)
:file (or buffer-file-name "<buffer>"))
(when arg (list :pause t))))
(let ((at (flan--text-at start end)))
(append
(list :op "eval-expr" :code (car at)
:file (or buffer-file-name "<buffer>"))
(cdr at)
(when arg (list :pause t)))))
"expression"
end))
@ -2897,6 +2909,7 @@ the command signals, as `C-c C-c' does."
(interactive)
(let* ((reply (flan--request
(list :op "load-file" :file (or buffer-file-name "<buffer>")
:syntax (flan--syntax)
:code (buffer-substring-no-properties
(point-min) (point-max)))))
(errors (plist-get reply :errors)))
@ -3230,8 +3243,9 @@ ALL asks for the fixpoint rather than one step. Answers the reply plist, or
signals — having drawn the refusal where it happened, which is why the caller
sends padded text."
(let ((r (funcall flan-macroexpand-request-function
(list :op "macroexpand" :code code :file file
:all (if all t nil)))))
(append (list :op "macroexpand" :code code :file file
:all (if all t nil))
flan--code-fields))))
(unless (equal (plist-get r :status) "ok")
(let ((loc (plist-get r :loc))
(msg (plist-get r :message)))
@ -3264,7 +3278,8 @@ indentation, which lives in `flan-mode' and not in the compiler."
(let ((inhibit-read-only t))
(erase-buffer)
(flan-macroexpansion-mode)
(setq flan-macroexpand--origin (list :code code :file file :all all))
(setq flan-macroexpand--origin (list :code code :file file :all all
:fields flan--code-fields))
(let ((start (point)))
(insert (format "; macroexpansion, %s\n"
(if all "all the way" "one step")))
@ -3314,10 +3329,11 @@ rather than with what is typed."
;; Padded onto its own line *and column*, unlike `C-x C-e', because
;; the refusals this path can get name a location inside the snippet
;; and a macro call is written well inside a line.
(code (flan--text-at (car b) (cdr b)))
(at (flan--text-at (car b) (cdr b)))
(code (car at))
(flan--code-fields (cdr at))
(r (flan-macroexpand--ask code file all)))
(flan-macroexpand--render r (buffer-substring-no-properties (car b) (cdr b))
file all)
(flan-macroexpand--render r code file all)
(pulse-momentary-highlight-region (car b) (cdr b))
(unless (plist-get r :expanded)
(message "flan: %s" (or (plist-get r :note) "nothing expanded")))
@ -3346,6 +3362,8 @@ non-nil ALL, take it all the way instead."
;; file, so there is no line or column for a refusal to be drawn at.
;; The file still goes on the wire — it is what tells the daemon which
;; session's macros to expand against.
;; An expansion is printed in parens whatever its file is written in.
(flan--code-fields (list :syntax "paren"))
(r (flan-macroexpand--ask code (plist-get flan-macroexpand--origin :file)
all)))
(if (not (plist-get r :expanded))
@ -3377,6 +3395,7 @@ remove."
(unless flan-macroexpand--origin
(user-error "flan: this is not a macroexpansion buffer"))
(let* ((o flan-macroexpand--origin)
(flan--code-fields (plist-get o :fields))
(r (flan-macroexpand--ask (plist-get o :code) (plist-get o :file)
(plist-get o :all))))
(flan-macroexpand--render r (plist-get o :code) (plist-get o :file)

24
lib/dev.ml
View File

@ -1123,7 +1123,7 @@ let errors_field (ds : Loc.diag list) =
survives the reply is a refusal, with the first error where every other
refusal puts it. *)
let load_file t ~code ~origin =
match Reader.read_all ~file:origin code with
match Source.read_code ~file:origin code with
| exception Loc.Error { Loc.dloc = l; dmsg = msg; _ } ->
error ~loc:(Loc.to_string l) msg
| forms ->
@ -4370,7 +4370,27 @@ let memory_op t ~file =
doing the only thing it can. See TODO.org, \"Memory diagnostics \
on demand\"" ]
let handle t req =
(* Every code-carrying request is read in the syntax it names and at the
position it names; see [Source.read_code]. *)
let rec handle t req =
let syntax =
match Wire.string_field req "syntax", Wire.string_field req "op",
Wire.string_field req "file" with
| (Some _ as s), _, _ -> Source.syntax_of_field s
(* A whole file named with no [:syntax] is in the syntax its name says:
that is not a guess, it is what [Source.read_file] would do. *)
| None, Some "load-file", Some f when Source.is_indented f -> Source.Indented
| None, _, _ -> Source.Paren
in
let at =
match Wire.int_field req "line", Wire.int_field req "col" with
| Some l, Some c -> Some (l, c)
| Some l, None -> Some (l, 1)
| _ -> None
in
Source.with_code ~syntax ~at (fun () -> handle_op t req)
and handle_op t req =
match Wire.string_field req "op" with
| Some "eval" ->
(match Wire.string_field req "code" with

118
lib/indent_printer.ml
View File

@ -55,6 +55,11 @@ let paren s = "(" ^ s ^ ")"
as 4293922815. Set by [program ~source]. *)
let spelling : (Form.t -> string option) ref = ref (fun _ -> None)
(* Whether a comment sits inside a form, on a line before its last: such a
form is not squeezed onto one line, or the comment would have no line of
its own to go to. Set by [program ~source]. *)
let inside : (Form.t -> bool) ref = ref (fun _ -> false)
(* The same form, locations aside. *)
let rec same (a : Form.t) (b : Form.t) =
match a.v, b.v with
@ -331,9 +336,12 @@ let rec block n (fs : Form.t list) : string list =
go fs
and stmt n ~last (f : Form.t) : string list =
match sugar n ~last f with
| Some ls -> ls
| None -> plain n f
let ls = match sugar n ~last f with Some ls -> ls | None -> plain n f in
(* The first line carries the line the form came from, for
[Source_text.weave] to put the comments back by. *)
match ls with
| first :: rest -> Source_text.tag f.loc.Loc.line first :: rest
| [] -> []
and plain n (f : Form.t) : string list =
let text =
@ -445,10 +453,12 @@ and sugar n ~last (f : Form.t) : string list option =
| _ -> true
in
let line = i ^ fst (expr f) in
if simple a && simple b && String.length line <= width then Some [ line ]
if simple a && simple b && String.length line <= width && not (!inside f)
then Some [ line ]
else
Some
([ i ^ "if " ^ at 1 c ] @ slot (n + 2) a @ [ i ^ "else" ] @ slot (n + 2) b)
([ i ^ "if " ^ at 1 c ] @ slot (n + 2) a
@ [ Source_text.tag b.loc.Loc.line (i ^ "else") ] @ slot (n + 2) b)
| Form.List ({ v = Form.Sym "when"; _ } :: c :: (_ :: _ as body)) ->
Some ((i ^ "if " ^ at 1 c) :: block (n + 2) body)
| Form.List ({ v = Form.Sym "cond"; _ } :: args) ->
@ -457,7 +467,7 @@ and sugar n ~last (f : Form.t) : string list option =
| Some prs ->
let tests, else_ =
match List.rev prs with
| (k, e) :: rest when is_else k -> (List.rev rest, Some e)
| (k, e) :: rest when is_else k -> (List.rev rest, Some (k, e))
| _ -> (prs, None)
in
if List.length tests < 2 then None
@ -466,10 +476,15 @@ and sugar n ~last (f : Form.t) : string list option =
(List.concat
(List.mapi
(fun j (c, b) ->
(i ^ (if j = 0 then "if " else "elif ") ^ at 1 c) :: slot (n + 2) b)
(* Each test's line carries the test's own line, so a
comment written above a clause stays above it. *)
Source_text.tag (c : Form.t).loc.Loc.line
(i ^ (if j = 0 then "if " else "elif ") ^ at 1 c)
:: slot (n + 2) b)
tests)
@ (match else_ with
| Some e -> (i ^ "else") :: slot (n + 2) e
| Some ((k : Form.t), e) ->
Source_text.tag k.loc.Loc.line (i ^ "else") :: slot (n + 2) e
| None -> [])))
| Form.List ({ v = Form.Sym (("while" | "until") as w); _ } :: rest) ->
let lbl, rest = label_of rest in
@ -503,7 +518,8 @@ and sugar n ~last (f : Form.t) : string list option =
Some
((i ^ "match " ^ at 0 s)
:: List.concat_map
(fun (pat, body) ->
(fun ((pat : Form.t), body) ->
List.mapi (fun k l -> if k = 0 then Source_text.tag pat.loc.Loc.line l else l) @@
let pt = at 8 pat in
let line = ind (n + 2) ^ pt ^ " -> " ^ inline_text body in
match body.v with
@ -569,7 +585,8 @@ and sugar n ~last (f : Form.t) : string list option =
| [ x ] when (match x.v with
| Form.List ({ v = Form.Sym h; _ } :: _) -> not (List.mem h sugar_heads)
| _ -> true)
&& String.length head + 3 + String.length (at 0 x) <= width ->
&& String.length head + 3 + String.length (at 0 x) <= width
&& not (!inside f) ->
Some [ head ^ " = " ^ at 0 x ]
| _ -> Some (head :: block (n + 2) body)))
| Form.List ({ v = Form.Sym (("def" | "defonce" | "defconst") as d); _ }
@ -596,12 +613,14 @@ and sugar n ~last (f : Form.t) : string list option =
:: List.map
(fun ((f : Form.t), t) ->
let fname = fst (expr f) in
ind (n + 2) ^ if is_sym "dyn" t then fname else fname ^ ": " ^ ty t)
Source_text.tag f.loc.Loc.line
(ind (n + 2) ^ if is_sym "dyn" t then fname else fname ^ ": " ^ ty t))
prs)
| _ -> None)
| Form.List [ { v = Form.Sym "defdata"; _ }; { v = Form.Sym name; _ }; { v = Form.Vec cs; _ } ]
when def_name name ->
let case (c : Form.t) =
Option.map (Source_text.tag c.loc.Loc.line) @@
match c.v with
| Form.Sym s when def_name s -> Some s
| Form.List [ { v = Form.Sym s; _ }; { v = Form.Vec ps; _ } ] when def_name s ->
@ -610,20 +629,26 @@ and sugar n ~last (f : Form.t) : string list option =
in
let cs = List.map case cs in
if List.mem None cs then None
else Some ((i ^ "data " ^ name) :: List.map (fun c -> ind (n + 2) ^ Option.get c) cs)
else
Some ((i ^ "data " ^ name)
:: List.map (fun c ->
let tags, body = Source_text.untag (Option.get c) in
List.fold_left (fun l t -> Source_text.tag t l) (ind (n + 2) ^ body) tags) cs)
| Form.List [ { v = Form.Sym "defenum"; _ }; { v = Form.Sym name; _ }; { v = Form.Vec ms; _ } ]
when def_name name ->
let rec members = function
| { Form.v = Form.Sym m; _ } :: ({ Form.v = Form.Int _ | Form.UInt _; _ } as v) :: rest
| ({ Form.v = Form.Sym m; _ } as mf) :: ({ Form.v = Form.Int _ | Form.UInt _; _ } as v) :: rest
when def_name m ->
Option.map (fun r -> (m ^ " = " ^ fst (expr v)) :: r) (members rest)
| { Form.v = Form.Sym m; _ } :: rest when def_name m ->
Option.map (fun r -> m :: r) (members rest)
Option.map (fun r -> (mf.loc.Loc.line, m ^ " = " ^ fst (expr v)) :: r) (members rest)
| ({ Form.v = Form.Sym m; _ } as mf) :: rest when def_name m ->
Option.map (fun r -> (mf.loc.Loc.line, m) :: r) (members rest)
| [] -> Some []
| _ -> None
in
Option.map
(fun ms -> (i ^ "enum " ^ name) :: List.map (fun m -> ind (n + 2) ^ m) ms)
(fun ms ->
(i ^ "enum " ^ name)
:: List.map (fun (l, m) -> Source_text.tag l (ind (n + 2) ^ m)) ms)
(members ms)
| Form.List [ { v = Form.Sym "import"; _ }; { v = Form.Sym a; _ }; ({ v = Form.Str _; _ } as p) ]
when def_name a ->
@ -654,46 +679,34 @@ and let_lines n ~last prs body =
("let " ^ x ^ ": " ^ ty ty_, w)
| _ -> ("let " ^ guard (at 8 t), v)
in
if last then
List.concat_map (fun b -> let p, v = bind b in value_lines n p v) prs @ block n body
(* Each binding line carries its own source line, so a comment written
after a binding stays on it. *)
let tagged ((t : Form.t), _) = function
| first :: more -> Source_text.tag t.loc.Loc.line first :: more
| [] -> []
in
let lines n b = let p, v = bind b in tagged b (value_lines n p v) in
if last then List.concat_map (lines n) prs @ block n body
else
match prs with
| b :: rest ->
let p, v = bind b in
(ind n ^ p ^ " = " ^ at 0 v)
:: (List.concat_map (fun b -> let p, v = bind b in value_lines (n + 2) p v) rest
@ block (n + 2) body)
tagged b [ ind n ^ p ^ " = " ^ at 0 v ]
@ List.concat_map (lines (n + 2)) rest
@ block (n + 2) body
| [] -> block n body
(** A whole file: top-level forms with a blank line between them. *)
let program ?source (fs : Form.t list) : string =
(* With the text the forms were read from, a number keeps its spelling:
the text under its span, when that reads back to the same value. *)
let lines =
match source with
| Some src -> Array.of_list (String.split_on_char '\n' src)
| None -> [||]
in
spelling :=
(fun (f : Form.t) ->
let l = f.loc in
if l.Loc.line < 1 || l.Loc.line > Array.length lines || l.Loc.eline <> l.Loc.line
then None
else
let text = lines.(l.Loc.line - 1) in
let a = l.Loc.col - 1 and b = l.Loc.ecol - 1 in
if a < 0 || b > String.length text || b <= a then None
else
let t = String.sub text a (b - a) in
match f.v with
| Form.Int i when Int64.of_string_opt t = Some i -> Some t
| Form.Float x
when String.exists (fun c -> c = '.' || c = 'e' || c = 'E') t
&& (match float_of_string_opt t with
| Some y -> Int64.equal (Int64.bits_of_float x) (Int64.bits_of_float y)
| None -> false) ->
Some t
| _ -> None);
(match source with Some src -> Source_text.spelling src | None -> fun _ -> None);
let cs = match source with Some src -> Source_text.comments src | None -> [] in
(inside :=
fun (f : Form.t) ->
List.exists
(fun (c : Source_text.comment) ->
f.loc.Loc.line <= c.line && c.line < f.loc.Loc.eline)
cs);
let rec go = function
| [] -> []
| [ x ] -> [ String.concat "\n" (stmt 0 ~last:true x) ]
@ -701,7 +714,12 @@ let program ?source (fs : Form.t list) : string =
in
let text =
try String.concat "\n\n" (go fs) ^ "\n"
with e -> spelling := (fun _ -> None); raise e
with e -> spelling := (fun _ -> None); inside := (fun _ -> false); raise e
in
spelling := (fun _ -> None);
text
inside := (fun _ -> false);
(* With the source, its comments go back where they were; without it the
tags come out and nothing goes in. *)
Source_text.weave ~starts:(Source_text.form_starts fs)
(match source with Some src -> Source_text.comments src | None -> [])
text

124
lib/indent_reader.ml
View File

@ -91,8 +91,12 @@ let split_fields text =
(* ── Lexing ────────────────────────────────────────────────────────── *)
let lex ~file src : token list =
let lex ?(line = 1) ?(col = 1) ~file src : token list =
let st = Reader.of_string ~file src in
(* Text taken from the middle of a buffer starts where it was written, so
every location read from it is the buffer's own. *)
st.Reader.line <- line;
st.Reader.col <- col;
let out = ref [] in
let sp = ref true in
let line_start = ref true in
@ -216,9 +220,12 @@ let point (l : Loc.t) = { l with Loc.line = l.Loc.eline; col = l.Loc.ecol }
(* NEWLINE, INDENT and DEDENT, at bracket depth zero only: inside ( [ { a
line break is whitespace. A line continues the one before it when either
side of the break is a spaced binary operator (spec §2 "Continuation"). *)
let layout ?(base = 1) (toks : token list) : token array =
let layout ?(snippet = false) ?(base = 1) (toks : token list) : token array =
let arr = Array.of_list toks in
let n = Array.length arr in
(* A snippet from the editor starts wherever it was written, and its first
line is its base: a later line may not go left of it. *)
let base = if snippet && n > 0 then arr.(0).loc.Loc.col else base in
let out = ref [] in
let add tok loc = out := { tok; loc; sp = true } :: !out in
let stack = ref [ base ] in
@ -272,6 +279,21 @@ let layout ?(base = 1) (toks : token list) : token array =
add INDENT at
end
else if col < top then begin
if col < base then
failk "dedent" t.loc
"%s"
(if snippet then
Printf.sprintf
"this line starts at column %d, left of column %d where \
the code sent starts. Its first line sets its left \
edge, and no later line can go left of it: send the \
enclosing form, or line this up at column %d or right \
of it"
col base base
else
Printf.sprintf
"this line starts at column %d, left of the top level at \
column %d" col base);
let closed = ref top in
let rec pop () =
match !stack with
@ -380,9 +402,9 @@ let stray p ~after =
finished here" after
| NAME "=" ->
failk "assign-in-test" t.loc
"= assigns, and here it follows %s where a value is being read. To \
compare, write ==: %s == ..."
after after
"this = follows %s, where it cannot assign: an assignment is a line \
of its own, with one =. To compare two values, write == instead"
after
| COLON ->
failk "header-colon" t.loc
"this line ends in a colon after %s. A header (if, elif, else, while, \
@ -432,8 +454,25 @@ let check_name (t : token) s =
| None -> s)
(* A form's own text, for the "after" half of a message. *)
(* The text being read, so that a message quotes what the user wrote rather
than the paren form it became. Set for the length of one [read_all]. *)
let source : (string * string array) ref = ref ("", [||])
let text_of (f : Form.t) =
let s = Form.to_source f in
let file, lines = !source in
let l = f.loc in
let from_source =
if l.Loc.file <> file || l.Loc.line < 1 || l.Loc.line > Array.length lines then None
else
let text = lines.(l.Loc.line - 1) in
let a = l.Loc.col - 1 in
let b = if l.Loc.eline = l.Loc.line then l.Loc.ecol - 1 else String.length text in
if a < 0 || b > String.length text || b <= a then None
else
let t = String.trim (String.sub text a (b - a)) in
Some (if l.Loc.eline > l.Loc.line then t ^ " ..." else t)
in
let s = match from_source with Some t -> t | None -> Form.to_source f in
if String.length s > 40 then String.sub s 0 37 ^ "..." else s
let unclosed p c l0 =
@ -822,10 +861,14 @@ let rec ty p : Form.t =
as a call does not. *)
type st = { p : p; mutable lets : Form.t list }
(* A block of several lines is a [do] spanning its lines, from the first
statement to the end of the last — not from the header above it, which is
another form's. *)
let blk (s : st) l (ss : Form.t list) =
match ss with
| [ x ] -> x
| _ -> mk s.p l (Form.List (sym l "do" :: ss))
| (first : Form.t) :: _ -> mk s.p first.loc (Form.List (sym first.loc "do" :: ss))
| [] -> mk s.p l (Form.List [ sym l "do" ])
let is_lambda_candidate (e : Form.t) =
match e.v with
@ -937,8 +980,48 @@ and value_line ?(block_ok = false) (s : st) ~after : Form.t =
blk s l0 (block s ~after)
end
else
match (peek p).tok with
(* [let r = match a] with its arms under it, and [let r = if c] with its
branches: a header read as the value, block and all. *)
| NAME (("match" | "handler-case" | "handler-bind" | "restart-case") as w)
when header_follow p w ->
header s w
| NAME "if" when header_follow p "if" && not (then_on_line p) -> header s "if"
| _ ->
let e, _ = expr p in
lambda_block ~block_ok s e ~after:(text_of e)
match (peek p).tok with
(* [let v = with-foo(a):] and its block: the call takes the block, as it
would on a line of its own. *)
| COLON when (match e.v, (last p).tok with
| Form.List (_ :: _), RP | Form.Sym _, NAME _ -> true
| _ -> false) ->
ignore (advance p);
(match (peek p).tok with
| NEWLINE -> ignore (advance p)
| _ -> stray p ~after:":");
let body = block s ~after:(text_of e ^ ":") in
(match e.v with
| Form.List items -> mk p e.loc (Form.List (items @ body))
| _ -> mk p e.loc (Form.List (e :: body)))
| COMMA ->
failk "one-binding" (peek p).loc
"%s is followed by a comma, and one line binds one name. Put each \
binding on its own line, one after the other"
(text_of e)
| _ -> lambda_block ~block_ok s e ~after:(text_of e)
(* Whether this line has a [then] at depth zero: a one-line if. *)
and then_on_line p =
let rec go k depth =
let t = peek_at p k in
match t.tok with
| NEWLINE | EOF -> false
| NAME "then" when depth = 0 -> true
| LP | LB | LC -> go (k + 1) (depth + 1)
| RP | RB | RC -> go (k + 1) (max 0 (depth - 1))
| _ -> go (k + 1) depth
in
go 1 0
and lambda_block ?(block_ok = false) (s : st) (e : Form.t) ~after =
let p = s.p in
@ -1473,14 +1556,23 @@ and lines (s : st) (one : unit -> Form.t list) : Form.t list =
(** All top-level forms in a [.fln] source string. [col] is the column the
text's top level starts at, 1 for a file. *)
let read_all ?(col = 1) ~file src =
let toks = layout ~base:col (lex ~file src) in
let s = { p = { toks; i = 0 }; lets = [] } in
let fs = stmts s in
(match (peek s.p).tok with
| EOF -> ()
| tk -> failk "unexpected-token" (where_ s.p) "unexpected %s" (show tk));
fs
let read_all ?(line = 1) ?col ~file src =
let snippet = col <> None in
let col = Option.value col ~default:1 in
let saved = !source in
(* The quoted text is indexed by the buffer's lines, so a snippet that
starts on line 40 is padded to start there. *)
source :=
(file, Array.of_list (String.split_on_char '\n'
(String.make (line - 1) '\n' ^ String.make (col - 1) ' ' ^ src)));
Fun.protect ~finally:(fun () -> source := saved) (fun () ->
let toks = layout ~snippet ~base:col (lex ~line ~col ~file src) in
let s = { p = { toks; i = 0 }; lets = [] } in
let fs = stmts s in
(match (peek s.p).tok with
| EOF -> ()
| tk -> failk "unexpected-token" (where_ s.p) "unexpected %s" (show tk));
fs)
let read_file path =
let ic = open_in_bin path in

129
lib/paren_printer.ml Normal file
View File

@ -0,0 +1,129 @@
(** [Form.t] to paren text, for [flan convert] of a [.fln] file: the other
direction of [Indent_printer]. It keeps what [Form.pretty] cannot — the
source's number spellings and comments, through [Source_text] — and lays
a form out the way the corpus is written: flat when it fits, otherwise
the head and the arguments that name the form on the first line and the
rest one per line, two columns in. *)
let width = 80
let rec flat spell (f : Form.t) =
let seq l = String.concat " " (List.map (flat spell) l) in
match f.v with
| Form.Int _ | Form.Float _ ->
(match spell f with Some t -> t | None -> Form.to_source f)
| Form.List l -> "(" ^ seq l ^ ")"
| Form.Vec l -> "[" ^ seq l ^ "]"
| Form.Map l -> "{" ^ seq l ^ "}"
| _ -> Form.to_source f
(* How many arguments stay on the head's line when the form is broken. *)
let kept head =
match head with
| "defn" | "defn-" | "defmethod" -> 3
| "defmacro" | "def" | "defonce" | "defconst" | "defstruct" | "defunion"
| "defdata" | "defenum" | "import" | "defalias" -> 2
| "do" | "cond" | "comment" | "restart-case" | "handler-case" -> 0
| _ -> 1
(* [inside l] says whether a comment sits on a line of [f] before its last,
where a flat [f] would leave it nowhere to go: such a form is broken. *)
let rec layout ?(inside = fun _ -> false) spell col (f : Form.t) : string list =
let layout = layout ~inside in
let one = flat spell f in
let tagl (x : Form.t) = function
| first :: rest -> Source_text.tag x.loc.Loc.line first :: rest
| [] -> []
in
if col + String.length one <= width && not (inside f) then [ one ]
else
let bracket o c items ~keep =
let placed inner x =
match layout spell inner x with
| first :: more ->
(* The pad goes after any tags, which lead the line. *)
let tags, body = Source_text.untag first in
let padded =
List.fold_left (fun l t -> Source_text.tag t l) (String.make inner ' ' ^ body) tags
in
tagl x (padded :: more)
| [] -> []
in
let lines =
let head_len k =
col + 1 + String.length
(String.concat " " (List.map (flat spell) (List.filteri (fun i _ -> i < k) items)))
in
let keep = if keep > 1 && head_len keep > width then 1 else keep in
if keep > 0 then
let first = List.filteri (fun i _ -> i < keep) items in
let rest = List.filteri (fun i _ -> i >= keep) items in
let before = List.filteri (fun i _ -> i < keep - 1) first in
match List.nth first (keep - 1) with
(* A binding vector with a comment inside it — [(let [a 1 ; first
b 2] ...)] — goes a pair to a line, each line carrying its pair's
source line, so a comment after a binding stays on it. *)
| { Form.v = Form.Vec vs; _ } as v
when keep > 1 && inside v && List.length vs mod 2 = 0 ->
let lead = o ^ String.concat " " (List.map (flat spell) before) ^ " [" in
let pad = String.make (col + String.length lead) ' ' in
let rec pairs k = function
| (a : Form.t) :: b :: more ->
Source_text.tag a.loc.Loc.line
((if k = 0 then lead else pad) ^ flat spell a ^ " " ^ flat spell b)
:: pairs (k + 1) more
| _ -> []
in
let ps = pairs 0 vs in
let np = List.length ps in
List.mapi (fun i l -> if i = np - 1 then l ^ "]" else l) ps
@ List.concat_map (placed (col + 2)) rest
| _ ->
(o ^ String.concat " " (List.map (flat spell) first))
:: List.concat_map (placed (col + 2)) rest
else
match items with
| [] -> [ o ]
| x :: xs ->
(match layout spell (col + 1) x with
| first :: more ->
let tags, body = Source_text.untag first in
List.fold_left (fun l t -> Source_text.tag t l) (o ^ body) tags :: more
| [] -> [ o ])
@ List.concat_map (placed (col + 1)) xs
in
let n = List.length lines in
List.mapi (fun i l -> if i = n - 1 then l ^ c else l) lines
in
match f.v with
| Form.List (({ v = Form.Sym h; _ }) :: _ as items) ->
bracket "(" ")" items ~keep:(1 + min (kept h) (List.length items - 1))
| Form.List items -> bracket "(" ")" items ~keep:0
| Form.Vec items -> bracket "[" "]" items ~keep:0
| Form.Map items -> bracket "{" "}" items ~keep:0
| _ -> [ one ]
(** A whole file, with [source]'s comments and spellings when given. *)
let program ?source (fs : Form.t list) : string =
let spell =
match source with Some src -> Source_text.spelling src | None -> fun _ -> None
in
let cs = match source with Some src -> Source_text.comments src | None -> [] in
let inside (f : Form.t) =
List.exists
(fun (c : Source_text.comment) ->
f.loc.Loc.line <= c.line && c.line < f.loc.Loc.eline)
cs
in
let text =
String.concat "\n\n"
(List.map
(fun (f : Form.t) ->
String.concat "\n"
(match layout ~inside spell 0 f with
| first :: rest -> Source_text.tag f.loc.Loc.line first :: rest
| [] -> []))
fs)
^ "\n"
in
Source_text.weave ~starts:(Source_text.form_starts fs) cs text

10
lib/session.ml
View File

@ -789,7 +789,7 @@ let rerun t = t.live <- SM.empty
there. *)
let eval ?(origin = "<eval>") ?base ?forms ?pause ?(running = true) t src : change =
let forms =
match forms with Some f -> f | None -> Reader.read_all ~file:origin src
match forms with Some f -> f | None -> Source.read_code ~file:origin src
in
(* What an annotated listing quotes for this form is what was sent, not what
the file on disk said when it was last read. *)
@ -2204,7 +2204,7 @@ let write_slot ?(origin = "<set>") t ~frame ~(fn : Tast.fn) ~slot ~path
List.map
(fun (at, _, tty, code) ->
let form =
match Reader.read_all ~file:origin code with
match Source.read_code ~expr:true ~file:origin code with
| [ f ] -> f
| [] -> fail loc "nothing to store into %s" at
| _ :: f :: _ -> fail f.Form.loc "one value at a time"
@ -2328,7 +2328,7 @@ let arm_restart ?(origin = "<restart>") t ~index ~(params : Types.t list)
List.map2
(fun ty code ->
let form =
match Reader.read_all ~file:origin code with
match Source.read_code ~expr:true ~file:origin code with
| [ f ] -> f
| [] -> fail loc "a value for a %s is empty" (Types.to_string ty)
| _ :: f :: _ -> fail f.Form.loc "one value for each parameter"
@ -2509,7 +2509,7 @@ let render_globals ?(origin = "<globals>") t ~(globals : Tast.global list)
declaration to live in. *)
let eval_expr ?(origin = "<eval>") ?(pause = false) t src : change =
let form =
match Reader.read_all ~file:origin src with
match Source.read_code ~expr:true ~file:origin src with
| [ f ] -> f
| [] -> fail Loc.unknown "nothing to evaluate"
| _ :: f :: _ -> fail f.Form.loc "one expression at a time"
@ -2692,7 +2692,7 @@ type expansion = {
[C-u] refuses. *)
let macroexpand ?(origin = "<eval>") ~(all : bool) t (src : string) : expansion =
let form =
match Reader.read_all ~file:origin src with
match Source.read_code ~file:origin src with
| [ f ] -> f
| [] -> fail Loc.unknown "nothing to expand"
| _ :: f :: _ -> fail f.Form.loc "one form at a time"

56
lib/source.ml
View File

@ -18,3 +18,59 @@ let is_source path =
let read_file path =
if is_indented path then Indent_reader.read_file path else Reader.read_file path
(* ── Code from the editor ─────────────────────────────────────────────
The dev loop's code-carrying requests say which syntax their [:code] is in
([:syntax]), and where in the buffer it starts ([:line], [:col]), rather
than having it guessed from [:file]: an expansion shown in paren syntax is
sent back under the name of the .fln file it came from, and a REPL line has
no file at all. [Dev] sets these for the length of one request, and every
place the session reads editor code reads it through [read_code]. *)
type syntax = Paren | Indented
let code_syntax = ref Paren
let code_at : (int * int) option ref = ref None
let syntax_of_field = function
| Some ("indented" | "fln") -> Indented
| _ -> Paren
let with_code ~syntax ~at f =
let s = !code_syntax and a = !code_at in
code_syntax := syntax;
code_at := at;
Fun.protect ~finally:(fun () -> code_syntax := s; code_at := a) f
(* The paren reader started at a line and column: [Reader.read_all] always
starts at 1:1. *)
let read_paren ?(line = 1) ?(col = 1) ~file src =
let st = Reader.of_string ~file src in
st.Reader.line <- line;
st.Reader.col <- col;
let rec go acc =
Reader.skip_ignorable st;
if Reader.at_end st then List.rev acc else go (Reader.read_form st :: acc)
in
go []
(** Editor code, in the request's syntax and at its position. With [expr], an
indented snippet of several statements is one expression, [(do ...)]: a
block of lines means its lines in order. *)
let read_code ?(expr = false) ~file code =
let line, col =
match !code_at with Some (l, c) -> (l, c) | None -> (1, 1)
in
match !code_syntax with
| Paren -> read_paren ~line ~col ~file code
| Indented ->
(match Indent_reader.read_all ~line ~col ~file code with
| (first :: _ :: _ as forms) when expr ->
let last = List.nth forms (List.length forms - 1) in
let loc =
{ first.Form.loc with Loc.eline = last.Form.loc.Loc.eline;
ecol = last.Form.loc.Loc.ecol }
in
[ Form.make (Form.List (Form.make (Form.Sym "do") first.Form.loc :: forms)) loc ]
| forms -> forms)

208
lib/source_text.ml Normal file
View File

@ -0,0 +1,208 @@
(** What a printer needs from the text a program was read from and a
[Form.t] does not carry: the comments, and the spelling of each number.
[flan convert] reads both here and puts them back (author's decision 83),
so a converted file keeps its [;] notes and its [0xFFF00FFF]s.
Both syntaxes share the lexical rules this depends on: a comment runs
from [;] to the end of its line, a string is ["..."] with backslash
escapes, and [\c] is a character — so [\;] is not a comment. *)
type comment = {
line : int; (* 1-based *)
text : string; (* from the [;] to the end of the line *)
own_line : bool; (* nothing but spaces before it on its line *)
gap_after : bool; (* the line after it is blank *)
}
let comments (src : string) : comment list =
let n = String.length src in
let out = ref [] in
let line = ref 1 and line_start = ref 0 in
let i = ref 0 in
while !i < n do
(match src.[!i] with
| '\n' -> incr line; line_start := !i + 1; incr i
| '"' ->
incr i;
while !i < n && src.[!i] <> '"' do
if src.[!i] = '\\' then incr i;
if !i < n && src.[!i] = '\n' then (incr line; line_start := !i + 1);
incr i
done;
incr i
| '\\' -> i := !i + 2
| ';' ->
let j = ref !i in
while !j < n && src.[!j] <> '\n' do incr j done;
let text = String.sub src !i (!j - !i) in
let text =
if text <> "" && text.[String.length text - 1] = '\r'
then String.sub text 0 (String.length text - 1) else text
in
let before = String.sub src !line_start (!i - !line_start) in
let k = ref (!j + 1) in
while !k < n && (src.[!k] = ' ' || src.[!k] = '\r') do incr k done;
let gap_after = !j < n && (!k >= n || src.[!k] = '\n') in
out := { line = !line; text; own_line = String.trim before = ""; gap_after } :: !out;
i := !j
| _ -> incr i)
done;
List.rev !out
(** A number's text as written, when it reads back to the same value: the
text under its span. [Form.Int] keeps only the value. *)
let spelling (src : string) : Form.t -> string option =
let lines = Array.of_list (String.split_on_char '\n' src) in
fun (f : Form.t) ->
let l = f.loc in
if l.Loc.line < 1 || l.Loc.line > Array.length lines || l.Loc.eline <> l.Loc.line
then None
else
let text = lines.(l.Loc.line - 1) in
let a = l.Loc.col - 1 and b = l.Loc.ecol - 1 in
if a < 0 || b > String.length text || b <= a then None
else
let t = String.sub text a (b - a) in
match f.v with
| Form.Int i when Int64.of_string_opt t = Some i -> Some t
| Form.Float x
when String.exists (fun c -> c = '.' || c = 'e' || c = 'E') t
&& (match float_of_string_opt t with
| Some y -> Int64.equal (Int64.bits_of_float x) (Int64.bits_of_float y)
| None -> false) ->
Some t
| _ -> None
(* ── Lines tagged with where they came from ───────────────────────────
A printer marks the first line of each form it lays out with the source
line that form started on. [weave] reads the marks back out and uses them
to put each comment where it was: an own-line comment above the first
line that came from after it, a trailing comment at the end of the line
the code it followed was printed on. *)
(* A line can come from several forms — a statement and the test at its
start — so it carries every line they started on. *)
let untag (text : string) : int list * string =
if String.length text > 0 && text.[0] = '\001' then
match String.index_opt text '\002' with
| Some k ->
(List.filter_map int_of_string_opt
(String.split_on_char ',' (String.sub text 1 (k - 1))),
String.sub text (k + 1) (String.length text - k - 1))
| None -> ([], text)
else ([], text)
let tag (line : int) (text : string) =
let tags, body = untag text in
let tags = if line > 0 && not (List.mem line tags) then line :: tags else tags in
if tags = [] then body
else "\001" ^ String.concat "," (List.map string_of_int tags) ^ "\002" ^ body
let indent_of s =
let n = String.length s in
let rec go i = if i < n && s.[i] = ' ' then go (i + 1) else i in
go 0
(** Where every form in [fs] starts, as (line, col), in source order. *)
let form_starts (fs : Form.t list) : (int * int) list =
let out = ref [] in
let rec walk (f : Form.t) =
out := (f.loc.Loc.line, f.loc.Loc.col) :: !out;
match f.v with
| Form.List l | Form.Vec l | Form.Map l -> List.iter walk l
| _ -> ()
in
List.iter walk fs;
List.sort_uniq compare !out
let weave ?(starts = []) (cs : comment list) (text : string) : string =
let lines = Array.of_list (List.map untag (String.split_on_char '\n' text)) in
let n = Array.length lines in
let all = Array.map fst lines and body = Array.map snd lines in
(* For ordering, a line is as early as the earliest form on it. *)
let tags =
Array.map (function [] -> None | l -> Some (List.fold_left min max_int l)) all
in
let before = Array.make (n + 1) [] and trailing = Array.make n [] in
List.iter
(fun c ->
(* The line printed from exactly [line], when one was: a printer
may reorder forms — handler-bind's clauses go after its body — so a
comment goes with the form, not with whatever line follows. *)
let exact line =
let r = ref (-1) in
Array.iteri (fun i t -> if List.mem line t && !r < 0 then r := i) all;
!r
in
if c.own_line then begin
(* The form it precedes: the first to start after it. *)
let owner =
List.find_opt (fun (l, _) -> l > c.line) starts |> Option.map fst
in
let rec find i =
if i >= n then n
else match tags.(i) with Some t when t > c.line -> i | _ -> find (i + 1)
in
let i =
match owner with
| Some l when exact l >= 0 -> exact l
| _ -> find 0
in
before.(i) <- c :: before.(i)
end
else begin
(* The line the code before it went to: the one printed from its own
line, or else the latest line tagged at or before it. *)
let last_exact =
let r = ref (-1) in
Array.iteri (fun i t -> if List.mem c.line t then r := i) all;
!r
in
if last_exact >= 0 then trailing.(last_exact) <- c :: trailing.(last_exact)
else begin
let best = ref (-1) and best_tag = ref 0 in
Array.iteri
(fun i t ->
match t with
| Some t when t <= c.line && t >= !best_tag -> best := i; best_tag := t
| _ -> ())
tags;
if !best < 0 then before.(0) <- c :: before.(0)
else trailing.(!best) <- c :: trailing.(!best)
end
end)
cs;
let b = Buffer.create (String.length text + 256) in
let emit s = Buffer.add_string b s; Buffer.add_char b '\n' in
for i = 0 to n do
let ind =
if i < n then indent_of body.(i)
else 0
in
List.iter
(fun c ->
emit (String.make ind ' ' ^ c.text);
(* A comment set apart from what follows it, at the top level, stays
set apart: a file's header, a section rule. *)
if c.gap_after && ind = 0 && i < n then emit "")
(List.rev before.(i));
if i < n then begin
match List.rev trailing.(i) with
| [] -> emit body.(i)
| first :: more ->
emit (body.(i) ^ " " ^ first.text);
(* A second trailing comment for the same printed line goes on its
own line under it, which reads the same and keeps both. *)
let ind = if i + 1 < n then indent_of body.(i + 1) else indent_of body.(i) in
List.iter (fun c -> emit (String.make ind ' ' ^ c.text)) more
end
done;
(* [text] ended in a newline, which split into a last empty line. *)
let s = Buffer.contents b in
let rec trim s =
let k = String.length s in
if k >= 2 && s.[k - 1] = '\n' && s.[k - 2] = '\n' then trim (String.sub s 0 (k - 1))
else s
in
trim s

5
spec-syntax.md
View File

@ -337,7 +337,10 @@ Each step lands on its own, with `dune test --root .` green.
paren-syntax expansion text under the original file's name. Replace the
space-padding in `flan--text-at` (`emacs/flan.el:2602-2622`), which breaks
significant indentation, with `:line`/`:col` fields; the reader seeds its
indent stack with that column.
indent stack with that column. **Built** (also `load-file` and restart
arguments; no `:syntax` means paren, except a `load-file` of a `.fln`
file; several indented statements sent as one expression read as
`(do …)`).
5. **Emacs mode** for `.fln`:
- A top-level form runs from a column-0 line that isn't `else`, `elif`,
`on` or `restart` to just before the next one, minus trailing blank and

40
test/test_dev.ml
View File

@ -634,6 +634,46 @@ let () =
finished run's storage, read by a thunk the finished run's thread ran.
Nothing is reset between runs and nothing is reset for an evaluation
either. *)
(* The indented syntax, named by [:syntax] and placed by [:line] and
[:col] (spec-syntax.md §4 step 4). Several statements are one
expression, [(do ...)], and a refusal is at the buffer's own line
and column, not the snippet's. *)
let r =
request c
"(:op \"eval-expr\" :code \"let a = 20\\na + 3\" :syntax \"indented\" \
:file \"/tmp/buf.fln\" :line 12 :col 1)"
in
if Wire.string_field r "value" <> Some "23" then
fail "an indented let: %s"
(Option.value ~default:(status r) (Wire.string_field r "message"));
let r =
request c
"(:op \"eval-expr\" :code \"extra\\n4\" :syntax \"indented\" \
:file \"/tmp/buf.fln\" :line 12 :col 1)"
in
if Wire.string_field r "value" <> Some "4" then
fail "two indented statements as one expression: %s"
(Option.value ~default:(status r) (Wire.string_field r "message"));
let r =
request c
"(:op \"eval-expr\" :code \"1 + nosuch-name\" :syntax \"indented\" \
:file \"/tmp/buf.fln\" :line 40 :col 7)"
in
(match Wire.string_field r "loc" with
| Some l when contains_sub l "buf.fln:40:11" -> ()
| l ->
fail "an indented refusal is at %s, wanted buf.fln:40:11"
(Option.value ~default:"nowhere" l));
let r =
request c
"(:op \"macroexpand\" :code \"unless(false, 1, 2)\" :syntax \"indented\" \
:file \"/tmp/buf.fln\" :line 3 :col 5)"
in
(match Wire.string_field r "text" with
| Some t when contains_sub t "(if (not false)" -> ()
| _ ->
fail "an indented macro call did not expand: %s"
(Option.value ~default:(status r) (Wire.string_field r "message")));
let r = request c "(:op \"eval-expr\" :code \"extra\" :file \"/tmp/buf.flan\")" in
if Wire.string_field r "value" <> Some "105" then
fail "a global the finished run left: %s"

199
test/test_syntax.ml
View File

@ -93,6 +93,100 @@ let () =
(* ── The round trip over the corpus ────────────────────────────────── *)
(* The comments of a text, as a sorted list: where each lands may move — a
comment inside an expression printed on one line goes above it — but none
may be lost or made. *)
let comment_texts src =
List.sort compare
(List.map (fun (c : Source_text.comment) -> String.trim c.text) (Source_text.comments src))
(* What each comment is attached to. An own-line comment belongs to the form
after it; a trailing one to the last form that starts on its line. After a
conversion, the form after an own-line comment must be that form or one
holding it (a comment inside an expression printed on one line goes above
the line), and a trailing comment's line — or, when it had to move onto a
line of its own, the line above — must hold its form. So a comment that
drifted to another statement is caught, not only a lost one. *)
let starts_of (fs : Form.t list) =
let out = ref [] in
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
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;
List.map (fun ((l, c, _), t) -> (l, c, t)) (List.sort compare !out)
let attachments src forms =
let st = starts_of forms in
List.map
(fun (c : Source_text.comment) ->
let owner =
if c.own_line then
List.find_opt (fun (l, _, _) -> l > c.line) st
else
(* The last place a form starts on the line, and the outermost
form starting there. *)
List.fold_left
(fun acc ((l, col, _) as x) ->
match acc with
| Some (_, col', _) when l = c.line && col = col' -> acc
| _ -> if l = c.line then Some x else acc)
None st
in
(c, Option.map (fun (_, _, t) -> t) owner))
(Source_text.comments src)
let attached_ok ~what path (src, forms) (out, back) =
let want = attachments src forms and got = attachments out back in
let st = starts_of back in
let on_line l = List.filter_map (fun (l', _, t) -> if l' = l then Some t else None) st in
(* Paired by text, in order: the n-th copy of a text with the n-th. *)
let rec pair = function
| [] -> ()
| ((c : Source_text.comment), o) :: rest ->
let t = String.trim c.text in
let same (d : Source_text.comment) = String.trim d.text = t in
let rec take = function
| [] -> None
| ((d, _) as x) :: xs ->
if same d && not (List.memq x !used) then (used := x :: !used; Some x)
else take xs
in
(match take got, o with
| None, _ -> fail "%s %s: the comment %s went missing" what path t
| Some _, None -> ()
| Some ((d : Source_text.comment), g), Some o ->
let holds x = Test_support.contains x o in
(* The code line a moved trailing comment sits under: up past the
comment lines between. *)
let rec code_above l =
if l < 1 then []
else match on_line l with [] -> code_above (l - 1) | fs -> fs
in
let fine =
if c.own_line then
(match g with
(* Above the form, above the statement holding it, or above the
first statement of the block it was: all of those read as
being about it. *)
| Some g -> holds g || (String.length g > 4 && Test_support.contains o g)
| None -> false)
else
List.exists holds (on_line d.line)
|| (d.own_line && List.exists holds (code_above (d.line - 1)))
in
if not fine then
fail "%s %s: the comment %s (line %d) was about %s and is now beside %s"
what path t c.line o (Option.value g ~default:"nothing"));
pair rest
and used = ref [] in
pair want
(* Every .flan the build tree holds. [..] is the workspace root from here;
the deps in test/dune decide what is in it. *)
let corpus () =
@ -124,8 +218,28 @@ let () =
| exception e -> fail "round trip %s: %s" path (diag_text e)
| back ->
let a = List.map norm forms and b = List.map norm back in
if same_forms a b then incr ok
else fail "round trip %s: %s" path (describe_diff a b))
if not (same_forms a b) then
fail "round trip %s: %s" path (describe_diff a b)
else if comment_texts text <> comment_texts source then
fail "round trip %s: the comments did not all come through" path
else begin
attached_ok ~what:"round trip" path (source, forms) (text, back);
(* And back to parens, from the indented text: the forms and
the comments survive the second printer too. *)
let paren = Paren_printer.program ~source:text back in
match Reader.read_all ~file:path paren with
| exception e -> fail "back to parens %s: %s" path (diag_text e)
| again ->
if not (same_forms (List.map norm again) b) then
fail "back to parens %s: %s" path
(describe_diff b (List.map norm again))
else if comment_texts paren <> comment_texts source then
fail "back to parens %s: the comments did not all come through" path
else begin
attached_ok ~what:"back to parens" path (text, back) (paren, again);
incr ok
end
end)
(corpus ());
Printf.printf "round trip: %d files\n" !ok;
(* The deps decide what is walked, and a stanza that lost them would pass
@ -269,7 +383,14 @@ let () =
(* Messages with a shape of their own. *)
refuses "parenthesised pair" "x = (a, b)" "indent/tuple" "[a, b]";
refuses "rest parameter" "fn f(& rest) -> () = 0" "indent/rest-parameter" "xs: [T]";
refuses "assignment as a test" "if x = 1\n y" "indent/assign-in-test" "x == ...";
refuses "assignment as a test" "if x = 1\n y" "indent/assign-in-test" "write == instead";
(* A message quotes the text as written, never the paren form. *)
refuses "two assignments" "if a then b = c = d" "indent/assign-in-test" "if a then b = c,";
refuses "a let-bound if with no block" "let r = if a > 1\nr" "indent/expected-block" "if a > 1 takes";
refuses "two bindings on a line" "let v: i32 = a, w = b" "indent/one-binding" "a is followed by a comma";
reads "a let-bound match" "let r = match a\n 1 -> 2\n _ -> 3\nr" "(let [r (match a 1 2 _ 3)] r)";
reads "a let-bound if" "let q = if a\n 1\nelse\n 2\nq" "(let [q (if a 1 2)] q)";
reads "a let-bound call with a block" "let v = foo(a):\n x\nv" "(let [v (foo a x)] v)";
refuses "colon after if" "if c:\n y" "indent/header-colon" "no colon";
refuses "colon after a return type" "fn f() -> i32:\n 0" "indent/header-colon" "no colon";
refuses "colon after a number" "while x < 3:\n y" "indent/header-colon" "no colon";
@ -300,7 +421,77 @@ let () =
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";
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 "hex spelling" "(def c dyn 0xFFF00FFF)" "0xFFF00FFF";
prints "own-line comment above its form" "(defn f [] ()\n ;; why\n (g))" " ;; why\n g()";
prints "trailing comment at its line's end" "(defn f [] ()\n (g) ; note\n (h))" " g() ; note\n";
(* The other direction keeps them too. *)
let back name src want =
match Indent_reader.read_all ~file:"<b>" src with
| forms ->
let got = Paren_printer.program ~source:src forms in
if not (Test_support.contains got want) then
fail "%s: printed %S, wanted it to contain %S" name got want
| exception e -> fail "%s: %s" name (diag_text e)
in
back "spellings to parens" "fn main() -> i32\n println(0x1F, 1e3, 1_000, 3.0, 2.50, 0b101)\n 0"
"(println 0x1F 1e3 1_000 3.0 2.50 0b101)";
back "each binding keeps its comment"
"fn main() -> i32\n let a = 1 ; first\n let b = 2 ; second\n a + b"
"(let [a 1 ; first\n b 2] ; second";
prints "each binding keeps its comment, indented"
"(defn f [] i32\n (let [a 1 ; first\n b 2] ; second\n (+ a b)))"
" let a = 1 ; first\n let b = 2 ; second";
back "comments to parens" "; head\n\nfn main() -> i32\n ; why\n g() ; note\n 0"
"; head\n\n(defn main [] i32\n ; why\n (g) ; note\n 0)"
(* ── Spans, for pause marks and error overlays ──────────────────────── *)
let span_is name (f : Form.t) (l, c, el, ec) =
let g = f.loc in
if (g.Loc.line, g.Loc.col, g.Loc.eline, g.Loc.ecol) <> (l, c, el, ec) then
fail "%s spans %d:%d-%d:%d, wanted %d:%d-%d:%d" name g.Loc.line g.Loc.col
g.Loc.eline g.Loc.ecol l c el ec
let () =
(* A rewritten statement spans its text from the first token to the last,
so a mark or an overlay drawn from it covers what was written. *)
match read "x = a.b.c + b + c" with
| [ ({ v = Form.List [ _; _; ({ v = Form.List [ _; abc; _; _ ]; _ } as sum) ]; _ } as set) ] ->
span_is "x = ..." set (1, 1, 1, 18);
span_is "a.b.c + b + c" sum (1, 5, 1, 18);
span_is "a.b.c" abc (1, 5, 1, 10)
| _ -> fail "x = a.b.c + b + c read as another shape"
let () =
(* Editor code, placed where it was written: line 40, column 5, and the
indent stack seeded with that column, so the next line at column 5 is a
sibling rather than a dedent. *)
Source.with_code ~syntax:Source.Indented ~at:(Some (40, 5)) (fun () ->
match Source.read_code ~expr:true ~file:"<buf>" "f(1)\n g(2)" with
| [ ({ v = Form.List [ { v = Form.Sym "do"; _ }; a; b ]; _ } as d) ] ->
span_is "the snippet" d (40, 5, 41, 9);
span_is "its first line" a (40, 5, 40, 9);
span_is "its second line" b (41, 5, 41, 9)
| fs ->
fail "a two-line snippet read as %s"
(String.concat " " (List.map Form.to_string fs)));
(* A snippet's first line is its left edge: a later line left of it is
refused as that, and a snippet sent with leading spaces starts where its
first token does. *)
Source.with_code ~syntax:Source.Indented ~at:(Some (40, 5)) (fun () ->
(match Source.read_code ~file:"<buf>" "f(1)\n g(2)" with
| _ -> fail "a line left of the snippet's first was read"
| exception Loc.Error d ->
if not (Test_support.contains d.Loc.dmsg "left of column 5 where the code sent starts")
then fail "a line left of a snippet: %s" d.Loc.dmsg);
match Source.read_code ~file:"<buf>" " f(1)\n g(2)" with
| [ _; _ ] -> ()
| _ -> fail "a snippet with leading spaces"
| exception e -> fail "a snippet with leading spaces: %s" (diag_text e));
Source.with_code ~syntax:Source.Paren ~at:(Some (7, 3)) (fun () ->
match Source.read_code ~file:"<buf>" "(f 1)" with
| [ f ] -> span_is "a paren snippet" f (7, 3, 7, 8)
| _ -> fail "a paren snippet")
(* ── Loading ───────────────────────────────────────────────────────── *)