374 lines
19 KiB
OCaml
374 lines
19 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 ────────────────────────────────── *)
|
|
|
|
(* 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 same_forms a b then incr ok
|
|
else fail "round trip %s: %s" path (describe_diff a b))
|
|
(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 "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" "x == ...";
|
|
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"
|
|
|
|
(* ── 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" ()
|