diff --git a/bin/main.ml b/bin/main.ml index a2206078..306e2373 100644 --- a/bin/main.ml +++ b/bin/main.ml @@ -324,14 +324,33 @@ 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 + 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 + "%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 +409,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 +573,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 +963,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/check.ml b/lib/check.ml index dcaa810d..a61a85fe 100644 --- a/lib/check.ml +++ b/lib/check.ml @@ -7262,6 +7262,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/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..c7444155 --- /dev/null +++ b/lib/indent_printer.ml @@ -0,0 +1,707 @@ +(** [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 ^ ")" + +(* 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 ───────────────────────────────────────────────────── *) + +(* 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 -> + 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 = 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"; + (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 " ^ 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 + +(* 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 + | _ -> + (* 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; + 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 = + [ "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 + 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) + | _ -> 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 + 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)) + 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 ] -> + 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 + 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 " ^ 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)) -> + 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 ^ " -> " ^ 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 ]) + 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 [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 b -> let p, v = bind b in value_lines n p v) prs @ block n body + else + match prs with + | 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 ?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 + 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 new file mode 100644 index 00000000..ee419924 --- /dev/null +++ b/lib/indent_reader.ml @@ -0,0 +1,1489 @@ +(** 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)) -> + (* [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 () = + 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 + (* 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; + 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 closed = ref top in + let rec pop () = + match !stack with + | top :: (_ :: _ as rest) when col < top -> + 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, 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 (List.hd !stack) !closed + (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 + | 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 \ + 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 ?(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 %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 + [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 + | 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 -> + 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 = inline_stmt p in + match (peek p).tok with + | NAME "else" -> + ignore (advance p); + 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 = + 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 = + (* 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 + | 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 -> + 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 + 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 ~brace:true 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 || (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 = + 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 + | _ -> + (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 + | _ -> sym n.loc "dyn" + in + (match (peek p).tok with + | COMMA -> ignore (advance p) + | RP -> () + | _ -> stray p ~after:(text_of (if typed then tyf else n))); + 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 + (* [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 + (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 + (* [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 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)) + | _ -> mk p t0.loc (Form.List (e :: body))) + | _ -> + (* [()] 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 = inline_stmt p in + let f = + match (peek p).tok with + | NAME "else" -> + ignore (advance p); + let b = inline_stmt p in + form [ c; a; b ] + | NAME "elif" -> + failk "one-line-elif" (peek p).loc + "a one-line if has then and else and no elif. Chain another if \ + after the else — if a then x else if b then y else z — or write \ + the if over several lines, where elif goes" + | _ -> named "when" [ c; a ] + in + expect_eol p ~after:(text_of f); + f + | _ -> + expect_line_end p ~after:("if " ^ text_of c); + let body = block s ~after:("if " ^ text_of c) in + let rec elifs acc = + match (peek p).tok with + | NAME "elif" -> + ignore (advance p); + let c, _ = binary p 1 in + (match (peek p).tok with + | NAME "then" -> + failk "elif-then" (peek p).loc + "elif takes its block on the indented lines under it, with no \ + then. Put the branch on the next line, indented" + | _ -> ()); + expect_line_end p ~after:("elif " ^ text_of c); + let b = block s ~after:"elif" in + elifs ((c, b) :: acc) + | _ -> List.rev acc + in + let els_ = elifs [] in + let else_ = + match (peek p).tok with + | NAME "else" -> + let et = advance p in + (match (peek p).tok with + | NEWLINE -> ignore (advance p) + | NAME "if" -> + failk "else-if" (where_ p) + "else takes its block on the lines under it. For another test \ + at this level, write elif c" + | _ -> stray p ~after:"else"); + Some (et.loc, block s ~after:"else") + | _ -> None + in + (match els_, else_ with + | [], None -> named "when" (c :: body) + | [], Some (el, e) -> form [ c; blk s l0 body; blk s el e ] + | _ -> + let pairs = + List.concat_map (fun (c, b) -> [ c; blk s c.Form.loc b ]) ((c, body) :: els_) + in + let tail = + match else_ with + | Some (el, e) -> [ Form.make (Form.Kw "else") el; blk s el e ] + | None -> [] + in + named "cond" (pairs @ tail))) + | "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 = inline_stmt 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 = inline_stmt p in + expect_eol p ~after:(text_of e); + e + end + in + [ pat; body ]) + in + form (scrut :: arms) + | "handler-case" | "handler-bind" -> + 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 + | 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 + clause_end p ("on " ^ text_of ty ^ "(" ^ text_of var ^ ")"); + 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" -> + 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 + | 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 + 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)) + in + clauses (c :: acc) + | _ -> List.rev acc + in + let cs = clauses [] in + form (blk s l0 body :: cs) + | "quote" -> + (* 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 + | 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 a6f70b98..70bb75cb 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 @@ -1205,12 +1213,26 @@ 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; + (* 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. *) - 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 41d45d6f..c8553887 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..2fb6c31d 100644 --- a/spec-syntax.md +++ b/spec-syntax.md @@ -99,61 +99,76 @@ 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). 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 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 +178,21 @@ 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 …)`. + `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`:** ``` @@ -182,7 +202,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 +220,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 +252,17 @@ 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)`. A bare name with a trailing colon takes a block too, +`comment:` (author's decision 85). ### 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 +276,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 e5fba609..ed527938 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..bc80d076 --- /dev/null +++ b/test/test_syntax.ml @@ -0,0 +1,368 @@ +(* The indented syntax (spec-syntax.md): its reader, its printer, and the + switch between the two readers by file extension. + + Four parts. Two programs hand-converted from paren to indented must read to + the same forms. Every corpus file must survive paren -> printed indented -> + read indented unchanged, up to the one merge the spec allows. A table pins + the lexical edge cases and the refusals, with their kinds. And a program in + each syntax importing a package in the other builds and runs the same on + both backends. *) + +open Flan + +let () = Watchdog.arm ~seconds:300 "test_syntax" + +let fail fmt = Test_support.fail fmt +let scratch = Test_support.scratch + +(* ── Forms, compared without locations ─────────────────────────────── *) + +let rec eq (a : Form.t) (b : Form.t) = + match a.v, b.v with + | Form.List x, Form.List y | Form.Vec x, Form.Vec y | Form.Map x, Form.Map y -> + List.length x = List.length y && List.for_all2 eq x y + | Form.Float x, Form.Float y -> + Int64.equal (Int64.bits_of_float x) (Int64.bits_of_float y) + | x, y -> x = y + +(* The innermost pair that differs, for the failure line. *) +let rec first_diff (a : Form.t) (b : Form.t) = + match a.v, b.v with + | (Form.List x, Form.List y | Form.Vec x, Form.Vec y | Form.Map x, Form.Map y) + when List.length x = List.length y -> + (match List.find_opt (fun (p, q) -> not (eq p q)) (List.combine x y) with + | Some (p, q) -> first_diff p q + | None -> (a, b)) + | _ -> (a, b) + +let same_forms a b = + List.length a = List.length b && List.for_all2 eq a b + +let describe_diff a b = + if List.length a <> List.length b then + Printf.sprintf "%d forms against %d" (List.length a) (List.length b) + else + match List.find_opt (fun (x, y) -> not (eq x y)) (List.combine a b) with + | Some (x, y) -> + let u, w = first_diff x y in + Printf.sprintf "wanted %s, read %s (at %d:%d)" (Form.to_string u) + (Form.to_string w) w.loc.Loc.line w.loc.Loc.col + | None -> "equal" + +(* A [let] whose whole body is another [let] is the merged [let]: spec §4 + step 3's one normalisation. Flan's [let] binds in order, so the two mean + the same thing. *) +let rec norm (f : Form.t) : Form.t = + let v = + match f.v with + | Form.List (({ v = Form.Sym "let"; _ } as h) :: { v = Form.Vec bs; loc } :: body) -> + (match List.map norm body with + | [ { v = Form.List ({ v = Form.Sym "let"; _ } :: { v = Form.Vec bs2; _ } :: body2); _ } ] -> + Form.List (h :: Form.make (Form.Vec (List.map norm bs @ bs2)) loc :: body2) + | body -> Form.List (h :: Form.make (Form.Vec (List.map norm bs)) loc :: body)) + | Form.List l -> Form.List (List.map norm l) + | Form.Vec l -> Form.Vec (List.map norm l) + | Form.Map l -> Form.Map (List.map norm l) + | v -> v + in + { f with v } + +let diag_text = function + | Loc.Error d -> Printf.sprintf "%s %d:%d %s" d.Loc.kind d.dloc.Loc.line d.dloc.Loc.col d.dmsg + | e -> Printexc.to_string e + +(* ── The hand-converted pairs ──────────────────────────────────────── *) + +let pair flan fln = + match Reader.read_file flan, Source.read_file fln with + | a, b -> + if not (same_forms a b) then + fail "%s and %s read differently: %s" flan fln (describe_diff a b) + | exception e -> fail "%s / %s: %s" flan fln (diag_text e) + +let () = + pair "syntax/algorithms.flan" "syntax/algorithms.fln"; + pair "../sand.flan" "syntax/sand.fln"; + (* Checked, never run: sand opens a window. *) + List.iter + (fun f -> + match Front.checked f with + | _ -> () + | exception e -> fail "%s does not check: %s" f (diag_text e)) + [ "syntax/sand.fln"; "syntax/algorithms.fln" ] + +(* ── The round trip over the corpus ────────────────────────────────── *) + +(* Every .flan the build tree holds. [..] is the workspace root from here; + the deps in test/dune decide what is in it. *) +let corpus () = + let rec walk dir acc = + Array.fold_left + (fun acc name -> + let path = Filename.concat dir name in + if name <> "" && (name.[0] = '.' || name.[0] = '_') then acc + else if Sys.is_directory path then walk path acc + else if Filename.check_suffix name ".flan" then path :: acc + else acc) + acc (Sys.readdir dir) + in + List.sort String.compare (walk ".." []) + +let () = + let ok = ref 0 in + List.iter + (fun path -> + match Reader.read_file path with + | exception Loc.Error _ -> () (* not a program the paren reader takes *) + | forms -> + let source = In_channel.with_open_bin path In_channel.input_all in + match Indent_printer.program ~source forms with + | exception Indent_printer.Unprintable (f, why) -> + fail "round trip %s: %s at %d:%d" path why f.loc.Loc.line f.loc.Loc.col + | text -> + match Indent_reader.read_all ~file:(path ^ ".fln") text with + | exception e -> fail "round trip %s: %s" path (diag_text e) + | back -> + let a = List.map norm forms and b = List.map norm back in + if same_forms a b then incr ok + else fail "round trip %s: %s" path (describe_diff a b)) + (corpus ()); + Printf.printf "round trip: %d files\n" !ok; + (* The deps decide what is walked, and a stanza that lost them would pass + over nothing. *) + if !ok < 390 then fail "round trip covered only %d files" !ok + +(* ── Lexical edge cases ────────────────────────────────────────────── *) + +let read src = Indent_reader.read_all ~file:"" src + +let reads name src want = + match read src with + | forms -> + let got = String.concat "\n" (List.map Form.to_string forms) in + if got <> want then fail "%s: read %s, wanted %s" name got want + | exception e -> fail "%s: refused: %s" name (diag_text e) + +let refuses name src kind needle = + match read src with + | forms -> + fail "%s: read %s, wanted the refusal %s" name + (String.concat " " (List.map Form.to_string forms)) kind + | exception Loc.Error d -> + if d.Loc.kind <> kind then fail "%s: refused as %s, wanted %s (%s)" name d.Loc.kind kind d.dmsg + else if not (Test_support.contains d.dmsg needle) then + fail "%s: %s does not say %S: %s" name kind needle d.dmsg + | exception e -> fail "%s: %s" name (Printexc.to_string e) + +let () = + (* Minus. *) + reads "subtraction" "x = a - 1" "(set x (- a 1))"; + reads "negative literal" "x = -1" "(set x -1)"; + reads "negation" "x = -y" "(set x (- y))"; + reads "negation binds after postfix" "x = -p.x" "(set x (- (.x p)))"; + reads "lisp name" "x = a-b" "(set x a-b)"; + reads "decrement is a name" "--(j)" "(-- j)"; + reads "minus as a call" "x = -(a + b)" "(set x (- (+ a b)))"; + refuses "glued minus" "x = a -1" "indent/glued-minus" "a - 1"; + refuses "glued minus in a call" "f(a -1)" "indent/glued-minus" "space the minus"; + (* The arrow. *) + reads "return arrow" "fn f(x: i32) -> i32 = x" "(defn f [x i32] i32 x)"; + reads "arrow inside a name" "fn dyn->f64(v: f64) -> f64 = v" "(defn dyn->f64 [v f64] f64 v)"; + reads "function type" + "fn g(h: Fn(i32, i32) -> bool) -> () = h(1, 2)" + "(defn g [h (Fn [i32 i32] bool)] () (h 1 2))"; + reads "untyped parameter is dyn" "fn id(x) -> dyn = x" "(defn id [x dyn] dyn x)"; + refuses "no return type" "fn f(x)\n x" "indent/return-type" "-> i32"; + (* Characters, lexed before brackets and separators. *) + reads "character literals" "x = [\\( \\, \\space \\)]" "(set x [\\( \\, \\space \\)])"; + reads "character arguments" "f(\\,, \\))" "(f \\, \\))"; + (* Keywords and annotations. *) + reads "keyword" "def k = :else" "(def k dyn :else)"; + reads "annotation" "once grid: [4 [8 u32]]" "(defonce grid [4 [8 u32]])"; + reads "keyword argument" "rl/key-pressed?(:key-r)" "(rl/key-pressed? :key-r)"; + refuses "colon inside a name" "fn f(x:i32) -> () = x" "indent/colon-in-name" "x: i32"; + (* Adjacency. *) + reads "call" "f(a, b)" "(f a b)"; + reads "index" "x[i, j]" "(at x i j)"; + reads "call of a call" "f(a)(b)" "((f a) b)"; + reads "field chain" "camera.target.x" "(.x (.target camera))"; + reads "qualified case" "Shape.Rect" "Shape.Rect"; + reads "field of a call" "f(x).y" "(.y (f x))"; + reads "struct literal" "Vector2{.x 1, .y 2}" "(Vector2 {.x 1 .y 2})"; + reads "operator call" "+(a, b, c)" "(+ a b c)"; + reads "operator value" "reduce(+, 0, xs)" "(reduce + 0 xs)"; + refuses "spaced call" "f (a)" "indent/spaced-call" "f(...)"; + refuses "spaced index" "x [i]" "indent/spaced-index" "x[i]"; + refuses "missing comma" "f(a b)" "indent/missing-comma" "commas"; + refuses "unspaced operator" "x = f(a)+ b" "indent/unspaced-operator" "a + b"; + (* Collections. *) + reads "whitespace vector" "x = [i n]" "(set x [i n])"; + reads "comma vector" "x = [a - 1, b]" "(set x [(- a 1) b])"; + refuses "operator between spaces" "x = [a - 1 b]" "indent/separate-elements" "commas"; + reads "quoted list" "x = '(a b c)" "(set x (quote (a b c)))"; + (* Trailing colon blocks. *) + reads "trailing block" "rl/with-drawing():\n clear()\n draw()" + "(rl/with-drawing (clear) (draw))"; + reads "fallback with a block" "defmethod(describe, :square, [s]):\n s" + "(defmethod describe :square [s] s)"; + refuses "block without the colon" "f(x)\n y" "indent/stray-indent" "trailing colon"; + refuses "colon on a non-call" "a + b:\n y" "indent/colon-block" "comment:"; + reads "bare name takes a block" "comment:\n f()\n g()" "(comment (f) (g))"; + reads "qualified name takes a block" "rl/with-drawing:\n f()" "(rl/with-drawing (f))"; + (* Indentation. *) + refuses "tab" "fn f() -> ()\n\tg()" "indent/tab" "spaces"; + refuses "dedent to no block" "if a\n b\n c" "indent/dedent" + "between the block at column 1 and the one at column 5"; + (* A continuation sits deeper than the line it continues. *) + refuses "leading operator left of its block" "if a\n b\n+ 1" "indent/continuation" "column 3"; + refuses "leading operator at the statement's column" "let x = 1\n+ 2\nx" + "indent/continuation" "Indent it further"; + refuses "trailing operator, shallower next line" "if a\n x = b +\nc" + "indent/continuation" "finish the line above"; + reads "blank and comment lines" "if a\n\n ; note\n b\n\n; more\nc" + "(when a b)\nc"; + (* Continuation lines. *) + reads "trailing operator" "x = a +\n b" "(set x (+ a b))"; + reads "leading operator" "x = a\n + b" "(set x (+ a b))"; + reads "continued condition" "if a\n and b\n c" "(when (and a b) c)"; + (* Runs of one operator. *) + reads "flattened" "x = a + b + c" "(set x (+ a b c))"; + reads "chain" "x = a < b < c" "(set x (< a b c))"; + reads "left to right" "x = a - b + c" "(set x (+ (- a b) c))"; + reads "precedence" "x = a or b and not c == d" "(set x (or a (and b (not (= c d)))))"; + refuses "not-equal chain" "x = a != b != c" "indent/chained-not-equal" "!=(a, b, c)"; + reads "not-equal call" "x = !=(a, b, c)" "(set x (!= a b c))"; + refuses "mixed comparison" "x = a < b <= c" "indent/mixed-comparison" "and"; + (* Statements. *) + reads "lets merge" "fn f() -> i32\n let a = 1\n let b = 2\n a + b" + "(defn f [] i32 (let [a 1 b 2] (+ a b)))"; + reads "let with a block" "let a = 1\n a\nb" "(let [a 1] a)\nb"; + reads "elif" "if a\n 1\nelif b\n 2\nelse\n 3" "(cond a 1 b 2 :else 3)"; + reads "one-line if" "x = if a then 1 else 2" "(set x (if a 1 2))"; + reads "assignment ops" "a[i] += 1" "(set (at a i) (+ (at a i) 1))"; + reads "for" "for :outer i in range(1, n)\n f(i)" "(dotimes :outer [i 1 n] (f i))"; + reads "unit statement" "restart-case\n f()\nrestart continue()\n ()" + "(restart-case (f) (continue [] (do)))"; + reads "match" "match s\n Circle(r) -> r\n _ ->\n a()\n b()" + "(match s (Circle r) r _ (do (a) (b)))"; + reads "handler-bind moves the clauses" "handler-bind\n f()\non E(c)\n g(c)" + "(handler-bind [(E [c] (g c))] (f))"; + reads "quote block" + "defmacro(m, [x & ys]):\n quote\n f(~x)\n ~@ys" + "(defmacro m [x & ys] (quasiquote (do (f (unquote x)) (unquote-splicing ys))))"; + reads "lambda" "g = fn(i, j) = i * 10 + j" "(set g (fn [i j] (+ (* i 10) j)))"; + reads "lambda with a block" "g = fn(i)\n a(i)\n b(i)" "(set g (fn [i] (a i) (b i)))"; + reads "where" "fn s(xs: [$t]) -> () where ordered?($t) = f(xs)" + "(defn s [xs [$t]] () {:where (ordered? $t)} (f xs))"; + reads "data" "data Shape\n Circle(r: f32)\n Empty" + "(defdata Shape [(Circle [r f32]) Empty])"; + reads "enum" "enum K\n lo = -1\n mid" "(defenum K [lo -1 mid])"; + reads "struct" "struct Cell\n row: i32\n tag" "(defstruct Cell [row i32 tag dyn])"; + reads "read-only pointer" "def p: Ptr(const u8) = uninit" "(def p (Ptr const u8) uninit)"; + (* Statements that fit on a line, in one-line slots. *) + reads "arm statements" "match s\n 1 -> break\n 2 -> continue :outer\n _ -> x += 1" + "(match s 1 (break) 2 (continue :outer) _ (set x (+ x 1)))"; + reads "then break" "if c then break" "(when c (break))"; + reads "then return else assign" "if c then return 5 else x = 2" "(if c (return 5) (set x 2))"; + reads "return in an expression if" "y = if c then return else 1" "(set y (if c (return) 1))"; + reads "defer an assignment" "defer x = 0" "(defer (set x 0))"; + (* Messages with a shape of their own. *) + refuses "parenthesised pair" "x = (a, b)" "indent/tuple" "[a, b]"; + refuses "rest parameter" "fn f(& rest) -> () = 0" "indent/rest-parameter" "xs: [T]"; + refuses "assignment as a test" "if x = 1\n y" "indent/assign-in-test" "x == ..."; + refuses "colon after if" "if c:\n y" "indent/header-colon" "no colon"; + refuses "colon after a return type" "fn f() -> i32:\n 0" "indent/header-colon" "no colon"; + refuses "colon after a number" "while x < 3:\n y" "indent/header-colon" "no colon"; + refuses "one-line handler-case" "handler-case g()" "indent/clause-header" "on Type(c)"; + refuses "one-line on clause" "handler-case\n g()\non A(c) -> 1" "indent/clause-body" "on A(c)"; + refuses "one-line elif" "x = if a then 1 elif b then 2 else 3" "indent/one-line-elif" "else if b"; + refuses "elif with then" "if a\n 1\nelif b then 2" "indent/elif-then" "no then"; + refuses "brace hint" "x = {.x a + 1 .y 2}" "indent/separate-elements" "{.x a + 1, .y 2}"; + refuses "mixed separators" "x = [1 2, 3]" "indent/mixed-separators" "[1, 2, 3]"; + reads "one-line quote" "defmacro(m, [x]):\n quote ~x + 1" + "(defmacro m [x] (quasiquote (+ (unquote x) 1)))"; + reads "typed let" "let x: i32 = 5\nx" "(let [x (the i32 5)] x)"; + (* And back: the printer writes the idioms. *) + let prints name src want = + match Reader.read_all ~file:"

" 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 ────────────────── *) + +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" ()