918 lines
46 KiB
OCaml
918 lines
46 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 normalisation the spec allows. A table pins
|
|
the lexical edge cases and the refusals, with their kinds. And a program in
|
|
each syntax importing a package in the other builds and runs the same on
|
|
both backends. *)
|
|
|
|
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"
|
|
|
|
(* Spec §4 step 3's normalisation. Each rule keeps the meaning.
|
|
|
|
First every name a [let] binds is renamed, through its scope, to one
|
|
numbered in the order the binders come: so two forms that differ only in
|
|
what their [let]s call things compare equal, and one where a name was
|
|
captured does not. Then, where statements are a body run in order, a
|
|
[let] takes in the statements after it (the printer's flat [let]; with
|
|
every [let] name unique by now, nothing after it can mean one of them). A
|
|
[(do x)] whose [x] is a [let] is [x], a [let] whose whole body is another
|
|
[let] is the merged [let], and [(and x)] and [(or x)] are [x]. The flat
|
|
[let] and the one-argument [and] stop at a quote or quasiquote: data, or
|
|
a template whose unquotes could name anything. *)
|
|
|
|
(* A binding target with every struct pattern written as [name .field]
|
|
pairs: [{.x}] and [{:keys [x]}] are [{x .x}] (Parse.dmap). *)
|
|
let rec pairs_pat (t : Form.t) : Form.t =
|
|
let dotted s = String.length s > 1 && s.[0] = '.' in
|
|
let rec items = function
|
|
| ({ Form.v = Form.Sym s; _ } as f) :: rest when dotted s ->
|
|
{ f with v = Form.Sym (String.sub s 1 (String.length s - 1)) } :: f :: items rest
|
|
| { Form.v = Form.Kw "keys"; _ } :: { Form.v = Form.Vec ns; _ } :: rest ->
|
|
List.concat_map
|
|
(fun (n : Form.t) -> match n.v with
|
|
| Form.Sym x -> [ n; { n with v = Form.Sym ("." ^ x) } ]
|
|
| _ -> [ n ])
|
|
ns
|
|
@ items rest
|
|
| pat :: f :: rest -> pairs_pat pat :: f :: items rest
|
|
| rest -> rest
|
|
in
|
|
match t.v with
|
|
| Form.Vec l -> { t with v = Form.Vec (List.map pairs_pat l) }
|
|
| Form.Map l -> { t with v = Form.Map (items l) }
|
|
| _ -> t
|
|
|
|
(* The names a target so written binds, in order. *)
|
|
let rec binders (t : Form.t) =
|
|
match t.v with
|
|
| Form.Sym "&" -> []
|
|
| Form.Sym s -> [ s ]
|
|
| Form.Vec l -> List.concat_map binders l
|
|
| Form.Map l -> List.concat (List.filteri (fun i _ -> i mod 2 = 0) (List.map binders l))
|
|
| _ -> []
|
|
|
|
let canon (f : Form.t) : Form.t =
|
|
let k = ref 0 in
|
|
let look env s =
|
|
match List.assoc_opt s env with
|
|
| Some c -> c
|
|
| None ->
|
|
(* [x.y], a field path on a bound [x]. *)
|
|
match String.index_opt s '.' with
|
|
| Some i when i > 0 ->
|
|
(match List.assoc_opt (String.sub s 0 i) env with
|
|
| Some c -> c ^ String.sub s i (String.length s - i)
|
|
| None -> s)
|
|
| _ -> s
|
|
in
|
|
let rec go env (f : Form.t) =
|
|
let v =
|
|
match f.v with
|
|
| Form.Sym s -> Form.Sym (look env s)
|
|
(* Quoted data keeps its names: renaming them would hide a printer
|
|
that renamed them too. *)
|
|
| Form.List ({ v = Form.Sym ("quote" | "quasiquote"); _ } :: _) -> f.v
|
|
| Form.List (({ v = Form.Sym "let"; _ } as h) :: ({ v = Form.Vec bs; _ } as bv) :: body) ->
|
|
let rec binds env acc = function
|
|
| t :: v :: rest ->
|
|
let v' = go env v in
|
|
let t = pairs_pat t in
|
|
let env' =
|
|
List.fold_left (fun e n -> incr k; (n, "%" ^ string_of_int !k) :: e)
|
|
env (binders t)
|
|
in
|
|
binds env' (v' :: go env' t :: acc) rest
|
|
| rest -> (env, List.rev_append acc (List.map (go env) rest))
|
|
in
|
|
let env', bs' = binds env [] bs in
|
|
Form.List (h :: { bv with v = Form.Vec bs' } :: List.map (go env') body)
|
|
| Form.List l -> Form.List (List.map (go env) l)
|
|
| Form.Vec l -> Form.Vec (List.map (go env) l)
|
|
| Form.Map l -> Form.Map (List.map (go env) l)
|
|
| v -> v
|
|
in
|
|
{ f with v }
|
|
in
|
|
go [] f
|
|
|
|
(* The macros of the file being compared ([Body_macros.table]). *)
|
|
let macros : Body_macros.t ref = ref (Hashtbl.create 1)
|
|
|
|
(* Where the statements of a body start, for a head whose trailing arguments
|
|
are a body run in order. *)
|
|
let body_start (l : Form.t list) =
|
|
let label k = match List.nth_opt l 1 with
|
|
| Some { Form.v = Form.Kw _; _ } -> k + 1 | _ -> k in
|
|
match l with
|
|
| { Form.v = Form.Sym h; _ } :: _ ->
|
|
(match h with
|
|
| "do" | "defer" -> Some 1
|
|
| "let" | "when" | "fn" | "loop" -> Some 2
|
|
| "while" | "until" | "dotimes" -> Some (label 2)
|
|
| "defmacro" -> Some 3
|
|
| "defmethod" -> Some 4
|
|
| "defn" | "defn-" ->
|
|
Some (match List.nth_opt l 4 with
|
|
| Some { Form.v = Form.Map _; _ } -> 5 | _ -> 4)
|
|
| h ->
|
|
(match List.assoc_opt h Body_macros.core with
|
|
| Some k -> Some (k + 1)
|
|
| None -> Option.map (fun k -> k + 1) (Hashtbl.find_opt !macros h)))
|
|
| _ -> None
|
|
|
|
let is_let (f : Form.t) =
|
|
match f.v with Form.List ({ v = Form.Sym "let"; _ } :: _) -> true | _ -> false
|
|
|
|
let rec shape ?(q = false) (f : Form.t) : Form.t =
|
|
let q = q || (match f.v with
|
|
| Form.List ({ v = Form.Sym ("quote" | "quasiquote"); _ } :: _) -> true | _ -> false) in
|
|
let sh = shape ~q in
|
|
(* A body's statements, each [let] taking in the ones after it. *)
|
|
let rec stmts = function
|
|
| [] -> []
|
|
| x :: (_ :: _ as rest) when not q ->
|
|
(match (sh x).v with
|
|
| Form.List (({ v = Form.Sym "let"; _ } as h) :: ({ v = Form.Vec (_ :: _); _ } as bv)
|
|
:: (_ :: _ as body)) ->
|
|
[ sh { x with v = Form.List (h :: bv :: (body @ rest)) } ]
|
|
| _ -> sh x :: stmts rest)
|
|
| x :: rest -> sh x :: stmts rest
|
|
in
|
|
let seq_list l =
|
|
match body_start l with
|
|
| Some k when List.length l > k ->
|
|
List.map sh (List.filteri (fun i _ -> i < k) l)
|
|
@ stmts (List.filteri (fun i _ -> i >= k) l)
|
|
| _ -> List.map sh l
|
|
in
|
|
(* Handler and restart clauses: [(name [v] body ...)]. *)
|
|
let clause (c : Form.t) =
|
|
match c.v with
|
|
| Form.List (n :: p :: body) -> { c with v = Form.List (sh n :: sh p :: stmts body) }
|
|
| _ -> sh c
|
|
in
|
|
match f.v with
|
|
| Form.List [ { v = Form.Sym ("and" | "or"); _ }; x ] when not q -> sh x
|
|
| _ ->
|
|
let v =
|
|
match f.v with
|
|
| Form.List (({ v = Form.Sym "let"; _ } as h) :: { v = Form.Vec bs; loc } :: body) ->
|
|
(match stmts body with
|
|
| [ { v = Form.List ({ v = Form.Sym "let"; _ } :: { v = Form.Vec bs2; _ } :: body2); _ } ] ->
|
|
Form.List (h :: Form.make (Form.Vec (List.map sh bs @ bs2)) loc :: body2)
|
|
| body -> Form.List (h :: Form.make (Form.Vec (List.map sh bs)) loc :: body))
|
|
| Form.List (({ v = Form.Sym "handler-case"; _ } as h) :: body :: ({ v = Form.Vec cls; _ } as cv) :: more) ->
|
|
Form.List (h :: sh body :: { cv with v = Form.Vec (List.map clause cls) }
|
|
:: List.map sh more)
|
|
| Form.List (({ v = Form.Sym "handler-bind"; _ } as h) :: ({ v = Form.Vec cls; _ } as cv) :: body) ->
|
|
Form.List (h :: { cv with v = Form.Vec (List.map clause cls) } :: stmts body)
|
|
| Form.List (({ v = Form.Sym "restart-case"; _ } as h) :: body :: cls) ->
|
|
Form.List (h :: sh body :: List.map clause cls)
|
|
| Form.List l ->
|
|
(match seq_list l with
|
|
| [ { v = Form.Sym "do"; _ }; x ] when is_let x -> x.v
|
|
| l -> Form.List l)
|
|
| Form.Vec l -> Form.Vec (List.map sh l)
|
|
| Form.Map l -> Form.Map (List.map sh l)
|
|
| v -> v
|
|
in
|
|
{ f with v }
|
|
|
|
let norm f = shape (canon f)
|
|
|
|
let diag_text = function
|
|
| Loc.Error d -> Printf.sprintf "%s %d:%d %s" d.Loc.kind d.dloc.Loc.line d.dloc.Loc.col d.dmsg
|
|
| 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 ->
|
|
macros := Body_macros.table ~file:flan a;
|
|
(* Normalised: a hand conversion writes a let flat where its scope does
|
|
not matter, as the printer does. *)
|
|
let a = List.map norm a and b = List.map norm b in
|
|
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 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
|
|
(* The normalised forms: a [let] a flat line extended is, on both sides,
|
|
the one that holds what now follows it. *)
|
|
List.iter walk (List.map norm fs);
|
|
List.map (fun ((l, c, _), t) -> (l, c, t)) (List.sort compare !out)
|
|
|
|
let attachments src forms =
|
|
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
|
|
macros := Body_macros.table ~file:path forms;
|
|
match Indent_printer.program ~source ~macros:!macros forms with
|
|
| exception Indent_printer.Unprintable (f, why) ->
|
|
fail "round trip %s: %s at %d:%d" path why f.loc.Loc.line f.loc.Loc.col
|
|
| text ->
|
|
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";
|
|
(* The fix is .fln's commas whatever the file is called: [read] names it
|
|
<syntax>. *)
|
|
refuses "where predicates joined with and"
|
|
"fn f(x: $t, y: $u) -> i32 where ordered?($t) and equal?($u)\n 0"
|
|
"indent/where-and" "commas, not and — write where ordered?($t), equal?($u)";
|
|
(* 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)))";
|
|
refuses "let with a block" "let a = 1\n a\nb" "indent/let-block" "go at the let's column";
|
|
reads "flat let" "let a = 1\na\nb" "(let [a 1] a b)";
|
|
reads "elif" "if a\n 1\nelif b\n 2\nelse\n 3" "(cond a 1 b 2 :else 3)";
|
|
reads "one-line if" "x = if a then 1 else 2" "(set x (if a 1 2))";
|
|
reads "assignment ops" "a[i] += 1" "(set (at a i) (+ (at a i) 1))";
|
|
(* 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 "match over a bool" "match b\n true -> a\n false -> b"
|
|
"(match b true a false b)";
|
|
reads "keyword arms over a dyn" "match d\n :north -> a\n 1 -> b\n _ -> c"
|
|
"(match d :north a 1 b _ c)";
|
|
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)";
|
|
refuses "a let takes no block" "fn f() -> ()\n let x = 1\n g(x)\n h(x)"
|
|
"indent/let-block" "go at the let's column";
|
|
(* And back: the printer writes the idioms. *)
|
|
let prints name src want =
|
|
match Reader.read_all ~file:"<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";
|
|
(* A let is always flat: it takes in the rest of its block. *)
|
|
prints "flat let" "(defn f [] () (let [j 1] (g j)) (h))" " let j = 1\n g(j)\n h()";
|
|
prints "a chain of lets, all flat" "(defn f [] () (let [a 1] (let [b 2] (g b)) (k a)) (h))"
|
|
" let a = 1\n let b = 2\n g(b)\n k(a)\n h()";
|
|
(* A later statement that means an outer name of the same spelling: the
|
|
let's own is renamed. *)
|
|
prints "a later outer name of the same spelling renames the let's"
|
|
"(defn f [x i32] () (let [x 1] (g x)) (h x))" " let x-2 = 1\n g(x-2)\n h(x)";
|
|
prints "the inner let of a chain renamed"
|
|
"(defn f [] () (let [a 1] (let [b 2] (g b)) (h b)))" " let a = 1\n let b-2 = 2\n g(b-2)\n h(b)";
|
|
prints "the binding's own value keeps the outer name"
|
|
"(defn f [x i32] () (let [x (+ x 1)] (g x)) (h x))" " let x-2 = x + 1\n g(x-2)\n h(x)";
|
|
prints "a later binding's value takes the new name"
|
|
"(defn f [x i32] () (let [x 1 y (+ x 1)] (g y)) (h x))"
|
|
" let x-2 = 1\n let y = x-2 + 1\n g(y)\n h(x)";
|
|
prints "the new name is one the function does not use"
|
|
"(defn f [x i32] () (let [x 1] (g x x-2)) (h x))" " let x-3 = 1\n g(x-3, x-2)\n h(x)";
|
|
prints "a later let of the same name is no mention"
|
|
"(defn f [] () (let [a 1] (g a)) (let [a 2] (k a)))" " let a = 1\n g(a)\n let a = 2\n k(a)";
|
|
prints "unless its value uses the name"
|
|
"(defn f [a i32] () (let [a 1] (g a)) (let [a (+ a 1)] (k a)))"
|
|
" let a-2 = 1\n g(a-2)\n let a = a + 1\n k(a)";
|
|
prints "a destructured name renamed alone" "(defn f [] () (let [[p q] v] (g p q)) (h q))"
|
|
" let [p q-2] = v\n g(p, q-2)\n h(q)";
|
|
prints "a qualified name counts" "(defn f [] () (let [p (pt)] (g p)) (h p/x))"
|
|
" let p-2 = pt()\n g(p-2)\n h(p/x)";
|
|
prints "a quoted name later counts" "(defn f [] () (let [a 1] (g a)) (h 'a))"
|
|
" let a-2 = 1\n g(a-2)\n h('a)";
|
|
(* Where a rename cannot be trusted, a do: block holds the let. *)
|
|
prints "a quoted name inside is not renamed" "(defn f [] () (let [a 1] (g 'a)) (h a))"
|
|
" do:\n let a = 1\n g('a)\n h(a)";
|
|
prints "a call of the name inside is not renamed" "(defn f [] () (let [len 1] (len v)) (h len))"
|
|
" do:\n let len = 1\n len(v)\n h(len)";
|
|
(* A struct pattern renames as pairs, so the field keeps its name. *)
|
|
prints "a struct pattern renamed"
|
|
"(defn f [x i32] () (let [{.x .y} p] (g x y)) (h x))" " let {x-2 .x y .y} = p\n g(x-2, y)\n h(x)";
|
|
prints "a :keys pattern renamed"
|
|
"(defn f [x i32] () (let [{:keys [x y]} p] (g x y)) (h x))" " let {x-2 .x y .y} = p\n g(x-2, y)\n h(x)";
|
|
prints "a struct pattern that binds none of them stays"
|
|
"(defn f [x i32] () (let [{.y .z} p] (g y)) (h x))" " let {.y .z} = p\n g(y)\n h(x)";
|
|
prints "a later struct pattern rebinding the name is no mention"
|
|
"(defn f [] () (let [x 1] (g x)) (let [{.x} p] (k x)))" " let x = 1\n g(x)\n let {.x} = p\n k(x)";
|
|
prints "a struct literal inside is renamed"
|
|
"(defn f [x i32] () (let [x 1] (g (P {.x x}))) (h x))" " let x-2 = 1\n g(P{.x x-2})\n h(x)";
|
|
(* A macro whose body its definition splices into a do is a body run in
|
|
order; one that splices it anywhere else is not. *)
|
|
prints "a macro's in-order body"
|
|
"(defmacro twice [n & body] `(do ~@body ~@body))\n(defn f [] () (twice 2 (let [a 1] (g a)) (h)))"
|
|
" twice(2):\n let a = 1\n g(a)\n h()";
|
|
prints "a macro's list of arguments"
|
|
"(defmacro listed [& xs] `(list ~@xs))\n(defn f [] () (listed (let [a 1] (g a)) (set x 2)))"
|
|
" listed:\n do:\n let a = 1\n g(a)\n x = 2";
|
|
prints "comment is a body in order" "(comment (let [a 1] (g a)) (h))" "comment:\n let a = 1\n g(a)\n h()";
|
|
prints "in a quasiquote" "(defmacro m [x] (quasiquote (do (let [a 1] (g a)) (h ~x))))"
|
|
" do:\n let a = 1\n g(a)\n h(~x)";
|
|
prints "among a call's arguments" "(foo 1 (let [a 1] (g a)) (set x 2))"
|
|
"foo(1):\n do:\n let a = 1\n g(a)\n x = 2";
|
|
prints "at the top level" "(let [a 1] (g a))\n(h)" "do:\n let a = 1\n g(a)\n\nh()";
|
|
prints "one-argument and" "(defn f [] () (while (and (< i n)) (g)))" " while i < n\n";
|
|
prints "one-argument or" "(defn f [] () (when (or c) (g)))" " if c\n";
|
|
prints "one-argument and in a quasiquote" "(defmacro m [x] (quasiquote (and ~x)))" "and(~x)";
|
|
prints "do in an arm is a block" "(defn f [] () (match s _ (do (a) (b))))" "_ ->\n a()";
|
|
prints "hex spelling" "(def c dyn 0xFFF00FFF)" "0xFFF00FFF";
|
|
prints "own-line comment above its form" "(defn f [] ()\n ;; why\n (g))" " ;; why\n g()";
|
|
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));
|
|
(* A condition cut out from after [elif ] at column 3: its wrapped line at
|
|
column 8 is deeper than the elif, which is what the file says, though not
|
|
deeper than the cut. [:indent] says where the statement starts; every
|
|
location stays the buffer's own. *)
|
|
Source.with_code ~indent:3 ~syntax:Source.Indented ~at:(Some (10, 8)) (fun () ->
|
|
(match Source.read_code ~expr:true ~file:"<buf>" "x == 0 or\n x == 1" with
|
|
| [ f ] -> span_is "a wrapped condition, cut mid-line" f (10, 8, 11, 14)
|
|
| _ -> fail "a wrapped condition read as more than one form"
|
|
| exception e -> fail "a wrapped condition: %s" (diag_text e));
|
|
match Source.read_code ~expr:true ~file:"<buf>" "x == 0 or\n x == 1" with
|
|
| _ -> fail "a continuation left of its statement was read"
|
|
| exception Loc.Error _ -> ());
|
|
Source.with_code ~syntax:Source.Indented ~at:(Some (10, 8)) (fun () ->
|
|
match Source.read_code ~expr:true ~file:"<buf>" "x == 0 or\n x == 1" with
|
|
| _ -> fail "without :indent, a wrapped line is measured from the cut"
|
|
| exception Loc.Error _ -> ());
|
|
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)
|
|
|
|
(* ── A refusal's fix is spelled in the file's own syntax, and compiles ── *)
|
|
|
|
let refused name text needles =
|
|
let f = Filename.concat scratch name in
|
|
write f text;
|
|
match Front.checked f with
|
|
| _ -> fail "%s checked" name
|
|
| exception (Loc.Error d | Loc.Errors [ d ]) ->
|
|
List.iter
|
|
(fun n ->
|
|
if not (Test_support.contains d.Loc.dmsg n) then
|
|
fail "%s: wanted %S in: %s" name n d.Loc.dmsg)
|
|
needles
|
|
| exception e -> fail "%s: %s" name (diag_text e)
|
|
|
|
let checks name text =
|
|
let f = Filename.concat scratch name in
|
|
write f text;
|
|
match Front.checked f with
|
|
| _ -> ()
|
|
| exception e -> fail "%s does not check: %s" name (diag_text e)
|
|
|
|
let () =
|
|
let poke_fln = "fn poke(coll) -> dyn\n coll[0] = 99\n coll\n\n" in
|
|
let poke_flan = "(defn poke [coll] dyn (set (at coll 0) 99) coll)\n" in
|
|
(* A typed local is not a global, so no dyn value may see into it. *)
|
|
refused "view-local.fln"
|
|
(poke_fln ^ "fn main() -> ()\n let a: [4 i64] = [6 2 4 9]\n poke(a)\n")
|
|
[ "a is a [4 i64], and a dyn value is wanted here";
|
|
"a local, a parameter or a temporary";
|
|
"as in let a: dyn = [...]" ];
|
|
refused "view-local.flan"
|
|
(poke_flan ^ "(defn main [] () (let [a (array 4 i64)] (poke a)))\n")
|
|
[ "a is a [4 i64]"; "as in (let [a (the dyn [...])] ...)" ];
|
|
refused "view-temp.flan"
|
|
(poke_flan ^ "(defn main [] () (poke (array 4 i64)))\n")
|
|
[ "This is a [4 i64]"; "as in (the dyn [...])" ];
|
|
(* An unannotated literal is [4 i32], whose elements no view carries. *)
|
|
refused "view-elem.fln"
|
|
(poke_fln ^ "fn main() -> ()\n let d = [6 2 4 9]\n poke(d)\n")
|
|
[ "d is a [4 i32]"; "only when its elements are i64, f64 or bool, and these are i32";
|
|
"as in let d: dyn = [...]" ];
|
|
(* A parameter is made by the caller, so its fix is its declaration. *)
|
|
refused "view-param.fln"
|
|
"fn take(d) -> i32 = 1\n\nfn give(n: i32, v: [4 i64]) -> i32\n take(v)\n\n\
|
|
fn main() -> i32 = 0\n"
|
|
[ "v is a [4 i64] parameter"; "Declare v as dyn in give's parameters: v: dyn" ];
|
|
refused "view-param.flan"
|
|
"(defn take [d dyn] i32 1)\n(defn give [n i32 v (Vec i64)] i32 (take v))\n\
|
|
(defn main [] i32 0)\n"
|
|
[ "v is a (Vec i64) parameter"; "Declare v as dyn in give's parameters: v dyn" ];
|
|
checks "view-param-fix.fln"
|
|
"fn take(d) -> i32 = 1\n\nfn give(n: i32, v: dyn) -> i32\n take(v)\n\n\
|
|
fn main() -> i32 = 0\n";
|
|
(* A global's fix redefines it, in the form it was defined with. *)
|
|
let show_flan = "(defn show [d dyn] i32 1)\n" in
|
|
refused "view-global.flan"
|
|
("(defonce gs [2 i32] [1 2])\n" ^ show_flan ^ "(defn main [] i32 (show gs))\n")
|
|
[ "gs is a [2 i32]"; "as in (defonce gs dyn [...])" ];
|
|
refused "view-global-def.flan"
|
|
("(def gs [2 i32] [1 2])\n" ^ show_flan ^ "(defn main [] i32 (show gs))\n")
|
|
[ "as in (def gs dyn [...])" ];
|
|
refused "view-global.fln"
|
|
"once gs: [2 i32] = [1 2]\n\nfn show(d) -> i32 = 1\n\nfn main() -> i32 = show(gs)\n"
|
|
[ "gs is a [2 i32]"; "as in once gs: dyn = [...]" ];
|
|
checks "view-global-fix.flan"
|
|
("(defonce gs dyn [1 2])\n(def hs dyn [1 2])\n" ^ show_flan
|
|
^ "(defn main [] i32 (show gs) (show hs))\n");
|
|
checks "view-global-fix.fln"
|
|
"once gs: dyn = [1 2]\n\nfn show(d) -> i32 = 1\n\nfn main() -> i32 = show(gs)\n";
|
|
(* The fix is spelled in the syntax the code was sent in, not the one the
|
|
file's name implies: an editor request from an indented buffer. *)
|
|
Source.with_code ~syntax:Source.Indented ~at:None (fun () ->
|
|
refused "unit-tail-request.flan"
|
|
"(defn f [coll] dyn (let [i 1] (while (< i 3) (++ i))))\n(defn main [] () (f 1))\n"
|
|
[ "fn f(...) -> ()" ]);
|
|
(* The fix both of them name. *)
|
|
checks "view-fix.fln"
|
|
(poke_fln ^ "fn main() -> ()\n let d: dyn = [6 2 4 9]\n poke(d)\n poke(the(dyn, [1 2]))\n");
|
|
checks "view-fix.flan"
|
|
(poke_flan
|
|
^ "(defn main [] () (let [a (the dyn [6 2 4 9])] (poke a)) (poke (the dyn [1 2])))\n");
|
|
(* A dyn function whose body ends in a while gives no value. *)
|
|
let loop_fln ret tail =
|
|
"fn f(coll) -> " ^ ret ^ "\n let i = 1\n while i < 3\n ++(i)\n" ^ tail
|
|
^ "\nfn main() -> ()\n f(1)\n"
|
|
in
|
|
refused "unit-tail.fln" (loop_fln "dyn" "")
|
|
[ "f is declared to return dyn, but the last form of its body gives no value";
|
|
"fn f(...) -> ()" ];
|
|
refused "unit-tail.flan"
|
|
"(defn f [coll] dyn (let [i 1] (while (< i 3) (++ i))))\n(defn main [] () (f 1))\n"
|
|
[ "f is declared to return dyn"; "(defn f [...] () ...)" ];
|
|
checks "unit-tail-nil.fln" (loop_fln "dyn" " nil\n");
|
|
checks "unit-tail-unit.fln" (loop_fln "()" "");
|
|
(* A unit argument deeper in the last form is about that argument. *)
|
|
refused "unit-arg.flan"
|
|
"(defn g [x dyn] dyn x)\n(defn f [coll] dyn (g (println 1)))\n(defn main [] () (f 1))\n"
|
|
[ "() does not box into dyn" ]
|
|
|
|
(* ── 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" ()
|