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

Hand-written .fln programs cover the syntax, and .fln gains else after a one-line if, typed lambdas, a restart's report on its header, Dir.north, and messages that spell types in the file's syntax

Browse Source
This commit is contained in:
Joseph Ferano 2026-09-26 00:36:49 +07:00
commit 3d97c73c32
29 changed files with 2235 additions and 325 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

27
TODO.org
View File

@ -640,6 +640,33 @@ awaiting confirmation, and the build order. Rules out Parinfer, wisp and
sweet-expressions, and a simplified in-paren syntax — all thin the parens
without removing them.
** WAIT A lambda with a block cannot be a call's argument
On the author's decision. =sort-by(xs, fn(a, b)= plus a block is refused; the
lambda has to be bound first with =let=. Proposal: a call ending in =fn(...)= and a trailing =:=
hands the block to that lambda: =sort-by(xs, fn(a, b)):=.
** WAIT A condition struct with a parent has no sugar
On the author's decision. =defstruct(DiskFull, :parent, IoError, [free i64])= is the fallback, with a
paren field vector. Proposal: =struct DiskFull :parent IoError= plus field lines.
** WAIT defmacro has no sugar
On the author's decision. =defmacro(repeat, [i n & body]):= with a space-separated parameter vector.
Proposal: =macro repeat(i, n, & body)= plus a block.
** WAIT loop/recur has no sugar
On the author's decision. =loop([x a y b]):=. Proposal: =loop x = a, y = b= plus a block; =recur(...)=
stays a call.
** TODO Hard-coded code in messages is still paren syntax in a .fln file
Types follow the code's syntax now (=Types.spell=). Hints written into a message's
text — =(Ptr %s)=, =(clone v)=, =(the T x)= in most of =check.ml= and =parse.ml=, the
runtime's =(get 0 :body)= and =(/ x 0)= — still print parens; each is fixed per
message as it is met.
** CANCELLED Sugar for defclass, defgeneric, defmulti and defmethod
CLOSED: [2026-09-26]
The fallback, =defmethod(area, point, [p]):=, reads well enough.
** TODO The shims in sand.flan can go
=sand.flan= defines =dyn->f64= and =dyn->u32=, one-line functions whose only job
is that their parameter slot unboxes. Every call site can write =(f64 d)= and

2
lib/body_macros.ml
View File

@ -29,7 +29,7 @@ let create () = { bodies = Hashtbl.create 32; names = Hashtbl.create 64 }
(* Core forms whose trailing arguments are a body run in order, and how many
arguments come before it. *)
let core = [ ("do", 0); ("let", 1); ("fn", 1); ("when", 1); ("while", 1); ("loop", 1);
("defer", 0); ("with-allocator", 1) ]
("dotimes", 1); ("defer", 0); ("with-allocator", 1) ]
let body_start (t : t) h =
match List.assoc_opt h core with Some k -> Some k | None -> Hashtbl.find_opt t.bodies h

551
lib/check.ml
View File

File diff suppressed because it is too large Load Diff

148
lib/indent_printer.ml
View File

@ -363,7 +363,7 @@ and head_text (h : Form.t) =
| Form.Sym s -> fst (sym h s)
| _ -> at 9 h
and list _f h args =
and list f h args =
let call () = (head_text h ^ "(" ^ commas args ^ ")", 9) in
match h.v, args with
| Form.Sym "quote", [ x ] -> ("'" ^ Form.to_source x, 10)
@ -380,7 +380,16 @@ and list _f h args =
| _ -> false
in
let ft = if fl < lvl || (fl = lvl && same) then paren ft else ft in
(String.concat (" " ^ op ^ " ") (ft :: List.map (at (lvl + 1)) rest), lvl)
(* [(a and b) or c]: the parentheses precedence makes optional are
written, as most readers expect them. *)
let and_in_or (x : Form.t) t =
match x.v with
| Form.List ({ v = Form.Sym "and"; _ } :: _ :: _ :: _) when s = "or" && t.[0] <> '(' -> paren t
| _ -> t
in
let ft = and_in_or first ft in
(String.concat (" " ^ op ^ " ")
(ft :: List.map (fun x -> and_in_or x (at (lvl + 1) x)) rest), lvl)
| Form.Sym "-", [ x ] ->
let t, l = expr x in
if l >= 9 && t <> "" && R.is_neg_char t.[0] then ("-" ^ t, 8)
@ -398,6 +407,10 @@ and list _f h args =
&& (match t.v with
| Form.Byte _ -> false
| Form.Sym x -> name_ok x && not (String.contains x '.') && not (R.capitalised x)
(* A field of a field chains: [w.x.count]. *)
| Form.List [ { v = Form.Sym f; _ }; _ ]
when String.length f > 1 && f.[0] = '.' && tt <> "" && tt.[0] <> '.' ->
String.length tt > 0 && not (String.contains tt ' ')
| _ ->
let c = tt.[String.length tt - 1] in
c = ')' || c = ']' || c = '}' || c = '"')
@ -405,8 +418,12 @@ and list _f h args =
if glued then (tt ^ s, 9) else call ()
| Form.Sym s, [ ({ v = Form.Map _; _ } as m) ] when name_ok s && R.capitalised s ->
(s ^ fst (expr m), 9)
| Form.Sym "the", _ when (match typed_lambda f with Some (_, [ _ ]) -> true | _ -> false) ->
(match typed_lambda f with
| Some (head, [ body ]) -> (head ^ " = " ^ unit_text body, 0)
| _ -> assert false)
| Form.Sym "fn", [ { v = Form.Vec ps; _ }; body ] when List.for_all sym_param ps ->
("fn(" ^ commas ps ^ ") = " ^ at 0 body, 0)
("fn(" ^ commas ps ^ ") = " ^ unit_text body, 0)
| Form.Sym "if", [ c; a; b ] ->
("if " ^ at 1 c ^ " then " ^ inline_text ~lvl:1 a ^ " else " ^ inline_text b, 0)
| _ -> call ()
@ -416,6 +433,10 @@ and list _f h args =
everything else as a value. [lvl] is what a value in the slot needs. *)
and inline_text ?(lvl = 0) (f : Form.t) =
match f.v with
(* In a one-line slot a bare [()] reads as [(do)]; the value [()] is
written [(())]. *)
| Form.List [] -> "(())"
| Form.List [ { v = Form.Sym "do"; _ } ] -> "()"
| Form.List [ { v = Form.Sym (("break" | "continue" | "return") as w); _ } ] -> w
| Form.List [ { v = Form.Sym (("break" | "continue") as w); _ }; { v = Form.Kw k; _ } ]
when kw_ok k ->
@ -427,6 +448,13 @@ and inline_text ?(lvl = 0) (f : Form.t) =
at 9 t ^ " " ^ op ^ "= " ^ at (max lvl 1) w
| _ -> at lvl f
(* A body after [=]: [()] there reads as [(do)]. *)
and unit_text (f : Form.t) =
match f.v with
| Form.List [] -> "(())"
| Form.List [ { v = Form.Sym "do"; _ } ] -> "()"
| _ -> at 0 f
(* [t = v], or [t += w] when [v] is [(+ t w)]. *)
and assign_text ?(lvl = 0) t v =
let tt = at 9 t in
@ -439,6 +467,26 @@ and assign_text ?(lvl = 0) t v =
and sym_param (p : Form.t) =
match p.v with Form.Sym s -> name_ok s | _ -> false
(* [(the (Fn [C dyn] R) (fn [a b] ...))] as [fn(a: C, b) -> R], the typed
lambda it reads from; [None] for any other shape. *)
and typed_lambda (f : Form.t) =
let rec tyt (t : Form.t) =
match t.v with
| Form.List [ { v = Form.Sym (("Fn" | "CFn") as h); _ }; { v = Form.Vec ps; _ }; r ] ->
h ^ "(" ^ String.concat ", " (List.map tyt ps) ^ ") -> " ^ tyt r
| _ -> at 9 t
in
match f.v with
| Form.List [ { v = Form.Sym "the"; _ };
{ v = Form.List [ { v = Form.Sym "Fn"; _ }; { v = Form.Vec ts; _ }; r ]; _ };
{ v = Form.List ({ v = Form.Sym "fn"; _ } :: { v = Form.Vec ps; _ } :: body); _ } ]
when List.length ts = List.length ps && List.for_all sym_param ps && body <> [] ->
let one (n : Form.t) (t : Form.t) =
if is_sym "dyn" t then fst (expr n) else fst (expr n) ^ ": " ^ tyt t
in
Some ("fn(" ^ String.concat ", " (List.map2 one ps ts) ^ ") -> " ^ tyt r, body)
| _ -> None
(* A type after [:] or [->]: the function-type arrow at the top, a postfix
term below it. *)
let rec ty (f : Form.t) =
@ -537,15 +585,26 @@ let body_guess (h : Form.t) args =
match List.rev args with a :: _ -> stmt_like a | [] -> false
in
ignore lead;
if is_with || last_stmt then begin
let k = ref 0 in
List.iteri
(fun i (a : Form.t) ->
match a.v with Form.List (_ :: _) -> () | _ -> k := i + 1)
args;
Some !k
end
else None)
let k = ref 0 in
List.iteri
(fun i (a : Form.t) ->
match a.v with Form.List (_ :: _) -> () | _ -> k := i + 1)
args;
(* The block starts at the first statement among the trailing lists,
so what comes before it — an if's test — stays in the parentheses:
[if(c):] rather than the test as the block's first line. *)
let first_stmt =
let rec go i = function
| [] -> None
| a :: rest -> if i >= !k && stmt_like a then Some i else go (i + 1) rest
in
go 0 args
in
if is_with then Some !k
else if last_stmt then Some (Option.value first_stmt ~default:!k)
else
(* A statement anywhere among the trailing lists makes them a body. *)
match first_stmt with Some _ -> Some !k | None -> None)
| _ -> None
let let_sugar (f : Form.t) =
@ -638,6 +697,9 @@ and plain n (f : Form.t) : string list =
(* No arguments before the block: [comment:] rather than
[comment():], the author's decision 85. *)
| Form.Sym s, [] when name_ok s && not (List.mem s reserved) -> s ^ ":"
(* A header word glued to its parenthesis is the fallback call,
[if(c):], so it needs no parentheses of its own. *)
| Form.Sym s, _ :: _ when List.mem s reserved -> s ^ "(" ^ commas fixed ^ "):"
| _ -> head_text h ^ "(" ^ commas fixed ^ "):"
in
[ ind n ^ guard opener ] @ block ~seq (n + 2) rest
@ -679,6 +741,24 @@ and wrapped n prefix (f : Form.t) =
List.map (fun l ->
let k = String.length l in
if k > 0 && l.[k - 1] = ' ' then String.sub l 0 (k - 1) else l) lines
(* A vector literal too long for its line, filled to the width, with the
separator [vec_text] chose. *)
| Form.Vec (_ :: _ :: _ as xs) ->
let open_ = prefix ^ "[" in
let col = n + String.length open_ in
let ts = List.map expr xs in
let sep = if List.for_all (fun (_, l) -> l >= 8) ts then "" else "," in
let rec go line acc = function
| [] -> List.rev ((line ^ "]") :: acc)
| (t, _) :: rest ->
let piece = if rest = [] then t else t ^ sep in
if String.length line = col || String.length line + String.length piece + 1 <= width
then go (line ^ piece ^ (if rest = [] then "" else " ")) acc rest
else
let line = String.sub line 0 (String.length line - 1) in
go (ind col ^ piece ^ (if rest = [] then "" else " ")) (line :: acc) rest
in
go (ind n ^ open_) [] ts
| _ -> [ ind n ^ prefix ^ at 0 f ]
(* [prefix = v], or [prefix =] and the value as an indented block when it is
@ -694,6 +774,9 @@ and value_lines n prefix (v : Form.t) =
else if n + String.length inline <= width then [ ind n ^ inline ]
else
match v.v with
| _ when typed_lambda v <> None ->
let head, body = Option.get (typed_lambda v) in
[ ind n ^ prefix ^ " = " ^ head ] @ block (n + 2) body
| Form.List ({ v = Form.Sym "fn"; _ } :: { v = Form.Vec ps; _ } :: (_ :: _ as body))
when List.for_all sym_param ps ->
[ ind n ^ prefix ^ " = fn(" ^ commas ps ^ ")" ] @ block (n + 2) body
@ -701,6 +784,7 @@ and value_lines n prefix (v : Form.t) =
when not (List.mem h sugar_heads || h = "fn" || h = "if") ->
wrapped n (prefix ^ " = ") v
| Form.List (_ :: _) -> [ ind n ^ prefix ^ " =" ] @ block (n + 2) (stmts_of v)
| Form.Vec (_ :: _ :: _) -> wrapped n (prefix ^ " = ") v
| _ -> [ ind n ^ inline ]
and slot n (f : Form.t) = block n (stmts_of f)
@ -730,8 +814,15 @@ and sugar n (f : Form.t) : string list option =
| Form.List ({ v = Form.Sym h; _ } :: _) -> not (List.mem h sugar_heads)
| _ -> true
in
(* An else that is another if with an else chains on the line:
[if a then x else if b then y else z]. *)
let rec chain (x : Form.t) =
match x.v with
| Form.List [ { v = Form.Sym "if"; _ }; _; a; b ] -> simple a && chain b
| _ -> simple x
in
let line = i ^ fst (expr f) in
if simple a && simple b && String.length line <= width && not (!inside f)
if simple a && chain b && String.length line <= width && not (!inside f)
then Some [ line ]
else
Some
@ -771,9 +862,17 @@ and sugar n (f : Form.t) : string list option =
| _ -> None)
| Form.List ({ v = Form.Sym "dotimes"; _ } :: rest) ->
let lbl, rest = label_of rest in
(* The variable is a name, or in a template an unquote, [for ~i in ...]. *)
let var (f : Form.t) =
match f.v with
| Form.Sym v when def_name v && v <> "in" -> Some v
| Form.List [ { v = Form.Sym "unquote"; _ }; _ ] -> Some (fst (expr f))
| _ -> None
in
(match rest with
| { v = Form.Vec ({ v = Form.Sym v; _ } :: bs); _ } :: (_ :: _ as body)
when def_name v && bs <> [] && List.length bs <= 3 && v <> "in" ->
| { v = Form.Vec (vf :: bs); _ } :: (_ :: _ as body)
when var vf <> None && bs <> [] && List.length bs <= 3 ->
let v = Option.get (var vf) in
Some
((i ^ "for " ^ lbl ^ v ^ " in range(" ^ commas bs ^ ")") :: block (n + 2) body)
| _ -> None)
@ -822,8 +921,14 @@ and sugar n (f : Form.t) : string list option =
match c.v with
| Form.List ({ v = Form.Sym r; _ } :: { v = Form.Vec ps; _ } :: (_ :: _ as b))
when def_name r ->
let report, b =
match b with
| { v = Form.Kw "report"; _ } :: ({ v = Form.Str _; _ } as t) :: (_ :: _ as rest) ->
(" " ^ fst (expr t), rest)
| _ -> ("", b)
in
Option.map
(fun pt -> (i ^ "restart " ^ r ^ "(" ^ pt ^ ")") :: block (n + 2) b)
(fun pt -> (i ^ "restart " ^ r ^ "(" ^ pt ^ ")" ^ report) :: block (n + 2) b)
(params_text ps)
| _ -> None
in
@ -869,7 +974,7 @@ and sugar n (f : Form.t) : string list option =
| _ -> true)
&& String.length head + 3 + String.length (at 0 x) <= width
&& not (!inside f) ->
Some [ head ^ " = " ^ at 0 x ]
Some [ head ^ " = " ^ unit_text x ]
| _ -> Some (head :: block (n + 2) body)))
| Form.List ({ v = Form.Sym (("def" | "defonce" | "defconst") as d); _ }
:: { v = Form.Sym name; _ } :: rest)
@ -956,7 +1061,8 @@ and let_lines n prs body =
(* [(let [x (the T v)])] is [let x: T = v]. *)
let bind ((t : Form.t), (v : Form.t)) =
match t.v, v.v with
| Form.Sym x, Form.List [ { v = Form.Sym "the"; _ }; ty_; w ] when def_name x ->
| Form.Sym x, Form.List [ { v = Form.Sym "the"; _ }; ty_; w ]
when def_name x && typed_lambda v = None ->
("let " ^ x ^ ": " ^ ty ty_, w)
| _ -> ("let " ^ guard (at 8 t), v)
in
@ -993,11 +1099,11 @@ let program ?source ?macros:m (fs : Form.t list) : string =
in
let rec go = function
| [] -> []
| [ x ] -> [ top x ]
| x :: rest -> top (if let_sugar x then in_do x else x) :: go rest
| [ x ] -> [ (x, top x) ]
| x :: rest -> (x, top (if let_sugar x then in_do x else x)) :: go rest
in
let text =
try String.concat "\n\n" (go fs) ^ "\n"
try Source_text.join_top (go fs) ^ "\n"
with e -> spelling := (fun _ -> None); inside := (fun _ -> false); raise e
in
spelling := (fun _ -> None);

393
lib/indent_reader.ml
View File

@ -208,9 +208,22 @@ let lex ?(line = 1) ?(col = 1) ~file src : token list =
Reader.advance st;
emit COLON (piece l0.Loc.line (l0.Loc.col + n) 1)
end
else
else begin
(* [0..10]: a range from another language. *)
let text = String.sub src st.Reader.pos (stop - st.Reader.pos) in
(match String.index_opt text '.' with
| Some i when i + 1 < String.length text && text.[i + 1] = '.' ->
failk "dot-range" (piece l0.Loc.line l0.Loc.col (String.length text))
"%s is not a number. A range of numbers is written range(%s, %s), \
as in for i in range(%s, %s)"
text (String.sub text 0 i)
(String.sub text (i + 2) (String.length text - i - 2))
(String.sub text 0 i)
(String.sub text (i + 2) (String.length text - i - 2))
| _ -> ());
let f = Reader.read_number st in
emit (ATOM f.v) f.loc
end
| _ -> name_run ()
in
let rec go () =
@ -373,6 +386,9 @@ let layout ?(snippet = false) ?(base = 1) ?indent (toks : token list) : token ar
type p = { toks : token array; mutable i : int }
(* Set below [params] and [ty], which the expression parser comes before. *)
let typed_fn_expr : (p -> Form.t * int) ref = ref (fun _ -> assert false)
let peek p = p.toks.(p.i)
let peek_at p k = p.toks.(min (p.i + k) (Array.length p.toks - 1))
let advance p =
@ -477,9 +493,13 @@ let expect_eol p ~after =
if (peek p).tok = INDENT then
failk "stray-indent" (peek_at p 1).loc
"this line is indented under %s, which takes no block. A call takes \
an indented block only with a trailing colon, as in \
rl/with-drawing():"
an indented block only with a trailing colon, as in %s:"
after
(* The call itself when [after] is one, [f(a, b)]; else an example. *)
(match String.index_opt after '(', String.index_opt after ' ' with
| Some i, Some j when i < j -> after
| Some _, None when after.[String.length after - 1] = ')' -> after
| _ -> "rl/with-drawing()")
| EOF -> ()
| _ -> stray p ~after
@ -725,6 +745,14 @@ and if_expr p =
(* What a one-line slot takes — a match arm's value, a then or an else, the
thing after defer: a value, or one of the statements that fit on a line,
break, continue, return and an assignment. *)
(* A bare [()] written where a body goes — a one-line slot, a function's
[= ()] — is the empty statement, [(do)], as it is on a line of its own:
"do nothing" is what it says there. [(())] stays a value. *)
and unit_slot p i0 (t0 : token) (e : Form.t) =
if p.i - i0 = 2 && t0.tok = LP && e.v = Form.List [] then
Form.make (Form.List [ sym t0.loc "do" ]) e.loc
else e
and inline_stmt p : Form.t =
let t = peek p in
let glued = let n = peek_at p 1 in n.tok = LP && not n.sp in
@ -744,6 +772,7 @@ and inline_stmt p : Form.t =
mk p t.loc (Form.List [ sym t.loc "return"; v ])
else mk p t.loc (Form.List [ sym t.loc "return" ])
| _ ->
let i0 = p.i in
let e, _ = expr p in
match (peek p).tok with
| NAME "=" ->
@ -754,11 +783,12 @@ and inline_stmt p : Form.t =
let eq = advance p in
let v, _ = expr p in
mk p t.loc (compound eq.loc (List.assoc op assign_ops) e v (span p e.loc))
| _ -> e
| _ -> unit_slot p i0 t e
(* [fn(a, b) = body] is a lambda; [fn(...)] followed by anything else is the
fallback call spelling of [(fn ...)]. *)
and fn_expr p =
if typed_lambda p then !typed_fn_expr p else
let t = advance p in
let lp = advance p in
let args = items p RP lp.loc ~what:"parameters" in
@ -766,13 +796,42 @@ and fn_expr p =
| NAME "=" ->
ignore (advance p);
let ps = lambda_params args in
let i0 = p.i and t0 = peek p in
let body, _ = expr p in
let body = unit_slot p i0 t0 body in
(mk p t.loc
(Form.List
[ sym t.loc "fn"; Form.make (Form.Vec ps) (span_of_list lp.loc args); body ]),
0)
| _ -> (mk p t.loc (Form.List (sym t.loc "fn" :: args)), 9)
(* A lambda with a block written inside a call's brackets, where no block can
open. The fix shown is the typed form, since a lambda bound by [let] has
no call to take its types from; [header] is [fn(a: T) -> R] or the
header as written. *)
and lambda_in_brackets : 'a. Loc.t -> string -> 'a = fun at header ->
failk "lambda-block-in-brackets" at
"a lambda's block cannot go inside brackets, where a line break is only \
a space. Name it first, with its types and the block under it:\n\n\
\ let f = %s\n ...\n\n\
and pass f, or write it on one line: %s = value"
header header
(* Whether the [fn(] at point has a [:] among its parameters or a [->]
after them: a lambda that states its types. *)
and typed_lambda p =
let rec go k depth =
let t = peek_at p k in
match t.tok with
| EOF -> false
| COLON when depth = 1 -> true
| LP | LB | LC -> go (k + 1) (depth + 1)
| RP when depth = 1 -> (peek_at p (k + 1)).tok = NAME "->"
| RP | RB | RC -> go (k + 1) (depth - 1)
| _ -> go (k + 1) depth
in
go 1 0
and span_of_list l args =
match List.rev args with
| [] -> l
@ -812,7 +871,31 @@ and items p closer open_loc ~what =
| EOF -> unclosed p opener open_loc
| _ ->
let n = peek p in
if starts_value n.tok && n.sp && not (negative_literal n.tok) then
let block_lambda =
match e.v with
| Form.List ({ v = Form.Sym "fn"; _ } :: ps) ->
List.for_all (fun (a : Form.t) -> match a.v with Form.Sym _ -> true | _ -> false) ps
&& n.loc.Loc.line > e.loc.Loc.eline
| _ -> false
in
if block_lambda then
let names =
match e.v with
| Form.List (_ :: ps) -> List.map text_of ps
| _ -> []
in
lambda_in_brackets n.loc
("fn(" ^ String.concat ", " (List.map (fun x -> x ^ ": T") names) ^ ") -> R")
else if starts_value n.tok && n.sp && not (negative_literal n.tok)
&& n.loc.Loc.line > e.loc.Loc.eline then
(* Most often the bracket was never closed: the next statement
has been read as one more argument. *)
failk "missing-comma" n.loc
"%s on a new line follows %s with no comma between them. If the \
%c on line %d was meant to close before this line, close it; \
otherwise separate %s with commas"
(show n.tok) (text_of e) opener open_loc.Loc.line what
else if starts_value n.tok && n.sp && not (negative_literal n.tok) then
failk "missing-comma" n.loc
"%s follows %s with no comma between them. Separate %s with \
commas: f(a, b)"
@ -869,6 +952,14 @@ and map_items p open_loc =
| COMMA -> ignore (advance p); go (e :: acc)
| RC -> ignore (advance p); List.rev (e :: acc)
| EOF -> unclosed p '{' open_loc
(* [P{x = 1}] or [P{x: 1}]: another language's field syntax. *)
| (NAME "=" | COLON) as tk
when (match e.v with Form.Sym n -> n <> "" && n.[0] <> '.' | _ -> false) ->
let n = text_of e in
failk "brace-field" (peek p).loc
"a field in braces is written {.%s value}: a dot before the name, \
and no %s between it and the value"
n (if tk = COLON then "colon" else "= sign")
| tk when starts_value tk && (peek p).sp ->
if lvl < 8 then refuse_ws ~brace:true t.loc e;
go (e :: acc)
@ -897,6 +988,51 @@ let rec ty p : Form.t =
as a call does not. *)
type st = { p : p; mutable lets : Form.t list }
(* Whether the code line before [t] is a one-line [if c then a] with no
else: an else under it reads as written for that if, and is not. *)
let one_line_if_above p (t : token) =
let layout = function NEWLINE | INDENT | DEDENT -> true | _ -> false in
let rec prev j =
if j < 0 then None
else
let u = p.toks.(j) in
if u.loc.Loc.line < t.loc.Loc.line && not (layout u.tok) then Some u.loc.Loc.line
else prev (j - 1)
in
match prev (p.i - 1) with
| None -> false
| Some l ->
let rec line j acc =
if j < 0 || p.toks.(j).loc.Loc.line < l then acc
else line (j - 1) (if layout p.toks.(j).tok || p.toks.(j).loc.Loc.line > l then acc
else p.toks.(j).tok :: acc)
in
(match line (p.i - 1) [] with
| NAME "if" :: rest -> List.mem (NAME "then") rest && not (List.mem (NAME "else") rest)
| _ -> false)
(* Whether the code line before [t] is [else if c then a]: that else took
the one-line if as its value, and an else under it has no if left. *)
let else_if_above p (t : token) =
let layout = function NEWLINE | INDENT | DEDENT -> true | _ -> false in
let rec prev j =
if j < 0 then None
else
let u = p.toks.(j) in
if u.loc.Loc.line < t.loc.Loc.line && not (layout u.tok) then Some u.loc.Loc.line
else prev (j - 1)
in
match prev (p.i - 1) with
| None -> false
| Some l ->
let rec first j =
if j <= 0 || p.toks.(j - 1).loc.Loc.line < l then j else first (j - 1)
in
let j = first (p.i - 1) in
let j = if layout p.toks.(j).tok then j + 1 else j in
j + 1 < Array.length p.toks
&& p.toks.(j).tok = NAME "else" && p.toks.(j + 1).tok = NAME "if"
(* A block of several lines is a [do] spanning its lines, from the first
statement to the end of the last — not from the header above it, which is
another form's. *)
@ -986,6 +1122,60 @@ let params p (lp : token) =
in
go []
(* [fn(a: C, b) -> R = body] is [(the (Fn [C dyn] R) (fn [a b] body))]: the
paren [fn] takes its parameters' types from where it is written, and [the]
is the form that says what a value is, as in [let x: T = v]. An untyped
parameter is dyn, as in a definition, and the return type is required. A
block body is added by [lambda_block]. *)
let () = typed_fn_expr := fun p ->
let t = advance p in
let lp = advance p in
let ps = params p lp in
let rec split = function
| n :: ty :: rest -> let ns, ts = split rest in (n :: ns, ty :: ts)
| _ -> ([], [])
in
let names, tys = split ps in
let r =
match (peek p).tok with
| NAME "->" -> ignore (advance p); ty p
| _ ->
failk "lambda-return" (where_ p)
"a lambda that states its parameters' types states its return type \
too: fn(%s) -> R = value"
(String.concat ", "
(List.map2 (fun n (ty : Form.t) ->
if ty.v = Form.Sym "dyn" then text_of n else text_of n ^ ": " ^ text_of ty)
names tys))
in
let fty = mk p lp.loc (Form.List [ sym t.loc "Fn"; Form.make (Form.Vec tys) lp.loc; r ]) in
let vec = Form.make (Form.Vec names) lp.loc in
let wrap body =
mk p t.loc (Form.List [ sym t.loc "the"; fty;
mk p t.loc (Form.List (sym t.loc "fn" :: vec :: body)) ])
in
match (peek p).tok with
| NAME "=" ->
ignore (advance p);
let i0 = p.i and t0 = peek p in
let body, _ = expr p in
(wrap [ unit_slot p i0 t0 body ], 0)
| NEWLINE when (peek_at p 1).tok = INDENT -> (wrap [], 0)
(* Inside brackets a line break is no token: the next line's first token
is what follows. *)
| tk when (peek p).loc.Loc.line > (last p).loc.Loc.eline && tk <> EOF ->
let header =
"fn(" ^ String.concat ", "
(List.map2 (fun n (ty : Form.t) ->
if ty.v = Form.Sym "dyn" then text_of n else text_of n ^ ": " ^ text_of ty)
names tys)
^ ") -> " ^ text_of r
in
lambda_in_brackets (peek p).loc header
| _ ->
failk "lambda-body" (where_ p)
"a lambda's body follows = on its line, or is the block under it"
let rec stmts (s : st) : Form.t list =
let p = s.p in
match (peek p).tok with
@ -1061,6 +1251,15 @@ and then_on_line p =
and lambda_block ?(block_ok = false) (s : st) (e : Form.t) ~after =
let p = s.p in
match e.v with
(* A typed lambda waiting for its block, from [typed_fn_expr]. *)
| Form.List [ ({ v = Form.Sym "the"; _ } as th); fty;
({ v = Form.List [ ({ v = Form.Sym "fn"; _ } as fh); ({ v = Form.Vec _; _ } as vec) ]; _ } as fn_) ]
when (peek p).tok = NEWLINE && (peek_at p 1).tok = INDENT ->
ignore (advance p);
let body = block s ~after in
mk p e.loc (Form.List [ th; fty; { fn_ with v = Form.List (fh :: vec :: body) } ])
| _ ->
if is_lambda_candidate e && (last p).tok = RP && (peek p).tok = NEWLINE
&& (peek_at p 1).tok = INDENT
then begin
@ -1132,6 +1331,18 @@ and stmt (s : st) : Form.t =
let t = peek p in
match t.tok with
| NAME w when header_follow p w -> header s w
| NAME (("else" | "elif") as w) when else_if_above p t ->
failk "orphan-else" t.loc
"the else above took the one-line if after it as its value, so this %s \
has no if to belong to. Write that line as elif:\n\n\
\ if a then x\n elif b then y\n else z"
w
| NAME (("else" | "elif") as w) when one_line_if_above p t ->
failk "orphan-else" t.loc
"this %s is not at the column of the one-line if above it. An else or \
elif that continues a one-line if goes at the if's column:\n\n\
\ if c then a\n else b"
w
| NAME (("else" | "elif") as w) ->
failk "orphan-else" t.loc
"%s is not under an if at this column. It goes at the same column as \
@ -1245,7 +1456,15 @@ and header (s : st) w : Form.t =
ignore (advance p);
block s ~after:"fn"
end
else [ value_line s ~after:"=" ]
else begin
let i0 = p.i and t0 = peek p in
let v = value_line s ~after:"=" in
let bare =
t0.tok = LP && p.toks.(i0 + 1).tok = RP && v.v = Form.List []
&& (match p.toks.(i0 + 2).tok with NEWLINE | EOF | DEDENT -> true | _ -> false)
in
[ (if bare then Form.make (Form.List [ sym t0.loc "do" ]) v.loc else v) ]
end
| NEWLINE ->
ignore (advance p);
if (peek p).tok = INDENT then block s ~after:"fn" else []
@ -1353,72 +1572,98 @@ and header (s : st) w : Form.t =
form [ alias; path ]
| "if" ->
let c, _ = binary p 1 in
(* The elif and else clauses at the if's column, then the whole form.
[oneline] when the if was [if c then a]: its clauses may then be
one-line too, [elif c then x] and [else y], or take blocks. *)
let clauses ~oneline body =
let rec elifs acc =
match (peek p).tok with
| NAME "elif" ->
ignore (advance p);
let c, _ = binary p 1 in
(match (peek p).tok with
| NAME "then" when oneline ->
ignore (advance p);
let x = inline_stmt p in
expect_eol p ~after:(text_of x);
elifs ((c, [ x ]) :: acc)
| NAME "then" ->
failk "elif-then" (peek p).loc
"elif takes its block on the indented lines under it, with no \
then. Put the branch on the next line, indented"
| _ ->
expect_line_end p ~after:("elif " ^ text_of c);
let b = block s ~after:"elif" in
elifs ((c, b) :: acc))
| _ -> List.rev acc
in
let els_ = elifs [] in
let else_ =
match (peek p).tok with
| NAME "else" ->
let et = advance p in
(match (peek p).tok with
| NEWLINE -> ignore (advance p); Some (et.loc, block s ~after:"else")
| NAME "if" when not oneline ->
failk "else-if" (where_ p)
"after an if with a block, another test at this level is \
written elif c, with its own block"
(* [else x] on one line, after a one-line if or a block. *)
| _ ->
let x = inline_stmt p in
expect_eol p ~after:(text_of x);
Some (et.loc, [ x ]))
| _ -> None
in
match els_, else_ with
| [], None -> named "when" (c :: body)
| [], Some (el, e) -> form [ c; blk s l0 body; blk s el e ]
| _ ->
let pairs =
List.concat_map (fun (c, b) -> [ c; blk s c.Form.loc b ]) ((c, body) :: els_)
in
let tail =
match else_ with
| Some (el, e) -> [ Form.make (Form.Kw "else") el; blk s el e ]
| None -> []
in
named "cond" (pairs @ tail)
in
(match (peek p).tok with
| NAME "then" ->
ignore (advance p);
let a = inline_stmt p in
let f =
match (peek p).tok with
| NAME "else" ->
ignore (advance p);
let b = inline_stmt p in
form [ c; a; b ]
| NAME "elif" ->
failk "one-line-elif" (peek p).loc
"a one-line if has then and else and no elif. Chain another if \
after the else — if a then x else if b then y else z — or write \
the if over several lines, where elif goes"
| _ -> named "when" [ c; a ]
in
expect_eol p ~after:(text_of f);
f
(match (peek p).tok with
| NAME "else" ->
ignore (advance p);
let b = inline_stmt p in
let f = form [ c; a; b ] in
expect_eol p ~after:(text_of f);
f
| NAME "elif" ->
failk "one-line-elif" (peek p).loc
"a one-line if has then and else and no elif. Chain another if \
after the else — if a then x else if b then y else z — or write \
the if over several lines, where elif goes"
| _ ->
(* An else or elif indented under the one-line if: it continues
that if only at the if's own column. *)
(match (peek p).tok, (peek_at p 1).tok, (peek_at p 2).tok with
| NEWLINE, INDENT, NAME (("else" | "elif") as w) ->
failk "else-column" (peek_at p 2).loc
"this %s is indented deeper than the one-line if it continues. \
Put it at the if's column:\n\n\
\ if c then a\n %s ..."
w w
| _ -> ());
expect_eol p ~after:(text_of (named "when" [ c; a ]));
(* An else or elif on the next line, at the if's column,
continues it. *)
clauses ~oneline:true [ a ])
| _ ->
expect_line_end p ~after:("if " ^ text_of c);
let body = block s ~after:("if " ^ text_of c) in
let rec elifs acc =
match (peek p).tok with
| NAME "elif" ->
ignore (advance p);
let c, _ = binary p 1 in
(match (peek p).tok with
| NAME "then" ->
failk "elif-then" (peek p).loc
"elif takes its block on the indented lines under it, with no \
then. Put the branch on the next line, indented"
| _ -> ());
expect_line_end p ~after:("elif " ^ text_of c);
let b = block s ~after:"elif" in
elifs ((c, b) :: acc)
| _ -> List.rev acc
in
let els_ = elifs [] in
let else_ =
match (peek p).tok with
| NAME "else" ->
let et = advance p in
(match (peek p).tok with
| NEWLINE -> ignore (advance p)
| NAME "if" ->
failk "else-if" (where_ p)
"else takes its block on the lines under it. For another test \
at this level, write elif c"
| _ -> stray p ~after:"else");
Some (et.loc, block s ~after:"else")
| _ -> None
in
(match els_, else_ with
| [], None -> named "when" (c :: body)
| [], Some (el, e) -> form [ c; blk s l0 body; blk s el e ]
| _ ->
let pairs =
List.concat_map (fun (c, b) -> [ c; blk s c.Form.loc b ]) ((c, body) :: els_)
in
let tail =
match else_ with
| Some (el, e) -> [ Form.make (Form.Kw "else") el; blk s el e ]
| None -> []
in
named "cond" (pairs @ tail)))
clauses ~oneline:false body)
| "while" | "until" ->
let label =
match (peek p).tok, (peek_at p 1).tok with
@ -1435,7 +1680,12 @@ and header (s : st) w : Form.t =
| KW k -> let kt = advance p in [ Form.make (Form.Kw k) kt.loc ]
| _ -> []
in
let v = name_tok p ~what:"the loop variable" in
(* In a macro template the variable may be an unquote, [for ~i in ...]. *)
let v =
match (peek p).tok with
| UNQ -> fst (primary p)
| _ -> name_tok p ~what:"the loop variable"
in
expect_name p "in" ~what:"in, as in for i in range(n)";
let rt = peek p in
expect_name p "range" ~what:"range(n), range(a, b) or range(a, b, step)";
@ -1532,10 +1782,19 @@ and header (s : st) w : Form.t =
let name = name_tok p ~what:"the restart's name" in
let lp = glued_lp p ~what:"the restart's parameters in parentheses" in
let ps = params p lp in
(* [restart name() "text"]: the report the break loop shows,
[:report "text"] in the clause. *)
let report =
match (peek p).tok with
| ATOM (Form.Str _ as v) ->
let st = advance p in
[ Form.make (Form.Kw "report") st.loc; Form.make v st.loc ]
| _ -> []
in
clause_end p ("restart " ^ text_of name ^ "(...)");
let b = block s ~after:"restart" in
let c =
mk p name.loc (Form.List (name :: Form.make (Form.Vec ps) lp.loc :: b))
mk p name.loc (Form.List (name :: Form.make (Form.Vec ps) lp.loc :: (report @ b)))
in
clauses (c :: acc)
| _ -> List.rev acc

233
lib/paren_printer.ml
View File

@ -7,9 +7,27 @@
let width = 80
(* The reader's prefix for a quoting form, as the corpus writes them:
[`(do ~x ~@xs)] rather than [(quasiquote (do (unquote x) ...))]. *)
let sugar (f : Form.t) =
match f.v with
| Form.List [ { v = Form.Sym s; _ }; x ] ->
(match s, x.v with
| "quote", _ -> Some ("'", x)
| "quasiquote", _ -> Some ("`", x)
| "unquote-splicing", _ -> Some ("~@", x)
(* [~@x] would read as a splice. *)
| "unquote", Form.Sym n when String.length n > 0 && n.[0] = '@' -> None
| "unquote", _ -> Some ("~", x)
| _ -> None)
| _ -> None
let rec flat spell (f : Form.t) =
let seq l = String.concat " " (List.map (flat spell) l) in
match f.v with
| _ when sugar f <> None ->
let p, x = Option.get (sugar f) in
p ^ flat spell x
| Form.Int _ | Form.Float _ ->
(match spell f with Some t -> t | None -> Form.to_source f)
| Form.List l -> "(" ^ seq l ^ ")"
@ -17,6 +35,19 @@ let rec flat spell (f : Form.t) =
| Form.Map l -> "{" ^ seq l ^ "}"
| _ -> Form.to_source f
(* Heads whose arguments are statements or clauses rather than values: these
break one argument to a line, never filled. *)
let statement_heads =
[ "let"; "loop"; "set"; "if"; "when"; "unless"; "cond"; "while"; "until";
"dotimes"; "match"; "handler-case"; "handler-bind"; "restart-case";
"return"; "defer"; "do"; "fn"; "with-allocator"; "comment"; "quasiquote";
"break"; "continue" ]
let form_heads =
[ "defn"; "defn-"; "defmacro"; "def"; "defonce"; "defconst"; "defstruct";
"defunion"; "defdata"; "defenum"; "import"; "defalias"; "defmethod";
"defgeneric"; "defmulti"; "defclass" ]
(* How many arguments stay on the head's line when the form is broken. *)
let kept head =
match head with
@ -26,6 +57,24 @@ let kept head =
| "do" | "cond" | "comment" | "restart-case" | "handler-case" -> 0
| _ -> 1
(* Two at a time: [a b] on one line when it fits and no comment sits
inside either, otherwise each laid out on its own lines. *)
let paired ~inside spell col placed items =
let rec go = function
| (a : Form.t) :: b :: more ->
let line = flat spell a ^ " " ^ flat spell b in
(* A comment on a line between the two would land beside the wrong
one, so a pair more than a line apart keeps two lines. *)
(if col + String.length line <= width && not (inside a) && not (inside b)
&& b.loc.Loc.line <= a.loc.Loc.eline + 1
then [ Source_text.tag a.loc.Loc.line
(Source_text.tag b.loc.Loc.line (String.make col ' ' ^ line)) ]
else placed col a @ placed col b)
@ go more
| rest -> List.concat_map (placed col) rest
in
go items
(* [inside l] says whether a comment sits on a line of [f] before its last,
where a flat [f] would leave it nowhere to go: such a form is broken. *)
let rec layout ?(inside = fun _ -> false) spell col (f : Form.t) : string list =
@ -37,7 +86,58 @@ let rec layout ?(inside = fun _ -> false) spell col (f : Form.t) : string list =
in
if col + String.length one <= width && not (inside f) then [ one ]
else
let bracket o c items ~keep =
match sugar f with
| Some (p, x) ->
(match layout spell (col + String.length p) x with
| first :: more ->
let tags, body = Source_text.untag first in
List.fold_left (fun l t -> Source_text.tag t l) (p ^ body) tags :: more
| [] -> [ one ])
| None ->
(* A plain call broken across lines: its arguments fill each line,
aligned under the first, and one that needs lines of its own gets
them. *)
let fill items =
match items with
| hd :: (_ :: _ as args) ->
let lead = "(" ^ flat spell hd ^ " " in
let acol = col + String.length lead in
let pad = String.make acol ' ' in
let vis l = String.length (snd (Source_text.untag l)) in
(* [cur] is the line being filled, [fresh] while it holds no argument;
the first line is built with its column and cut back after. *)
let rec go cur fresh acc = function
| [] -> List.rev (if fresh then acc else cur :: acc)
| (a : Form.t) :: more ->
let t = flat spell a in
let sep = if fresh then "" else " " in
let close = if more = [] then 1 else 0 in
if (not (inside a)) && vis cur + String.length sep + String.length t + close <= width
then go (Source_text.tag a.loc.Loc.line (cur ^ sep ^ t)) false acc more
else if fresh then
match layout spell acol a with
| l1 :: ls ->
let tags, b = Source_text.untag l1 in
let l1 = List.fold_left (fun l t -> Source_text.tag t l) (cur ^ b) tags in
let l1 = Source_text.tag a.loc.Loc.line l1 in
go pad true (List.rev_append (l1 :: ls) acc) more
| [] -> go cur fresh acc more
else go pad true (cur :: acc) (a :: more)
in
let lines = go (String.make col ' ' ^ lead) true [] args in
let lines =
match lines with
| l1 :: rest ->
let tags, b = Source_text.untag l1 in
List.fold_left (fun l t -> Source_text.tag t l) (String.sub b col (String.length b - col)) tags
:: rest
| [] -> []
in
let n = List.length lines in
List.mapi (fun i l -> if i = n - 1 then l ^ ")" else l) lines
| _ -> [ one ]
in
let bracket ?(pairs = false) o c items ~keep =
let placed inner x =
match layout spell inner x with
| first :: more ->
@ -54,8 +154,27 @@ let rec layout ?(inside = fun _ -> false) spell col (f : Form.t) : string list =
col + 1 + String.length
(String.concat " " (List.map (flat spell) (List.filteri (fun i _ -> i < k) items)))
in
let keep = if keep > 1 && head_len keep > width then 1 else keep in
if keep > 0 then
let hang =
(* [(Rule {.label "a"\n .applies f})]: a literal the head
names hangs on the head's line rather than dropping below it. *)
keep > 1
&& (match List.nth_opt items (keep - 1) with
| Some { Form.v = Form.Map _; _ } -> head_len (keep - 1) + 1 < width - 20
| _ -> false)
in
let keep = if keep > 1 && head_len keep > width && not hang then 1 else keep in
if hang && head_len keep > width then
let first = List.filteri (fun i _ -> i < keep - 1) items in
let lit = List.nth items (keep - 1) in
let rest = List.filteri (fun i _ -> i >= keep) items in
let lead = o ^ String.concat " " (List.map (flat spell) first) ^ " " in
(match layout spell (col + String.length lead) lit with
| l1 :: more ->
let tags, b = Source_text.untag l1 in
List.fold_left (fun l t -> Source_text.tag t l) (lead ^ b) tags :: more
| [] -> [ lead ])
@ List.concat_map (placed (col + 2)) rest
else if keep > 0 then
let first = List.filteri (fun i _ -> i < keep) items in
let rest = List.filteri (fun i _ -> i >= keep) items in
let before = List.filteri (fun i _ -> i < keep - 1) first in
@ -80,10 +199,18 @@ let rec layout ?(inside = fun _ -> false) spell col (f : Form.t) : string list =
@ List.concat_map (placed (col + 2)) rest
| _ ->
(o ^ String.concat " " (List.map (flat spell) first))
:: List.concat_map (placed (col + 2)) rest
:: (if pairs then paired ~inside spell (col + 2) placed rest
else List.concat_map (placed (col + 2)) rest)
else
match items with
| [] -> [ o ]
| _ when pairs ->
(match paired ~inside spell (col + 1) placed items with
| first :: more ->
let tags, body = Source_text.untag first in
let body = String.sub body (col + 1) (String.length body - col - 1) in
List.fold_left (fun l t -> Source_text.tag t l) (o ^ body) tags :: more
| [] -> [ o ])
| x :: xs ->
(match layout spell (col + 1) x with
| first :: more ->
@ -96,10 +223,94 @@ let rec layout ?(inside = fun _ -> false) spell col (f : Form.t) : string list =
List.mapi (fun i l -> if i = n - 1 then l ^ c else l) lines
in
match f.v with
| Form.List (({ v = Form.Sym h; _ }) :: _ as items) ->
bracket "(" ")" items ~keep:(1 + min (kept h) (List.length items - 1))
(* A let's binding vector opens on the head's line, a pair to a line,
each value hanging after its name, as the corpus writes them. *)
| Form.List (({ v = Form.Sym (("let" | "loop") as h); _ } as hd)
:: ({ v = Form.Vec bs; _ } as v) :: body)
when bs <> [] && List.length bs mod 2 = 0 && not (inside v) ->
let lead = "(" ^ h ^ " [" in
let vcol = col + String.length lead in
let rec pairs k = function
| (a : Form.t) :: b :: more ->
let an = flat spell a in
let pad = if k = 0 then lead else String.make vcol ' ' in
let lines =
match layout spell (vcol + String.length an + 1) b with
| first :: rest ->
let tags, bt = Source_text.untag first in
List.fold_left (fun l t -> Source_text.tag t l)
(Source_text.tag a.loc.Loc.line (pad ^ an ^ " " ^ bt)) tags
:: rest
| [] -> [ pad ^ an ]
in
lines @ pairs (k + 1) more
| _ -> []
in
let flat_v = lead ^ String.concat " " (List.map (flat spell) bs) in
let bl =
if col + String.length flat_v + 1 <= width then [ flat_v ] else pairs 0 bs
in
let nb = List.length bl in
let bl = List.mapi (fun i l -> if i = nb - 1 then l ^ "]" else l) bl in
let placed x =
match layout spell (col + 2) x with
| first :: more ->
let tags, b = Source_text.untag first in
Source_text.tag x.loc.Loc.line
(List.fold_left (fun l t -> Source_text.tag t l) (String.make (col + 2) ' ' ^ b) tags)
:: more
| [] -> []
in
let lines =
(match bl with
| first :: rest -> Source_text.tag hd.loc.Loc.line first :: rest
| [] -> [])
@ List.concat_map placed body
in
let n = List.length lines in
List.mapi (fun i l -> if i = n - 1 then l ^ ")" else l) lines
(* A match's arms and a cond's clauses go a pair to a line when the pair
fits, the way the corpus writes them. *)
| Form.List (({ v = Form.Sym "match"; _ }) :: _ :: rest as items)
when List.length rest mod 2 = 0 ->
bracket ~pairs:true "(" ")" items ~keep:2
| Form.List (({ v = Form.Sym "cond"; _ }) :: rest as items)
when List.length rest mod 2 = 0 ->
bracket ~pairs:true "(" ")" items ~keep:1
| Form.List (({ v = Form.Sym h; _ }) :: rest as items) ->
(* A loop's label stays with its test: [(while :outer (< i n)]. *)
let label =
match h, rest with
| ("while" | "until" | "dotimes"), { v = Form.Kw _; _ } :: _ :: _ -> 1
| _ -> 0
in
let stmt (a : Form.t) =
match a.v with
| Form.List ({ v = Form.Sym x; _ } :: _) -> List.mem x statement_heads
| _ -> false
in
let n = List.length rest in
if List.mem h statement_heads || List.mem h form_heads || List.exists stmt rest
|| n < 2 || h.[0] = '.'
then
(* A body: the arguments before its first list stay on the head's
line, [(repeat i 2\n (set ...) ...)]. *)
let lead =
if List.mem h statement_heads || List.mem h form_heads then 0
else
let rec go k = function
| { Form.v = Form.List _; _ } :: _ | [] -> k
| _ :: more -> go (k + 1) more
in
go 0 rest
in
bracket "(" ")" items
~keep:(1 + label + max (min lead (n - 1)) (min (kept h) (n - label)))
else fill items
| Form.List items -> bracket "(" ")" items ~keep:0
| Form.Vec items -> bracket "[" "]" items ~keep:0
| Form.Map items when List.length items mod 2 = 0 ->
bracket ~pairs:true "{" "}" items ~keep:0
| Form.Map items -> bracket "{" "}" items ~keep:0
| _ -> [ one ]
@ -116,13 +327,13 @@ let program ?source (fs : Form.t list) : string =
cs
in
let text =
String.concat "\n\n"
Source_text.join_top
(List.map
(fun (f : Form.t) ->
String.concat "\n"
(match layout ~inside spell 0 f with
| first :: rest -> Source_text.tag f.loc.Loc.line first :: rest
| [] -> []))
(f, String.concat "\n"
(match layout ~inside spell 0 f with
| first :: rest -> Source_text.tag f.loc.Loc.line first :: rest
| [] -> [])))
fs)
^ "\n"
in

15
lib/parse.ml
View File

@ -1984,7 +1984,22 @@ let rec decl (f : Form.t) : Ast.decl =
rule against a suggestion that does not compile. The shapes alone
then, which is what there is to say about a form that named too
little. *)
let atom (x : Form.t) = match x.v with Form.List _ | Form.Vec _ | Form.Map _ -> false | _ -> true in
(match args with
(* In a .fln file, the two definitions in its spelling. *)
| [ n; v ] when Source.indented_at f.loc && atom n ->
let rest =
Form.to_string n ^ " = " ^ (if atom v then Form.to_string v else "...") in
Loc.failk "parse/defvar-renamed" f.loc
"there is no defvar. Did you mean once? once %s initialises once and \
keeps its value; def %s re-initialises on every re-run" rest rest
| [ n; t; v ] when Source.indented_at f.loc && atom n && atom t ->
let rest =
Form.to_string n ^ ": " ^ Form.to_string t ^ " = "
^ (if atom v then Form.to_string v else "...") in
Loc.failk "parse/defvar-renamed" f.loc
"there is no defvar. Did you mean once? once %s initialises once and \
keeps its value; def %s re-initialises on every re-run" rest rest
| [] | [ _ ] ->
Loc.failk "parse/defvar-renamed" f.loc
"there is no defvar. Did you mean defonce? \

20
lib/source_text.ml
View File

@ -206,3 +206,23 @@ let weave ?(starts = []) (cs : comment list) (text : string) : string =
else s
in
trim s
(** Top-level forms' printed texts joined with a blank line between them,
except that one-line globals written on adjacent lines stay adjacent. *)
let join_top (items : (Form.t * string) list) : string =
let global (f : Form.t) =
match f.v with
| Form.List ({ v = Form.Sym ("def" | "defonce" | "defconst"); _ } :: _) -> true
| _ -> false
in
let rec go = function
| [] -> []
| [ (_, t) ] -> [ t ]
| ((a : Form.t), ta) :: (((b : Form.t), tb) :: _ as rest) ->
let tight =
global a && global b && (not (String.contains ta '\n'))
&& (not (String.contains tb '\n')) && b.loc.Loc.line = a.loc.Loc.eline + 1
in
ta :: (if tight then "\n" else "\n\n") :: go rest
in
String.concat "" (go items)

32
lib/types.ml
View File

@ -229,6 +229,10 @@ let rec equal a b =
and then only in how a message spells it. *)
let display : (string, string) Hashtbl.t = Hashtbl.create 16
(* The same copies as the template and its arguments, for [spell] to write
in either syntax. *)
let display_app : (string, string * t list) Hashtbl.t = Hashtbl.create 16
(* A struct's name as a printed value's head: its own name, or for a generic
struct's copy the template and its arguments, [Pair i32] — so a value
prints as [(Pair i32 {.a 1 .b 2})], the way its type is written. *)
@ -238,7 +242,33 @@ let struct_head n =
String.sub d 1 (String.length d - 2)
| _ -> n
let rec to_string = function
(* A type as the code it is written in spells it: [(Fn [i32] bool)] in a
.flan file, [Fn(i32) -> bool] in a .fln one. Messages use it; a spelling
that is a key, a symbol or a runtime string stays [to_string]'s. *)
let rec spell ~indented t =
if not indented then to_string t
else
let sp = spell ~indented in
let call h args = h ^ "(" ^ String.concat ", " args ^ ")" in
match t with
| Named n ->
(match Hashtbl.find_opt display_app n with
| Some (g, args) -> call g (List.map sp args)
| None -> to_string t)
| Slice (Mut, t) -> "[" ^ sp t ^ "]"
| Slice (Const, t) -> "[const " ^ sp t ^ "]"
| Array (n, t) -> Printf.sprintf "[%Ld %s]" n (sp t)
| LArray (n, t) -> Printf.sprintf "[$%s %s]" n (sp t)
| Map (k, v) -> call "Map" [ sp k; sp v ]
| Ptr (Mut, t) -> call "Ptr" [ sp t ]
| Ptr (Const, t) -> call "Ptr" [ "const " ^ sp t ]
| Vec t -> call "Vec" [ sp t ]
| Option t -> call "Option" [ sp t ]
| Fn (ps, r) -> call "Fn" (List.map sp ps) ^ " -> " ^ sp r
| CFn (ps, r) -> call "CFn" (List.map sp ps) ^ " -> " ^ sp r
| _ -> to_string t
and to_string = function
| Int k -> ikind_name k
| Float k -> fkind_name k
| Bool -> "bool"

17
runtime/flan_rt.c
View File

@ -2430,14 +2430,25 @@ void flan_alloc_region_only(flan_allocator *a, const uint8_t *loc,
if (a->caps & FLAN_CAN_FREE) flan_region_only_fail(loc, loclen);
}
/* Whether a "file:line:col" location names an indented (.fln) file, so a
* suggestion is written in the syntax the reader's code is in. */
static int rt_loc_is_fln(const uint8_t *loc, int64_t loclen) {
for (int64_t i = 0; i + 5 <= loclen; i++)
if (memcmp(loc + i, ".fln:", 5) == 0) return 1;
return 0;
}
_Noreturn void flan_region_only_fail(const uint8_t *loc, int64_t loclen) {
rt_flush_out();
fprintf(stderr,
"%.*s: this container's elements own storage, and this allocator "
"frees one block at a time, so freeing it here would leak what the "
"elements hold. Build it against a region allocator: "
"(with-allocator context/temp ...) or an (arena-new n)\n",
(int)loclen, (const char *)loc);
"elements hold. Build it against a region allocator: %s\n",
(int)loclen, (const char *)loc,
rt_loc_is_fln(loc, loclen)
? "with-allocator(context/temp): and the code under it, or an "
"arena-new(n)"
: "(with-allocator context/temp ...) or an (arena-new n)");
rt_die();
}

69
spec-syntax.md
View File

@ -92,9 +92,10 @@ reads as `(rl/with-drawing (rl/clear-background rl/black) (game-draw))`.
Replacing macros with built-in constructs is **not** part of this work.
**Diagnostics may print paren syntax** during the test drive. `Form.to_string`,
`Types.to_string`, the usage strings in `parse.ml` and `check.ml`, and
`Render` all print parens today (inventory in section 5). Fixing that waits on
the author deciding to switch.
the usage strings in `parse.ml` and `check.ml`, and `Render` print parens
today (inventory in section 5). Types in `check.ml`'s messages do not: they
are spelled by `Types.spell`, in the syntax of the code the message is about
(section 3, item 9).
## 2. Proposed (confirm before building the piece it governs)
@ -205,12 +206,16 @@ Each item: the proposal, then the reason in one line.
- **`if`/`elif`/`else`.** `else` and `elif` sit at the `if`'s column. No `elif`
reads as `if` (with else) or `when` (without); with `elif` it reads as `cond`.
One-line form: `if c then a else b`, for use in a `let`. **Built** (a block
of one line is that line; of more, `(do …)`).
of one line is that line; of more, `(do …)`). An `else` or `elif` on the
line after a one-line `if c then a`, at its column, continues it (section
3, item 6); each such clause is one-line (`elif c then x`, `else y`) or
takes a block.
- **`while c`, `until c`**, optional label first: `while :outer c`. **Built.**
- **`for i in range(n)`**, `range(a, b)`, `range(a, b, step)` read as
`dotimes`. `range` here is syntax, not a function. `..` is avoided because
`a..b` would lex as one name. **Built** (a label goes first here too:
`for :outer i in range(n)`).
`for :outer i in range(n)`; in a macro template the variable may be an
unquote, `for ~i in range(~n)`).
- **`return v`, `break`, `break :outer`, `continue`, `defer expr`** (or `defer`
plus a block). **Built**; `defer` plus a block reads `(defer a b …)`.
`break`, `continue`, `return v` and `x = v`/`x += v` also fit the one-line
@ -256,13 +261,17 @@ Each item: the proposal, then the reason in one line.
v * 2
```
`handler-bind` takes the same `on` clauses; the reader moves them in front of
the body, where the form wants them. **Built.**
the body, where the form wants them. **Built.** A restart's report text goes
on its header, `restart retry() "Try the load again"`, and reads
`(retry [] :report "Try the load again" …)`.
- **Unit:** `()` as a statement reads `(do)`; in a type it is `()`. **Built**;
inside an expression `()` stays `()`, and the printer writes a lone `()`
statement as `(())`.
statement as `(())`. A bare `()` in a one-line body slot (`fn f() -> () = ()`,
`_ -> ()`, `fn() = ()`, `then ()`) is a statement too, and reads `(do)`.
- **Lambda:** `fn(i, j) = i * 10 + j`, or `fn(i, j)` plus a block. **Built**;
its parameters are bare names, as `(fn [i j] …)` wants, with no `dyn`.
`fn(…)` followed by anything else is the fallback call.
`fn(…)` followed by anything else is the fallback call. A lambda may state
its types, `fn(a: C, b) -> bool = …` or plus a block (section 3, item 7).
### Definitions
@ -277,10 +286,14 @@ Each item: the proposal, then the reason in one line.
- `struct Cell` with a `name: Type` line per field. `data Shape` with a line per
case: `Circle(r: f32)`, `Empty`. `enum K` with `lo = -1`, `mid`. `union U` like
`struct`. **Built** (an untyped field is `dyn`; `Empty()` is `(Empty [])`).
A member is `:mid` or `K.mid`, in a value and in a match arm, in both
syntaxes (section 3, item 8).
- `import rl "vendor:raylib"`. **Built.**
- **Every other form uses the fallback** (next item) until someone asks for
sugar: `defclass`, `defgeneric`, `defmulti`, `defmethod`, `declare`,
`declare-c`, `defalias`, `defmacro`, `loop`/`recur`, `array-fill`. **Built.**
The class forms keep the fallback for good (2026-09-26):
`defmethod(area, point, [p]):` reads well enough.
### The fallback
@ -344,6 +357,46 @@ after it, so `~name(x)` is `((unquote name) x)`, and `~(f(x))` unquotes a call.
omitted. `_` in type position means "fill this in" in Rust and OCaml too,
and no type can be named `_`.
Settled 2026-09-26, after writing programs by hand (`test/syntax/handwritten/`):
6. **A one-line if continues on the next line.** `if c then a` followed by
`else b` (or `elif c2 then d`, or either with a block) at the if's column
is one if. An `else` left of that column, or indented deeper, is refused.
After an if with a block, `else x` on one line is accepted too.
**Binding:** an `else` or `elif` on a line of its own belongs to the if
that starts at its column. An if inside a one-line slot (after `then`,
after `else`, in an arm) ends with its line and takes no later clause, so
```
if a then x
else if b then y
else z
```
is refused at its last line: the first `else` took `if b then y` as its
value, and the chain is `if a then x else if b then y else z` on one line,
or `elif b then y` on the second.
7. **Typed lambdas.** `fn(a: C, b) -> R = body`, or plus a block, reads
`(the (Fn [C dyn] R) (fn [a b] body))`: the paren `fn` has no typed
parameters, and `the` is how a value states its type, as in
`let x: T = v`. An untyped parameter is `dyn`; the return type is
required. Where a `CFn` of the same signature is wanted, the literal is
that `CFn`; at a generic's `CFn($t) -> $t` parameter the literal is a
`CFn` at its own types, which bind `$t` as any argument's would. The
printer writes that form back as the typed lambda. A block lambda cannot
sit inside a call's brackets; the refusal shows the typed `let` form to
bind it with.
8. **`Dir.north` is the enum member `:north`**, in a value and in a match
pattern, in both syntaxes. `:north` stays. A local named `Dir` shadows the
enum as a local shadows any global: `Dir.north` is then its field.
9. **Types in messages follow the code's syntax.** `Types.spell ~indented` is
the one printer, `Fn(A) -> R`, `Option(i32)`, `Small(4, i32)` for a .fln
location and `(Fn [A] R)` for a .flan one; `Types.to_string` stays the
spelling for keys, symbols and runtime strings. Hard-coded code in a hint
is written per message.
10. **`flan convert` keeps adjacent one-line globals adjacent**, in both
directions.
## 4. Build order
Each step lands on its own, with `dune test --root .` green.

93
test/syntax/handwritten/csv.fln Normal file
View File

@ -0,0 +1,93 @@
; A CSV reader written as a state machine over bytes: quoted fields, doubled
; quotes inside them, and a count of rows kept in globals.
enum State
start
bare
quoted
quote-in-quoted
once rows-seen: i32
def fields-seen: i32 = 0
const separator = \,
; Frame the body's output with a title line and a closing rule.
defmacro(with-section, [title & body]):
quote
println("--", ~title, "--")
~@body
println("-----")
fn flush(field: Ptr(Vec(u8)), row: Ptr(Vec(string))) -> ()
push(deref(row), string(slice(deref(field))))
fields-seen += 1
deref(field) = vec-new(u8)
fn parse-line(line: [const u8]) -> Vec(string)
let row = vec-new(string)
let field = vec-new(u8)
let state = State.start
for i in range(length(line))
let c = line[i]
match state
:start ->
if c == \"
state = :quoted
elif c == separator
flush(addr(field), addr(row))
else
push(field, c)
state = :bare
State.bare ->
if c == separator
flush(addr(field), addr(row))
state = :start
else
push(field, c)
:quoted ->
if c == \" then state = :quote-in-quoted else push(field, c)
:quote-in-quoted ->
if c == \"
push(field, c)
state = :quoted
else
flush(addr(field), addr(row))
state = :start
flush(addr(field), addr(row))
rows-seen += 1
row
fn widest(rows: [Vec(string)]) -> i32
let best = 0
for r in range(length(rows))
for f in range(length(rows[r]))
best = max(best, i32(length(rows[r][f])))
best
fn pad(s: string, width: i32) -> ()
print(s)
let n = width - i32(length(s))
until n <= 0
print(" ")
n -= 1
fn main() -> i32
let text = "name,qty,note\npear,3,\"ripe, soft\"\nfig,12,\"said \"\"hi\"\"\"\n,0,none"
let frame = arena-new(65536)
defer arena-destroy(frame)
with-allocator(frame):
let lines = split(bytes-view(text), \newline)
let rows = vec-new(Vec(string))
for i in range(length(lines))
push(rows, parse-line(lines[i]))
let w = widest(slice(rows)) + 1
with-section("table"):
for r in range(length(rows))
for f in range(length(rows[r]))
let last = f + 1 == length(rows[r])
pad(rows[r][f], if last then 0 else w)
println("")
println("rows", rows-seen, "fields", fields-seen)
comment:
parse-line(bytes-view("a,\"b\",c"))
0

7
test/syntax/handwritten/csv.out Normal file
View File

@ -0,0 +1,7 @@
-- table --
name qty note
pear 3 ripe, soft
fig 12 said "hi"
0 none
-----
rows 4 fields 12

81
test/syntax/handwritten/inventory.fln Normal file
View File

@ -0,0 +1,81 @@
; An inventory report: items from the stock package, reorder rules held as
; function values, and the report's text built in an arena that is reset
; between runs.
import stock "stock"
struct Rule
label: string
applies: CFn(stock/Item) -> bool
def report-width: i32 = 28
once runs: i32
const reorder-below = 5
; Run the body n times, counting passes in the name given.
defmacro(repeat, [i n & body]):
quote
for ~i in range(~n)
~@body
; Say what went wrong when a check does not hold.
defmacro(expect, [test message]):
quote
if not ~test
println("expected:", ~message)
fn gcd(a: i32, b: i32) -> i32
loop([x a y b]):
if y == 0 then x else recur(y, x % y)
fn line(it: stock/Item) -> ()
let price = stock/money(stock/value(it))
defer
free(price)
let dots = report-width - i32(length(it.name)) - i32(length(price))
print(it.name)
for i in range(max(dots, 1))
print(".")
println(string(slice(price)))
fn low?(it: stock/Item) -> bool = it.count < reorder-below
fn count-if(items: [stock/Item], keep?: Fn(stock/Item) -> bool) -> i32
let n = 0
for i in range(length(items))
if keep?(items[i])
++(n)
n
fn main() -> i32
let items = [stock/item("bolts", 12, 400), stock/item("nuts", 5, 3),
stock/item("gears", 1250, 7), stock/item("belts", 899, 0)]
let rules = [Rule{.label "reorder", .applies low?},
Rule{.label "valuable", .applies fn(it) = stock/value(it) > 5000}]
let frame = arena-new(4096)
repeat(pass, 2):
runs += 1
with-allocator(frame):
println("report", runs)
for i in range(length(items))
line(items[i])
for r in range(length(rules))
let names = vec-new(string)
for i in range(length(items))
if rules[r].applies(items[i])
push(names, items[i].name)
println(rules[r].label, slice(names))
free-all(frame)
arena-destroy(frame)
let total = 0
for i in range(0, length(items), 2)
total += items[i].count
println("even rows hold", total, "and share a factor of",
gcd(items[0].count, items[2].count + 1))
println("sign bits", stock/sign-bit(-2.5), stock/sign-bit(2.5),
"masked", bit-and(-total, 0xFF))
let big = 1000
println("worth over", big, count-if(slice(items), fn(it) = stock/value(it) > big))
expect(total == 407, "407 on even rows")
expect(runs == 2, "two runs")
0

17
test/syntax/handwritten/inventory.out Normal file
View File

@ -0,0 +1,17 @@
report 1
bolts..................48.00
nuts....................0.15
gears..................87.50
belts...................0.00
reorder ["nuts" "belts"]
valuable ["gears"]
report 2
bolts..................48.00
nuts....................0.15
gears..................87.50
belts...................0.00
reorder ["nuts" "belts"]
valuable ["gears"]
even rows hold 407 and share a factor of 8
sign bits 1 0 masked 105
worth over 1000 2

75
test/syntax/handwritten/ledger.fln Normal file
View File

@ -0,0 +1,75 @@
; A ledger that applies transfers between accounts. A transfer that would
; overdraw signals, and the caller picks a restart: skip it, cap it at what
; the account holds, or allow an overdraft up to a limit it supplies.
defstruct(Overdraft, :parent, Error, [account i32 short i64])
struct Audit
account: i32
amount: i64
once balances: [4 i64]
once audits: i32
once log: i64
; Every transfer leaves a digit in the log when it is done with, however it
; ended: 1 applied, 2 left through a restart.
fn note(d: i64) -> ()
log = log * 10 + d
fn withdraw(account: i32, amount: i64) -> i64
let have = balances[account]
if amount > have
let short = amount - have
restart-case
error(Overdraft{.account account, .short short})
restart skip()
return 0
restart cap()
return withdraw(account, have)
restart allow(limit: i64)
if short > limit
return 0
if amount >= 100
signal(Audit{.account account, .amount amount})
balances[account] -= amount
amount
fn transfer(from: i32, to: i32, amount: i64) -> i64
let applied: i64 = 0
defer note(if applied == amount then 1 else 2)
applied = withdraw(from, amount)
balances[to] += applied
applied
fn run(policy) -> ()
balances = [100 50 0 10]
log = 0
handler-bind
transfer(0, 2, 30)
transfer(1, 2, 80)
transfer(3, 0, 25)
transfer(0, 1, 100)
on Overdraft(o)
match policy
:skip -> invoke-restart('skip)
:cap -> invoke-restart('cap)
_ -> invoke-restart('allow, i64(20))
on Audit(a)
audits += 1
println(policy, slice(balances), "log", log)
fn main() -> i32
run(:skip)
run(:cap)
run(:allow)
println("audited", audits)
let caught =
handler-case
balances = [0 0 0 0]
withdraw(2, 5)
on Overdraft(o)
println("unhandled overdraft on", o.account, "short by", o.short)
-1
println("caught", caught)
0

6
test/syntax/handwritten/ledger.out Normal file
View File

@ -0,0 +1,6 @@
:skip [70 50 30 10] log 1222
:cap [0 80 80 0] log 1222
:allow [-5 150 30 -15] log 1211
audited 1
unhandled overdraft on 2 short by 5
caught -1

83
test/syntax/handwritten/lisp.fln Normal file
View File

@ -0,0 +1,83 @@
; A small interpreter over dyn values: a program is nested vectors whose
; first element is a keyword naming the operation, variables are keywords,
; and environments are dyn maps chained through a :parent key.
defclass(lambda, [param body env])
defgeneric(describe, [v], dyn)
defmethod(describe, lambda, [f]):
"a function of one argument"
defmulti(kind, [v], dyn, type-of(v))
defmethod(kind, :int, [v]):
"number"
defmethod(kind, :vec, [v]):
"form"
defmethod(kind, :else, [v]):
"value"
once steps = 0
fn lookup(env, name) -> dyn
if env == nil
println("unbound", name)
return 0
if has-key?(env, name) then get(env, name) else lookup(get(env, :parent), name)
fn extend(env, name, value) -> dyn
{:parent env name value}
fn eval(e, env) -> dyn
steps += 1
match type-of(e)
:keyword -> lookup(env, e)
:vec -> eval-form(e, env)
_ -> e
fn eval-form(e, env) -> dyn
let op = e[0]
match op
:+ -> eval(e[1], env) + eval(e[2], env)
:- -> eval(e[1], env) - eval(e[2], env)
:* -> eval(e[1], env) * eval(e[2], env)
:< -> eval(e[1], env) < eval(e[2], env)
:if ->
if eval(e[1], env) then eval(e[2], env) else eval(e[3], env)
:let ->
let v = eval(e[2], env)
let inner = extend(env, e[1], v)
; A function sees its own name, so it can call itself.
if type-of(v) == :lambda
put(v, :env, inner)
eval(e[3], inner)
:fn -> lambda(e[1], e[2], env)
:do ->
let last = nil
for i in range(1, length(e))
last = eval(e[i], env)
last
_ ->
let f = eval(op, env)
let arg = eval(e[1], env)
eval(get(f, :body), extend(get(f, :env), get(f, :param), arg))
fn run(program) -> ()
steps = 0
let result = eval(program, {:parent nil})
println(kind(program), "=>", result, "in", steps, "steps")
fn main() -> i32
run(42)
run([:+ 1 [:* 2 3]])
run([:let :x 5 [:if [:< :x 3] :small [:* :x :x]]])
let fact = [:let :fact [:fn :n [:if [:< :n 2] 1 [:* :n [:fact [:- :n 1]]]]] [:fact 6]]
run(fact)
run([:let :k 10 [:let :add-k [:fn :y [:+ :y :k]] [:do [:add-k 1] [:add-k 32]]]])
let f = eval([:fn :x :x], {:parent nil})
println(describe(f), "/", kind(f), "/", type-of(f))
run([:let :greeting "hello" :greeting])
0

7
test/syntax/handwritten/lisp.out Normal file
View File

@ -0,0 +1,7 @@
number => 42 in 1 steps
form => 7 in 5 steps
form => 25 in 9 steps
form => 720 in 65 steps
form => 42 in 17 steps
a function of one argument / value / :lambda
form => hello in 3 steps

95
test/syntax/handwritten/ring.fln Normal file
View File

@ -0,0 +1,95 @@
; A fixed-size ring buffer of samples, generic over the element type, with
; the statistics a sensor log wants: a median, the distinct values, and a
; checksum over the raw bytes.
struct Ring
items: [$n $t]
head: i32
count: i32
struct Reading
sensor: u8
value: i32
fn push-ring!(r: Ptr(Ring($n, $t)), x: $t) -> ()
r.items[r.head] = x
r.head = (r.head + 1) % n
if r.count < n
r.count += 1
; The oldest sample first.
fn nth-oldest(r: Ptr(Ring($n, $t)), i: i32) -> $t
let start = if r.count < n then 0 else r.head
r.items[(start + i) % n]
fn copy-out(r: Ptr(Ring($n, $t))) -> Vec($t)
let v = vec-new(t)
for i in range(r.count)
push(v, nth-oldest(r, i))
v
fn median(xs: [$t]) -> Option($t) where ordered?($t), equal?($t)
if length(xs) == 0
return None
sort(xs)
Some(xs[length(xs) / 2])
fn distinct(xs: [const $t]) -> Vec($t) where equal?($t), hashable?($t)
let seen = map-new(t, bool)
defer free(seen)
let out = vec-new(t)
for i in range(length(xs))
if not has-key?(seen, xs[i])
put(seen, xs[i], true)
push(out, xs[i])
out
; FNV-1a over the bytes of any array of plain values.
fn checksum(p: Ptr(u8), size: i64) -> u32
let bytes = slice-from(p, size)
let h: u32 = 2166136261
for i in range(length(bytes))
h = bit-xor(h, u32(bytes[i]))
h = h * 16777619
h
; Apply f n times, for any element type.
fn repeat-apply(f: CFn($t) -> $t, x: $t, n: i32) -> $t
let v = x
for i in range(n)
v = f(v)
v
fn halve-all(x: $t) -> $t where numeric?($t) = repeat-apply(fn(a: $t) -> $t = a / 2, x, 3)
fn main() -> i32
let r: Ring(5, i32) = zeroed()
let samples = [7 3 9 3 12 5 3 8]
for :fill i in range(length(samples))
if samples[i] > 10
continue :fill
push-ring!(addr(r), samples[i])
let kept = copy-out(addr(r))
defer free(kept)
println("kept", slice(kept))
match median(slice(kept))
Some(m) -> println("median", m)
None -> println("no samples")
let empty: [0 i32] = zeroed()
println("median of none", or-else(median(slice(empty)), -1))
let d = distinct(slice(samples))
println("distinct", slice(d))
free(d)
let big = filter(slice(samples), fn(x) = x >= 7)
println("seven and up", slice(big), "sum", reduce(slice(big), 0, fn(a, b) = a + b))
free(big)
let rs = [Reading{.sensor 2, .value 40} Reading{.sensor 1, .value 15}
Reading{.sensor 3, .value 22}]
sort-by(slice(rs), fn(a, b) = a.value < b.value)
for i in range(length(rs))
println("sensor", rs[i].sensor, rs[i].value)
let raw: [4 u32] = [1 2 3 4]
let p = Ptr(u8)(addr(raw[0]))
println("checksum", checksum(p, 16))
println("doubled", repeat-apply(fn(a: i32) -> i32 = a * 2, 1, 10), "halved", halve-all(800.0))
0

10
test/syntax/handwritten/ring.out Normal file
View File

@ -0,0 +1,10 @@
kept [9 3 5 3 8]
median 5
median of none -1
distinct [7 3 9 12 5 8]
seven and up [7 9 12 8] sum 36
sensor 1 15
sensor 3 22
sensor 2 40
checksum 1041505217
doubled 1024 halved 100

115
test/syntax/handwritten/rpn.fln Normal file
View File

@ -0,0 +1,115 @@
; A reverse-Polish calculator: a tokenizer, a data type for tokens, and an
; evaluator that signals on a bad program and lets the caller decide.
data Token
Num(n: i64)
Op(c: u8)
Word(w: [const u8])
End
struct Underflow
op: u8
struct Unknown
word: [const u8]
const max-depth = 16
struct Machine
stack: [max-depth i64]
depth: i32
; Read the token that starts at pos; the position after it comes back too.
fn next-token(src: [const u8], pos: Ptr(i32)) -> Token
let n = length(src)
while deref(pos) < n and space?(src[deref(pos)])
++(deref(pos))
if deref(pos) >= n
return Token.End
let start = deref(pos)
until deref(pos) >= n or space?(src[deref(pos)])
++(deref(pos))
let text = slice(src, start, deref(pos))
let c = text[0]
if digit?(c) or (c == \- and length(text) > 1)
match parse-i64(text)
Some(v) -> Token.Num{.n v}
None -> Token.Word{.w text}
elif length(text) == 1 and some?(index-of(bytes-view("+-*/%"), c))
Token.Op{.c c}
else
Token.Word{.w text}
fn push!(m: Ptr(Machine), v: i64) -> ()
m.stack[m.depth] = v
m.depth += 1
fn pop!(m: Ptr(Machine), op: u8) -> i64
if m.depth == 0
error(Underflow{.op op})
m.depth -= 1
m.stack[m.depth]
fn apply(op: u8, a: i64, b: i64) -> i64
match op
\+ -> a + b
\- -> a - b
\* -> a * b
\/ -> if b == 0 then 0 else a / b
_ -> a % b
fn run(src: string) -> i64
let m: Machine = zeroed()
let text = bytes-view(src)
let pos = 0
while :tokens true
match next-token(text, addr(pos))
End -> break :tokens
Num(n) -> push!(addr(m), n)
Op(c) ->
let b = pop!(addr(m), c)
let a = pop!(addr(m), c)
push!(addr(m), apply(c, a, b))
Word(w) ->
if bytes=?(w, bytes-view("dup"))
let v = pop!(addr(m), \d)
push!(addr(m), v)
push!(addr(m), v)
elif bytes=?(w, bytes-view("drop"))
pop!(addr(m), \d)
continue
else
error(Unknown{.word w})
pop!(addr(m), \=)
fn show(src: string) -> ()
let r =
handler-case
run(src)
on Underflow(u)
println(src, "=> stack empty at", string-of-byte(u.op))
return
on Unknown(u)
println(src, "=> unknown word", string(u.word))
return
println(src, "=>", r)
fn string-of-byte(b: u8) -> string
match b
\+ -> "+"
\- -> "-"
\* -> "*"
\/ -> "/"
\d -> "dup"
_ -> "?"
fn main() -> i32
show("1 2 +")
show("3 4 * 5 -")
show("-7 2 /")
show("10 dup *")
show("1 2 drop 9 %")
show("1 +")
show("2 3 swap")
show("8 0 /")
0

8
test/syntax/handwritten/rpn.out Normal file
View File

@ -0,0 +1,8 @@
1 2 + => 3
3 4 * 5 - => 7
-7 2 / => -3
10 dup * => 100
1 2 drop 9 % => 1
1 + => stack empty at +
2 3 swap => unknown word swap
8 0 / => 0

37
test/syntax/handwritten/stock/stock.fln Normal file
View File

@ -0,0 +1,37 @@
; Stock items and prices kept in cents, imported by ../inventory.fln.
struct Item
name: string
cents: i64
count: i32
; A price read as a float without a division, by its bits.
union Bits
f: f32
u: u32
const cents-per-unit = 100
fn- whole(cents: i64) -> i64 = cents / cents-per-unit
fn- part(cents: i64) -> i64 = cents % cents-per-unit
fn item(name: string, cents: i64, count: i32) -> Item
Item{.name name, .cents cents, .count count}
fn value(it: Item) -> i64 = it.cents * i64(it.count)
; 1234 as "12.34", into a buffer the caller frees.
fn money(cents: i64) -> Vec(u8)
let out = vec-new(u8)
append-i64(addr(out), whole(cents))
append(addr(out), bytes-view("."))
if part(cents) < 10
append(addr(out), bytes-view("0"))
append-i64(addr(out), part(cents))
out
fn sign-bit(x: f32) -> u32
let b: Bits = zeroed()
b.f = x
b.u >> 31

87
test/syntax/handwritten/traffic.fln Normal file
View File

@ -0,0 +1,87 @@
; A traffic light at a crossing, driven by a clock and a pedestrian button.
; Each state carries how long it has left; a fault drops the light to
; flashing, and a supervisor decides whether to reset it.
data Light
Green(left: i32)
Yellow(left: i32, walk: bool)
Red(left: i32, walk: bool)
Flashing()
struct Fault
tick: i32
const green-time = 4
const yellow-time = 1
const red-time = 3
fn next(l: Light, pressed: bool) -> Light
match l
Green(left) ->
if left > 1 and not pressed then Light.Green{.left left - 1}
else Light.Yellow{.left yellow-time, .walk pressed}
Yellow(left, walk) ->
if left > 1
Light.Yellow{.left left - 1, .walk walk}
else
Light.Red{.left red-time, .walk walk}
Red(left, walk) ->
if left > 1 then Light.Red{.left left - 1, .walk walk} else Light.Green{.left green-time}
Flashing -> Light.Flashing{}
fn show(l: Light) -> string
match l
Green(_) -> "G"
Yellow(_, _) -> "Y"
Red(_, walk) -> if walk then "W" else "R"
Flashing -> "*"
; Runs the light for ticks steps; a fault at fault-at is signalled, and
; whoever handles it may reset the light to red.
fn run(ticks: i32, presses: [const i32], fault-at: i32) -> ()
let l = Light.Red{.left 1, .walk false}
let p = 0
let t = 0
until :clock t >= ticks
let pressed = p < length(presses)
and presses[p] == t
if pressed
++(p)
if t == fault-at
l = restart-case
error(Fault{.tick t})
l
restart reset() "Put the light back to red and carry on"
Light.Red{.left red-time, .walk false}
restart flash()
Light.Flashing{}
match l
Flashing ->
print(show(l))
break :clock
_ -> print(show(l))
l = next(l, pressed)
t += 1
println("")
fn main() -> i32
let none = [-1]
let two = [1 9]
run(12, slice(none), -1)
run(12, slice(two), -1)
handler-bind
run(12, slice(none), 5)
on Fault(f)
invoke-restart('reset)
handler-bind
run(12, slice(none), 5)
on Fault(f)
invoke-restart('flash)
println:
handler-case
run(12, slice(none), 2)
"no fault"
on Fault(f)
println("")
"fault at tick"
0

6
test/syntax/handwritten/traffic.out Normal file
View File

@ -0,0 +1,6 @@
RGGGGYRRRGGG
RGYWWWGGGGYW
RGGGGRRRGGGG
RGGGG*
RG
fault at tick

84
test/syntax/handwritten/words.fln Normal file
View File

@ -0,0 +1,84 @@
; Word statistics over a paragraph: a frequency table, the longest words,
; and a grade for how varied the vocabulary is.
enum Grade
poor = 1
fair = 2
rich = 3
struct Count
word: [const u8]
n: i32
fn letter?(c: u8) -> bool
(c >= \a and c <= \z)
or (c >= \A and c <= \Z)
or c == \'
; The words of text, lowercased, in order.
fn words(text: [const u8]) -> Vec([const u8])
let out = vec-new([const u8])
let lower = to-lower(text)
let i = 0
let n = length(lower)
while :scan i < n
until i >= n or letter?(lower[i])
i += 1
if i >= n
break :scan
let start = i
while i < n and letter?(lower[i])
i += 1
push(out, slice(lower, start, i))
out
fn tally(ws: [[const u8]]) -> Vec(Count)
let seen = map-new(string, i32)
defer free(seen)
let counts = vec-new(Count)
for i in range(length(ws))
match get(seen, string(ws[i]))
Some(k) -> counts[k].n += 1
None ->
put(seen, string(ws[i]), i32(length(counts)))
push(counts, Count{.word ws[i], .n 1})
counts
fn grade(distinct: i32, total: i32) -> Grade
let ratio = distinct * 10 / max(total, 1)
if ratio >= 7 then :rich else if ratio >= 4 then :fair else :poor
fn describe(g: Grade) -> string
match i32(g)
1 -> "repetitive"
2 -> "ordinary"
_ -> "varied"
fn main() -> i32
let text = "The cat saw the dog. The dog didn't see the cat, but the bird saw both!"
let ws = words(bytes-view(text))
let counts = tally(slice(ws))
let by-count = fn(a: Count, b: Count) -> bool
if a.n != b.n
return a.n > b.n
bytes<?(a.word, b.word)
sort-by(slice(counts), by-count)
for i in range(3)
let {.word .n} = counts[i]
println(string(word), n)
let top: [3 i32] = [counts[0].n counts[1].n counts[2].n]
let [most & others] = top
println("most frequent seen", most, "times, then", others)
let total = i32(length(ws))
let distinct = i32(length(counts))
let g = grade(distinct, total)
println(distinct, "of", total, "distinct:", describe(g))
let longest = reduce(slice(ws), slice(ws[0], 0, 0), fn(a, b) =
if length(b) > length(a) then b else a)
println("longest", string(longest))
let short = 0 < length(longest) < 5
match short
true -> println("short words only")
false -> println("some long words")
println("three distinct counts?", !=(counts[0].n, counts[1].n, counts[2].n))
0

8
test/syntax/handwritten/words.out Normal file
View File

@ -0,0 +1,8 @@
the 5
cat 2
dog 2
most frequent seen 5 times, then [2 2]
9 of 16 distinct: ordinary
longest didn't
some long words
three distinct counts? false

234
test/test_syntax.ml
View File

@ -586,6 +586,46 @@ let () =
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";
(* Mistakes carried over from other languages, answered in this one. *)
refuses "a block without the colon names the call" "with-allocator(a, b)\n g()"
"indent/stray-indent" "as in with-allocator(a, b):";
refuses "field with =" "p = P{x = 1}" "indent/brace-field" "{.x value}";
refuses "field with a colon" "p = P{x: 1}" "indent/brace-field" "no colon";
refuses "a dotted range" "for i in 0..10\n g(i)" "indent/dot-range" "range(0, 10)";
refuses "a block lambda inside a call" "sort-by(xs, fn(a, b)\n a < b)"
"indent/lambda-block-in-brackets" "let f = fn(a: T, b: T) -> R";
refuses "a typed block lambda inside a call" "sort-by(xs, fn(a: C, b: C) -> bool\n a < b)"
"indent/lambda-block-in-brackets" "let f = fn(a: C, b: C) -> bool";
refuses "an else after else-if on one line" "if a then x\nelse if b then y\nelse z"
"indent/orphan-else" "Write that line as elif";
refuses "else deeper than a one-line if" "if a then b\n else c"
"indent/else-column" "Put it at the if's column";
reads "a one-line else after an if with a block" "if a\n b()\n c()\nelse d()"
"(if a (do (b) (c)) (d))";
refuses "an unclosed call swallows the next line" "fn f() -> ()\n push(v, 1\n g()"
"indent/missing-comma" "If the ( on line 2 was meant to close";
reads "else on the line after a one-line if" "if a then b\nelse c" "(if a b c)";
reads "elif and else continuing a one-line if"
"if a then b\nelif c then d\nelif e\n f()\n g()\nelse\n h()"
"(cond a b c d e (do (f) (g)) :else (h))";
refuses "else left of a one-line if" "while x\n if a then b\nelse c"
"indent/orphan-else" "goes at the if's column";
reads "a typed lambda" "f = fn(a: C, b) -> bool = a.n < b"
"(set f (the (Fn [C dyn] bool) (fn [a b] (< (.n a) b))))";
reads "a typed lambda with a block" "let f = fn(x: i32) -> i32\n let y = x + 1\n y\ng(f)"
"(let [f (the (Fn [i32] i32) (fn [x] (let [y (+ x 1)] y)))] (g f))";
refuses "a typed lambda states its return type" "f = fn(a: C) = a"
"indent/lambda-return" "fn(a: C) -> R = value";
reads "a restart's report on its header"
"restart-case\n go()\nrestart retry(n: i32) \"Try again\"\n n"
"(restart-case (go) (retry [n i32] :report \"Try again\" n))";
reads "a bare () in a body slot does nothing"
"fn f() -> () = ()\nfn g(x) -> ()\n match x\n 1 -> h()\n _ -> ()\n k = fn() = ()"
"(defn f [] () (do))\n(defn g [x dyn] () (match x 1 (h) _ (do)) (set k (fn [] (do))))";
reads "a parenthesised () stays a value" "x = (())" "(set x ())";
reads "a template's for takes an unquoted variable"
"quote\n for ~i in range(~n)\n g(~i)"
"(quasiquote (dotimes [(unquote i) (unquote n)] (g (unquote i))))";
(* And back: the printer writes the idioms. *)
let prints name src want =
match Reader.read_all ~file:"<p>" src with
@ -722,7 +762,52 @@ let () =
"(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)"
"; head\n\n(defn main [] i32\n ; why\n (g) ; note\n 0)";
(* Written the way the corpus writes them. *)
back "quasiquote as its reader sugar"
"defmacro(m, [x & body]):\n quote\n g(~x)\n ~@body"
"`(do (g ~x) ~@body)";
back "arms a pair to a line"
("fn f(s) -> dyn\n match s\n 1 -> \"one, a long string to break the line\"\n"
^ " _ -> \"another long string to push it over\"")
" (match s\n 1 \"one, a long string to break the line\"\n _ \"another";
back "a let's bindings hang after their names"
("fn f() -> dyn\n let a = compute-something-long(1, 2, 3, 4, 5)\n"
^ " let b = compute-something-long(5, 6, 7, 8, 9)\n a")
"(let [a (compute-something-long 1 2 3 4 5)\n b (compute-something-long 5 6 7 8 9)]";
back "a label stays with its test"
"fn f() -> ()\n while :outer some-long-condition?(1, 2, 3) and another-long-one?(4, 5, 6)\n g()"
"(while :outer";
back "a call's arguments fill the line"
"fn f() -> ()\n println(\"alpha\", \"beta\", \"gamma\", \"delta\", \"epsilon\", \"zeta\", \"eta\", \"theta\", \"iota\", g(1))"
"\"eta\" \"theta\" \"iota\"\n (g 1))";
back "a comment between a cond's test and its branch stays there"
"fn f(x) -> dyn\n if x\n ; why\n 1\n elif y\n 2\n else\n 3"
"; why";
prints "an if with no else keeps its test in the parentheses"
"(defn f [] () (if (> a 1) (let [k 2] (g k))))" " if(a > 1):\n let k = 2";
prints "and inside or keeps its parentheses"
"(defn f [a bool b bool c bool] bool (or (and a b) c))" "= (a and b) or c";
prints "a typed lambda prints as one"
"(defn f [] () (let [g (the (Fn [C] bool) (fn [c] (> (.n c) 3)))] (h g)))"
"let g = fn(c: C) -> bool = c.n > 3";
prints "a restart's report goes on its header"
"(defn f [] i32 (restart-case (go) (retry [] :report \"Try again\" 7)))"
"restart retry() \"Try again\"\n 7";
prints "adjacent one-line globals stay adjacent"
"(defonce a i32)\n(def b i32 2)\n\n(defconst c 3)\n"
"once a: i32\ndef b: i32 = 2\n\nconst c = 3";
back "adjacent one-line globals stay adjacent in parens"
"once a: i32\ndef b: i32 = 2\n\nconst c = 3\n"
"(defonce a i32)\n(def b i32 2)\n\n(defconst c 3)";
prints "a field of a field chains" "(defn f [] () (g (.count (.x w))))" "g(w.x.count)";
prints "an else-if chain on one line"
"(defn f [r] dyn (if (> r 7) :rich (if (> r 4) :fair :poor)))"
"if r > 7 then :rich else if r > 4 then :fair else :poor";
prints "a long vector wraps" ("(defn f [] () (let [v [" ^ String.concat " " (List.init 30 string_of_int) ^ "]] (g v)))")
" let v = [0 1 2 3";
prints "a template's for keeps its unquotes"
"(defmacro m [i n & body] `(dotimes [~i ~n] ~@body))" "for ~i in range(~n)"
(* ── Spans, for pause marks and error overlays ──────────────────────── *)
@ -918,11 +1003,74 @@ let () =
(* 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" ]
[ "() does not box into dyn" ];
(* Checker messages about a .fln file are in its spelling. *)
refused "enum-none.fln" "fn main() -> i32\n let n = None\n 0\n" [ "the(Option(i32), None)" ];
checks "enum-annotated.fln"
"enum Dir\n north\n south\n\nfn main() -> i32\n let d: Dir = :north\n i32(d)\n";
refused "annotation-dyn.fln" "fn main() -> i32\n let d = the(dyn, 3)\n let x: i32 = d\n x\n"
[ "a type annotation checks a value as i32"; "write i32(d)" ];
refused "narrowing.fln" "fn f() -> i64 = 1\n\nfn main() -> i32\n let x: i32 = 0\n x = f()\n x\n"
[ "it has to be written: i32(x)" ];
refused "unknown-type.fln" "fn f(p: Keyword) -> i32 = 0\n\nfn main() -> i32 = 0\n"
[ "unknown type Keyword" ];
refused "untyped-lambda.fln" "fn main() -> i32\n let f = fn(a)\n a\n 0\n"
[ "let f: Fn(T, ...) -> R = fn(...)" ];
refused "plusplus.fln" "fn main() -> i32\n let x = 1\n x++\n x\n"
[ "write ++(x) or x += 1" ];
refused "plusplus-global.fln" "once g = 0\n\nfn main() -> i32\n g--\n 0\n"
[ "write --(g) or g -= 1" ];
(* Types in a message are in the syntax of the code it is about. *)
refused "types.fln" "fn g(x: Option(i32)) -> i32 = 0\n\nfn main() -> i32\n let v = vec-new(i32)\n g(v)\n"
[ "expected Option(i32), found Vec(i32)" ];
refused "types.flan" "(defn g [x (Option i32)] i32 0)\n(defn main [] i32 (let [v (vec-new i32)] (g v)))\n"
[ "expected (Option i32), found (Vec i32)" ];
refused "fn-field.fln" "struct R\n f: Fn(i32) -> bool\n\nfn main() -> i32 = 0\n"
[ "cannot be Fn(i32) -> bool"; "store a CFn(i32) -> bool" ];
refused "generic-struct.fln"
"struct Small\n items: [$n $t]\n\nfn main() -> i32\n let s: Small(4, i32) = zeroed()\n let q: i32 = s\n 0\n"
[ "found Small(4, i32)" ];
(* Dir.north is the member :north. *)
checks "enum-qualified.fln"
("enum Dir\n north\n south\n\nfn name(d: Dir) -> i32\n match d\n Dir.north -> 1\n :south -> 2\n\n"
^ "fn main() -> i32\n let d = Dir.north\n let e: Dir = Dir.south\n name(d) + name(e)\n");
refused "enum-qualified-miss.fln"
"enum Dir\n north\n\nfn f(d: Dir) -> i32\n match d\n Dir.west -> 1\n _ -> 0\n\nfn main() -> i32 = 0\n"
[ "Dir has no member west — it has Dir.north" ];
(* A bad key type is one error, not three. *)
refused "map-key.fln" "fn main() -> i32\n let m = map-new([const u8], i32)\n 0\n"
[ "[const u8] is not a map key" ];
(match Front.checked (Filename.concat scratch "map-key.fln") with
| exception Loc.Errors (_ :: _ :: _ as ds) ->
fail "map-key.fln: %d errors, wanted one" (List.length ds)
| exception _ -> ()
| _ -> ());
(* The fix the lambda-in-brackets refusal shows compiles, with its
placeholders filled in. *)
(match read "sort-by(xs, fn(a, b)\n a.n < b.n)" with
| _ -> fail "lambda in brackets: read"
| exception Loc.Error d ->
let header =
let m = d.Loc.dmsg in
let i = String.index m '=' + 2 in
String.sub m i (String.index_from m i '\n' - i)
in
let header =
String.concat "C" (String.split_on_char 'T' header)
|> String.split_on_char 'R' |> String.concat "bool"
in
checks "lambda-fix.fln"
("struct C\n n: i32\n\nfn main() -> i32\n let xs = [C{.n 2} C{.n 1}]\n"
^ " let f = " ^ header ^ "\n a.n < b.n\n sort-by(slice(xs), f)\n xs[0].n\n"));
refused "cfn-captures.fln"
"fn app(f: CFn(Option(i32)) -> i32) -> i32 = f(None)\n\nfn main() -> i32\n let k = 1\n app(fn(o) = k)\n"
[ "so it is a Fn(Option(i32)) -> i32 and not a CFn(Option(i32)) -> i32" ];
refused "defvar.fln" "defvar(x, 1)\n\nfn main() -> i32 = 0\n"
[ "once x = 1 initialises once"; "def x = 1 re-initialises" ]
(* ── Both directions of an import, on both backends ────────────────── *)
let run_both path want =
let run_both ?(backends = [ false; true ]) path want =
List.iter
(fun x86 ->
let exe =
@ -943,7 +1091,7 @@ let run_both path want =
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 ]
backends
(* A program and its conversion print the same: the flat lets, the renames
and the macro bodies they rest on keep what each name means. *)
@ -976,6 +1124,66 @@ let run_converted path =
| ((c, a), (d, b)) ->
fail "%s printed %S (exit %d), and converted %S (exit %d)" path a c b d
(* ── Programs written by hand in the indented syntax ─────────────────── *)
(* Each [syntax/handwritten/x.fln] prints [x.out] on both backends; its
conversion to parens reads back to the same forms, with every comment,
and converts back to indented text that reads to them again; and the
converted .flan builds and prints the same. *)
let handwritten () =
let dir = "syntax/handwritten" in
Sys.readdir dir |> Array.to_list
|> List.filter (fun f -> Filename.check_suffix f ".fln")
|> List.sort compare
|> List.map (Filename.concat dir)
let converts_back path =
let src = In_channel.with_open_bin path In_channel.input_all in
let forms = Source.read_file path in
let norm_all fs =
macros := Body_macros.table ~file:path fs;
List.map norm fs
in
let want = norm_all forms in
let paren = Paren_printer.program ~source:src forms in
match Reader.read_all ~file:path paren with
| exception e -> fail "%s to parens: %s" path (diag_text e)
| again ->
if not (same_forms want (norm_all again)) then
fail "%s to parens: %s" path (describe_diff want (norm_all again))
else if comment_texts paren <> comment_texts src then
fail "%s to parens: the comments did not all come through" path
else begin
let fln = Indent_printer.program ~source:paren ~macros:!macros again in
(match Indent_reader.read_all ~file:path fln with
| exception e -> fail "%s back to indented: %s" path (diag_text e)
| back ->
if not (same_forms want (norm_all back)) then
fail "%s back to indented: %s" path (describe_diff want (norm_all back)));
(* Beside the original, so its imports resolve the same way. *)
let flan = Filename.concat (Filename.dirname path)
(Printf.sprintf ".conv-%d-%s.flan" (Unix.getpid ())
(Filename.remove_extension (Filename.basename path))) in
Out_channel.with_open_bin flan (fun oc -> output_string oc paren);
Fun.protect ~finally:(fun () -> try Sys.remove flan with Sys_error _ -> ())
(fun () -> run_both ~backends:[ false ] flan
(In_channel.with_open_bin (Filename.remove_extension path ^ ".out")
In_channel.input_all))
end
let () =
List.iter
(fun p -> try converts_back p with e -> fail "%s: %s" p (diag_text e))
(List.filter (fun _ -> Test_support.have "clang") (handwritten ()));
if List.length (handwritten ()) < 8 then
fail "only %d hand-written programs" (List.length (handwritten ()));
if Test_support.have "clang" then
List.iter
(fun p ->
run_both p (In_channel.with_open_bin (Filename.remove_extension p ^ ".out")
In_channel.input_all))
(handwritten ())
let () =
if Test_support.have "clang" then begin
List.iter run_converted
@ -989,4 +1197,22 @@ let () =
end
else print_endline "syntax: no clang, the import programs are not built"
let () =
(* A local named like an enum shadows it. *)
List.iter
(fun (name, text) ->
let f = Filename.concat scratch name in
write f text;
match Test_support.linked f with
| exception e -> fail "%s: %s" name (diag_text e)
| _ -> run_both f "5 true\n")
(if Test_support.have "clang" then
[ ("shadow-enum.fln",
"enum Dir\n north\n south\n\nstruct P\n north: i32\n\nfn main() -> i32\n"
^ " let a = Dir.north\n let Dir = P{.north 5}\n println(Dir.north, a == :north)\n 0\n");
("shadow-enum.flan",
"(defenum Dir [north south])\n(defstruct P [north i32])\n(defn main [] i32 "
^ "(let [a Dir.north Dir (P {.north 5})] (println Dir.north (= a :north)) 0))\n") ]
else [])
let () = Test_support.report ~label:"syntax" ()