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

A .fln file is read by an indented reader that yields the paren reader's forms, every program entry point picks the reader by extension, and flan convert prints either syntax as the other

Browse Source
This commit is contained in:
Joseph Ferano 2026-09-25 15:04:32 +07:00
parent 22d2a4cfb2
commit d7016f91c7
17 changed files with 2646 additions and 50 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

35
bin/main.ml
View File

@ -324,14 +324,32 @@ let () =
List.iter
(fun path ->
with_errors path (fun () ->
Flan.Reader.read_file path
Flan.Source.read_file path
|> List.iter (fun f -> print_endline (Flan.Form.to_string f))))
files
(* The other syntax, on stdout: a .flan file printed indented, a .fln file
printed with parentheses. Comments are not forms, so they do not carry
over. *)
| [ _; "convert"; path ] ->
with_errors path (fun () ->
let forms = Flan.Source.read_file path in
if Flan.Source.is_indented path then
print_string
(String.concat "\n\n" (List.map (fun f -> Flan.Form.pretty f) forms)
^ "\n")
else
match Flan.Indent_printer.program forms with
| text -> print_string text
| exception Flan.Indent_printer.Unprintable (f, why) ->
Flan.Loc.failk "convert/unprintable" f.Flan.Form.loc
"%s has no spelling in the indented syntax, so this file cannot \
be converted. Rename it in the .flan file and convert again"
why)
| _ :: "parse" :: files when files <> [] ->
List.iter
(fun path ->
with_errors path (fun () ->
Flan.Reader.read_file path
Flan.Source.read_file path
|> Flan.Parse.program_all
|> List.iter (fun d -> print_endline (summarise d))))
files
@ -390,13 +408,13 @@ let () =
the header's records. *)
| _ :: "import-c" :: header :: rest ->
with_errors header (fun () ->
let pkg = List.filter (fun a -> Filename.check_suffix a ".flan") rest in
let pkg = List.filter Flan.Source.is_source rest in
let flags =
List.filter (fun a -> not (Filename.check_suffix a ".flan")) rest
List.filter (fun a -> not (Flan.Source.is_source a)) rest
in
let ds =
List.concat_map
(fun f -> Flan.Parse.program (Flan.Reader.read_file f)) pkg
(fun f -> Flan.Parse.program (Flan.Source.read_file f)) pkg
in
let structs =
List.filter_map
@ -554,10 +572,10 @@ let () =
let out = Filename.concat dir "generated.flan" in
let ds =
List.concat_map
(fun f -> Flan.Parse.program (Flan.Reader.read_file f))
(fun f -> Flan.Parse.program (Flan.Source.read_file f))
(List.filter
(fun f -> not (String.equal f out))
(Flan.Load.entries dir ".flan"))
(Flan.Load.source_entries dir))
in
let config = Flan.Load.binding_config dir in
match Flan.Load.header_specs ~loc dir with
@ -944,5 +962,6 @@ let () =
[--debug] [--sanitize] [--x86] [--warn-memory] [--target=wasm32-wasi|web|js]\n\
\ flan run <file.flan> [build flags...] [--] [program args...]\n\
\ flan reload <program.flan> <forms.flan> [-o out.so] [--x86]\n\
\ flan dev <program.flan> [-s socket] [--x86]";
\ flan dev <program.flan> [-s socket] [--x86]\n\
\ flan convert <file.flan|file.fln>";
exit 2

2
lib/front.ml
View File

@ -13,7 +13,7 @@
let load ?(all = false) path : Load.t =
Load.program ~file:path
~parse:(if all then Parse.program_all else Parse.program)
(Reader.read_file path)
(Source.read_file path)
let check ?(all = false) (l : Load.t) : Tast.program =
(if all then Check.program_all else Check.program) l.Load.decls

597
lib/indent_printer.ml Normal file
View File

@ -0,0 +1,597 @@
(** [Form.t] to indented text: the inverse of [Indent_reader], and what
[flan convert] writes.
The one rule that keeps the round trip exact: a piece of sugar is printed
only when the form has exactly the shape that sugar reads back to, and
everything else goes through the fallback, [head(arg, ...)], or
[head(arg, ...):] with the trailing arguments as an indented block. The
fallback reads any form, so a form this printer cannot sweeten still
prints; what it cannot print at all is a name with no spelling in the
indented syntax, and that raises [Unprintable].
Comments are not in a [Form.t], so a converted file has none. *)
module R = Indent_reader
exception Unprintable of Form.t * string
let width = 80
let unprintable (f : Form.t) why = raise (Unprintable (f, why))
(* Words a statement may start with that the reader takes as a header. A
statement whose text would lead with one is wrapped in parentheses, which
the reader takes as grouping and so as the plain name. *)
let reserved =
[ "fn"; "fn-"; "def"; "once"; "const"; "struct"; "union"; "data"; "enum";
"import"; "if"; "elif"; "else"; "while"; "until"; "match"; "let"; "for";
"return"; "break"; "continue"; "defer"; "handler-case"; "handler-bind";
"restart-case"; "quote"; "on"; "restart" ]
(* A symbol the reader gives back as itself when it is written bare. *)
let name_ok s =
let n = String.length s in
n > 0
&& (not (String.exists Reader.is_delimiter s))
&& (not (String.contains s ':'))
&& s.[0] <> '\'' && s.[0] <> '\\'
&& (not (Reader.is_digit s.[0]))
&& (not ((s.[0] = '-' || s.[0] = '+') && n > 1 && Reader.is_digit s.[1]))
&& (not (n > 1 && s.[0] = '-' && R.is_neg_char s.[1]))
&& R.split_fields s = [ s ]
&& (not (R.is_op_word s))
&& not (n >= 2 && s.[0] = '#' && s.[1] = '_')
let kw_ok k = k <> "" && not (String.exists Reader.is_delimiter k)
(* A name a definition's header can take: the reader reads a leading dot
there as a field access, so [.init-once.counter] keeps the fallback. *)
let def_name s = name_ok s && s.[0] <> '.'
let paren s = "(" ^ s ^ ")"
let is_sym s (f : Form.t) = match f.v with Form.Sym x -> x = s | _ -> false
(* ── Expressions ───────────────────────────────────────────────────── *)
(* Text and syntactic level, the same scale [Indent_reader] reads: 10 an atom
or bracket, 9 a postfix chain, 8 a unary minus, 1-7 binary, 3 [not], 0 a
one-line [if] or a lambda. *)
let rec expr (f : Form.t) : string * int =
match f.v with
| Form.Sym s -> sym f s
| Form.Kw k ->
if kw_ok k then (":" ^ k, 10) else unprintable f "a keyword with no spelling"
| Form.Int i -> (Int64.to_string i, if Int64.compare i 0L < 0 then 8 else 10)
| Form.UInt (_, s) -> (s, 10)
| Form.Float x ->
let s = Form.float_repr x in
if not (Reader.is_digit s.[0] || (s.[0] = '-' && String.length s > 1
&& Reader.is_digit s.[1]))
then unprintable f "a float with no literal";
(s, if s.[0] = '-' then 8 else 10)
| Form.Str s -> ("\"" ^ Form.escape s ^ "\"", 10)
| Form.Byte b -> (Form.byte_repr b, 10)
| Form.Vec xs -> ("[" ^ vec_text xs ^ "]", 10)
| Form.Map xs -> ("{" ^ map_text xs ^ "}", 10)
| Form.List [] -> ("()", 10)
| Form.List (h :: args) -> list f h args
and sym f s =
if s = "==" then unprintable f "the name == (it reads as =)"
else if R.is_op_word s || s = "if" then (paren s, 10)
else if name_ok s then (s, 10)
else unprintable f (Printf.sprintf "the name %s" s)
and at lvl f =
let t, l = expr f in
if l < lvl then paren t else t
and comma_items xs =
let rec go = function
| [] -> []
| ({ Form.v = Form.Sym "const"; _ }) :: y :: rest ->
("const " ^ at 0 y) :: go rest
| x :: rest -> at 0 x :: go rest
in
go xs
and commas xs = String.concat ", " (comma_items xs)
(* Whitespace between single terms, as [[1 2 3]] and [[4 f32]] read; commas
as soon as one element has an operator in it. *)
and vec_text xs =
let ts = List.map expr xs in
if List.for_all (fun (_, l) -> l >= 8) ts then String.concat " " (List.map fst ts)
else String.concat ", " (List.map (fun (t, _) -> t) ts)
and map_text xs =
let ts = List.map expr xs in
if List.for_all (fun (_, l) -> l >= 8) ts then String.concat " " (List.map fst ts)
else
let rec pairs = function
| (k, kl) :: (v, _) :: rest ->
((if kl < 8 then paren k else k) ^ " " ^ v) :: pairs rest
| [ (k, _) ] -> [ k ]
| [] -> []
in
String.concat ", " (pairs ts)
and head_text (h : Form.t) =
match h.v with
| Form.Sym "==" -> unprintable h "the name =="
| Form.Sym s when R.is_op_word s -> s
| Form.Sym s -> fst (sym h s)
| _ -> at 9 h
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)
| Form.Sym "unquote", [ x ] -> ("~" ^ at 10 x, 10)
| Form.Sym "unquote-splicing", [ x ] -> ("~@" ^ at 10 x, 10)
| Form.Sym s, _ :: _ :: _
when (R.is_binop s || s = "=") && s <> "==" && not (s = "!=" && List.length args > 2) ->
let op = if s = "=" then "==" else s in
let lvl = Option.get (R.binop_level op) in
let first = List.hd args and rest = List.tl args in
let ft, fl = expr first in
let same = match first.v with
| Form.List (h' :: _ :: _ :: _) -> is_sym s h' || lvl = 4
| _ -> 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)
| Form.Sym "-", [ x ] ->
let t, l = expr x in
if l >= 9 && t <> "" && R.is_neg_char t.[0] then ("-" ^ t, 8)
else ("-(" ^ at 0 x ^ ")", 9)
| Form.Sym "not", [ x ] -> ("not " ^ at 3 x, 3)
| Form.Sym "at", t :: (_ :: _ as idx) -> (at 9 t ^ "[" ^ commas idx ^ "]", 9)
| Form.Sym s, [ t ]
when String.length s > 1 && s.[0] = '.' && name_ok s
&& not (String.contains (String.sub s 1 (String.length s - 1)) '.') ->
let tt, tl = expr t in
let glued =
tl >= 9
&& (match t.v with
| Form.Byte _ -> false
| Form.Sym x -> name_ok x && not (String.contains x '.') && not (R.capitalised x)
| _ ->
let c = tt.[String.length tt - 1] in
c = ')' || c = ']' || c = '}' || c = '"')
in
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 "fn", [ { v = Form.Vec ps; _ }; body ] when List.for_all sym_param ps ->
("fn(" ^ commas ps ^ ") = " ^ at 0 body, 0)
| Form.Sym "if", [ c; a; b ] ->
("if " ^ at 1 c ^ " then " ^ at 1 a ^ " else " ^ at 0 b, 0)
| _ -> call ()
and sym_param (p : Form.t) =
match p.v with Form.Sym s -> name_ok s | _ -> false
(* A type after [:] or [->]: the function-type arrow at the top, a postfix
term below it. *)
let rec ty (f : Form.t) =
match f.v with
| Form.List [ { v = Form.Sym (("Fn" | "CFn") as h); _ }; { v = Form.Vec ps; _ }; r ] ->
h ^ "(" ^ commas ps ^ ") -> " ^ ty r
| _ -> at 9 f
(* A [defn]'s parameter type the reader could not mistake for a name: a
primitive, a capitalised or [$] name, or a bracket. [[x y]] with a
lowercase [y] keeps the fallback, because what it means depends on
whether [y] names a type. *)
let type_shaped (f : Form.t) =
match f.v with
| Form.Sym t ->
List.mem t Types.primitive_names || (t <> "" && t.[0] = '$') || R.capitalised t
| Form.List [] | Form.List ({ v = Form.Sym _; _ } :: _) | Form.Vec _ -> true
| _ -> false
let rec pairs = function
| a :: b :: rest -> Option.map (fun r -> (a, b) :: r) (pairs rest)
| [] -> Some []
| [ _ ] -> None
(* [(a: i32, b)] from [[a i32 b dyn]], when every name is a plain name. *)
let params_text ?(shaped = false) (ps : Form.t list) =
match pairs ps with
| None -> None
| Some prs ->
if List.for_all
(fun ((n : Form.t), t) ->
(match n.v with Form.Sym x -> def_name x | _ -> false)
&& ((not shaped) || is_sym "dyn" t || type_shaped t))
prs
then
Some
(String.concat ", "
(List.map
(fun ((n : Form.t), t) ->
let n = fst (expr n) in
if is_sym "dyn" t then n else n ^ ": " ^ ty t)
prs))
else None
(* ── Statements ────────────────────────────────────────────────────── *)
let ind n = String.make n ' '
let lead_word text =
let n = String.length text in
let rec go i = if i < n && not (Reader.is_delimiter text.[i]) then go (i + 1) else i in
let i = go 0 in
(String.sub text 0 i, i = n || text.[i] = ' ')
(* A statement whose text leads with a reserved word, parenthesised. *)
let guard text =
let w, spaced = lead_word text in
if spaced && List.mem w reserved then paren text else text
let stmts_of (f : Form.t) =
match f.v with
| Form.List ({ v = Form.Sym "do"; _ } :: (_ :: _ :: _ as ss)) -> ss
| _ -> [ f ]
(* Heads whose trailing arguments are a body, and how many come before it. *)
let body_split (h : Form.t) args =
match h.v with
| Form.Sym s ->
let base =
match String.rindex_opt s '/' with
| Some i -> String.sub s (i + 1) (String.length s - i - 1)
| None -> s
in
let lead = List.length (List.filter (fun (a : Form.t) ->
match a.v with Form.List _ -> false | _ -> true) args) in
(match base with
| "comment" | "do" -> Some 0
| "unless" | "loop" -> Some 1
| "defmacro" -> Some 2
| "defmethod" -> Some 3
| _ when String.length base > 5 && String.sub base 0 5 = "with-" ->
let rec leading n = function
| ({ Form.v = Form.List _; _ }) :: _ -> n
| _ :: rest -> leading (n + 1) rest
| [] -> n
in
ignore lead;
Some (leading 0 args)
| _ -> None)
| _ -> None
let sugar_heads =
[ "let"; "set"; "if"; "when"; "cond"; "while"; "until"; "dotimes"; "match";
"handler-case"; "handler-bind"; "restart-case"; "return"; "defer"; "do";
"quasiquote" ]
let rec block n (fs : Form.t list) : string list =
let rec go = function
| [] -> []
| [ x ] -> stmt n ~last:true x
| x :: rest -> stmt n ~last:false x @ go rest
in
go fs
and stmt n ~last (f : Form.t) : string list =
match sugar n ~last f with
| Some ls -> ls
| None -> plain n f
and plain n (f : Form.t) : string list =
let text =
match f.v with
| Form.List [] -> "(())"
| Form.List [ { v = Form.Sym "do"; _ } ] -> "()"
| Form.Sym s when List.mem s reserved -> paren s
| _ -> guard (fst (expr f))
in
let one = [ ind n ^ text ] in
match f.v with
| Form.List (h :: args) when args <> [] ->
(match body_split h args with
| Some k when k < List.length args ->
let fixed = List.filteri (fun i _ -> i < k) args in
let rest = List.filteri (fun i _ -> i >= k) args in
[ ind n ^ guard (head_text h ^ "(" ^ commas fixed ^ "):") ] @ block (n + 2) rest
| _ when n + String.length text > width && fst (expr f) = text ->
wrapped n "" f
| _ -> one)
| _ -> one
(* A call too long for its line, broken after commas inside its
parentheses, where a line break is only whitespace. [prefix] is what
comes before the call on the first line. *)
and wrapped n prefix (f : Form.t) =
match f.v with
| Form.List (h :: (_ :: _ as args)) when (match h.v with
| Form.Sym ("at" | "quote" | "unquote" | "unquote-splicing") -> false
| Form.Sym s -> not (R.is_op_word s) && not (String.length s > 1 && s.[0] = '.')
| _ -> false) ->
let open_ = prefix ^ head_text h ^ "(" in
let col = n + String.length open_ in
let items = comma_items args in
let rec go line acc = function
| [] -> List.rev ((line ^ ")") :: acc)
| [ t ] ->
if String.length line = col || String.length line + String.length t + 1 <= width
then go (line ^ t) acc []
else
let line = String.sub line 0 (String.length line - 1) in
go (ind col ^ t) (line :: acc) []
| t :: rest ->
let piece = t ^ "," in
if String.length line = col || String.length line + String.length piece <= width
then go (line ^ piece ^ " ") acc rest
else
let line = String.sub line 0 (String.length line - 1) in
go (ind col ^ piece ^ " ") (line :: acc) rest
in
(* The last item on a line carries a trailing space; the break drops it. *)
let lines = go (ind n ^ open_) [] items in
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
| _ -> [ ind n ^ prefix ^ at 0 f ]
(* [prefix = v], or [prefix =] and the value as an indented block when it is
too long for the line. *)
and value_lines n prefix (v : Form.t) =
let inline = prefix ^ " = " ^ at 0 v in
if n + String.length inline <= width then [ ind n ^ inline ]
else
match v.v with
| 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
| Form.List ({ v = Form.Sym h; _ } :: _)
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)
| _ -> [ ind n ^ inline ]
and slot n (f : Form.t) = block n (stmts_of f)
and label_of = function
| ({ Form.v = Form.Kw k; _ }) :: rest when kw_ok k -> (":" ^ k ^ " ", rest)
| rest -> ("", rest)
and sugar n ~last (f : Form.t) : string list option =
let i = ind n in
match f.v with
| Form.List ({ v = Form.Sym "let"; _ } :: { v = Form.Vec bs; _ } :: (_ :: _ as body)) ->
(match pairs bs with
| None | Some [] -> None
| Some prs -> Some (let_lines n ~last prs body))
| Form.List [ { v = Form.Sym "set"; _ }; t; v ] ->
Some (value_lines n (guard (at 9 t)) v)
| Form.List [ { v = Form.Sym "if"; _ }; c; a; b ] ->
let simple (x : Form.t) =
match x.v with
| Form.List ({ v = Form.Sym h; _ } :: _) -> not (List.mem h sugar_heads)
| _ -> true
in
let line = i ^ fst (expr f) in
if simple a && simple b && String.length line <= width then Some [ line ]
else
Some
([ i ^ "if " ^ at 1 c ] @ slot (n + 2) a @ [ i ^ "else" ] @ slot (n + 2) b)
| Form.List ({ v = Form.Sym "when"; _ } :: c :: (_ :: _ as body)) ->
Some ((i ^ "if " ^ at 1 c) :: block (n + 2) body)
| Form.List ({ v = Form.Sym "cond"; _ } :: args) ->
(match pairs args with
| None -> None
| Some prs ->
let tests, else_ =
match List.rev prs with
| (k, e) :: rest when is_else k -> (List.rev rest, Some e)
| _ -> (prs, None)
in
if List.length tests < 2 then None
else
Some
(List.concat
(List.mapi
(fun j (c, b) ->
(i ^ (if j = 0 then "if " else "elif ") ^ at 1 c) :: slot (n + 2) b)
tests)
@ (match else_ with
| Some e -> (i ^ "else") :: slot (n + 2) e
| None -> [])))
| Form.List ({ v = Form.Sym (("while" | "until") as w); _ } :: rest) ->
let lbl, rest = label_of rest in
(match rest with
| c :: (_ :: _ as body) -> Some ((i ^ w ^ " " ^ lbl ^ at 0 c) :: block (n + 2) body)
| _ -> None)
| Form.List ({ v = Form.Sym "dotimes"; _ } :: rest) ->
let lbl, rest = label_of rest 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" ->
Some
((i ^ "for " ^ lbl ^ v ^ " in range(" ^ commas bs ^ ")") :: block (n + 2) body)
| _ -> None)
| Form.List [ { v = Form.Sym "return"; _ } ] -> Some [ i ^ "return" ]
| Form.List [ { v = Form.Sym "return"; _ }; v ] -> Some [ i ^ "return " ^ at 0 v ]
| Form.List [ { v = Form.Sym (("break" | "continue") as w); _ } ] -> Some [ i ^ w ]
| Form.List [ { v = Form.Sym (("break" | "continue") as w); _ }; { v = Form.Kw k; _ } ]
when kw_ok k ->
Some [ i ^ w ^ " :" ^ k ]
| Form.List [ { v = Form.Sym "defer"; _ }; x ] ->
let line = i ^ "defer " ^ at 0 x in
if String.length line <= width then Some [ line ]
else Some ((i ^ "defer") :: block (n + 2) [ x ])
| Form.List ({ v = Form.Sym "defer"; _ } :: (_ :: _ :: _ as body)) ->
Some ((i ^ "defer") :: block (n + 2) body)
| Form.List ({ v = Form.Sym "match"; _ } :: s :: (_ :: _ as arms)) ->
(match pairs arms with
| None -> None
| Some prs ->
Some
((i ^ "match " ^ at 0 s)
:: List.concat_map
(fun (pat, body) ->
let pt = at 8 pat in
let line = ind (n + 2) ^ pt ^ " -> " ^ at 0 body in
match body.v with
| Form.List (_ :: _) when String.length line > width ->
(ind (n + 2) ^ pt ^ " ->") :: slot (n + 4) body
| _ -> [ line ])
prs))
| Form.List [ { v = Form.Sym "handler-case"; _ }; body; { v = Form.Vec cls; _ } ]
when cls <> [] ->
Option.map
(fun cl -> ((i ^ "handler-case") :: slot (n + 2) body) @ cl)
(handler_clauses n cls)
| Form.List ({ v = Form.Sym "handler-bind"; _ } :: { v = Form.Vec cls; _ } :: (_ :: _ as body))
when cls <> [] ->
Option.map
(fun cl -> ((i ^ "handler-bind") :: block (n + 2) body) @ cl)
(handler_clauses n cls)
| Form.List ({ v = Form.Sym "restart-case"; _ } :: body :: (_ :: _ as cls)) ->
let clause (c : Form.t) =
match c.v with
| Form.List ({ v = Form.Sym r; _ } :: { v = Form.Vec ps; _ } :: (_ :: _ as b))
when def_name r ->
Option.map
(fun pt -> (i ^ "restart " ^ r ^ "(" ^ pt ^ ")") :: block (n + 2) b)
(params_text ps)
| _ -> None
in
let cs = List.map clause cls in
if List.mem None cs then None
else
Some (((i ^ "restart-case") :: slot (n + 2) body)
@ List.concat_map Option.get cs)
| Form.List [ { v = Form.Sym "quasiquote"; _ }; x ] ->
Some ((i ^ "quote") :: slot (n + 2) x)
| Form.List ({ v = Form.Sym "fn"; _ } :: { v = Form.Vec ps; _ } :: (_ :: _ :: _ as body))
when List.for_all sym_param ps ->
Some ((guard (i ^ "fn(" ^ commas ps ^ ")")) :: block (n + 2) body)
| Form.List ({ v = Form.Sym (("defn" | "defn-") as d); _ } :: { v = Form.Sym name; _ }
:: { v = Form.Vec ps; _ } :: ret :: body)
when def_name name ->
(match params_text ~shaped:true ps with
| None -> None
| Some pt ->
let where_, body =
match body with
| { v = Form.Map [ { v = Form.Kw "where"; _ }; x ]; _ } :: rest ->
let preds =
match x.v with
| Form.Vec (_ :: _ :: _ as xs) -> commas xs
| _ -> at 0 x
in
(" where " ^ preds, rest)
| _ -> ("", body)
in
let head =
i ^ (if d = "defn" then "fn " else "fn- ") ^ name ^ "(" ^ pt ^ ") -> "
^ ty ret ^ where_
in
(match body with
| [] -> Some [ head ]
| [ x ] when (match x.v with
| Form.List ({ v = Form.Sym h; _ } :: _) -> not (List.mem h sugar_heads)
| _ -> true)
&& String.length head + 3 + String.length (at 0 x) <= width ->
Some [ head ^ " = " ^ at 0 x ]
| _ -> Some (head :: block (n + 2) body)))
| Form.List ({ v = Form.Sym (("def" | "defonce" | "defconst") as d); _ }
:: { v = Form.Sym name; _ } :: rest)
when def_name name ->
let w = match d with "def" -> "def" | "defonce" -> "once" | _ -> "const" in
let pre = i ^ w ^ " " ^ name in
(match d, rest with
| "defconst", [ v ] -> Some (value_lines n (w ^ " " ^ name) v)
| "defconst", [ t; v ] -> Some (value_lines n (w ^ " " ^ name ^ ": " ^ ty t) v)
| "defconst", _ -> None
| _, [ t; v ] when is_sym "dyn" t -> Some (value_lines n (w ^ " " ^ name) v)
| _, [ t ] when type_shaped t -> Some [ pre ^ ": " ^ ty t ]
| _, [ t; v ] -> Some (value_lines n (w ^ " " ^ name ^ ": " ^ ty t) v)
| _ -> None)
| Form.List [ { v = Form.Sym (("defstruct" | "defunion") as d); _ };
{ v = Form.Sym name; _ }; { v = Form.Vec fs; _ } ]
when def_name name ->
(match pairs fs with
| Some prs when List.for_all (fun ((f : Form.t), _) ->
match f.v with Form.Sym x -> def_name x | _ -> false) prs ->
Some
((i ^ (if d = "defstruct" then "struct " else "union ") ^ name)
:: List.map
(fun ((f : Form.t), t) ->
let fname = fst (expr f) in
ind (n + 2) ^ if is_sym "dyn" t then fname else fname ^ ": " ^ ty t)
prs)
| _ -> None)
| Form.List [ { v = Form.Sym "defdata"; _ }; { v = Form.Sym name; _ }; { v = Form.Vec cs; _ } ]
when def_name name ->
let case (c : Form.t) =
match c.v with
| Form.Sym s when def_name s -> Some s
| Form.List [ { v = Form.Sym s; _ }; { v = Form.Vec ps; _ } ] when def_name s ->
Option.map (fun pt -> s ^ "(" ^ pt ^ ")") (params_text ps)
| _ -> None
in
let cs = List.map case cs in
if List.mem None cs then None
else Some ((i ^ "data " ^ name) :: List.map (fun c -> ind (n + 2) ^ Option.get c) cs)
| Form.List [ { v = Form.Sym "defenum"; _ }; { v = Form.Sym name; _ }; { v = Form.Vec ms; _ } ]
when def_name name ->
let rec members = function
| { Form.v = Form.Sym m; _ } :: ({ Form.v = Form.Int _ | Form.UInt _; _ } as v) :: rest
when def_name m ->
Option.map (fun r -> (m ^ " = " ^ fst (expr v)) :: r) (members rest)
| { Form.v = Form.Sym m; _ } :: rest when def_name m ->
Option.map (fun r -> m :: r) (members rest)
| [] -> Some []
| _ -> None
in
Option.map
(fun ms -> (i ^ "enum " ^ name) :: List.map (fun m -> ind (n + 2) ^ m) ms)
(members ms)
| Form.List [ { v = Form.Sym "import"; _ }; { v = Form.Sym a; _ }; ({ v = Form.Str _; _ } as p) ]
when def_name a ->
Some [ i ^ "import " ^ a ^ " " ^ fst (expr p) ]
| _ -> None
and is_else (f : Form.t) = match f.v with Form.Kw "else" -> true | _ -> false
and handler_clauses n cls =
let clause (c : Form.t) =
match c.v with
| Form.List (t :: { v = Form.Vec [ { v = Form.Sym v; _ } ]; _ } :: (_ :: _ as b))
when def_name v ->
Some ((ind n ^ "on " ^ at 9 t ^ "(" ^ v ^ ")") :: block (n + 2) b)
| _ -> None
in
let cs = List.map clause cls in
if List.mem None cs then None else Some (List.concat_map Option.get cs)
(* A [let] last in its block reads to the block's end, so it is written flat.
One with siblings after it takes its body as an indented block under the
first binding, and the rest of the bindings go inside that block. *)
and let_lines n ~last prs body =
let target (t : Form.t) = "let " ^ guard (at 8 t) in
if last then
List.concat_map (fun (t, v) -> value_lines n (target t) v) prs @ block n body
else
match prs with
| (t, v) :: rest ->
(ind n ^ target t ^ " = " ^ at 0 v)
:: (List.concat_map (fun (t, v) -> value_lines (n + 2) (target t) v) rest
@ block (n + 2) body)
| [] -> block n body
(** A whole file: top-level forms with a blank line between them. *)
let program (fs : Form.t list) : string =
let rec go = function
| [] -> []
| [ x ] -> [ String.concat "\n" (stmt 0 ~last:true x) ]
| x :: rest -> String.concat "\n" (stmt 0 ~last:false x) :: go rest
in
String.concat "\n\n" (go fs) ^ "\n"

1310
lib/indent_reader.ml Normal file
View File

File diff suppressed because it is too large Load Diff

22
lib/load.ml
View File

@ -94,14 +94,14 @@ let rec find_collection dir name =
let parent = Filename.dirname dir in
if String.equal parent dir then None else find_collection parent name
(* A package is a directory, or a single [.flan] file named outright. The file
(* A package is a directory, or a single source file named outright. The file
form is for the program that is also a library: sand.flan sits beside three
other loose .flan files, so naming its directory would import all four, and
moving it into one of its own would be arranging the tree around a
limitation. A file carries no [.c] and no [link] — those belong to a
directory, and a package that needs them has one. *)
let is_package_file path =
Filename.check_suffix path ".flan" && Sys.file_exists path
Source.is_source path && Sys.file_exists path
&& not (Sys.is_directory path)
(* [Filename.concat] of a directory and "." leaves the dot on the end, and the
@ -117,8 +117,8 @@ let resolve_dir ~file loc path =
match split_path path with
| None, rel ->
let d = Filename.concat here rel in
if ok d then d else fail loc "no package at %s — wanted a directory or a \
.flan file" d
if ok d then d else fail loc "no package at %s — wanted a directory, a \
.flan file or a .fln file" d
| Some collection, rel ->
(match find_collection here collection with
| None ->
@ -141,6 +141,14 @@ let entries dir suffix =
|> List.sort String.compare
|> List.map (Filename.concat dir)
(* A package directory's source files, in either syntax. *)
let source_entries dir =
Sys.readdir dir
|> Array.to_list
|> List.filter Source.is_source
|> List.sort String.compare
|> List.map (Filename.concat dir)
(* ── Qualifying an imported package ────────────────────────────────── *)
let qualify alias n = alias ^ "/" ^ n
@ -1203,12 +1211,12 @@ let rec import ~seen ~open_ ~loc alias dir =
Hashtbl.replace seen dir' (alias, []);
let open_ = open_ @ [ (dir', alias) ] in
let one_file = is_package_file dir in
let files = if one_file then [ dir ] else entries dir ".flan" in
if files = [] then fail loc "the package at %s has no .flan file" dir;
let files = if one_file then [ dir ] else source_entries dir in
if files = [] then fail loc "the package at %s has no .flan or .fln file" dir;
(* Read once. The forms are wanted twice — for the imports below and for
the macros at the end — and reading a file twice is the kind of second
opinion this module spends its comments warning about. *)
let sources = List.map (fun f -> (f, Reader.read_file f)) files in
let sources = List.map (fun f -> (f, Source.read_file f)) files in
(* What this package imports, resolved first and relative to itself. Its
declarations come back already qualified under their own aliases, so the
rename below leaves them alone: they are not in [owned].

4
lib/session.ml
View File

@ -268,7 +268,7 @@ let of_forms ~debug ~x86 ~file forms =
built = record_built env p p.Tast.fns SM.empty; live = SM.empty }, l)
let create ?(debug = false) ?(x86 = false) ~file () =
of_forms ~debug ~x86 ~file (Reader.read_file file)
of_forms ~debug ~x86 ~file (Source.read_file file)
(* ── A file loaded a form at a time, keeping what compiles ─────────── *)
@ -348,7 +348,7 @@ let create_dev ?(debug = false) ?(x86 = false) ~file () =
of_forms ~debug ~x86 ~file
(if declares_main forms then forms else forms @ stub_main ())
in
let (t, l), _, errs = pruned build (Reader.read_file file) in
let (t, l), _, errs = pruned build (Source.read_file file) in
(t, l, errs)
(* What a macro may call, for the same reason [macros] is held: an evaluation

20
lib/source.ml Normal file
View File

@ -0,0 +1,20 @@
(** A program source file, read by the reader its extension names: [.fln] is
the indented syntax ([Indent_reader]), anything else the paren syntax
([Reader]). Both give the same [Form.t], so nothing past this point knows
which one a file was written in, and a program may mix them freely.
Only program sources come through here. The prelude, the wire protocol and
the registry's spellings are paren text the compiler writes itself, and
read it with [Reader] directly. *)
let indented_ext = ".fln"
let paren_ext = ".flan"
let is_indented path = Filename.check_suffix path indented_ext
(** A file a package directory contributes, in either syntax. *)
let is_source path =
Filename.check_suffix path paren_ext || is_indented path
let read_file path =
if is_indented path then Indent_reader.read_file path else Reader.read_file path

92
spec-syntax.md
View File

@ -99,61 +99,75 @@ Each item: the proposal, then the reason in one line.
### Lexical
- **Extension `.fln`.** Short; `.flan` keeps meaning parens, so
`generated.flan` and every existing path stay valid.
- **Comments stay `;`.** Nothing else wants the character.
`generated.flan` and every existing path stay valid. **Built.**
- **Comments stay `;`.** Nothing else wants the character. **Built.**
- **Spaces only.** A tab in indentation is an error. The corpus has no tabs.
**Built.**
- **Indentation is measured in columns, any width.** A dedent must land on a
column already on the stack (GDScript `gdscript_tokenizer.cpp:1291-1296`).
**Built.**
- **Blank and comment-only lines never open or close a block** (GDScript
1170-1239).
1170-1239). **Built.**
- **Inside `(` `[` `{`, newlines and indentation are ignored** except where a
trailing block is allowed. Make it parser-driven, the way GDScript's
`push_multiline` is (`gdscript_parser.cpp` 658-672, 3695-3770), not a paren
counter in the lexer, or a block inside a call can't work.
*Built as a depth counter instead: inside brackets a line break is always
whitespace, so no block opens inside a call's parentheses (§3.1's blocks all
open after the `)`; a lambda with a block body is a statement or a value,
`let f = fn(x)` plus a block).*
- **Continuation outside brackets:** a line that starts with a spaced infix
operator (`+`, `and`, `==`, …) continues the previous line; so does a line
after one that ends in a spaced infix operator. (F# `LexFilter.fs` 360-380,
1850-1870, 2345-2360.) No `\` continuation.
1850-1870, 2345-2360.) No `\` continuation. **Built** (`=` does not
continue: `let x =` plus a block is a block value).
- **Minus.** `-` glued to a digit is a negative literal (`-1`; 269 in the
corpus). `-` glued to a name is negation (`-x` becomes `(- x)`; no name starts
with `-` except two prelude sentinels, `lib/prelude.ml:2280,2285`, which
rename). `a - b` is subtraction. `a -1` is an error: "separate with a comma or
space the minus".
- **`->` needs spaces as the return arrow.** `dyn->f64` stays a name.
space the minus". **Built.**
- **`->` needs spaces as the return arrow.** `dyn->f64` stays a name. **Built.**
- **Character literals stay `\c`**, lexed before brackets and operators:
`\(`, `\,`, `\space`. 277 uses, many of them delimiters of the new syntax.
**Built.**
### Collections and separators
- **Commas separate elements. With no commas, whitespace does, but only
between single terms.** `[1 2 3]`, `[i n]`, `{.x 1 .y 2}` and `[4 f32]` read
as today. `[a - 1 b]` is refused: "separate elements with commas". This keeps
the Lisp look for data and is refusable by shape.
the Lisp look for data and is refusable by shape. **Built** (in braces a
value may have an operator in it, `{.x a + 1, .y 2}`; the comma after it is
what is required).
- **Struct literal:** `Vector2{.x 1, .y 2}` (brace glued to the name) reads
`(Vector2 {.x 1 .y 2})`. A bare `{.x 1}` is today's bare literal. `{:a 1}` is a
dyn map.
dyn map. **Built.**
- **No set literal.** Flan has none today: `#{1 2}` reads as the symbol `#` and
a map. Adding sets is a language change, not a syntax one.
a map. Adding sets is a language change, not a syntax one. *In a `.fln` file
`#{1 2}` reads `(# {1 2})`, a brace glued to a name.*
### Expressions
- **Precedence**, low to high: `or` < `and` < `not` < comparisons
(`== != < <= > >=`) < `<< >>` < `+ -` < `* / %` < unary `-` < postfix (call,
index, field).
index, field). **Built.** Mixing comparison operators in one chain,
`a < b <= c`, is refused. An operator glued to `(` is always a call.
- **`==` is `=`; `=` is assignment.** `x = v` reads `(set x v)`, `a[i] = v`
reads `(set (at a i) v)`, `p.x = v` reads `(set (.x p) v)`. `x += v` reads
`(set x (+ x v))`; like `++` today, the place is evaluated twice.
`(set x (+ x v))`; like `++` today, the place is evaluated twice. **Built**
(also `-=`, `*=`, `/=`).
- **A run of the same operator flattens** (variadics, section 3):
`a + b + c` reads `(+ a b c)`, `a < b < c` reads `(< a b c)` (Flan's chain
semantics, `test/programs/chain.flan`). This keeps the converter round trip
exact (section 4).
exact (section 4). **Built.**
- **Field access is postfix:** `camera.target.x` reads `(.x (.target camera))`.
A capitalised left side is a qualified case, not a field: `Shape.Rect` stays
one symbol. `test/programs/dev-rerun.flan:65` names a global
`.init-once.counter`; rename it.
- **`and`, `or`, `not` are words**, since they are Flan's own names.
`.init-once.counter`; rename it. **Built**, without the rename: it prints and
reads back through the fallback, `defonce(.init-once.counter, i64, 7)`.
- **`and`, `or`, `not` are words**, since they are Flan's own names. **Built.**
- **Casts and type-taking builtins are calls:** `i32(x)`, `vec-new(u8)`,
`max-value(u8)`, `the([3 f32], [1 2 3.5])`.
`max-value(u8)`, `the([3 f32], [1 2 3.5])`. **Built.**
### Statements and blocks
@ -163,16 +177,19 @@ Each item: the proposal, then the reason in one line.
which is how the printer writes a `let` that has siblings after it.
Destructuring: `let {.x .y} = p`, `let [head & tail] = xs`. (`defer` is
function-scoped, not let-scoped, `TODO.org` "defer may be written in a let",
so merging never moves a cleanup.)
so merging never moves a cleanup.) **Built**; `let x =` with the value as an
indented block also reads, and so does `def`/`once`/`const`.
- **`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`.
- **`while c`, `until c`**, optional label first: `while :outer c`.
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 …)`).
- **`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.
`a..b` would lex as one name. **Built** (a label goes first here too:
`for :outer i in range(n)`).
- **`return v`, `break`, `break :outer`, `continue`, `defer expr`** (or `defer`
plus a block).
plus a block). **Built**; `defer` plus a block reads `(defer a b …)`.
- **`match`:**
```
@ -182,7 +199,8 @@ Each item: the proposal, then the reason in one line.
:north -> 0
_ -> 0
```
An arm's body can be an indented block, which reads as `(do …)`.
An arm's body can be an indented block, which reads as `(do …)`. **Built** (a
one-line block reads as that line).
- **Conditions**, clauses at the header's column:
```
@ -199,24 +217,30 @@ 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.
- **Unit:** `()` as a statement reads `(do)`; in a type it is `()`.
- **Lambda:** `fn(i, j) = i * 10 + j`, or `fn(i, j)` plus a block.
the body, where the form wants them. **Built.**
- **Unit:** `()` as a statement reads `(do)`; in a type it is `()`. **Built**;
inside an expression `()` stays `()`, and the printer writes a lone `()`
statement as `(())`.
- **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.
### Definitions
- `fn name(a: i32, b) -> R` plus a block; `fn name(a) = expr` for one
expression. Reads `(defn name [a i32 b dyn] R …)`. A `{:where …}` constraint
becomes `where ordered?($t)` after the return type.
becomes `where ordered?($t)` after the return type. **Built**, with `-> R`
required until step 6; several predicates are `where p, q`.
- `def x = v`, `def x: T = v`, `once x: T`, `once x = v`, `const n = 3`,
`def scratch: [4 u8] = uninit`.
`def scratch: [4 u8] = uninit`. **Built.** `def x = v` and `once x = v` read
with `dyn`; `const n = 3` reads `(defconst n 3)`, its type inferred as today.
- `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`.
- `import rl "vendor:raylib"`.
`struct`. **Built** (an untyped field is `dyn`; `Empty()` is `(Empty [])`).
- `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`.
`declare-c`, `defalias`, `defmacro`, `loop`/`recur`, `array-fill`. **Built.**
### The fallback
@ -225,14 +249,16 @@ plus an indented block, reads as `(head arg … block…)`. Commas vanish into t
`defmethod(describe, :square, [s]):` plus a block is
`(defmethod describe :square [s] …)`. So every form is reachable on day one,
the printer has something to fall back on, and the sugar above can land one
piece at a time.
piece at a time. **Built**; a header word glued to `(` is always this call,
`if(c, a)`, `let([x 1], x)`.
### Types
After `:` and `->`, a small type grammar that reads to today's type forms:
`i32`, `$t`, `()`, `[T]`, `[const T]`, `[n T]`, `Vec(T)`, `Map(K, V)`,
`Option(T)`, `Ptr(T)`, `Ptr(const T)`, `Fn(A, B) -> R`, `CFn(A) -> R`,
`rl/Vector2`.
`rl/Vector2`. **Built** (the arrow is read only in a type position; inside a
value, `vec-new(Fn([i32], i32))` is the call spelling).
### Macro templates
@ -246,7 +272,9 @@ defmacro(with-mode-2d, [camera & body]):
`quote` plus a block is a quasiquote; `~x` and `~@xs` are unquote and splice,
the Clojure spellings the reader already has. (An earlier sketch used `$x`;
that collides with type variables such as `$t`.)
that collides with type variables such as `$t`.) **Built**: one line reads
`(quasiquote line)`, more read `(quasiquote (do …))`; `~` takes the atom right
after it, so `~name(x)` is `((unquote name) x)`, and `~(f(x))` unquotes a call.
## 3. Settled after review (2026-09-25)

21
test/dune
View File

@ -99,6 +99,27 @@
; flan run --target=web is refused by the CLI, so the CLI has to be here.
(file %{workspace_root}/bin/main.exe)))
; The indented syntax: its two hand-converted programs, the paren -> indented
; -> paren round trip over every .flan the build tree holds, and the import
; programs in test/syntax/mixed. Its own stanza for its deps: the round trip
; walks every directory that has a .flan in it, which is more than the corpus
; alias carries, and the other binaries have no use for the rest.
(test
(name test_syntax)
(modules test_syntax test_support watchdog own_tmp)
(libraries flan unix)
(deps
(alias corpus)
(source_tree syntax)
(file %{workspace_root}/conditions-play.flan)
(glob_files %{workspace_root}/spike/backend/*.flan)
(glob_files %{workspace_root}/spike/generics/*.flan)
(glob_files %{workspace_root}/spike/js/*.flan)
(glob_files %{workspace_root}/spike/x86/*.flan)
(glob_files %{workspace_root}/spike/x86/bench/*.flan)
(glob_files %{workspace_root}/web/examples/*.flan)
(glob_files %{workspace_root}/web/examples/geom/*.flan)))
; The corpus a second time under ASan and UBSan. Its own alias and not part of
; `dune test`: a sanitized build is a statically linked 1.8MB binary that takes
; tens of seconds to produce, so the sweep is minutes against the existing

51
test/syntax/algorithms.flan Normal file
View File

@ -0,0 +1,51 @@
(import agent "vendor:agent")
(defn find-match [str string pattern string] i32
(dotimes [i (length str)]
(let [matched true]
(dotimes [j (length pattern)]
(when (!= (at str (+ i j)) (at pattern j))
(set matched false)))
(when matched
(return i))))
-1)
(defn selection-sort [coll [$t]] ()
{:where (ordered? $t)}
(let [len (length coll)]
(dotimes [i len]
(let [min-val i]
(dotimes [j (+ i 1) len]
(when (< (at coll j) (at coll min-val))
(set min-val j)))
(let [tmp (at coll min-val)]
(set (at coll min-val) (at coll i))
(set (at coll i) tmp))))))
(defn insertion-sort [coll [$t]] ()
{:where (ordered? $t)}
(let [i 1
length (length coll)]
(while (and (< i length))
(let [j i]
(while (and (> j 0)
(< (at coll j) (at coll (dec j))))
(let [temp (at coll j)]
(set (at coll j) (at coll (dec j)))
(set (at coll (dec j)) temp))
(-- j)))
(++ i))))
(defn main [] i32 0)
(comment
(insertion-sort [\I \N \S \E \R \T \I \O \N \S \O \R \T])
(insertion-sort (slice [6 2 4 9 1 9 4 5] 0 8))
(let [str (bytes "INSERTIONSORT")]
(insertion-sort str)
(println str))
(let [str (bytes "SELECTIONSORT")]
(selection-sort str)
(println str))
(find-match "aababba" "abba")
:-)

52
test/syntax/algorithms.fln Normal file
View File

@ -0,0 +1,52 @@
; algorithms.flan, written by hand in the indented syntax. test_syntax reads
; both and wants the same forms.
import agent "vendor:agent"
fn find-match(str: string, pattern: string) -> i32
for i in range(length(str))
let matched = true
for j in range(length(pattern))
if str[i + j] != pattern[j]
matched = false
if matched
return i
-1
fn selection-sort(coll: [$t]) -> () where ordered?($t)
let len = length(coll)
for i in range(len)
let min-val = i
for j in range(i + 1, len)
if coll[j] < coll[min-val]
min-val = j
let tmp = coll[min-val]
coll[min-val] = coll[i]
coll[i] = tmp
fn insertion-sort(coll: [$t]) -> () where ordered?($t)
let i = 1
let length = length(coll)
while and(i < length)
let j = i
while j > 0
and coll[j] < coll[dec(j)]
let temp = coll[j]
coll[j] = coll[dec(j)]
coll[dec(j)] = temp
--(j)
++(i)
fn main() -> i32 = 0
comment():
insertion-sort([\I \N \S \E \R \T \I \O \N \S \O \R \T])
insertion-sort(slice([6 2 4 9 1 9 4 5], 0, 8))
let str = bytes("INSERTIONSORT")
insertion-sort(str)
println(str)
let str = bytes("SELECTIONSORT")
selection-sort(str)
println(str)
find-match("aababba", "abba")
:-

10
test/syntax/mixed/geo/geo.flan Normal file
View File

@ -0,0 +1,10 @@
;;;; A package written in the paren syntax, imported by ../main.fln.
(defstruct Pt [x i32 y i32])
(defn pt [x i32 y i32] Pt (Pt {.x x .y y}))
(defn dist2 [a Pt b Pt] i32
(let [dx (- (.x a) (.x b))
dy (- (.y a) (.y b))]
(+ (* dx dx) (* dy dy))))

11
test/syntax/mixed/main.flan Normal file
View File

@ -0,0 +1,11 @@
;;;; A paren-syntax program importing a package written in the indented
;;;; syntax. main.fln is the other direction.
(import shapes "shapes")
(defn main [] i32
(println (shapes/area (shapes/rect (i64 3) (i64 4))))
(println (shapes/area (shapes/Shape.Circle {.r (i64 2)})))
(println (shapes/area (shapes/Shape.Empty {})))
(println (shapes/triangle 10))
0)

21
test/syntax/mixed/main.fln Normal file
View File

@ -0,0 +1,21 @@
; An indented-syntax program importing a package written in the paren
; syntax. main.flan is the other direction.
import geo "geo"
fn far?(a: geo/Pt, b: geo/Pt, limit: i32) -> bool = geo/dist2(a, b) > limit * limit
fn main() -> i32
let a = geo/pt(1, 2)
let b = geo/Pt{.x 4, .y 6}
println(geo/dist2(a, b))
println(a.x + b.y)
if far?(a, b, 4)
println("far")
else
println("near")
let n = 0
while n < 3
n += 1
println(n)
0

20
test/syntax/mixed/shapes/shapes.fln Normal file
View File

@ -0,0 +1,20 @@
; A package written in the indented syntax, imported by ../main.flan.
data Shape
Circle(r: i64)
Rect(w: i64, h: i64)
Empty()
fn area(s: Shape) -> i64
match s
Circle(r) -> 3 * r * r
Rect(w, h) -> w * h
Empty -> 0
fn rect(w: i64, h: i64) -> Shape = Shape.Rect{.w w, .h h}
fn triangle(n: i32) -> i64
let sum = i64(0)
for i in range(n + 1)
sum += i64(i)
sum

143
test/syntax/sand.fln Normal file
View File

@ -0,0 +1,143 @@
; sand.flan, written by hand in the indented syntax. test_syntax reads both
; and wants the same forms, and checks this one; nothing runs it.
import rl "vendor:raylib"
import agent "vendor:agent"
import edn "vendor:edn"
const screen-width = 900
const screen-height = 600
const cell-size = 5
const rows = screen-height / cell-size
const cols = screen-width / cell-size
const brush-size = 10
fn dyn->f64(v: f64) -> f64 = v
fn dyn->u32(v: i64) -> u32 = u32(v)
def gravity = 0.05
def colors =
let v = vec-new(dyn)
push(v, 0xFFF00FFF)
push(v, 0x3B6E8CFF)
push(v, 0xA83232FF)
push(v, 0xCC6B1FFF)
v
once grid: [rows [cols u32]]
once velocity: [rows [cols f32]]
once current-color = 0
fn clear-grid() -> ()
grid = zeroed()
velocity = zeroed()
fn next-color() -> ()
current-color = (current-color + 1) % length(colors)
fn paint-at(row: i32, col: i32) -> ()
let half = brush-size / 2
for x in range(brush-size)
for y in range(brush-size)
let r = y + (row - half)
let c = x + (col - half)
if r >= 0 and r < rows - 1
and c >= 0 and c < cols - 1
and 0 == grid[r, c]
and f32(rand()) < 0.5
grid[r, c] = dyn->u32(colors[current-color])
velocity[r, c] = 1.0
fn settle(row: i32, col: i32) -> ()
let vel = f32(dyn->f64(gravity)) + velocity[row, col]
let y = min(rows - 1, row + i32(vel))
while y > row
if 0 == grid[y, col]
grid[y, col] = grid[row, col]
grid[row, col] = 0
velocity[y, col] = vel
velocity[row, col] = 0.0
return
let left? = col > 0 and 0 == grid[y, col - 1]
let right? = col < cols - 1 and 0 == grid[y, col + 1]
if left? or right?
let side =
if not left?
1
elif not right?
-1
else
if f32(rand()) < 0.5 then 1 else -1
grid[y, col + side] = grid[row, col]
grid[row, col] = 0
velocity[y, col + side] = vel
velocity[row, col] = 0.0
return
y = y - 1
velocity[row, col] = 0.0
fn step() -> ()
let row = rows - 2
while row >= 0
for col in range(cols)
unless(0 == grid[row, col]):
settle(row, col)
row = row - 1
const fnv-offset: u64 = 0xcbf29ce484222325
const fnv-prime: u64 = 1099511628211
fn hash-grid() -> u64
let h = fnv-offset
for row in range(rows)
for col in range(cols)
let c = grid[row, col]
for b in range(4)
h = bit-xor(h, u64(bit-and(c >> u32(b * 8), 255)))
h = h * fnv-prime
h
fn game-update() -> ()
if rl/key-pressed?(:key-r)
clear-grid()
if rl/mouse-button-down?(:mouse-left)
let m = rl/get-mouse-position()
paint-at(i32(m.y) / cell-size,
i32(m.x) / cell-size)
if rl/mouse-button-released?(:mouse-left)
next-color()
step()
fn game-draw() -> ()
rl/clear-background(rl/black)
for row in range(rows)
for col in range(cols)
let c = grid[row, col]
unless(0 == c):
rl/draw-rectangle(i32(col * cell-size),
i32(row * cell-size),
cell-size, cell-size,
rl/get-color(c))
rl/draw-fps(20, 20)
once frame: Allocator = arena-new(262144)
def game-data =
handler-case
edn/read-file("game-data.edn")
on FileError(c)
nil
fn main() -> ()
rl/set-trace-log-level(:log-warning)
rl/init-window(screen-width, screen-height, "SAND")
defer rl/close-window()
rl/set-target-fps(120)
agent/start("/tmp/flan-sand.sock")
until rl/window-should-close?()
restart-case
agent/poll()
game-update()
restart continue()
()
rl/with-drawing():
game-draw()

285
test/test_syntax.ml Normal file
View File

@ -0,0 +1,285 @@
(* The indented syntax (spec-syntax.md): its reader, its printer, and the
switch between the two readers by file extension.
Four parts. Two programs hand-converted from paren to indented must read to
the same forms. Every corpus file must survive paren -> printed indented ->
read indented unchanged, up to the one merge the spec allows. A table pins
the lexical edge cases and the refusals, with their kinds. And a program in
each syntax importing a package in the other builds and runs the same on
both backends. *)
open Flan
let () = Watchdog.arm ~seconds:300 "test_syntax"
let fail fmt = Test_support.fail fmt
let scratch = Test_support.scratch
(* ── Forms, compared without locations ─────────────────────────────── *)
let rec eq (a : Form.t) (b : Form.t) =
match a.v, b.v with
| Form.List x, Form.List y | Form.Vec x, Form.Vec y | Form.Map x, Form.Map y ->
List.length x = List.length y && List.for_all2 eq x y
| Form.Float x, Form.Float y ->
Int64.equal (Int64.bits_of_float x) (Int64.bits_of_float y)
| x, y -> x = y
(* The innermost pair that differs, for the failure line. *)
let rec first_diff (a : Form.t) (b : Form.t) =
match a.v, b.v with
| (Form.List x, Form.List y | Form.Vec x, Form.Vec y | Form.Map x, Form.Map y)
when List.length x = List.length y ->
(match List.find_opt (fun (p, q) -> not (eq p q)) (List.combine x y) with
| Some (p, q) -> first_diff p q
| None -> (a, b))
| _ -> (a, b)
let same_forms a b =
List.length a = List.length b && List.for_all2 eq a b
let describe_diff a b =
if List.length a <> List.length b then
Printf.sprintf "%d forms against %d" (List.length a) (List.length b)
else
match List.find_opt (fun (x, y) -> not (eq x y)) (List.combine a b) with
| Some (x, y) ->
let u, w = first_diff x y in
Printf.sprintf "wanted %s, read %s (at %d:%d)" (Form.to_string u)
(Form.to_string w) w.loc.Loc.line w.loc.Loc.col
| None -> "equal"
(* A [let] whose whole body is another [let] is the merged [let]: spec §4
step 3's one normalisation. Flan's [let] binds in order, so the two mean
the same thing. *)
let rec norm (f : Form.t) : Form.t =
let v =
match f.v with
| Form.List (({ v = Form.Sym "let"; _ } as h) :: { v = Form.Vec bs; loc } :: body) ->
(match List.map norm body with
| [ { v = Form.List ({ v = Form.Sym "let"; _ } :: { v = Form.Vec bs2; _ } :: body2); _ } ] ->
Form.List (h :: Form.make (Form.Vec (List.map norm bs @ bs2)) loc :: body2)
| body -> Form.List (h :: Form.make (Form.Vec (List.map norm bs)) loc :: body))
| Form.List l -> Form.List (List.map norm l)
| Form.Vec l -> Form.Vec (List.map norm l)
| Form.Map l -> Form.Map (List.map norm l)
| v -> v
in
{ f with v }
let diag_text = function
| Loc.Error d -> Printf.sprintf "%s %d:%d %s" d.Loc.kind d.dloc.Loc.line d.dloc.Loc.col d.dmsg
| e -> Printexc.to_string e
(* ── The hand-converted pairs ──────────────────────────────────────── *)
let pair flan fln =
match Reader.read_file flan, Source.read_file fln with
| a, b ->
if not (same_forms a b) then
fail "%s and %s read differently: %s" flan fln (describe_diff a b)
| exception e -> fail "%s / %s: %s" flan fln (diag_text e)
let () =
pair "syntax/algorithms.flan" "syntax/algorithms.fln";
pair "../sand.flan" "syntax/sand.fln";
(* Checked, never run: sand opens a window. *)
List.iter
(fun f ->
match Front.checked f with
| _ -> ()
| exception e -> fail "%s does not check: %s" f (diag_text e))
[ "syntax/sand.fln"; "syntax/algorithms.fln" ]
(* ── The round trip over the corpus ────────────────────────────────── *)
(* Every .flan the build tree holds. [..] is the workspace root from here;
the deps in test/dune decide what is in it. *)
let corpus () =
let rec walk dir acc =
Array.fold_left
(fun acc name ->
let path = Filename.concat dir name in
if name <> "" && (name.[0] = '.' || name.[0] = '_') then acc
else if Sys.is_directory path then walk path acc
else if Filename.check_suffix name ".flan" then path :: acc
else acc)
acc (Sys.readdir dir)
in
List.sort String.compare (walk ".." [])
let () =
let ok = ref 0 in
List.iter
(fun path ->
match Reader.read_file path with
| exception Loc.Error _ -> () (* not a program the paren reader takes *)
| forms ->
match Indent_printer.program forms with
| exception Indent_printer.Unprintable (f, why) ->
fail "round trip %s: %s at %d:%d" path why f.loc.Loc.line f.loc.Loc.col
| text ->
match Indent_reader.read_all ~file:(path ^ ".fln") text with
| exception e -> fail "round trip %s: %s" path (diag_text e)
| back ->
let a = List.map norm forms and b = List.map norm back in
if same_forms a b then incr ok
else fail "round trip %s: %s" path (describe_diff a b))
(corpus ());
Printf.printf "round trip: %d files\n" !ok;
(* The deps decide what is walked, and a stanza that lost them would pass
over nothing. *)
if !ok < 390 then fail "round trip covered only %d files" !ok
(* ── Lexical edge cases ────────────────────────────────────────────── *)
let read src = Indent_reader.read_all ~file:"<syntax>" src
let reads name src want =
match read src with
| forms ->
let got = String.concat "\n" (List.map Form.to_string forms) in
if got <> want then fail "%s: read %s, wanted %s" name got want
| exception e -> fail "%s: refused: %s" name (diag_text e)
let refuses name src kind needle =
match read src with
| forms ->
fail "%s: read %s, wanted the refusal %s" name
(String.concat " " (List.map Form.to_string forms)) kind
| exception Loc.Error d ->
if d.Loc.kind <> kind then fail "%s: refused as %s, wanted %s (%s)" name d.Loc.kind kind d.dmsg
else if not (Test_support.contains d.dmsg needle) then
fail "%s: %s does not say %S: %s" name kind needle d.dmsg
| exception e -> fail "%s: %s" name (Printexc.to_string e)
let () =
(* Minus. *)
reads "subtraction" "x = a - 1" "(set x (- a 1))";
reads "negative literal" "x = -1" "(set x -1)";
reads "negation" "x = -y" "(set x (- y))";
reads "negation binds after postfix" "x = -p.x" "(set x (- (.x p)))";
reads "lisp name" "x = a-b" "(set x a-b)";
reads "decrement is a name" "--(j)" "(-- j)";
reads "minus as a call" "x = -(a + b)" "(set x (- (+ a b)))";
refuses "glued minus" "x = a -1" "indent/glued-minus" "a - 1";
refuses "glued minus in a call" "f(a -1)" "indent/glued-minus" "space the minus";
(* The arrow. *)
reads "return arrow" "fn f(x: i32) -> i32 = x" "(defn f [x i32] i32 x)";
reads "arrow inside a name" "fn dyn->f64(v: f64) -> f64 = v" "(defn dyn->f64 [v f64] f64 v)";
reads "function type"
"fn g(h: Fn(i32, i32) -> bool) -> () = h(1, 2)"
"(defn g [h (Fn [i32 i32] bool)] () (h 1 2))";
reads "untyped parameter is dyn" "fn id(x) -> dyn = x" "(defn id [x dyn] dyn x)";
refuses "no return type" "fn f(x)\n x" "indent/return-type" "-> i32";
(* Characters, lexed before brackets and separators. *)
reads "character literals" "x = [\\( \\, \\space \\)]" "(set x [\\( \\, \\space \\)])";
reads "character arguments" "f(\\,, \\))" "(f \\, \\))";
(* Keywords and annotations. *)
reads "keyword" "def k = :else" "(def k dyn :else)";
reads "annotation" "once grid: [4 [8 u32]]" "(defonce grid [4 [8 u32]])";
reads "keyword argument" "rl/key-pressed?(:key-r)" "(rl/key-pressed? :key-r)";
refuses "colon inside a name" "fn f(x:i32) -> () = x" "indent/colon-in-name" "x: i32";
(* Adjacency. *)
reads "call" "f(a, b)" "(f a b)";
reads "index" "x[i, j]" "(at x i j)";
reads "call of a call" "f(a)(b)" "((f a) b)";
reads "field chain" "camera.target.x" "(.x (.target camera))";
reads "qualified case" "Shape.Rect" "Shape.Rect";
reads "field of a call" "f(x).y" "(.y (f x))";
reads "struct literal" "Vector2{.x 1, .y 2}" "(Vector2 {.x 1 .y 2})";
reads "operator call" "+(a, b, c)" "(+ a b c)";
reads "operator value" "reduce(+, 0, xs)" "(reduce + 0 xs)";
refuses "spaced call" "f (a)" "indent/spaced-call" "f(...)";
refuses "spaced index" "x [i]" "indent/spaced-index" "x[i]";
refuses "missing comma" "f(a b)" "indent/missing-comma" "commas";
refuses "unspaced operator" "x = f(a)+ b" "indent/unspaced-operator" "a + b";
(* Collections. *)
reads "whitespace vector" "x = [i n]" "(set x [i n])";
reads "comma vector" "x = [a - 1, b]" "(set x [(- a 1) b])";
refuses "operator between spaces" "x = [a - 1 b]" "indent/separate-elements" "commas";
reads "quoted list" "x = '(a b c)" "(set x (quote (a b c)))";
(* Trailing colon blocks. *)
reads "trailing block" "rl/with-drawing():\n clear()\n draw()"
"(rl/with-drawing (clear) (draw))";
reads "fallback with a block" "defmethod(describe, :square, [s]):\n s"
"(defmethod describe :square [s] s)";
refuses "block without the colon" "f(x)\n y" "indent/stray-indent" "trailing colon";
refuses "colon on a non-call" "x:\n y" "indent/colon-block" "x():";
(* Indentation. *)
refuses "tab" "fn f() -> ()\n\tg()" "indent/tab" "spaces";
refuses "dedent to no block" "if a\n b\n c" "indent/dedent" "column 3";
reads "blank and comment lines" "if a\n\n ; note\n b\n\n; more\nc"
"(when a b)\nc";
(* Continuation lines. *)
reads "trailing operator" "x = a +\n b" "(set x (+ a b))";
reads "leading operator" "x = a\n + b" "(set x (+ a b))";
reads "continued condition" "if a\n and b\n c" "(when (and a b) c)";
(* Runs of one operator. *)
reads "flattened" "x = a + b + c" "(set x (+ a b c))";
reads "chain" "x = a < b < c" "(set x (< a b c))";
reads "left to right" "x = a - b + c" "(set x (+ (- a b) c))";
reads "precedence" "x = a or b and not c == d" "(set x (or a (and b (not (= c d)))))";
refuses "not-equal chain" "x = a != b != c" "indent/chained-not-equal" "!=(a, b, c)";
reads "not-equal call" "x = !=(a, b, c)" "(set x (!= a b c))";
refuses "mixed comparison" "x = a < b <= c" "indent/mixed-comparison" "and";
(* Statements. *)
reads "lets merge" "fn f() -> i32\n let a = 1\n let b = 2\n a + b"
"(defn f [] i32 (let [a 1 b 2] (+ a b)))";
reads "let with a block" "let a = 1\n a\nb" "(let [a 1] a)\nb";
reads "elif" "if a\n 1\nelif b\n 2\nelse\n 3" "(cond a 1 b 2 :else 3)";
reads "one-line if" "x = if a then 1 else 2" "(set x (if a 1 2))";
reads "assignment ops" "a[i] += 1" "(set (at a i) (+ (at a i) 1))";
reads "for" "for :outer i in range(1, n)\n f(i)" "(dotimes :outer [i 1 n] (f i))";
reads "unit statement" "restart-case\n f()\nrestart continue()\n ()"
"(restart-case (f) (continue [] (do)))";
reads "match" "match s\n Circle(r) -> r\n _ ->\n a()\n b()"
"(match s (Circle r) r _ (do (a) (b)))";
reads "handler-bind moves the clauses" "handler-bind\n f()\non E(c)\n g(c)"
"(handler-bind [(E [c] (g c))] (f))";
reads "quote block"
"defmacro(m, [x & ys]):\n quote\n f(~x)\n ~@ys"
"(defmacro m [x & ys] (quasiquote (do (f (unquote x)) (unquote-splicing ys))))";
reads "lambda" "g = fn(i, j) = i * 10 + j" "(set g (fn [i j] (+ (* i 10) j)))";
reads "lambda with a block" "g = fn(i)\n a(i)\n b(i)" "(set g (fn [i] (a i) (b i)))";
reads "where" "fn s(xs: [$t]) -> () where ordered?($t) = f(xs)"
"(defn s [xs [$t]] () {:where (ordered? $t)} (f xs))";
reads "data" "data Shape\n Circle(r: f32)\n Empty"
"(defdata Shape [(Circle [r f32]) Empty])";
reads "enum" "enum K\n lo = -1\n mid" "(defenum K [lo -1 mid])";
reads "struct" "struct Cell\n row: i32\n tag" "(defstruct Cell [row i32 tag dyn])";
reads "read-only pointer" "def p: Ptr(const u8) = uninit" "(def p (Ptr const u8) uninit)"
(* ── 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" ()