567 lines
28 KiB
OCaml
567 lines
28 KiB
OCaml
(* The indented syntax (spec-syntax.md): its reader, its printer, and the
|
|
switch between the two readers by file extension.
|
|
|
|
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
|
|
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. *)
|
|
|
|
open Flan
|
|
|
|
let () = Watchdog.arm ~seconds:300 "test_syntax"
|
|
|
|
let fail fmt = Test_support.fail fmt
|
|
let scratch = Test_support.scratch
|
|
|
|
(* ── Forms, compared without locations ─────────────────────────────── *)
|
|
|
|
let rec eq (a : Form.t) (b : Form.t) =
|
|
match a.v, b.v with
|
|
| Form.List x, Form.List y | Form.Vec x, Form.Vec y | Form.Map x, Form.Map y ->
|
|
List.length x = List.length y && List.for_all2 eq x y
|
|
| Form.Float x, Form.Float y ->
|
|
Int64.equal (Int64.bits_of_float x) (Int64.bits_of_float y)
|
|
| x, y -> x = y
|
|
|
|
(* The innermost pair that differs, for the failure line. *)
|
|
let rec first_diff (a : Form.t) (b : Form.t) =
|
|
match a.v, b.v with
|
|
| (Form.List x, Form.List y | Form.Vec x, Form.Vec y | Form.Map x, Form.Map y)
|
|
when List.length x = List.length y ->
|
|
(match List.find_opt (fun (p, q) -> not (eq p q)) (List.combine x y) with
|
|
| Some (p, q) -> first_diff p q
|
|
| None -> (a, b))
|
|
| _ -> (a, b)
|
|
|
|
let same_forms a b =
|
|
List.length a = List.length b && List.for_all2 eq a b
|
|
|
|
let describe_diff a b =
|
|
if List.length a <> List.length b then
|
|
Printf.sprintf "%d forms against %d" (List.length a) (List.length b)
|
|
else
|
|
match List.find_opt (fun (x, y) -> not (eq x y)) (List.combine a b) with
|
|
| Some (x, y) ->
|
|
let u, w = first_diff x y in
|
|
Printf.sprintf "wanted %s, read %s (at %d:%d)" (Form.to_string u)
|
|
(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
|
|
in
|
|
{ f with v }
|
|
|
|
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
|
|
| e -> Printexc.to_string e
|
|
|
|
(* ── The hand-converted pairs ──────────────────────────────────────── *)
|
|
|
|
let pair flan fln =
|
|
match Reader.read_file flan, Source.read_file fln with
|
|
| a, b ->
|
|
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)
|
|
|
|
let () =
|
|
pair "syntax/algorithms.flan" "syntax/algorithms.fln";
|
|
pair "../sand.flan" "syntax/sand.fln";
|
|
(* Checked, never run: sand opens a window. *)
|
|
List.iter
|
|
(fun f ->
|
|
match Front.checked f with
|
|
| _ -> ()
|
|
| exception e -> fail "%s does not check: %s" f (diag_text e))
|
|
[ "syntax/sand.fln"; "syntax/algorithms.fln" ]
|
|
|
|
(* ── 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 () =
|
|
let rec walk dir acc =
|
|
Array.fold_left
|
|
(fun acc name ->
|
|
let path = Filename.concat dir name in
|
|
if name <> "" && (name.[0] = '.' || name.[0] = '_') then acc
|
|
else if Sys.is_directory path then walk path acc
|
|
else if Filename.check_suffix name ".flan" then path :: acc
|
|
else acc)
|
|
acc (Sys.readdir dir)
|
|
in
|
|
List.sort String.compare (walk ".." [])
|
|
|
|
let () =
|
|
let ok = ref 0 in
|
|
List.iter
|
|
(fun path ->
|
|
match Reader.read_file path with
|
|
| 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
|
|
| 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 ->
|
|
match Indent_reader.read_all ~file:(path ^ ".fln") text with
|
|
| 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 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
|
|
over nothing. *)
|
|
if !ok < 390 then fail "round trip covered only %d files" !ok
|
|
|
|
(* ── Lexical edge cases ────────────────────────────────────────────── *)
|
|
|
|
let read src = Indent_reader.read_all ~file:"<syntax>" src
|
|
|
|
let reads name src want =
|
|
match read src with
|
|
| forms ->
|
|
let got = String.concat "\n" (List.map Form.to_string forms) in
|
|
if got <> want then fail "%s: read %s, wanted %s" name got want
|
|
| exception e -> fail "%s: refused: %s" name (diag_text e)
|
|
|
|
let refuses name src kind needle =
|
|
match read src with
|
|
| forms ->
|
|
fail "%s: read %s, wanted the refusal %s" name
|
|
(String.concat " " (List.map Form.to_string forms)) kind
|
|
| exception Loc.Error d ->
|
|
if d.Loc.kind <> kind then fail "%s: refused as %s, wanted %s (%s)" name d.Loc.kind kind d.dmsg
|
|
else if not (Test_support.contains d.dmsg needle) then
|
|
fail "%s: %s does not say %S: %s" name kind needle d.dmsg
|
|
| exception e -> fail "%s: %s" name (Printexc.to_string e)
|
|
|
|
let () =
|
|
(* Minus. *)
|
|
reads "subtraction" "x = a - 1" "(set x (- a 1))";
|
|
reads "negative literal" "x = -1" "(set x -1)";
|
|
reads "negation" "x = -y" "(set x (- y))";
|
|
reads "negation binds after postfix" "x = -p.x" "(set x (- (.x p)))";
|
|
reads "lisp name" "x = a-b" "(set x a-b)";
|
|
reads "decrement is a name" "--(j)" "(-- j)";
|
|
reads "minus as a call" "x = -(a + b)" "(set x (- (+ a b)))";
|
|
refuses "glued minus" "x = a -1" "indent/glued-minus" "a - 1";
|
|
refuses "glued minus in a call" "f(a -1)" "indent/glued-minus" "space the minus";
|
|
(* The arrow. *)
|
|
reads "return arrow" "fn f(x: i32) -> i32 = x" "(defn f [x i32] i32 x)";
|
|
reads "arrow inside a name" "fn dyn->f64(v: f64) -> f64 = v" "(defn dyn->f64 [v f64] f64 v)";
|
|
reads "function type"
|
|
"fn g(h: Fn(i32, i32) -> bool) -> () = h(1, 2)"
|
|
"(defn g [h (Fn [i32 i32] bool)] () (h 1 2))";
|
|
reads "untyped parameter is dyn" "fn id(x) -> dyn = x" "(defn id [x dyn] dyn x)";
|
|
refuses "no return type" "fn f(x)\n x" "indent/return-type" "-> i32";
|
|
(* Characters, lexed before brackets and separators. *)
|
|
reads "character literals" "x = [\\( \\, \\space \\)]" "(set x [\\( \\, \\space \\)])";
|
|
reads "character arguments" "f(\\,, \\))" "(f \\, \\))";
|
|
(* Keywords and annotations. *)
|
|
reads "keyword" "def k = :else" "(def k dyn :else)";
|
|
reads "annotation" "once grid: [4 [8 u32]]" "(defonce grid [4 [8 u32]])";
|
|
reads "keyword argument" "rl/key-pressed?(:key-r)" "(rl/key-pressed? :key-r)";
|
|
refuses "colon inside a name" "fn f(x:i32) -> () = x" "indent/colon-in-name" "x: i32";
|
|
(* Adjacency. *)
|
|
reads "call" "f(a, b)" "(f a b)";
|
|
reads "index" "x[i, j]" "(at x i j)";
|
|
reads "call of a call" "f(a)(b)" "((f a) b)";
|
|
reads "field chain" "camera.target.x" "(.x (.target camera))";
|
|
reads "qualified case" "Shape.Rect" "Shape.Rect";
|
|
reads "field of a call" "f(x).y" "(.y (f x))";
|
|
reads "struct literal" "Vector2{.x 1, .y 2}" "(Vector2 {.x 1 .y 2})";
|
|
reads "operator call" "+(a, b, c)" "(+ a b c)";
|
|
reads "operator value" "reduce(+, 0, xs)" "(reduce + 0 xs)";
|
|
refuses "spaced call" "f (a)" "indent/spaced-call" "f(...)";
|
|
refuses "spaced index" "x [i]" "indent/spaced-index" "x[i]";
|
|
refuses "missing comma" "f(a b)" "indent/missing-comma" "commas";
|
|
refuses "unspaced operator" "x = f(a)+ b" "indent/unspaced-operator" "a + b";
|
|
(* Collections. *)
|
|
reads "whitespace vector" "x = [i n]" "(set x [i n])";
|
|
reads "comma vector" "x = [a - 1, b]" "(set x [(- a 1) b])";
|
|
refuses "operator between spaces" "x = [a - 1 b]" "indent/separate-elements" "commas";
|
|
reads "quoted list" "x = '(a b c)" "(set x (quote (a b c)))";
|
|
(* Trailing colon blocks. *)
|
|
reads "trailing block" "rl/with-drawing():\n clear()\n draw()"
|
|
"(rl/with-drawing (clear) (draw))";
|
|
reads "fallback with a block" "defmethod(describe, :square, [s]):\n s"
|
|
"(defmethod describe :square [s] s)";
|
|
refuses "block without the colon" "f(x)\n y" "indent/stray-indent" "trailing colon";
|
|
refuses "colon on a non-call" "a + b:\n y" "indent/colon-block" "comment:";
|
|
reads "bare name takes a block" "comment:\n f()\n g()" "(comment (f) (g))";
|
|
reads "qualified name takes a block" "rl/with-drawing:\n f()" "(rl/with-drawing (f))";
|
|
(* Indentation. *)
|
|
refuses "tab" "fn f() -> ()\n\tg()" "indent/tab" "spaces";
|
|
refuses "dedent to no block" "if a\n b\n c" "indent/dedent"
|
|
"between the block at column 1 and the one at column 5";
|
|
(* A continuation sits deeper than the line it continues. *)
|
|
refuses "leading operator left of its block" "if a\n b\n+ 1" "indent/continuation" "column 3";
|
|
refuses "leading operator at the statement's column" "let x = 1\n+ 2\nx"
|
|
"indent/continuation" "Indent it further";
|
|
refuses "trailing operator, shallower next line" "if a\n x = b +\nc"
|
|
"indent/continuation" "finish the line above";
|
|
reads "blank and comment lines" "if a\n\n ; note\n b\n\n; more\nc"
|
|
"(when a b)\nc";
|
|
(* Continuation lines. *)
|
|
reads "trailing operator" "x = a +\n b" "(set x (+ a b))";
|
|
reads "leading operator" "x = a\n + b" "(set x (+ a b))";
|
|
reads "continued condition" "if a\n and b\n c" "(when (and a b) c)";
|
|
(* Runs of one operator. *)
|
|
reads "flattened" "x = a + b + c" "(set x (+ a b c))";
|
|
reads "chain" "x = a < b < c" "(set x (< a b c))";
|
|
reads "left to right" "x = a - b + c" "(set x (+ (- a b) c))";
|
|
reads "precedence" "x = a or b and not c == d" "(set x (or a (and b (not (= c d)))))";
|
|
refuses "not-equal chain" "x = a != b != c" "indent/chained-not-equal" "!=(a, b, c)";
|
|
reads "not-equal call" "x = !=(a, b, c)" "(set x (!= a b c))";
|
|
refuses "mixed comparison" "x = a < b <= c" "indent/mixed-comparison" "and";
|
|
(* 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";
|
|
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))";
|
|
(* A place with a call in it is evaluated once: it reads as update. *)
|
|
reads "assignment op over a call's place" "a[next()] += 1"
|
|
"(update (at a (next)) + 1)";
|
|
reads "for" "for :outer i in range(1, n)\n f(i)" "(dotimes :outer [i 1 n] (f i))";
|
|
reads "unit statement" "restart-case\n f()\nrestart continue()\n ()"
|
|
"(restart-case (f) (continue [] (do)))";
|
|
reads "match" "match s\n Circle(r) -> r\n _ ->\n a()\n b()"
|
|
"(match s (Circle r) r _ (do (a) (b)))";
|
|
reads "match over literals" "match n\n 5 -> a\n -2.5 -> b\n \"go\" -> c\n \\a -> d\n _ -> e"
|
|
"(match n 5 a -2.5 b \"go\" c \\a d _ e)";
|
|
reads "handler-bind moves the clauses" "handler-bind\n f()\non E(c)\n g(c)"
|
|
"(handler-bind [(E [c] (g c))] (f))";
|
|
reads "quote block"
|
|
"defmacro(m, [x & ys]):\n quote\n f(~x)\n ~@ys"
|
|
"(defmacro m [x & ys] (quasiquote (do (f (unquote x)) (unquote-splicing ys))))";
|
|
reads "lambda" "g = fn(i, j) = i * 10 + j" "(set g (fn [i j] (+ (* i 10) j)))";
|
|
reads "lambda with a block" "g = fn(i)\n a(i)\n b(i)" "(set g (fn [i] (a i) (b i)))";
|
|
reads "where" "fn s(xs: [$t]) -> () where ordered?($t) = f(xs)"
|
|
"(defn s [xs [$t]] () {:where (ordered? $t)} (f xs))";
|
|
reads "data" "data Shape\n Circle(r: f32)\n Empty"
|
|
"(defdata Shape [(Circle [r f32]) Empty])";
|
|
reads "enum" "enum K\n lo = -1\n mid" "(defenum K [lo -1 mid])";
|
|
reads "struct" "struct Cell\n row: i32\n tag" "(defstruct Cell [row i32 tag dyn])";
|
|
reads "read-only pointer" "def p: Ptr(const u8) = uninit" "(def p (Ptr const u8) uninit)";
|
|
(* Statements that fit on a line, in one-line slots. *)
|
|
reads "arm statements" "match s\n 1 -> break\n 2 -> continue :outer\n _ -> x += 1"
|
|
"(match s 1 (break) 2 (continue :outer) _ (set x (+ x 1)))";
|
|
reads "then break" "if c then break" "(when c (break))";
|
|
reads "then return else assign" "if c then return 5 else x = 2" "(if c (return 5) (set x 2))";
|
|
reads "return in an expression if" "y = if c then return else 1" "(set y (if c (return) 1))";
|
|
reads "defer an assignment" "defer x = 0" "(defer (set x 0))";
|
|
(* 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" "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";
|
|
refuses "one-line handler-case" "handler-case g()" "indent/clause-header" "on Type(c)";
|
|
refuses "one-line on clause" "handler-case\n g()\non A(c) -> 1" "indent/clause-body" "on A(c)";
|
|
refuses "one-line elif" "x = if a then 1 elif b then 2 else 3" "indent/one-line-elif" "else if b";
|
|
refuses "elif with then" "if a\n 1\nelif b then 2" "indent/elif-then" "no then";
|
|
refuses "brace hint" "x = {.x a + 1 .y 2}" "indent/separate-elements" "{.x a + 1, .y 2}";
|
|
refuses "mixed separators" "x = [1 2, 3]" "indent/mixed-separators" "[1, 2, 3]";
|
|
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)";
|
|
(* And back: the printer writes the idioms. *)
|
|
let prints name src want =
|
|
match Reader.read_all ~file:"<p>" src with
|
|
| forms ->
|
|
let got = Indent_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
|
|
prints "compound assignment" "(defn f [] () (set x (+ x 1)))" " x += 1";
|
|
prints "compound update" "(defn f [] () (update (at a (next)) + 1))"
|
|
" a[next()] += 1";
|
|
prints "arm statements" "(defn f [] () (match s 1 (break) _ (return 2)))"
|
|
"1 -> break\n _ -> return 2";
|
|
prints "then and else statements" "(defn f [] () (if c (return 1) (set x 2)))"
|
|
"if c then return 1 else x = 2";
|
|
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";
|
|
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()";
|
|
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 ───────────────────────────────────────────────────────── *)
|
|
|
|
let write path text = Out_channel.with_open_bin path (fun oc -> output_string oc text)
|
|
|
|
let () =
|
|
(* A spaced-out operator is one name; the checker says which arithmetic. *)
|
|
let f = Filename.concat scratch "syntax-hint.fln" in
|
|
write f "fn main() -> i32\n let x = 3\n x-1\n";
|
|
(match Front.checked f with
|
|
| _ -> fail "x-1 checked"
|
|
| exception Loc.Error d ->
|
|
if not (Test_support.contains d.Loc.dmsg "Did you mean x - 1?") then
|
|
fail "x-1: %s" d.Loc.dmsg
|
|
| exception e -> fail "x-1: %s" (Printexc.to_string e));
|
|
(* One package, one file in two syntaxes: refused naming both. *)
|
|
let dir = Filename.concat scratch "syntax-twin" in
|
|
let pkg = Filename.concat dir "geo" in
|
|
(try Unix.mkdir dir 0o755 with Unix.Unix_error _ -> ());
|
|
(try Unix.mkdir pkg 0o755 with Unix.Unix_error _ -> ());
|
|
write (Filename.concat pkg "geo.flan") "(defn one [] i32 1)\n";
|
|
write (Filename.concat pkg "geo.fln") "fn one() -> i32 = 1\n";
|
|
let main = Filename.concat dir "main.flan" in
|
|
write main "(import geo \"geo\")\n(defn main [] i32 (geo/one))\n";
|
|
match Front.checked main with
|
|
| _ -> fail "a package with geo.flan and geo.fln loaded"
|
|
| exception Loc.Error d ->
|
|
if not (Test_support.contains d.Loc.dmsg "geo.flan"
|
|
&& Test_support.contains d.Loc.dmsg "geo.fln") then
|
|
fail "twin files: %s" d.Loc.dmsg
|
|
| exception e -> fail "twin files: %s" (Printexc.to_string e)
|
|
|
|
(* ── Both directions of an import, on both backends ────────────────── *)
|
|
|
|
let run_both path want =
|
|
List.iter
|
|
(fun x86 ->
|
|
let exe =
|
|
Filename.concat scratch
|
|
(Printf.sprintf "flan-syntax-%s-%d%s"
|
|
(Filename.basename path) (Unix.getpid ()) (if x86 then "-x86" else ""))
|
|
in
|
|
match
|
|
let p, csrcs, lflags = Test_support.linked path in
|
|
ignore (Build.executable ~opts:{ Build.default with x86 } ~csrcs ~lflags p ~out:exe)
|
|
with
|
|
| exception e -> fail "%s%s does not build: %s" path (if x86 then " --x86" else "") (diag_text e)
|
|
| () ->
|
|
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 _ -> ());
|
|
if code <> 0 || text <> want then
|
|
fail "%s%s printed %S and exited %d, wanted %S" path
|
|
(if x86 then " --x86" else "") text code want)
|
|
[ false; true ]
|
|
|
|
let () =
|
|
if Test_support.have "clang" then begin
|
|
run_both "syntax/mixed/main.flan" "12\n12\n0\n55\n";
|
|
run_both "syntax/mixed/main.fln" "25\n7\nfar\n3\n"
|
|
end
|
|
else print_endline "syntax: no clang, the import programs are not built"
|
|
|
|
let () = Test_support.report ~label:"syntax" ()
|