From d7016f91c7f971833116bbafc6630c23e851c9ad Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Fri, 25 Sep 2026 15:04:32 +0700 Subject: [PATCH 1/2] 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 --- bin/main.ml | 35 +- lib/front.ml | 2 +- lib/indent_printer.ml | 597 ++++++++++++ lib/indent_reader.ml | 1310 +++++++++++++++++++++++++++ lib/load.ml | 22 +- lib/session.ml | 4 +- lib/source.ml | 20 + spec-syntax.md | 92 +- test/dune | 21 + test/syntax/algorithms.flan | 51 ++ test/syntax/algorithms.fln | 52 ++ test/syntax/mixed/geo/geo.flan | 10 + test/syntax/mixed/main.flan | 11 + test/syntax/mixed/main.fln | 21 + test/syntax/mixed/shapes/shapes.fln | 20 + test/syntax/sand.fln | 143 +++ test/test_syntax.ml | 285 ++++++ 17 files changed, 2646 insertions(+), 50 deletions(-) create mode 100644 lib/indent_printer.ml create mode 100644 lib/indent_reader.ml create mode 100644 lib/source.ml create mode 100644 test/syntax/algorithms.flan create mode 100644 test/syntax/algorithms.fln create mode 100644 test/syntax/mixed/geo/geo.flan create mode 100644 test/syntax/mixed/main.flan create mode 100644 test/syntax/mixed/main.fln create mode 100644 test/syntax/mixed/shapes/shapes.fln create mode 100644 test/syntax/sand.fln create mode 100644 test/test_syntax.ml diff --git a/bin/main.ml b/bin/main.ml index 0f1db3e2..7fb8306d 100644 --- a/bin/main.ml +++ b/bin/main.ml @@ -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 [build flags...] [--] [program args...]\n\ \ flan reload [-o out.so] [--x86]\n\ - \ flan dev [-s socket] [--x86]"; + \ flan dev [-s socket] [--x86]\n\ + \ flan convert "; exit 2 diff --git a/lib/front.ml b/lib/front.ml index fee00c6f..6ee0ad30 100644 --- a/lib/front.ml +++ b/lib/front.ml @@ -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 diff --git a/lib/indent_printer.ml b/lib/indent_printer.ml new file mode 100644 index 00000000..9132c1f3 --- /dev/null +++ b/lib/indent_printer.ml @@ -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" diff --git a/lib/indent_reader.ml b/lib/indent_reader.ml new file mode 100644 index 00000000..4c8b34da --- /dev/null +++ b/lib/indent_reader.ml @@ -0,0 +1,1310 @@ +(** The indented reader: [.fln] text to exactly the [Form.t] tree the paren + reader ([Reader]) makes. Nothing after the reader knows which syntax a form + came from. spec-syntax.md is the grammar; this comment is only the shape. + + Three passes. [lex] turns text into tokens, reusing [Reader]'s own string, + character, number and quoted-datum readers so the atoms mean exactly what + they mean in a [.flan] file. [layout] adds NEWLINE, INDENT and DEDENT at + bracket depth zero from an indent stack of columns. The parser is a + statement parser (soft keywords at the start of a line) over a precedence + climber for expressions. + + Locations are spans, as [Reader] makes them: a form starts at its first + token and ends where its last one does. A form this reader invents — the + [dyn] of an untyped parameter, the [do] around a block, the [set] of an + assignment — takes the location of the text that asked for it. *) + +type tok = + | NAME of string (* a name run, after field splitting *) + | KW of string + | ATOM of Form.value (* number, string, character *) + | DATUM of Form.t (* 'x and '(a b), read by the paren reader *) + | LP | RP | LB | RB | LC | RC + | COMMA + | COLON (* x: T, and the trailing : of a call's block *) + | UNQ | SPLICE (* ~ and ~@ *) + | NEG (* the - glued to the front of a name *) + | NEWLINE | INDENT | DEDENT | EOF + +type token = { tok : tok; loc : Loc.t; sp : bool (* whitespace before it *) } + +let failk ?notes kind loc fmt = Loc.failk ?notes ("indent/" ^ kind) loc fmt + +let show = function + | NAME s -> s + | KW s -> ":" ^ s + | ATOM v -> Form.to_source (Form.make v Loc.unknown) + | DATUM f -> Form.to_source f + | LP -> "(" | RP -> ")" | LB -> "[" | RB -> "]" | LC -> "{" | RC -> "}" + | COMMA -> "," | COLON -> ":" | UNQ -> "~" | SPLICE -> "~@" | NEG -> "-" + | NEWLINE -> "the end of the line" + | INDENT -> "an indented line" + | DEDENT -> "the end of the block" + | EOF -> "the end of the file" + +(* ── Names ─────────────────────────────────────────────────────────── *) + +(* Binary operators and their levels, low to high (spec §2 "Precedence"). + [not] sits at 3 and unary minus at 8; neither is binary. *) +let binops = + [ ("or", 1); ("and", 2); + ("==", 4); ("!=", 4); ("<", 4); ("<=", 4); (">", 4); (">=", 4); + ("<<", 5); (">>", 5); ("+", 6); ("-", 6); ("*", 7); ("/", 7); ("%", 7) ] + +let binop_level s = List.assoc_opt s binops +let is_binop s = binop_level s <> None + +(* [==] is Flan's [=]; every other operator is its own name. *) +let op_sym = function "==" -> "=" | s -> s + +(* Words that are operators rather than names wherever a value is read. Alone + before a comma or a closer they are the symbol itself, [reduce(+, 0, xs)]; + glued to a parenthesis they are a call, [+(a, b, c)]. *) +let is_op_word s = is_binop s || s = "not" || s = "=" + +let assign_ops = [ ("+=", "+"); ("-=", "-"); ("*=", "*"); ("/=", "/") ] + +(* A [-] glued to one of these starts a negation: [-x] is [(- x)]. Anything + else keeps the Lisp reading, so [--], [->] and [-=] stay names. *) +let is_neg_char c = + (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z') || c = '$' || c = '_' + || c = '*' + +(* The segment a dot splits after, checked for a capital: [Shape.Rect] and + [tree/Node.Branch] are one qualified name, [camera.target.x] is two field + accesses. The part after a package's [/] is what is checked. *) +let capitalised seg = + let base = + match String.rindex_opt seg '/' with + | Some i -> String.sub seg (i + 1) (String.length seg - i - 1) + | None -> seg + in + base <> "" && base.[0] >= 'A' && base.[0] <= 'Z' + +let split_fields text = + if text = "" || text.[0] = '.' then [ text ] + else + let segs = String.split_on_char '.' text in + if List.length segs < 2 || List.mem "" segs || capitalised (List.hd segs) + then [ text ] + else segs + +(* ── Lexing ────────────────────────────────────────────────────────── *) + +let lex ~file src : token list = + let st = Reader.of_string ~file src in + let out = ref [] in + let sp = ref true in + let line_start = ref true in + let tab = ref None in + let emit tok loc = out := { tok; loc; sp = !sp } :: !out; sp := false in + let piece line col len = + { (Loc.make file line col) with Loc.eline = line; ecol = col + len } + in + let name_run () = + let l0 = Reader.here st in + let text = Reader.take_while st (fun c -> not (Reader.is_delimiter c)) in + let n = String.length text in + let line = l0.Loc.line and col = l0.Loc.col in + if n = 0 then + failk "unexpected-character" l0 "unexpected character %C" (Reader.peek st); + if text = ":" then emit COLON (piece line col 1) + else if text.[0] = ':' then emit (KW (String.sub text 1 (n - 1))) (piece line col n) + else begin + let body, colon = + if text.[n - 1] = ':' then (String.sub text 0 (n - 1), true) + else (text, false) + in + let bn = String.length body in + let bcol, body = + if bn > 1 && body.[0] = '-' && is_neg_char body.[1] then begin + emit NEG (piece line col 1); + (col + 1, String.sub body 1 (bn - 1)) + end + else (col, body) + in + let off = ref 0 in + List.iteri + (fun i seg -> + let s = if i = 0 then seg else "." ^ seg in + emit (NAME s) (piece line (bcol + !off) (String.length s)); + off := !off + String.length s) + (split_fields body); + if colon then emit COLON (piece line (col + n - 1) 1) + end + in + let token c = + let l0 = Reader.here st in + let simple t = Reader.advance st; emit t (Loc.upto l0 (Reader.here st)) in + match c with + | '(' -> simple LP | ')' -> simple RP + | '[' -> simple LB | ']' -> simple RB + | '{' -> simple LC | '}' -> simple RC + | ',' -> simple COMMA + | '"' -> let f = Reader.read_string st in emit (ATOM f.v) f.loc + | '\\' -> let f = Reader.read_byte st in emit (ATOM f.v) f.loc + (* The paren reader reads the quoted datum whole, so ['(a (b c))] is the + Lisp list it always was and nothing here re-invents it. *) + | '\'' -> let f = Reader.read_form st in emit (DATUM f) f.loc + | '`' -> + failk "backquote" l0 + "` is not read in a .fln file. A quasiquote is quote followed by an \ + indented block, or quasiquote(x) on one line" + | '~' -> + Reader.advance st; + if Reader.peek st = '@' then begin + Reader.advance st; + emit SPLICE (Loc.upto l0 (Reader.here st)) + end + else emit UNQ (Loc.upto l0 (Reader.here st)) + | c when Reader.is_digit c + || ((c = '-' || c = '+') && Reader.is_digit (Reader.peek2 st)) -> + let f = Reader.read_number st in + emit (ATOM f.v) f.loc + | _ -> name_run () + in + let rec go () = + if not (Reader.at_end st) then + match Reader.peek st with + | ' ' | '\r' -> Reader.advance st; sp := true; go () + | '\t' -> + if !line_start && !tab = None then tab := Some (Reader.here st); + Reader.advance st; sp := true; go () + | '\n' -> + Reader.advance st; sp := true; line_start := true; tab := None; go () + | ';' -> + while (not (Reader.at_end st)) && Reader.peek st <> '\n' do + Reader.advance st + done; + go () + | c -> + (match !tab with + | Some l when !line_start -> + failk "tab" l + "this line is indented with a tab. Indentation in a .fln file is \ + measured in columns, and a tab has no one width, so only spaces \ + indent. Replace the tab with spaces" + | _ -> ()); + line_start := false; + token c; + go () + in + go (); + List.rev !out + +(* ── Layout ────────────────────────────────────────────────────────── *) + +let point (l : Loc.t) = { l with Loc.line = l.Loc.eline; col = l.Loc.ecol } + +(* NEWLINE, INDENT and DEDENT, at bracket depth zero only: inside ( [ { a + line break is whitespace. A line continues the one before it when either + side of the break is a spaced binary operator (spec §2 "Continuation"). *) +let layout ?(base = 1) (toks : token list) : token array = + let arr = Array.of_list toks in + let n = Array.length arr in + let out = ref [] in + let add tok loc = out := { tok; loc; sp = true } :: !out in + let stack = ref [ base ] in + let depth = ref 0 in + let binop t = match t.tok with NAME s -> is_binop s | _ -> false in + for i = 0 to n - 1 do + let t = arr.(i) in + (if i = 0 then begin + if t.loc.Loc.col <> base then + failk "unexpected-indent" t.loc + "the first line starts at column %d, and a file's top-level lines \ + start at column %d. Remove the indentation" + t.loc.Loc.col base + end + else + let p = arr.(i - 1) in + if !depth = 0 && t.loc.Loc.line > p.loc.Loc.eline then begin + let spaced_after = + i + 1 < n && arr.(i + 1).loc.Loc.line = t.loc.Loc.line + && arr.(i + 1).sp + in + let continues = (binop p && p.sp) || (binop t && spaced_after) in + if not continues then begin + let at = point p.loc in + add NEWLINE at; + let col = t.loc.Loc.col in + let top = List.hd !stack in + if col > top then begin + stack := col :: !stack; + add INDENT at + end + else if col < top then begin + let rec pop () = + match !stack with + | top :: (_ :: _ as rest) when col < top -> + stack := rest; add DEDENT at; pop () + | _ -> () + in + pop (); + if col <> List.hd !stack then + failk "dedent" t.loc + "this line starts at column %d, which is not where any \ + enclosing block starts — those start at column%s %s. Line \ + it up with one of them" + col + (if List.length !stack > 1 then "s" else "") + (String.concat ", " + (List.rev_map string_of_int !stack)) + end + end + end); + out := t :: !out; + (match t.tok with + | LP | LB | LC -> incr depth + | RP | RB | RC -> if !depth > 0 then decr depth + | _ -> ()) + done; + (if n > 0 then + let at = point arr.(n - 1).loc in + add NEWLINE at; + List.iter (fun _ -> add DEDENT at) (List.tl !stack)); + let eof_loc = if n > 0 then point arr.(n - 1).loc else Loc.unknown in + add EOF eof_loc; + Array.of_list (List.rev !out) + +(* ── Parsing ───────────────────────────────────────────────────────── *) + +type p = { toks : token array; mutable i : int } + +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 = + let t = peek p in + if t.tok <> EOF then p.i <- p.i + 1; + t +let last p = p.toks.(max 0 (p.i - 1)) + +(* From [l] to the end of the last token consumed. *) +let span p (l : Loc.t) = + let e = (last p).loc in + if e.Loc.eline > l.Loc.line + || (e.Loc.eline = l.Loc.line && e.Loc.ecol > l.Loc.col) + then { l with Loc.eline = e.Loc.eline; ecol = e.Loc.ecol } + else l + +let mk p l v = Form.make v (span p l) +let sym l s = Form.make (Form.Sym s) l + +(* Where a stray token is, pointing at the real token after a layout one. *) +let where_ p = + let t = peek p in + match t.tok with + | NEWLINE | INDENT | DEDENT -> (peek_at p 1).loc + | _ -> t.loc + +let starts_value = function + | NAME _ | KW _ | ATOM _ | DATUM _ | LP | LB | LC | UNQ | SPLICE | NEG -> true + | _ -> false + +let ends_value = function + | RP | RB | RC | COMMA | NEWLINE | EOF | INDENT | DEDENT -> true + | _ -> false + +let negative_literal = function + | ATOM (Form.Int i) -> Int64.compare i 0L < 0 + | ATOM (Form.Float f) -> f < 0. + | _ -> false + +(* Something followed a complete value where nothing may. The two shapes that + get their own sentence are the ones a Lisp hand writes: [a -1] and + [f (x)]. *) +let stray p ~after = + let t = peek p in + match t.tok with + | ATOM _ when t.sp && negative_literal t.tok -> + let text = show t.tok in + let digits = String.sub text 1 (String.length text - 1) in + failk "glued-minus" t.loc + "%s is read as the number %s, right after %s with nothing between them. \ + To subtract, space the minus: %s - %s. For two values, separate them \ + with a comma: %s, %s" + text text after after digits after text + | LP when t.sp -> + failk "spaced-call" t.loc + "there is a space before this (, so it does not call %s — a call has \ + none. Write %s(...), or put a comma before the ( if it is a separate \ + value" + after after + | LB when t.sp -> + failk "spaced-index" t.loc + "there is a space before this [, so it does not index %s — indexing has \ + none. Write %s[i]" + after after + | NEWLINE | INDENT | DEDENT | EOF -> + failk "unexpected-end" (where_ p) "the line ends after %s, which is not \ + finished here" after + | _ -> + failk "unexpected-token" t.loc + "%s follows %s, and two values cannot sit side by side here. Separate \ + them with a comma, or join them with an operator" + (show t.tok) after + +let expect p tok ~what = + let t = peek p in + if t.tok = tok then ignore (advance p) + else + failk "expected" (where_ p) "expected %s here, and found %s" what + (show t.tok) + +let expect_name p s ~what = + match (peek p).tok with + | NAME n when n = s -> ignore (advance p) + | t -> failk "expected" (where_ p) "expected %s here, and found %s" what (show t) + +(* The end of a line that is not followed by a block. *) +let expect_eol p ~after = + match (peek p).tok with + | NEWLINE -> + ignore (advance p); + 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():" + after + | EOF -> () + | _ -> stray p ~after + +let check_name (t : token) s = + if String.contains s ':' then + failk "colon-in-name" t.loc + "%s has a colon inside it, and a name cannot. A type annotation puts a \ + space after the colon: %s" + s + (match String.index_opt s ':' with + | Some i -> String.sub s 0 (i + 1) ^ " " ^ String.sub s (i + 1) (String.length s - i - 1) + | None -> s) + +(* A form's own text, for the "after" half of a message. *) +let text_of (f : Form.t) = + let s = Form.to_source f in + if String.length s > 40 then String.sub s 0 37 ^ "..." else s + +let unclosed p c l0 = + failk "unclosed" l0 + ~notes:[ Loc.note (where_ p) "the input ends here, still inside it" ] + "unclosed %C" c + +let refuse_ws loc e = + failk "separate-elements" loc + "%s has an operator in it and sits in a list separated by spaces, where \ + only single values are. Separate the elements with commas: [a - 1, b]" + (text_of e) + +(* Expressions come back with their syntactic level: 10 an atom or a bracket, + 9 a postfix chain, 8 a unary minus, 1-7 a binary operator's level, 3 a + [not], 0 a one-line [if] or a lambda. Anything under 8 is "compound": it + has an operator at its top, so it cannot sit in a list separated only by + whitespace. *) +let rec expr p : Form.t * int = binary p 1 + +and binary p lvl : Form.t * int = + if lvl = 3 then not_ p + else if lvl > 7 then unary p + else + let l0 = (peek p).loc in + let ((first, _) as fst_) = binary p (lvl + 1) in + let close op operands = + match List.rev operands with + | [ x ] -> (x, lvl) + | ops -> + if op = "!=" && List.length ops > 2 then + failk "chained-not-equal" l0 + "a != b != c is not read. != with more than two values means all \ + of them are distinct, which is not what the chain says, so it is \ + written as a call: !=(a, b, c)"; + (mk p l0 (Form.List (sym l0 (op_sym op) :: ops)), lvl) + in + (* An operator glued to a parenthesis is a call, [+(a, b)], and never + the operator between two values. *) + let binary_here s = + binop_level s = Some lvl + && not ((peek_at p 1).tok = LP && not (peek_at p 1).sp) + in + let rec run op operands = + match (peek p).tok with + | NAME s when binary_here s -> + let ot = advance p in + if not (ot.sp && (peek p).sp) then + failk "unspaced-operator" ot.loc + "%s is an operator here, and a binary operator has a space on each \ + side: a %s b. Without them a-b is one name" + s s; + let rhs, _ = binary p (lvl + 1) in + if s = op then run op (rhs :: operands) + else begin + if lvl = 4 then + failk "mixed-comparison" ot.loc + "%s follows %s in one chain, and a chain compares with one \ + operator. Join the tests with and, or parenthesise one side" + s op; + let folded, _ = close op operands in + run s [ rhs; folded ] + end + | _ -> close op operands + in + (* [run] folds a different operator at the same level into the left + operand, so the first operator here only starts the first run. *) + match (peek p).tok with + | NAME s when binary_here s -> run s [ first ] + | _ -> fst_ + +and not_ p = + let t = peek p in + match t.tok with + | NAME "not" when (peek_at p 1).sp && starts_value (peek_at p 1).tok -> + ignore (advance p); + let x, _ = not_ p in + (mk p t.loc (Form.List [ sym t.loc "not"; x ]), 3) + | _ -> binary p 4 + +and unary p = + let t = peek p in + match t.tok with + | NEG -> + ignore (advance p); + let x, _ = postfix p in + (mk p t.loc (Form.List [ sym t.loc "-"; x ]), 8) + | _ -> postfix p + +and postfix p = + let l0 = (peek p).loc in + let rec loop ((f, _) as fp) = + let t = peek p in + if t.sp then fp + else + match t.tok with + | LP -> + ignore (advance p); + let args = items p RP t.loc ~what:"arguments" in + loop (mk p l0 (Form.List (f :: args)), 9) + | LB -> + ignore (advance p); + let idx = items p RB t.loc ~what:"indices" in + loop (mk p l0 (Form.List (sym t.loc "at" :: f :: idx)), 9) + | NAME s when String.length s > 1 && s.[0] = '.' -> + ignore (advance p); + loop (mk p l0 (Form.List [ sym t.loc s; f ]), 9) + | LC -> + ignore (advance p); + let m = map_items p t.loc in + loop (mk p l0 (Form.List [ f; Form.make (Form.Map m) (span p t.loc) ]), 9) + | _ -> fp + in + loop (primary p) + +and primary p : Form.t * int = + let t = peek p in + let l0 = t.loc in + match t.tok with + | NAME s -> + let nxt = peek_at p 1 in + let glued_lp = nxt.tok = LP && not nxt.sp in + if s = "if" && nxt.sp && starts_value nxt.tok then if_expr p + else if s = "fn" && glued_lp then fn_expr p + else if is_op_word s then begin + if glued_lp || ends_value nxt.tok then begin + ignore (advance p); + (sym l0 (op_sym s), 10) + end + else + failk "operator-operand" l0 + "%s is an operator, and nothing is on its left. As a value on its \ + own it goes before a comma or a closing bracket, reduce(%s, xs); \ + as a call it is glued to its parenthesis, %s(a, b)" + s s s + end + else begin + ignore (advance p); + check_name t s; + (sym l0 s, 10) + end + | KW k -> ignore (advance p); (Form.make (Form.Kw k) l0, 10) + | ATOM v -> + ignore (advance p); + (Form.make v l0, if negative_literal t.tok then 8 else 10) + | DATUM f -> ignore (advance p); (f, 10) + | LP -> + ignore (advance p); + if (peek p).tok = RP then begin + ignore (advance p); + (mk p l0 (Form.List []), 10) + end + else + let e, _ = expr p in + (match (peek p).tok with + | RP -> ignore (advance p) + | EOF -> unclosed p '(' l0 + | _ -> stray p ~after:(text_of e)); + (e, 10) + | LB -> + ignore (advance p); + let xs = vec_items p l0 in + (mk p l0 (Form.Vec xs), 10) + | LC -> + ignore (advance p); + let xs = map_items p l0 in + (mk p l0 (Form.Map xs), 10) + | UNQ | SPLICE -> + ignore (advance p); + let x, _ = primary p in + let name = if t.tok = UNQ then "unquote" else "unquote-splicing" in + (mk p l0 (Form.List [ sym l0 name; x ]), 10) + | NEG -> unary p + | tk -> + failk "expected-value" (where_ p) "expected a value here, and found %s" + (show tk) + +(* [if c then a else b]: the one-line form, for a value. *) +and if_expr p = + let t = advance p in + let c, _ = binary p 1 in + (match (peek p).tok with + | NAME "then" -> ignore (advance p) + | _ -> + failk "if-then" (where_ p) + "an if inside a line is if c then a else b, and there is no then \ + after %s. Write the then, or start the if on its own line with its \ + branches indented under it" + (text_of c)); + let a, _ = binary p 1 in + match (peek p).tok with + | NAME "else" -> + ignore (advance p); + let b, _ = expr p in + (mk p t.loc (Form.List [ sym t.loc "if"; c; a; b ]), 0) + | _ -> (mk p t.loc (Form.List [ sym t.loc "when"; c; a ]), 0) + +(* [fn(a, b) = body] is a lambda; [fn(...)] followed by anything else is the + fallback call spelling of [(fn ...)]. *) +and fn_expr p = + let t = advance p in + let lp = advance p in + let args = items p RP lp.loc ~what:"parameters" in + match (peek p).tok with + | NAME "=" -> + ignore (advance p); + let ps = lambda_params args in + let body, _ = expr p 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) + +and span_of_list l args = + match List.rev args with + | [] -> l + | (x : Form.t) :: _ -> { l with Loc.eline = x.loc.Loc.eline; ecol = x.loc.Loc.ecol } + +and lambda_params args = + List.map + (fun (a : Form.t) -> + match a.v with + | Form.Sym _ -> a + | _ -> + failk "lambda-param" a.loc + "a lambda's parameter is a name, and this is %s. Take the value \ + under a name and destructure it in the body" + (text_of a)) + args + +(* Comma-separated values up to [closer]. [const T] is two elements without a + comma, for [Ptr(const u8)]: const is a reserved word in a type and never a + value. *) +and items p closer open_loc ~what = + let opener = if closer = RB then '[' else '(' in + let rec go acc = + let t = peek p in + if t.tok = closer then (ignore (advance p); List.rev acc) + else if t.tok = EOF then unclosed p opener open_loc + else + match t.tok, peek_at p 1 with + | NAME "const", n when n.sp && starts_value n.tok -> + ignore (advance p); + go (sym t.loc "const" :: acc) + | _ -> + let e, _ = expr p in + (match (peek p).tok with + | COMMA -> ignore (advance p); go (e :: acc) + | tk when tk = closer -> ignore (advance p); List.rev (e :: acc) + | EOF -> unclosed p opener open_loc + | _ -> + let n = peek p in + 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)" + (show n.tok) (text_of e) what + else stray p ~after:(text_of e)) + in + go [] + +(* [[a b c]] or [[a, b + 1]]: whitespace separates only single terms. *) +and vec_items p open_loc = + let rec go acc prev_ws = + let t = peek p in + match t.tok with + | RB -> ignore (advance p); List.rev acc + | EOF -> unclosed p '[' open_loc + | _ -> + let e, lvl = expr p in + if lvl < 8 && prev_ws then refuse_ws t.loc e; + (match (peek p).tok with + | COMMA -> ignore (advance p); go (e :: acc) false + | RB -> ignore (advance p); List.rev (e :: acc) + | EOF -> unclosed p '[' open_loc + | tk when starts_value tk && (peek p).sp -> + if lvl < 8 then refuse_ws t.loc e; + go (e :: acc) true + | _ -> stray p ~after:(text_of e)) + in + go [] false + +(* Braces pair a key with a value, so a value may be any expression; after + one that has an operator in it, the next entry needs a comma. *) +and map_items p open_loc = + let rec go acc = + let t = peek p in + match t.tok with + | RC -> ignore (advance p); List.rev acc + | EOF -> unclosed p '{' open_loc + | _ -> + let e, lvl = expr p in + (match (peek p).tok with + | COMMA -> ignore (advance p); go (e :: acc) + | RC -> ignore (advance p); List.rev (e :: acc) + | EOF -> unclosed p '{' open_loc + | tk when starts_value tk && (peek p).sp -> + if lvl < 8 then refuse_ws t.loc e; + go (e :: acc) + | _ -> stray p ~after:(text_of e)) + in + go [] + + +(* A type after [:] or [->]: a postfix term, plus the arrow of a function + type, [Fn(A, B) -> R], which reads as [(Fn [A B] R)]. *) +let rec ty p : Form.t = + let l0 = (peek p).loc in + let f, _ = postfix p in + match f.v, (peek p).tok with + | Form.List (({ v = Form.Sym ("Fn" | "CFn"); _ } as h) :: args), NAME "->" + when (last p).tok = RP -> + ignore (advance p); + let r = ty p in + mk p l0 (Form.List [ h; Form.make (Form.Vec args) h.loc; r ]) + | _ -> f + +(* ── Statements ────────────────────────────────────────────────────── *) + +(* The let-statements this reader built, so that a [let] whose whole body is + another one merges into one binding vector (spec §2), and a [let] written + as a call does not. *) +type st = { p : p; mutable lets : Form.t list } + +let blk (s : st) l (ss : Form.t list) = + match ss with + | [ x ] -> x + | _ -> mk s.p l (Form.List (sym l "do" :: ss)) + +let is_lambda_candidate (e : Form.t) = + match e.v with + | Form.List ({ v = Form.Sym "fn"; _ } :: args) -> + List.for_all (fun (a : Form.t) -> match a.v with Form.Sym _ -> true | _ -> false) args + | _ -> false + +let header_follow p s = + let n = peek_at p 1 in + let plain_name = function + | NAME x -> not (is_op_word x || x = "=" || List.mem_assoc x assign_ops) + | _ -> false + in + match s with + | "fn" | "fn-" | "def" | "once" | "const" | "struct" | "union" | "data" + | "enum" | "import" -> + n.sp && plain_name n.tok + | "if" | "while" | "until" | "match" | "let" | "for" -> + n.sp && starts_value n.tok + && (match n.tok with + | NAME x when x = "=" || List.mem_assoc x assign_ops -> false + | NAME x when is_binop x -> + let a = peek_at p 2 in + a.tok = LP && not a.sp + | _ -> true) + | "return" -> n.tok = NEWLINE || (n.sp && starts_value n.tok) + | "break" | "continue" -> + n.tok = NEWLINE || (n.sp && (match n.tok with KW _ -> true | _ -> false)) + | "defer" -> + (n.tok = NEWLINE && (peek_at p 2).tok = INDENT) || (n.sp && starts_value n.tok) + | "handler-case" | "handler-bind" | "restart-case" -> n.tok = NEWLINE + | "quote" -> n.tok = NEWLINE && (peek_at p 2).tok = INDENT + | _ -> false + +let name_tok p ~what = + let t = peek p in + match t.tok with + | NAME s when not (String.length s > 0 && s.[0] = '.') -> + ignore (advance p); + check_name t s; + sym t.loc s + | tk -> failk "expected-name" (where_ p) "expected %s here, and found %s" what (show tk) + +let glued_lp p ~what = + let t = peek p in + if t.tok = LP && not t.sp then advance p + else failk "expected" (where_ p) "expected %s here, and found %s" what (show t.tok) + +(* [(a: i32, b)] as name/type pairs, [dyn] written out for the untyped: the + reader never leaves a vector for [Check.pair_params] to guess at. *) +let params p (lp : token) = + let rec go acc = + let t = peek p in + match t.tok with + | RP -> ignore (advance p); List.rev acc + | EOF -> unclosed p '(' lp.loc + | _ -> + let n = name_tok p ~what:"a parameter's name" in + let tyf = + match (peek p).tok with + | COLON -> ignore (advance p); ty p + | _ -> sym n.loc "dyn" + in + (match (peek p).tok with + | COMMA -> ignore (advance p) + | RP -> () + | _ -> stray p ~after:(text_of tyf)); + go (tyf :: n :: acc) + in + go [] + +let rec stmts (s : st) : Form.t list = + let p = s.p in + match (peek p).tok with + | DEDENT -> ignore (advance p); [] + | EOF -> [] + | NAME "let" when header_follow p "let" -> let_stmt s + | _ -> + let f = stmt s in + f :: stmts s + +and block (s : st) ~after : Form.t list = + let p = s.p in + match (peek p).tok with + | INDENT -> ignore (advance p); stmts s + | _ -> + failk "expected-block" (where_ p) + "%s takes an indented block on the lines under it, and the next line is \ + not indented" + after + +(* The rest of a line read as a value, through its end: [= v], or [=] and an + indented block that reduces to one form, or a lambda with a block body. *) +and value_line ?(block_ok = false) (s : st) ~after : Form.t = + let p = s.p in + let l0 = where_ p in + if (peek p).tok = NEWLINE && (peek_at p 1).tok = INDENT then begin + ignore (advance p); + blk s l0 (block s ~after) + end + else + let e, _ = expr p in + lambda_block ~block_ok s e ~after:(text_of e) + +and lambda_block ?(block_ok = false) (s : st) (e : Form.t) ~after = + let p = s.p in + if is_lambda_candidate e && (last p).tok = RP && (peek p).tok = NEWLINE + && (peek_at p 1).tok = INDENT + then begin + ignore (advance p); + let body = block s ~after in + match e.v with + | Form.List (h :: args) -> + mk p e.loc + (Form.List (h :: Form.make (Form.Vec args) (span_of_list e.loc args) :: body)) + | _ -> assert false + end + else begin + if block_ok && (peek p).tok = NEWLINE then ignore (advance p) + else expect_eol p ~after; + e + end + +and let_stmt (s : st) : Form.t list = + let p = s.p in + let t = advance p in + let target, _ = unary p in + (match (peek p).tok with + | NAME "=" -> ignore (advance p) + | _ -> + failk "let-equals" (where_ p) + "a let is let name = value, and %s is not followed by =" (text_of target)); + let v = value_line ~block_ok:true s ~after:("let " ^ text_of target) in + let make bindings body = + let f = + mk p t.loc + (Form.List + (sym t.loc "let" :: Form.make (Form.Vec bindings) (span_of_list target.loc bindings) + :: body)) + in + s.lets <- f :: s.lets; + f + in + let merged body = + match body with + | [ ({ Form.v = Form.List (_ :: { v = Form.Vec bs; _ } :: body); _ } as inner) ] + when List.memq inner s.lets -> + make (target :: v :: bs) body + | _ -> make [ target; v ] body + in + if (peek p).tok = INDENT then begin + let f = merged (block s ~after:"let") in + f :: stmts s + end + else [ merged (stmts s) ] + +and stmt (s : st) : Form.t = + let p = s.p in + let t = peek p in + match t.tok with + | NAME w when header_follow p w -> header s 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 \ + the if it belongs to, right after that if's block" + w + | _ -> expr_stmt s + +and expr_stmt (s : st) : Form.t = + let p = s.p in + let i0 = p.i in + let t0 = peek p in + let e, _ = expr p in + match (peek p).tok with + | NAME "=" -> + let eq = advance p in + let v = value_line s ~after:(text_of e ^ " =") in + mk p t0.loc (Form.List [ sym eq.loc "set"; e; v ]) + | NAME op when List.mem_assoc op assign_ops -> + let eq = advance p in + let v = value_line s ~after:(text_of e ^ " " ^ op) in + let o = List.assoc op assign_ops in + mk p t0.loc + (Form.List + [ sym eq.loc "set"; e; + Form.make (Form.List [ sym eq.loc o; e; v ]) (span p e.loc) ]) + | COLON -> + let before = (last p).tok in + let c = advance p in + (match e.v, before with + | Form.List (_ :: _), RP -> () + | _ -> + failk "colon-block" c.loc + "a trailing colon gives a call an indented block, and %s is not a \ + call. Write it as one, as in %s():" + (text_of e) (text_of e)); + (match (peek p).tok with + | NEWLINE -> ignore (advance p) + | _ -> stray p ~after:":"); + let body = block s ~after:(text_of e ^ ":") in + (match e.v with + | Form.List items -> mk p t0.loc (Form.List (items @ body)) + | _ -> assert false) + | _ -> + (* [()] alone on a line is the empty statement, spec §2 "Unit". *) + let e = + 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 + in + lambda_block s e ~after:(text_of e) + +and header (s : st) w : Form.t = + let p = s.p in + let t = advance p in + let l0 = t.loc in + let form items = mk p l0 (Form.List (sym l0 w :: items)) in + let named head items = mk p l0 (Form.List (sym l0 head :: items)) in + match w with + | "fn" | "fn-" -> + let name = name_tok p ~what:"the function's name" in + let lp = glued_lp p ~what:"the parameters, in parentheses glued to the name" in + let ps = params p lp in + let rp = last p in + let ret = + match (peek p).tok with + | NAME "->" -> ignore (advance p); ty p + | _ -> + let n = match name.v with Form.Sym n -> n | _ -> "" in + failk "return-type" rp.loc + "fn %s has no return type after its parameters, and a .fln \ + function states one for now. Write it after an arrow: fn %s(...) \ + -> i32, or -> dyn, or -> () when it returns nothing" + n n + in + let where_clause = + match (peek p).tok with + | NAME "where" -> + let wt = advance p in + let rec preds acc = + let e, _ = expr p in + match (peek p).tok with + | COMMA -> ignore (advance p); preds (e :: acc) + | _ -> List.rev (e :: acc) + in + let es = preds [] in + let v = + match es with + | [ e ] -> e + | _ -> Form.make (Form.Vec es) (span p wt.loc) + in + [ mk p wt.loc (Form.Map [ Form.make (Form.Kw "where") wt.loc; v ]) ] + | _ -> [] + in + let body = + match (peek p).tok with + | NAME "=" -> + ignore (advance p); + if (peek p).tok = NEWLINE && (peek_at p 1).tok = INDENT then begin + ignore (advance p); + block s ~after:"fn" + end + else [ value_line s ~after:"=" ] + | NEWLINE -> + ignore (advance p); + if (peek p).tok = INDENT then block s ~after:"fn" else [] + | _ -> stray p ~after:(text_of ret) + in + named (if w = "fn" then "defn" else "defn-") + (name :: Form.make (Form.Vec ps) lp.loc :: ret :: (where_clause @ body)) + | "def" | "once" | "const" -> + let name = name_tok p ~what:"the name being defined" in + let tyf = + match (peek p).tok with + | COLON -> ignore (advance p); Some (ty p) + | _ -> None + in + let v = + match (peek p).tok with + | NAME "=" -> + ignore (advance p); + Some (value_line s ~after:(w ^ " " ^ text_of name ^ " =")) + | _ -> + expect_eol p ~after:(match tyf with Some f -> text_of f | None -> text_of name); + None + in + let head = + match w with "def" -> "def" | "once" -> "defonce" | _ -> "defconst" + in + let items = + match w, tyf, v with + | "const", None, Some v -> [ name; v ] + | "const", Some t, Some v -> [ name; t; v ] + | "const", _, None -> + failk "const-value" l0 + "a const needs its value: const %s = 3" (text_of name) + | _, None, Some v -> [ name; sym name.loc "dyn"; v ] + | _, Some t, None -> [ name; t ] + | _, Some t, Some v -> [ name; t; v ] + | _, None, None -> + failk "def-empty" l0 + "%s %s names neither a type nor a value. Give it one or both: %s %s: \ + i32 = 0" + w (text_of name) w (text_of name) + in + named head items + | "struct" | "union" -> + let name = name_tok p ~what:"the type's name" in + expect_eol_block p ~after:(w ^ " " ^ text_of name); + let fields = + lines s (fun () -> + let f = name_tok p ~what:"a field's name" in + let tf = + match (peek p).tok with + | COLON -> ignore (advance p); ty p + | _ -> sym f.loc "dyn" + in + expect_eol p ~after:(text_of tf); + [ f; tf ]) + in + named (if w = "struct" then "defstruct" else "defunion") + [ name; Form.make (Form.Vec fields) (span p name.loc) ] + | "data" -> + let name = name_tok p ~what:"the type's name" in + expect_eol_block p ~after:("data " ^ text_of name); + let cases = + lines s (fun () -> + let c = name_tok p ~what:"a case's name" in + let f = + match (peek p).tok with + | LP when not (peek p).sp -> + let lp = advance p in + let ps = params p lp in + mk p c.loc (Form.List [ c; Form.make (Form.Vec ps) lp.loc ]) + | _ -> c + in + expect_eol p ~after:(text_of f); + [ f ]) + in + named "defdata" [ name; Form.make (Form.Vec cases) (span p name.loc) ] + | "enum" -> + let name = name_tok p ~what:"the enum's name" in + expect_eol_block p ~after:("enum " ^ text_of name); + let members = + lines s (fun () -> + let m = name_tok p ~what:"a member's name" in + match (peek p).tok with + | NAME "=" -> + ignore (advance p); + let v, _ = unary p in + expect_eol p ~after:(text_of v); + [ m; v ] + | _ -> expect_eol p ~after:(text_of m); [ m ]) + in + named "defenum" [ name; Form.make (Form.Vec members) (span p name.loc) ] + | "import" -> + let alias = name_tok p ~what:"the package's alias" in + let path = + match (peek p).tok with + | ATOM (Form.Str _ as v) -> let pt = advance p in Form.make v pt.loc + | tk -> + failk "import-path" (where_ p) + "an import is import alias \"collection:path\", and found %s where \ + the path goes" + (show tk) + in + expect_eol p ~after:(text_of path); + form [ alias; path ] + | "if" -> + let c, _ = binary p 1 in + (match (peek p).tok with + | NAME "then" -> + ignore (advance p); + let a, _ = binary p 1 in + let f = + match (peek p).tok with + | NAME "else" -> + ignore (advance p); + let b, _ = expr p in + form [ c; a; b ] + | _ -> named "when" [ c; a ] + in + expect_eol p ~after:(text_of f); + f + | _ -> + 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 + 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))) + | "while" | "until" -> + let label = + match (peek p).tok, (peek_at p 1).tok with + | KW k, n when n <> NEWLINE -> let kt = advance p in [ Form.make (Form.Kw k) kt.loc ] + | _ -> [] + in + let c, _ = expr p in + expect_line_end p ~after:(w ^ " " ^ text_of c); + let body = block s ~after:w in + form (label @ (c :: body)) + | "for" -> + let label = + match (peek p).tok with + | 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 + 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)"; + let lp = glued_lp p ~what:"range's bounds in parentheses" in + let bs = items p RP lp.loc ~what:"bounds" in + if bs = [] || List.length bs > 3 then + failk "range-arity" rt.loc + "range takes one, two or three bounds: range(stop), range(start, stop) \ + or range(start, stop, step)"; + expect_line_end p ~after:"range(...)"; + let body = block s ~after:"for" in + named "dotimes" + (label @ (Form.make (Form.Vec (v :: bs)) (span_of_list v.loc bs) :: body)) + | "return" -> + (match (peek p).tok with + | NEWLINE -> expect_eol p ~after:"return"; form [] + | _ -> + let e, _ = expr p in + expect_eol p ~after:(text_of e); + form [ e ]) + | "break" | "continue" -> + (match (peek p).tok with + | KW k -> + let kt = advance p in + expect_eol p ~after:(":" ^ k); + form [ Form.make (Form.Kw k) kt.loc ] + | _ -> expect_eol p ~after:w; form []) + | "defer" -> + (match (peek p).tok with + | NEWLINE -> + ignore (advance p); + form (block s ~after:"defer") + | _ -> + let e, _ = expr p in + expect_eol p ~after:(text_of e); + form [ e ]) + | "match" -> + let scrut, _ = expr p in + expect_eol_block p ~after:("match " ^ text_of scrut); + let arms = + lines s (fun () -> + let pat, _ = unary p in + expect_name p "->" ~what:"-> and the arm's value"; + let body = + if (peek p).tok = NEWLINE && (peek_at p 1).tok = INDENT then begin + let nl = advance p in + blk s nl.loc (block s ~after:"->") + end + else begin + let e, _ = expr p in + expect_eol p ~after:(text_of e); + e + end + in + [ pat; body ]) + in + form (scrut :: arms) + | "handler-case" | "handler-bind" -> + expect_line_end p ~after:w; + let body = block s ~after:w in + let rec clauses acc = + match (peek p).tok, (peek_at p 1) with + | NAME "on", n when n.sp -> + let ot = advance p in + let head, _ = postfix p in + let ty, var = + match head.v with + | Form.List [ ty; ({ v = Form.Sym _; _ } as var) ] -> (ty, var) + | _ -> + failk "on-clause" head.loc + "a handler clause is on Type(name), naming the condition type \ + and the name it is bound to, as in on FileError(c)" + in + expect_line_end p ~after:("on " ^ text_of head); + let b = block s ~after:"on" in + let c = + mk p ot.loc + (Form.List (ty :: Form.make (Form.Vec [ var ]) var.loc :: b)) + in + clauses (c :: acc) + | _ -> List.rev acc + in + let cs = clauses [] in + let vec = Form.make (Form.Vec cs) (span p l0) in + if w = "handler-case" then form [ blk s l0 body; vec ] + else form (vec :: body) + | "restart-case" -> + expect_line_end p ~after:w; + let body = block s ~after:w in + let rec clauses acc = + match (peek p).tok, (peek_at p 1) with + | NAME "restart", n when n.sp -> + ignore (advance p); + 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 + expect_line_end p ~after:("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)) + in + clauses (c :: acc) + | _ -> List.rev acc + in + let cs = clauses [] in + form (blk s l0 body :: cs) + | "quote" -> + expect_line_end p ~after:"quote"; + let body = block s ~after:"quote" in + named "quasiquote" [ blk s l0 body ] + | _ -> assert false + +(* The end of a header line whose block must follow. *) +and expect_line_end p ~after = + match (peek p).tok with + | NEWLINE -> ignore (advance p) + | _ -> stray p ~after + +and expect_eol_block p ~after = + expect_line_end p ~after + +(* An indented run of one-line entries — a struct's fields, a match's arms. + None at all is allowed for the declarations and is refused later, by the + form, where it matters. *) +and lines (s : st) (one : unit -> Form.t list) : Form.t list = + let p = s.p in + if (peek p).tok <> INDENT then [] + else begin + ignore (advance p); + let rec go acc = + match (peek p).tok with + | DEDENT -> ignore (advance p); List.rev acc + | EOF -> List.rev acc + | _ -> go (List.rev_append (one ()) acc) + in + go [] + end + +(** All top-level forms in a [.fln] source string. [col] is the column the + text's top level starts at, 1 for a file. *) +let read_all ?(col = 1) ~file src = + let toks = layout ~base:col (lex ~file src) in + let s = { p = { toks; i = 0 }; lets = [] } in + let fs = stmts s in + (match (peek s.p).tok with + | EOF -> () + | tk -> failk "unexpected-token" (where_ s.p) "unexpected %s" (show tk)); + fs + +let read_file path = + let ic = open_in_bin path in + Fun.protect ~finally:(fun () -> close_in ic) (fun () -> + let n = in_channel_length ic in + read_all ~file:path (really_input_string ic n)) diff --git a/lib/load.ml b/lib/load.ml index 040ac95c..55c6b489 100644 --- a/lib/load.ml +++ b/lib/load.ml @@ -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]. diff --git a/lib/session.ml b/lib/session.ml index 9a5ea5dd..6cac3334 100644 --- a/lib/session.ml +++ b/lib/session.ml @@ -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 diff --git a/lib/source.ml b/lib/source.ml new file mode 100644 index 00000000..541f9fc6 --- /dev/null +++ b/lib/source.ml @@ -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 diff --git a/spec-syntax.md b/spec-syntax.md index 4800e773..e4d50942 100644 --- a/spec-syntax.md +++ b/spec-syntax.md @@ -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) diff --git a/test/dune b/test/dune index 48c41582..ac95f19b 100644 --- a/test/dune +++ b/test/dune @@ -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 diff --git a/test/syntax/algorithms.flan b/test/syntax/algorithms.flan new file mode 100644 index 00000000..c99ccb33 --- /dev/null +++ b/test/syntax/algorithms.flan @@ -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") + :-) diff --git a/test/syntax/algorithms.fln b/test/syntax/algorithms.fln new file mode 100644 index 00000000..eaaa4d7a --- /dev/null +++ b/test/syntax/algorithms.fln @@ -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") + :- diff --git a/test/syntax/mixed/geo/geo.flan b/test/syntax/mixed/geo/geo.flan new file mode 100644 index 00000000..666d3d96 --- /dev/null +++ b/test/syntax/mixed/geo/geo.flan @@ -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)))) diff --git a/test/syntax/mixed/main.flan b/test/syntax/mixed/main.flan new file mode 100644 index 00000000..d05e9a6d --- /dev/null +++ b/test/syntax/mixed/main.flan @@ -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) diff --git a/test/syntax/mixed/main.fln b/test/syntax/mixed/main.fln new file mode 100644 index 00000000..d03e1649 --- /dev/null +++ b/test/syntax/mixed/main.fln @@ -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 diff --git a/test/syntax/mixed/shapes/shapes.fln b/test/syntax/mixed/shapes/shapes.fln new file mode 100644 index 00000000..5917a8b2 --- /dev/null +++ b/test/syntax/mixed/shapes/shapes.fln @@ -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 diff --git a/test/syntax/sand.fln b/test/syntax/sand.fln new file mode 100644 index 00000000..1efab947 --- /dev/null +++ b/test/syntax/sand.fln @@ -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() diff --git a/test/test_syntax.ml b/test/test_syntax.ml new file mode 100644 index 00000000..54fb145a --- /dev/null +++ b/test/test_syntax.ml @@ -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:"" 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" () From 074b2da6f39abc04e04b0ea4c97474725a81c7d4 Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Fri, 25 Sep 2026 15:30:52 +0700 Subject: [PATCH 2/2] The indented reader refuses a continuation line that is not deeper than its statement, takes one-line statements in arms, then/else and defer, typed lets and bare-name blocks, and names the shape it wanted where it used to say two values cannot sit side by side --- bin/main.ml | 3 +- lib/check.ml | 26 +++++ lib/indent_printer.ml | 154 +++++++++++++++++++++++---- lib/indent_reader.ml | 237 ++++++++++++++++++++++++++++++++++++------ lib/load.ml | 14 +++ spec-syntax.md | 8 +- test/test_syntax.ml | 91 +++++++++++++++- 7 files changed, 475 insertions(+), 58 deletions(-) diff --git a/bin/main.ml b/bin/main.ml index 39e523ef..306e2373 100644 --- a/bin/main.ml +++ b/bin/main.ml @@ -338,7 +338,8 @@ let () = (String.concat "\n\n" (List.map (fun f -> Flan.Form.pretty f) forms) ^ "\n") else - match Flan.Indent_printer.program forms with + let source = In_channel.with_open_bin path In_channel.input_all in + match Flan.Indent_printer.program ~source forms with | text -> print_string text | exception Flan.Indent_printer.Unprintable (f, why) -> Flan.Loc.failk "convert/unprintable" f.Flan.Form.loc diff --git a/lib/check.ml b/lib/check.ml index ee0c4daf..7a300980 100644 --- a/lib/check.ml +++ b/lib/check.ml @@ -7144,6 +7144,32 @@ and unknown_name : 'a. ?setting:bool -> ctx -> Loc.t -> string -> 'a = (match no_such_rand name with | Some msg -> Loc.failk "check/unknown-name" loc "%s" msg | None -> ()); + (* In the indented syntax a binary operator needs spaces, so [x-1], [i+1] + and [x/2] are one name each. When the parts either side of an operator + character are a value in scope and a number or another value, that is + almost certainly the arithmetic, and the sentence says how to spell it. *) + (if Filename.check_suffix loc.Loc.file ".fln" then begin + let known s = + s <> "" + && (String.for_all (fun c -> (c >= '0' && c <= '9') || c = '.') s + || lookup ctx s <> None + || Hashtbl.mem ctx.env.globals s) + in + let n = String.length name in + let rec scan i = + if i < n - 1 then + match name.[i] with + | ('-' | '+' | '*' | '/') as c + when i > 0 && known (String.sub name 0 i) + && known (String.sub name (i + 1) (n - i - 1)) -> + Loc.failk "check/unknown-name" loc + "unknown name %s — an operator needs a space on each side, so \ + this is one name and not arithmetic. Did you mean %s %c %s?" + name (String.sub name 0 i) c (String.sub name (i + 1) (n - i - 1)) + | _ -> scan (i + 1) + in + scan 0 + end); let dot = String.index_opt name '.' in let head, field = match dot with diff --git a/lib/indent_printer.ml b/lib/indent_printer.ml index 9132c1f3..c7444155 100644 --- a/lib/indent_printer.ml +++ b/lib/indent_printer.ml @@ -50,6 +50,18 @@ let def_name s = name_ok s && s.[0] <> '.' let paren s = "(" ^ s ^ ")" +(* A number's own spelling, when the caller has the text it was read from: + [Form.Int] keeps only the value, so without this 0xFFF00FFF would print + as 4293922815. Set by [program ~source]. *) +let spelling : (Form.t -> string option) ref = ref (fun _ -> None) + +(* The same form, locations aside. *) +let rec same (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 same x y + | x, y -> x = y + let is_sym s (f : Form.t) = match f.v with Form.Sym x -> x = s | _ -> false (* ── Expressions ───────────────────────────────────────────────────── *) @@ -62,10 +74,12 @@ let rec expr (f : Form.t) : string * int = | 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.Int i -> + let t = Option.value (!spelling f) ~default:(Int64.to_string i) in + (t, if t.[0] = '-' then 8 else 10) | Form.UInt (_, s) -> (s, 10) | Form.Float x -> - let s = Form.float_repr x in + let s = Option.value (!spelling f) ~default:(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"; @@ -167,9 +181,30 @@ and list _f h args = | 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) + ("if " ^ at 1 c ^ " then " ^ inline_text ~lvl:1 a ^ " else " ^ inline_text b, 0) | _ -> call () +(* A one-line slot's text — an arm's value, a then or an else, what follows + defer: the statements that fit on a line are written as statements, + 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 + | 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 -> + w ^ " :" ^ k + | Form.List [ { v = Form.Sym "return"; _ }; v ] -> "return " ^ at (max lvl 1) v + | Form.List [ { v = Form.Sym "set"; _ }; t; v ] -> assign_text ~lvl t v + | _ -> at lvl f + +(* [t = v], or [t += w] when [v] is [(+ t w)]. *) +and assign_text ?(lvl = 0) t v = + let tt = at 9 t in + match v.v with + | Form.List [ { v = Form.Sym (("+" | "-" | "*" | "/") as op); _ }; a; w ] when same a t -> + tt ^ " " ^ op ^ "= " ^ at (max lvl 1) w + | _ -> tt ^ " = " ^ at (max lvl 1) v + and sym_param (p : Form.t) = match p.v with Form.Sym s -> name_ok s | _ -> false @@ -253,15 +288,33 @@ let body_split (h : Form.t) args = | "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 + | _ -> + (* A with- macro, or any call whose last argument is a statement — + a let, a loop, an assignment — has a body: the trailing run of + lists goes in the block. *) + let stmt_like (a : Form.t) = + match a.v with + | Form.List ({ v = Form.Sym h; _ } :: _) -> + List.mem h [ "let"; "set"; "when"; "unless"; "cond"; "while"; + "until"; "dotimes"; "match"; "handler-case"; + "handler-bind"; "restart-case"; "return"; "defer"; + "do"; "break"; "continue" ] + | _ -> false + in + let is_with = String.length base > 5 && String.sub base 0 5 = "with-" in + let last_stmt = + match List.rev args with a :: _ -> stmt_like a | [] -> false in ignore lead; - Some (leading 0 args) - | _ -> None) + 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) | _ -> None let sugar_heads = @@ -297,7 +350,14 @@ and plain n (f : Form.t) : string list = | 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 + let opener = + match h.v, fixed with + (* 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 ^ ":" + | _ -> head_text h ^ "(" ^ commas fixed ^ "):" + in + [ ind n ^ guard opener ] @ block (n + 2) rest | _ when n + String.length text > width && fst (expr f) = text -> wrapped n "" f | _ -> one) @@ -342,7 +402,13 @@ and wrapped n prefix (f : Form.t) = 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 ] + let is_do = + match v.v with + | Form.List ({ v = Form.Sym "do"; _ } :: _ :: _ :: _) -> true + | _ -> false + in + if is_do then [ ind n ^ prefix ^ " =" ] @ block (n + 2) (stmts_of v) + else 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)) @@ -368,10 +434,13 @@ and sugar n ~last (f : Form.t) : string list option = | 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) + let line = i ^ guard (assign_text t v) in + if String.length line <= width then Some [ line ] + else 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 ("return" | "set" | "break" | "continue"); _ } :: _) -> true | Form.List ({ v = Form.Sym h; _ } :: _) -> not (List.mem h sugar_heads) | _ -> true in @@ -422,7 +491,7 @@ and sugar n ~last (f : Form.t) : string list option = when kw_ok k -> Some [ i ^ w ^ " :" ^ k ] | Form.List [ { v = Form.Sym "defer"; _ }; x ] -> - let line = i ^ "defer " ^ at 0 x in + let line = i ^ "defer " ^ inline_text 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)) -> @@ -436,8 +505,10 @@ and sugar n ~last (f : Form.t) : string list option = :: List.concat_map (fun (pat, body) -> let pt = at 8 pat in - let line = ind (n + 2) ^ pt ^ " -> " ^ at 0 body in + let line = ind (n + 2) ^ pt ^ " -> " ^ inline_text body in match body.v with + | Form.List ({ v = Form.Sym "do"; _ } :: _ :: _ :: _) -> + (ind (n + 2) ^ pt ^ " ->") :: slot (n + 4) body | Form.List (_ :: _) when String.length line > width -> (ind (n + 2) ^ pt ^ " ->") :: slot (n + 4) body | _ -> [ line ]) @@ -576,22 +647,61 @@ and handler_clauses n cls = 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 + (* [(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 -> + ("let " ^ x ^ ": " ^ ty ty_, w) + | _ -> ("let " ^ guard (at 8 t), v) + in if last then - List.concat_map (fun (t, v) -> value_lines n (target t) v) prs @ block n body + List.concat_map (fun b -> let p, v = bind b in value_lines n p 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 + | b :: rest -> + let p, v = bind b in + (ind n ^ p ^ " = " ^ at 0 v) + :: (List.concat_map (fun b -> let p, v = bind b in value_lines (n + 2) p 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 program ?source (fs : Form.t list) : string = + (* With the text the forms were read from, a number keeps its spelling: + the text under its span, when that reads back to the same value. *) + let lines = + match source with + | Some src -> Array.of_list (String.split_on_char '\n' src) + | None -> [||] + in + spelling := + (fun (f : Form.t) -> + let l = f.loc in + if l.Loc.line < 1 || l.Loc.line > Array.length lines || l.Loc.eline <> l.Loc.line + then None + else + let text = lines.(l.Loc.line - 1) in + let a = l.Loc.col - 1 and b = l.Loc.ecol - 1 in + if a < 0 || b > String.length text || b <= a then None + else + let t = String.sub text a (b - a) in + match f.v with + | Form.Int i when Int64.of_string_opt t = Some i -> Some t + | Form.Float x + when String.exists (fun c -> c = '.' || c = 'e' || c = 'E') t + && (match float_of_string_opt t with + | Some y -> Int64.equal (Int64.bits_of_float x) (Int64.bits_of_float y) + | None -> false) -> + Some t + | _ -> None); 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" + let text = + try String.concat "\n\n" (go fs) ^ "\n" + with e -> spelling := (fun _ -> None); raise e + in + spelling := (fun _ -> None); + text diff --git a/lib/indent_reader.ml b/lib/indent_reader.ml index 4c8b34da..ee419924 100644 --- a/lib/indent_reader.ml +++ b/lib/indent_reader.ml @@ -159,8 +159,25 @@ let lex ~file src : token list = else emit UNQ (Loc.upto l0 (Reader.here st)) | c when Reader.is_digit c || ((c = '-' || c = '+') && Reader.is_digit (Reader.peek2 st)) -> - let f = Reader.read_number st in - emit (ATOM f.v) f.loc + (* [while x < 3:] — the colon is a mistake the parser explains, and not + part of the number, so the number is read without it. *) + let rec run i = + if i < String.length src && not (Reader.is_delimiter src.[i]) then run (i + 1) + else i + in + let stop = run st.Reader.pos in + if stop - st.Reader.pos > 1 && src.[stop - 1] = ':' then begin + let text = String.sub src st.Reader.pos (stop - st.Reader.pos - 1) in + let f = Reader.read_number (Reader.of_string ~file text) in + let n = String.length text in + for _ = 1 to n do Reader.advance st done; + emit (ATOM f.v) (piece l0.Loc.line l0.Loc.col n); + Reader.advance st; + emit COLON (piece l0.Loc.line (l0.Loc.col + n) 1) + end + else + let f = Reader.read_number st in + emit (ATOM f.v) f.loc | _ -> name_run () in let rec go () = @@ -224,6 +241,27 @@ let layout ?(base = 1) (toks : token list) : token array = && arr.(i + 1).sp in let continues = (binop p && p.sp) || (binop t && spaced_after) in + (* A continuation line sits deeper than the statement it continues. + One at or left of that statement's column is not read as joining + it: that would pull a line into a block it was written outside + of, silently. *) + if continues && t.loc.Loc.col <= List.hd !stack then + failk "continuation" t.loc + "%s" + (if binop t then + Printf.sprintf + "this line starts with the operator %s, so it continues the \ + line above, but it is not indented past the start of that \ + line (column %d). Indent it further to continue the line, \ + or give %s a value on its left" + (show t.tok) (List.hd !stack) (show t.tok) + else + Printf.sprintf + "the line above ends with the operator %s, so this line \ + continues it, but it is not indented past the start of \ + that line (column %d). Indent it further, or finish the \ + line above" + (show p.tok) (List.hd !stack)); if not continues then begin let at = point p.loc in add NEWLINE at; @@ -234,19 +272,21 @@ let layout ?(base = 1) (toks : token list) : token array = add INDENT at end else if col < top then begin + let closed = ref top in let rec pop () = match !stack with | top :: (_ :: _ as rest) when col < top -> - stack := rest; add DEDENT at; pop () + closed := top; stack := rest; add DEDENT at; pop () | _ -> () in pop (); if col <> List.hd !stack then failk "dedent" t.loc - "this line starts at column %d, which is not where any \ - enclosing block starts — those start at column%s %s. Line \ + "this line starts at column %d, between the block at column \ + %d and the one at column %d it would close, so it belongs \ + to neither. The enclosing blocks start at column%s %s: line \ it up with one of them" - col + col (List.hd !stack) !closed (if List.length !stack > 1 then "s" else "") (String.concat ", " (List.rev_map string_of_int !stack)) @@ -338,6 +378,17 @@ let stray p ~after = | NEWLINE | INDENT | DEDENT | EOF -> failk "unexpected-end" (where_ p) "the line ends after %s, which is not \ finished here" after + | NAME "=" -> + failk "assign-in-test" t.loc + "= assigns, and here it follows %s where a value is being read. To \ + compare, write ==: %s == ..." + after after + | COLON -> + failk "header-colon" t.loc + "this line ends in a colon after %s. A header (if, elif, else, while, \ + until, for, fn, match, ...) opens its block with no colon; only a call \ + takes one, as in f(x):. Remove the colon" + after | _ -> failk "unexpected-token" t.loc "%s follows %s, and two values cannot sit side by side here. Separate \ @@ -390,11 +441,13 @@ let unclosed p c l0 = ~notes:[ Loc.note (where_ p) "the input ends here, still inside it" ] "unclosed %C" c -let refuse_ws loc e = +let refuse_ws ?(brace = false) loc e = failk "separate-elements" loc "%s has an operator in it and sits in a list separated by spaces, where \ - only single values are. Separate the elements with commas: [a - 1, b]" + only single values are. Separate the %s with commas: %s" (text_of e) + (if brace then "entries" else "elements") + (if brace then "{.x a + 1, .y 2}" else "[a - 1, b]") (* Expressions come back with their syntactic level: 10 an atom or a bracket, 9 a postfix chain, 8 a unary minus, 1-7 a binary operator's level, 3 a @@ -540,6 +593,11 @@ and primary p : Form.t * int = (match (peek p).tok with | RP -> ignore (advance p) | EOF -> unclosed p '(' l0 + | COMMA -> + failk "tuple" (peek p).loc + "parentheses group one value, and this comma starts a second. \ + Several values in a list are written in brackets, [a, b]; \ + arguments go glued to a name, f(a, b)" | _ -> stray p ~after:(text_of e)); (e, 10) | LB -> @@ -572,14 +630,57 @@ and if_expr p = after %s. Write the then, or start the if on its own line with its \ branches indented under it" (text_of c)); - let a, _ = binary p 1 in + let a = inline_stmt p in match (peek p).tok with | NAME "else" -> ignore (advance p); - let b, _ = expr p in + let b = inline_stmt p in (mk p t.loc (Form.List [ sym t.loc "if"; c; a; b ]), 0) + | 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" | _ -> (mk p t.loc (Form.List [ sym t.loc "when"; c; a ]), 0) +(* 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. *) +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 + match t.tok with + | NAME (("break" | "continue") as w) when not glued -> + ignore (advance p); + (match (peek p).tok with + | KW k -> + let kt = advance p in + mk p t.loc (Form.List [ sym t.loc w; Form.make (Form.Kw k) kt.loc ]) + | _ -> mk p t.loc (Form.List [ sym t.loc w ])) + | NAME "return" when not glued -> + ignore (advance p); + let n = peek p in + if starts_value n.tok && not (n.tok = NAME "else") then + let v, _ = expr p in + mk p t.loc (Form.List [ sym t.loc "return"; v ]) + else mk p t.loc (Form.List [ sym t.loc "return" ]) + | _ -> + let e, _ = expr p in + match (peek p).tok with + | NAME "=" -> + let eq = advance p in + let v, _ = expr p in + mk p t.loc (Form.List [ sym eq.loc "set"; e; v ]) + | NAME op when List.mem_assoc op assign_ops -> + let eq = advance p in + let v, _ = expr p in + mk p t.loc + (Form.List + [ sym eq.loc "set"; e; + Form.make (Form.List [ sym eq.loc (List.assoc op assign_ops); e; v ]) + (span p e.loc) ]) + | _ -> e + (* [fn(a, b) = body] is a lambda; [fn(...)] followed by anything else is the fallback call spelling of [(fn ...)]. *) and fn_expr p = @@ -647,6 +748,14 @@ and items p closer open_loc ~what = (* [[a b c]] or [[a, b + 1]]: whitespace separates only single terms. *) and vec_items p open_loc = + (* One separator per bracket: [1 2, 3] mixes them, and which elements the + comma was meant to part is a guess. *) + let commas = ref false and spaces = ref false in + let mixed at = + failk "mixed-separators" at + "this bracket separates some elements with commas and some with only \ + spaces. Use one: [1, 2, 3] or [1 2 3]" + in let rec go acc prev_ws = let t = peek p in match t.tok with @@ -656,11 +765,16 @@ and vec_items p open_loc = let e, lvl = expr p in if lvl < 8 && prev_ws then refuse_ws t.loc e; (match (peek p).tok with - | COMMA -> ignore (advance p); go (e :: acc) false + | COMMA -> + if !spaces then mixed (peek p).loc; + commas := true; + ignore (advance p); go (e :: acc) false | RB -> ignore (advance p); List.rev (e :: acc) | EOF -> unclosed p '[' open_loc | tk when starts_value tk && (peek p).sp -> if lvl < 8 then refuse_ws t.loc e; + if !commas then mixed (peek p).loc; + spaces := true; go (e :: acc) true | _ -> stray p ~after:(text_of e)) in @@ -681,7 +795,7 @@ and map_items p open_loc = | RC -> ignore (advance p); List.rev (e :: acc) | EOF -> unclosed p '{' open_loc | tk when starts_value tk && (peek p).sp -> - if lvl < 8 then refuse_ws t.loc e; + if lvl < 8 then refuse_ws ~brace:true t.loc e; go (e :: acc) | _ -> stray p ~after:(text_of e)) in @@ -742,8 +856,10 @@ let header_follow p s = n.tok = NEWLINE || (n.sp && (match n.tok with KW _ -> true | _ -> false)) | "defer" -> (n.tok = NEWLINE && (peek_at p 2).tok = INDENT) || (n.sp && starts_value n.tok) - | "handler-case" | "handler-bind" | "restart-case" -> n.tok = NEWLINE - | "quote" -> n.tok = NEWLINE && (peek_at p 2).tok = INDENT + | "handler-case" | "handler-bind" | "restart-case" -> + n.tok = NEWLINE || (n.sp && starts_value n.tok) + | "quote" -> + (n.tok = NEWLINE && (peek_at p 2).tok = INDENT) || (n.sp && starts_value n.tok) | _ -> false let name_tok p ~what = @@ -769,7 +885,15 @@ let params p (lp : token) = | RP -> ignore (advance p); List.rev acc | EOF -> unclosed p '(' lp.loc | _ -> + (match t.tok with + | NAME "&" -> + failk "rest-parameter" t.loc + "a function's parameters are a fixed list of names, each with an \ + optional : Type, and & (a rest parameter) is not one. Take the rest \ + as one parameter, xs: [T]" + | _ -> ()); let n = name_tok p ~what:"a parameter's name" in + let typed = (peek p).tok = COLON in let tyf = match (peek p).tok with | COLON -> ignore (advance p); ty p @@ -778,7 +902,7 @@ let params p (lp : token) = (match (peek p).tok with | COMMA -> ignore (advance p) | RP -> () - | _ -> stray p ~after:(text_of tyf)); + | _ -> stray p ~after:(text_of (if typed then tyf else n))); go (tyf :: n :: acc) in go [] @@ -839,12 +963,25 @@ and let_stmt (s : st) : Form.t list = let p = s.p in let t = advance p in let target, _ = unary p in + (* [let x: T = v] is [(let [x (the T v)])]: a let binding has no type slot + of its own, and [the] is the form that says what a value is. *) + let annot = + match (peek p).tok with + | COLON -> ignore (advance p); Some (ty p) + | _ -> None + in (match (peek p).tok with | NAME "=" -> ignore (advance p) | _ -> failk "let-equals" (where_ p) "a let is let name = value, and %s is not followed by =" (text_of target)); let v = value_line ~block_ok:true s ~after:("let " ^ text_of target) in + let v = + match annot with + | Some tyf -> + Form.make (Form.List [ sym tyf.loc "the"; tyf; v ]) (span p tyf.loc) + | None -> v + in let make bindings body = let f = mk p t.loc @@ -901,20 +1038,23 @@ and expr_stmt (s : st) : Form.t = | COLON -> let before = (last p).tok in let c = advance p in + (* [f(x):] and, with no arguments, [comment:] — a bare name — open a + block; anything else has no call to hang it on. *) (match e.v, before with | Form.List (_ :: _), RP -> () + | Form.Sym _, NAME _ -> () | _ -> failk "colon-block" c.loc "a trailing colon gives a call an indented block, and %s is not a \ - call. Write it as one, as in %s():" - (text_of e) (text_of e)); + call. Write it as one, as in f(x): or comment:" + (text_of e)); (match (peek p).tok with | NEWLINE -> ignore (advance p) | _ -> stray p ~after:":"); let body = block s ~after:(text_of e ^ ":") in (match e.v with | Form.List items -> mk p t0.loc (Form.List (items @ body)) - | _ -> assert false) + | _ -> mk p t0.loc (Form.List (e :: body))) | _ -> (* [()] alone on a line is the empty statement, spec §2 "Unit". *) let e = @@ -1085,13 +1225,18 @@ and header (s : st) w : Form.t = (match (peek p).tok with | NAME "then" -> ignore (advance p); - let a, _ = binary p 1 in + let a = inline_stmt p in let f = match (peek p).tok with | NAME "else" -> ignore (advance p); - let b, _ = expr p in + 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); @@ -1104,6 +1249,12 @@ and header (s : st) w : Form.t = | 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) @@ -1187,7 +1338,7 @@ and header (s : st) w : Form.t = ignore (advance p); form (block s ~after:"defer") | _ -> - let e, _ = expr p in + let e = inline_stmt p in expect_eol p ~after:(text_of e); form [ e ]) | "match" -> @@ -1203,7 +1354,7 @@ and header (s : st) w : Form.t = blk s nl.loc (block s ~after:"->") end else begin - let e, _ = expr p in + let e = inline_stmt p in expect_eol p ~after:(text_of e); e end @@ -1212,7 +1363,7 @@ and header (s : st) w : Form.t = in form (scrut :: arms) | "handler-case" | "handler-bind" -> - expect_line_end p ~after:w; + clause_header_end p w; let body = block s ~after:w in let rec clauses acc = match (peek p).tok, (peek_at p 1) with @@ -1227,7 +1378,7 @@ and header (s : st) w : Form.t = "a handler clause is on Type(name), naming the condition type \ and the name it is bound to, as in on FileError(c)" in - expect_line_end p ~after:("on " ^ text_of head); + clause_end p ("on " ^ text_of ty ^ "(" ^ text_of var ^ ")"); let b = block s ~after:"on" in let c = mk p ot.loc @@ -1241,7 +1392,7 @@ and header (s : st) w : Form.t = if w = "handler-case" then form [ blk s l0 body; vec ] else form (vec :: body) | "restart-case" -> - expect_line_end p ~after:w; + clause_header_end p w; let body = block s ~after:w in let rec clauses acc = match (peek p).tok, (peek_at p 1) with @@ -1250,7 +1401,7 @@ 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 - expect_line_end p ~after:("restart " ^ text_of name); + 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)) @@ -1261,11 +1412,39 @@ and header (s : st) w : Form.t = let cs = clauses [] in form (blk s l0 body :: cs) | "quote" -> - expect_line_end p ~after:"quote"; - let body = block s ~after:"quote" in - named "quasiquote" [ blk s l0 body ] + (* One line, [quote ~x + 1], is the quasiquote of that expression. *) + (match (peek p).tok with + | NEWLINE -> + ignore (advance p); + let body = block s ~after:"quote" in + named "quasiquote" [ blk s l0 body ] + | _ -> + let e, _ = expr p in + expect_eol p ~after:(text_of e); + named "quasiquote" [ e ]) | _ -> assert false +(* handler-case, handler-bind and restart-case take nothing on their own line. *) +and clause_header_end p w = + match (peek p).tok with + | NEWLINE -> ignore (advance p) + | _ -> + failk "clause-header" (peek p).loc + "%s takes its body on the indented lines under it, and its %s clauses \ + at its own column after that, each with its block under it:\n\ + %s\n body\n%s" + w (if w = "restart-case" then "restart" else "on") w + (if w = "restart-case" then "restart name()\n value" else "on Type(c)\n value") + +and clause_end p head = + match (peek p).tok with + | NEWLINE -> ignore (advance p) + | _ -> + failk "clause-body" (peek p).loc + "the body of %s goes on the indented lines under it, not on its line. \ + Move it to the next line, indented" + head + (* The end of a header line whose block must follow. *) and expect_line_end p ~after = match (peek p).tok with diff --git a/lib/load.ml b/lib/load.ml index 3df71271..70bb75cb 100644 --- a/lib/load.ml +++ b/lib/load.ml @@ -1215,6 +1215,20 @@ let rec import ~seen ~open_ ~loc alias dir = let one_file = is_package_file dir in 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; + (* geo.flan beside geo.fln is one file written twice — a conversion that + kept its original — and loading both would report every definition in + it as defined twice, pointing at neither file as the cause. *) + List.iter + (fun f -> + if Filename.check_suffix f Source.paren_ext then + let twin = Filename.remove_extension f ^ Source.indented_ext in + if List.mem twin files then + fail loc + "the package at %s has both %s and %s. They are one file in two \ + syntaxes, and a package reads every source file it has, so \ + keep one of them" + dir (Filename.basename f) (Filename.basename twin)) + files; (* 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. *) diff --git a/spec-syntax.md b/spec-syntax.md index e4d50942..2fb6c31d 100644 --- a/spec-syntax.md +++ b/spec-syntax.md @@ -120,7 +120,8 @@ Each item: the proposal, then the reason in one line. 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. **Built** (`=` does not - continue: `let x =` plus a block is a block value). + continue: `let x =` plus a block is a block value). A continuation line must + sit deeper than the line it continues; one that does not is refused. - **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 @@ -190,6 +191,8 @@ Each item: the proposal, then the reason in one line. `for :outer 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 + slots: a match arm's value, `then`/`else`, and after `defer`. - **`match`:** ``` @@ -250,7 +253,8 @@ plus an indented block, reads as `(head arg … block…)`. Commas vanish into t `(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. **Built**; a header word glued to `(` is always this call, -`if(c, a)`, `let([x 1], x)`. +`if(c, a)`, `let([x 1], x)`. A bare name with a trailing colon takes a block too, +`comment:` (author's decision 85). ### Types diff --git a/test/test_syntax.ml b/test/test_syntax.ml index 54fb145a..bc80d076 100644 --- a/test/test_syntax.ml +++ b/test/test_syntax.ml @@ -115,7 +115,8 @@ let () = match Reader.read_file path with | exception Loc.Error _ -> () (* not a program the paren reader takes *) | forms -> - match Indent_printer.program forms with + let source = In_channel.with_open_bin path In_channel.input_all in + match Indent_printer.program ~source forms with | exception Indent_printer.Unprintable (f, why) -> fail "round trip %s: %s at %d:%d" path why f.loc.Loc.line f.loc.Loc.col | text -> @@ -205,10 +206,19 @@ let () = 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():"; + refuses "colon on a non-call" "a + b:\n y" "indent/colon-block" "comment:"; + reads "bare name takes a block" "comment:\n f()\n g()" "(comment (f) (g))"; + reads "qualified name takes a block" "rl/with-drawing:\n f()" "(rl/with-drawing (f))"; (* Indentation. *) refuses "tab" "fn f() -> ()\n\tg()" "indent/tab" "spaces"; - refuses "dedent to no block" "if a\n b\n c" "indent/dedent" "column 3"; + refuses "dedent to no block" "if a\n b\n c" "indent/dedent" + "between the block at column 1 and the one at column 5"; + (* A continuation sits deeper than the line it continues. *) + refuses "leading operator left of its block" "if a\n b\n+ 1" "indent/continuation" "column 3"; + refuses "leading operator at the statement's column" "let x = 1\n+ 2\nx" + "indent/continuation" "Indent it further"; + refuses "trailing operator, shallower next line" "if a\n x = b +\nc" + "indent/continuation" "finish the line above"; reads "blank and comment lines" "if a\n\n ; note\n b\n\n; more\nc" "(when a b)\nc"; (* Continuation lines. *) @@ -248,7 +258,80 @@ let () = "(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)" + reads "read-only pointer" "def p: Ptr(const u8) = uninit" "(def p (Ptr const u8) uninit)"; + (* Statements that fit on a line, in one-line slots. *) + reads "arm statements" "match s\n 1 -> break\n 2 -> continue :outer\n _ -> x += 1" + "(match s 1 (break) 2 (continue :outer) _ (set x (+ x 1)))"; + reads "then break" "if c then break" "(when c (break))"; + reads "then return else assign" "if c then return 5 else x = 2" "(if c (return 5) (set x 2))"; + reads "return in an expression if" "y = if c then return else 1" "(set y (if c (return) 1))"; + reads "defer an assignment" "defer x = 0" "(defer (set x 0))"; + (* Messages with a shape of their own. *) + refuses "parenthesised pair" "x = (a, b)" "indent/tuple" "[a, b]"; + refuses "rest parameter" "fn f(& rest) -> () = 0" "indent/rest-parameter" "xs: [T]"; + refuses "assignment as a test" "if x = 1\n y" "indent/assign-in-test" "x == ..."; + refuses "colon after if" "if c:\n y" "indent/header-colon" "no colon"; + refuses "colon after a return type" "fn f() -> i32:\n 0" "indent/header-colon" "no colon"; + refuses "colon after a number" "while x < 3:\n y" "indent/header-colon" "no colon"; + refuses "one-line handler-case" "handler-case g()" "indent/clause-header" "on Type(c)"; + refuses "one-line on clause" "handler-case\n g()\non A(c) -> 1" "indent/clause-body" "on A(c)"; + refuses "one-line elif" "x = if a then 1 elif b then 2 else 3" "indent/one-line-elif" "else if b"; + refuses "elif with then" "if a\n 1\nelif b then 2" "indent/elif-then" "no then"; + refuses "brace hint" "x = {.x a + 1 .y 2}" "indent/separate-elements" "{.x a + 1, .y 2}"; + refuses "mixed separators" "x = [1 2, 3]" "indent/mixed-separators" "[1, 2, 3]"; + reads "one-line quote" "defmacro(m, [x]):\n quote ~x + 1" + "(defmacro m [x] (quasiquote (+ (unquote x) 1)))"; + reads "typed let" "let x: i32 = 5\nx" "(let [x (the i32 5)] x)"; + (* And back: the printer writes the idioms. *) + let prints name src want = + match Reader.read_all ~file:"

" src with + | forms -> + let got = Indent_printer.program ~source:src forms in + if not (Test_support.contains got want) then + fail "%s: printed %S, wanted it to contain %S" name got want + | exception e -> fail "%s: %s" name (diag_text e) + in + prints "compound assignment" "(defn f [] () (set x (+ x 1)))" " x += 1"; + prints "arm statements" "(defn f [] () (match s 1 (break) _ (return 2)))" + "1 -> break\n _ -> return 2"; + prints "then and else statements" "(defn f [] () (if c (return 1) (set x 2)))" + "if c then return 1 else x = 2"; + prints "a statement argument makes a block" "(foo 1 (set x 2))" "foo(1):\n x = 2"; + prints "no arguments before the block" "(comment (f))" "comment:\n f()"; + prints "typed let" "(defn f [] i32 (let [x (the i32 5)] x))" "let x: i32 = 5"; + prints "do in an arm is a block" "(defn f [] () (match s _ (do (a) (b))))" "_ ->\n a()"; + prints "hex spelling" "(def c dyn 0xFFF00FFF)" "0xFFF00FFF" + +(* ── Loading ───────────────────────────────────────────────────────── *) + +let write path text = Out_channel.with_open_bin path (fun oc -> output_string oc text) + +let () = + (* A spaced-out operator is one name; the checker says which arithmetic. *) + let f = Filename.concat scratch "syntax-hint.fln" in + write f "fn main() -> i32\n let x = 3\n x-1\n"; + (match Front.checked f with + | _ -> fail "x-1 checked" + | exception Loc.Error d -> + if not (Test_support.contains d.Loc.dmsg "Did you mean x - 1?") then + fail "x-1: %s" d.Loc.dmsg + | exception e -> fail "x-1: %s" (Printexc.to_string e)); + (* One package, one file in two syntaxes: refused naming both. *) + let dir = Filename.concat scratch "syntax-twin" in + let pkg = Filename.concat dir "geo" in + (try Unix.mkdir dir 0o755 with Unix.Unix_error _ -> ()); + (try Unix.mkdir pkg 0o755 with Unix.Unix_error _ -> ()); + write (Filename.concat pkg "geo.flan") "(defn one [] i32 1)\n"; + write (Filename.concat pkg "geo.fln") "fn one() -> i32 = 1\n"; + let main = Filename.concat dir "main.flan" in + write main "(import geo \"geo\")\n(defn main [] i32 (geo/one))\n"; + match Front.checked main with + | _ -> fail "a package with geo.flan and geo.fln loaded" + | exception Loc.Error d -> + if not (Test_support.contains d.Loc.dmsg "geo.flan" + && Test_support.contains d.Loc.dmsg "geo.fln") then + fail "twin files: %s" d.Loc.dmsg + | exception e -> fail "twin files: %s" (Printexc.to_string e) (* ── Both directions of an import, on both backends ────────────────── *)