From 8fe8062a0ced257b12fd017e9cd5359fcb2df367 Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Fri, 25 Sep 2026 23:26:53 +0700 Subject: [PATCH 1/6] Hand-written .fln programs exist, flan convert writes corpus-shaped paren text, and several .fln diagnostics suggest .fln spellings --- lib/body_macros.ml | 2 +- lib/check.ml | 52 ++++-- lib/indent_printer.ml | 60 +++++-- lib/indent_reader.ml | 7 +- lib/paren_printer.ml | 223 +++++++++++++++++++++++- runtime/flan_rt.c | 17 +- test/syntax/handwritten/csv.fln | 93 ++++++++++ test/syntax/handwritten/csv.out | 7 + test/syntax/handwritten/inventory.fln | 81 +++++++++ test/syntax/handwritten/inventory.out | 17 ++ test/syntax/handwritten/ledger.fln | 75 ++++++++ test/syntax/handwritten/ledger.out | 6 + test/syntax/handwritten/lisp.fln | 83 +++++++++ test/syntax/handwritten/lisp.out | 7 + test/syntax/handwritten/ring.fln | 85 +++++++++ test/syntax/handwritten/ring.out | 9 + test/syntax/handwritten/rpn.fln | 115 ++++++++++++ test/syntax/handwritten/rpn.out | 8 + test/syntax/handwritten/stock/stock.fln | 37 ++++ 19 files changed, 946 insertions(+), 38 deletions(-) create mode 100644 test/syntax/handwritten/csv.fln create mode 100644 test/syntax/handwritten/csv.out create mode 100644 test/syntax/handwritten/inventory.fln create mode 100644 test/syntax/handwritten/inventory.out create mode 100644 test/syntax/handwritten/ledger.fln create mode 100644 test/syntax/handwritten/ledger.out create mode 100644 test/syntax/handwritten/lisp.fln create mode 100644 test/syntax/handwritten/lisp.out create mode 100644 test/syntax/handwritten/ring.fln create mode 100644 test/syntax/handwritten/ring.out create mode 100644 test/syntax/handwritten/rpn.fln create mode 100644 test/syntax/handwritten/rpn.out create mode 100644 test/syntax/handwritten/stock/stock.fln diff --git a/lib/body_macros.ml b/lib/body_macros.ml index f03c0d9d..61bdd4ff 100644 --- a/lib/body_macros.ml +++ b/lib/body_macros.ml @@ -29,7 +29,7 @@ let create () = { bodies = Hashtbl.create 32; names = Hashtbl.create 64 } (* Core forms whose trailing arguments are a body run in order, and how many arguments come before it. *) let core = [ ("do", 0); ("let", 1); ("fn", 1); ("when", 1); ("while", 1); ("loop", 1); - ("defer", 0); ("with-allocator", 1) ] + ("dotimes", 1); ("defer", 0); ("with-allocator", 1) ] let body_start (t : t) h = match List.assoc_opt h core with Some k -> Some k | None -> Hashtbl.find_opt t.bodies h diff --git a/lib/check.ml b/lib/check.ml index 3bdf5e80..e5c506ce 100644 --- a/lib/check.ml +++ b/lib/check.ml @@ -2050,7 +2050,12 @@ let dyn_param_or_typo env n loc = | Some m when has_digit m && not (has_digit n) -> None | m -> m in + (* In a .fln file the type sits after [name:], so it cannot be read as a + second parameter and needs no word about parameter vectors. *) + let fln = Source.indented_at loc in match suggestion with + | Some m when fln -> + Loc.failk "check/unknown-type" loc "unknown type %s — did you mean %s?" n m | Some m -> Loc.failk "check/unknown-type" loc "unknown type %s — did you mean %s? Otherwise %s reads as a second \ @@ -2060,6 +2065,8 @@ let dyn_param_or_typo env n loc = if n <> "" && n.[0] = Char.uppercase_ascii n.[0] && n.[0] <> Char.lowercase_ascii n.[0] then + if fln then Loc.failk "check/unknown-type" loc "unknown type %s" n + else Loc.failk "check/unknown-type" loc "unknown type %s. A capitalised name in a parameter vector is a type; \ parameters are lowercase" @@ -4300,19 +4307,23 @@ let declare_env ctx = function | Some _ as s -> s | None -> Some (fresh_slot ctx (Types.Ptr (Types.Mut, Types.Unit))) -let numeric_note ~(want : Types.t) ~(got : Types.t) = +let numeric_note ?(fln = false) ~(want : Types.t) ~(got : Types.t) () = + let cast = + if fln then Printf.sprintf "%s(x)" (Types.to_string want) + else Printf.sprintf "(%s x)" (Types.to_string want) + in if not (Types.is_numeric want && Types.is_numeric got) then "" else if Types.widens_to ~from:want ~into:got then Printf.sprintf - " — %s into %s can lose, so it has to be written: (%s x). The other way \ + " — %s into %s can lose, so it has to be written: %s. The other way \ round, %s widens into %s by itself" - (Types.to_string got) (Types.to_string want) (Types.to_string want) + (Types.to_string got) (Types.to_string want) cast (Types.to_string want) (Types.to_string got) else Printf.sprintf " — neither widens into the other, so the conversion has to be written: \ - (%s x)" - (Types.to_string want) + %s" + cast (* The rest of the sentence when a read-only slice meets a writable one. *) let const_note env ~(want : Types.t) ~(got : Types.t) = @@ -4414,7 +4425,7 @@ let expect ctx loc ~want (got : Tast.expr) = to be told, in the same breath, which direction needed nothing. *) Loc.failk "check/type-mismatch" loc "expected %s, found %s%s%s" (Types.to_string w) (Types.to_string got.Tast.ty) - (numeric_note ~want:w ~got:got.Tast.ty) + (numeric_note ~fln:(Source.indented_at loc) ~want:w ~got:got.Tast.ty ()) (const_note ctx.env ~want:w ~got:got.Tast.ty) (* Something a [break] may not jump out of, named so the refusal can say which. @@ -5999,7 +6010,8 @@ and var ctx ?(qualified = false) loc ~want name = | _ -> fail loc "nothing here says what None is an Option of — use it where an \ - Option is expected, or name one, as in (the (Option i32) None)") + Option is expected, or name one, as in %s" + (if fln_source loc then "the(Option(i32), None)" else "(the (Option i32) None)")) (* spec-memory.md puts the allocator in the calling convention as [context/allocator] and [context/temp]. They read as names rather than calls because that is how the spec writes them, and they are dynamic @@ -8268,16 +8280,24 @@ and check_the ctx ~want loc (t : Ast.texpr) (v : Ast.expr) = let is_nil = match v.Ast.e with Ast.Var "nil" -> true | _ -> false in if ty <> Types.Dyn && not is_nil && probe ctx loc (fun () -> (check ctx v).Tast.ty) = Some Types.Dyn + (* A keyword naming one of an enum's members is that member at the + enum's type, not a dyn: [let d: Dir = :north]. *) + && not (match ty, v.Ast.e with Types.Enum _, Ast.Kw _ -> true | _ -> false) then begin let tn = Types.to_string ty in let numeric = match ty with Types.Int _ | Types.Float _ -> true | _ -> false in + (* In a .fln file the user wrote [x: T = v], not [the]. *) + let fln = fln_source loc in + let the_ = if fln then "a type annotation" else "the" in if numeric then fail v.Ast.loc - "the checks a value as %s and does not convert one, and this is a dyn \ + "%s checks a value as %s and does not convert one, and this is a dyn \ — %s" - tn + the_ tn (match spell_arg "" v with - | "" -> Printf.sprintf "convert it with the %s cast instead" tn + | s when fln && s <> "" && not (String.exists (fun c -> c = ' ' || c = '(') s) -> + Printf.sprintf "write %s(%s) to convert it" tn s + | s when s = "" || fln -> Printf.sprintf "convert it with the %s cast instead" tn | s -> Printf.sprintf "write (%s %s) to convert it" tn s) else (* What a dyn does at this type is the boundary's own answer, asked of @@ -8290,19 +8310,19 @@ and check_the ctx ~want loc (t : Ast.texpr) (v : Ast.expr) = match crosses with | Some () -> fail v.Ast.loc - "the checks a value as %s and does not convert one, and this is a \ + "%s checks a value as %s and does not convert one, and this is a \ dyn — a dyn becomes a %s where a %s is passed, returned or stored" - tn tn tn + the_ tn tn tn | None -> (match speculate ctx.env (fun () -> check ctx ~want:ty v) with | _ -> fail v.Ast.loc - "the checks a value as %s and does not convert one, and this is \ - a dyn" tn + "%s checks a value as %s and does not convert one, and this is \ + a dyn" the_ tn | exception Loc.Error d -> fail v.Ast.loc - "the checks a value as %s and does not convert one, and this is \ - a dyn — %s" tn d.Loc.dmsg) + "%s checks a value as %s and does not convert one, and this is \ + a dyn — %s" the_ tn d.Loc.dmsg) end; let r = match ty, v.Ast.e with diff --git a/lib/indent_printer.ml b/lib/indent_printer.ml index 844f2dda..439d2c52 100644 --- a/lib/indent_printer.ml +++ b/lib/indent_printer.ml @@ -537,15 +537,26 @@ let body_guess (h : Form.t) args = match List.rev args with a :: _ -> stmt_like a | [] -> false in ignore lead; - if is_with || last_stmt then begin - let k = ref 0 in - List.iteri - (fun i (a : Form.t) -> - match a.v with Form.List (_ :: _) -> () | _ -> k := i + 1) - args; - Some !k - end - else None) + let k = ref 0 in + List.iteri + (fun i (a : Form.t) -> + match a.v with Form.List (_ :: _) -> () | _ -> k := i + 1) + args; + (* The block starts at the first statement among the trailing lists, + so what comes before it — an if's test — stays in the parentheses: + [if(c):] rather than the test as the block's first line. *) + let first_stmt = + let rec go i = function + | [] -> None + | a :: rest -> if i >= !k && stmt_like a then Some i else go (i + 1) rest + in + go 0 args + in + if is_with then Some !k + else if last_stmt then Some (Option.value first_stmt ~default:!k) + else + (* A statement anywhere among the trailing lists makes them a body. *) + match first_stmt with Some _ -> Some !k | None -> None) | _ -> None let let_sugar (f : Form.t) = @@ -679,6 +690,24 @@ and wrapped n prefix (f : Form.t) = List.map (fun l -> let k = String.length l in if k > 0 && l.[k - 1] = ' ' then String.sub l 0 (k - 1) else l) lines + (* A vector literal too long for its line, filled to the width, with the + separator [vec_text] chose. *) + | Form.Vec (_ :: _ :: _ as xs) -> + let open_ = prefix ^ "[" in + let col = n + String.length open_ in + let ts = List.map expr xs in + let sep = if List.for_all (fun (_, l) -> l >= 8) ts then "" else "," in + let rec go line acc = function + | [] -> List.rev ((line ^ "]") :: acc) + | (t, _) :: rest -> + let piece = if rest = [] then t else t ^ sep in + if String.length line = col || String.length line + String.length piece + 1 <= width + then go (line ^ piece ^ (if rest = [] then "" else " ")) acc rest + else + let line = String.sub line 0 (String.length line - 1) in + go (ind col ^ piece ^ (if rest = [] then "" else " ")) (line :: acc) rest + in + go (ind n ^ open_) [] ts | _ -> [ ind n ^ prefix ^ at 0 f ] (* [prefix = v], or [prefix =] and the value as an indented block when it is @@ -701,6 +730,7 @@ and value_lines n prefix (v : Form.t) = when not (List.mem h sugar_heads || h = "fn" || h = "if") -> wrapped n (prefix ^ " = ") v | Form.List (_ :: _) -> [ ind n ^ prefix ^ " =" ] @ block (n + 2) (stmts_of v) + | Form.Vec (_ :: _ :: _) -> wrapped n (prefix ^ " = ") v | _ -> [ ind n ^ inline ] and slot n (f : Form.t) = block n (stmts_of f) @@ -771,9 +801,17 @@ and sugar n (f : Form.t) : string list option = | _ -> None) | Form.List ({ v = Form.Sym "dotimes"; _ } :: rest) -> let lbl, rest = label_of rest in + (* The variable is a name, or in a template an unquote, [for ~i in ...]. *) + let var (f : Form.t) = + match f.v with + | Form.Sym v when def_name v && v <> "in" -> Some v + | Form.List [ { v = Form.Sym "unquote"; _ }; _ ] -> Some (fst (expr f)) + | _ -> None + in (match rest with - | { v = Form.Vec ({ v = Form.Sym v; _ } :: bs); _ } :: (_ :: _ as body) - when def_name v && bs <> [] && List.length bs <= 3 && v <> "in" -> + | { v = Form.Vec (vf :: bs); _ } :: (_ :: _ as body) + when var vf <> None && bs <> [] && List.length bs <= 3 -> + let v = Option.get (var vf) in Some ((i ^ "for " ^ lbl ^ v ^ " in range(" ^ commas bs ^ ")") :: block (n + 2) body) | _ -> None) diff --git a/lib/indent_reader.ml b/lib/indent_reader.ml index 13d6b434..8248ef3d 100644 --- a/lib/indent_reader.ml +++ b/lib/indent_reader.ml @@ -1439,7 +1439,12 @@ and header (s : st) w : Form.t = | KW k -> let kt = advance p in [ Form.make (Form.Kw k) kt.loc ] | _ -> [] in - let v = name_tok p ~what:"the loop variable" in + (* In a macro template the variable may be an unquote, [for ~i in ...]. *) + let v = + match (peek p).tok with + | UNQ -> fst (primary p) + | _ -> name_tok p ~what:"the loop variable" + in expect_name p "in" ~what:"in, as in for i in range(n)"; let rt = peek p in expect_name p "range" ~what:"range(n), range(a, b) or range(a, b, step)"; diff --git a/lib/paren_printer.ml b/lib/paren_printer.ml index ed72d06e..78df2da9 100644 --- a/lib/paren_printer.ml +++ b/lib/paren_printer.ml @@ -7,9 +7,27 @@ let width = 80 +(* The reader's prefix for a quoting form, as the corpus writes them: + [`(do ~x ~@xs)] rather than [(quasiquote (do (unquote x) ...))]. *) +let sugar (f : Form.t) = + match f.v with + | Form.List [ { v = Form.Sym s; _ }; x ] -> + (match s, x.v with + | "quote", _ -> Some ("'", x) + | "quasiquote", _ -> Some ("`", x) + | "unquote-splicing", _ -> Some ("~@", x) + (* [~@x] would read as a splice. *) + | "unquote", Form.Sym n when String.length n > 0 && n.[0] = '@' -> None + | "unquote", _ -> Some ("~", x) + | _ -> None) + | _ -> None + let rec flat spell (f : Form.t) = let seq l = String.concat " " (List.map (flat spell) l) in match f.v with + | _ when sugar f <> None -> + let p, x = Option.get (sugar f) in + p ^ flat spell x | Form.Int _ | Form.Float _ -> (match spell f with Some t -> t | None -> Form.to_source f) | Form.List l -> "(" ^ seq l ^ ")" @@ -17,6 +35,19 @@ let rec flat spell (f : Form.t) = | Form.Map l -> "{" ^ seq l ^ "}" | _ -> Form.to_source f +(* Heads whose arguments are statements or clauses rather than values: these + break one argument to a line, never filled. *) +let statement_heads = + [ "let"; "loop"; "set"; "if"; "when"; "unless"; "cond"; "while"; "until"; + "dotimes"; "match"; "handler-case"; "handler-bind"; "restart-case"; + "return"; "defer"; "do"; "fn"; "with-allocator"; "comment"; "quasiquote"; + "break"; "continue" ] + +let form_heads = + [ "defn"; "defn-"; "defmacro"; "def"; "defonce"; "defconst"; "defstruct"; + "defunion"; "defdata"; "defenum"; "import"; "defalias"; "defmethod"; + "defgeneric"; "defmulti"; "defclass" ] + (* How many arguments stay on the head's line when the form is broken. *) let kept head = match head with @@ -26,6 +57,24 @@ let kept head = | "do" | "cond" | "comment" | "restart-case" | "handler-case" -> 0 | _ -> 1 +(* Two at a time: [a b] on one line when it fits and no comment sits + inside either, otherwise each laid out on its own lines. *) +let paired ~inside spell col placed items = + let rec go = function + | (a : Form.t) :: b :: more -> + let line = flat spell a ^ " " ^ flat spell b in + (* A comment on a line between the two would land beside the wrong + one, so a pair more than a line apart keeps two lines. *) + (if col + String.length line <= width && not (inside a) && not (inside b) + && b.loc.Loc.line <= a.loc.Loc.eline + 1 + then [ Source_text.tag a.loc.Loc.line + (Source_text.tag b.loc.Loc.line (String.make col ' ' ^ line)) ] + else placed col a @ placed col b) + @ go more + | rest -> List.concat_map (placed col) rest + in + go items + (* [inside l] says whether a comment sits on a line of [f] before its last, where a flat [f] would leave it nowhere to go: such a form is broken. *) let rec layout ?(inside = fun _ -> false) spell col (f : Form.t) : string list = @@ -37,7 +86,58 @@ let rec layout ?(inside = fun _ -> false) spell col (f : Form.t) : string list = in if col + String.length one <= width && not (inside f) then [ one ] else - let bracket o c items ~keep = + match sugar f with + | Some (p, x) -> + (match layout spell (col + String.length p) x with + | first :: more -> + let tags, body = Source_text.untag first in + List.fold_left (fun l t -> Source_text.tag t l) (p ^ body) tags :: more + | [] -> [ one ]) + | None -> + (* A plain call broken across lines: its arguments fill each line, + aligned under the first, and one that needs lines of its own gets + them. *) + let fill items = + match items with + | hd :: (_ :: _ as args) -> + let lead = "(" ^ flat spell hd ^ " " in + let acol = col + String.length lead in + let pad = String.make acol ' ' in + let vis l = String.length (snd (Source_text.untag l)) in + (* [cur] is the line being filled, [fresh] while it holds no argument; + the first line is built with its column and cut back after. *) + let rec go cur fresh acc = function + | [] -> List.rev (if fresh then acc else cur :: acc) + | (a : Form.t) :: more -> + let t = flat spell a in + let sep = if fresh then "" else " " in + let close = if more = [] then 1 else 0 in + if (not (inside a)) && vis cur + String.length sep + String.length t + close <= width + then go (Source_text.tag a.loc.Loc.line (cur ^ sep ^ t)) false acc more + else if fresh then + match layout spell acol a with + | l1 :: ls -> + let tags, b = Source_text.untag l1 in + let l1 = List.fold_left (fun l t -> Source_text.tag t l) (cur ^ b) tags in + let l1 = Source_text.tag a.loc.Loc.line l1 in + go pad true (List.rev_append (l1 :: ls) acc) more + | [] -> go cur fresh acc more + else go pad true (cur :: acc) (a :: more) + in + let lines = go (String.make col ' ' ^ lead) true [] args in + let lines = + match lines with + | l1 :: rest -> + let tags, b = Source_text.untag l1 in + List.fold_left (fun l t -> Source_text.tag t l) (String.sub b col (String.length b - col)) tags + :: rest + | [] -> [] + in + let n = List.length lines in + List.mapi (fun i l -> if i = n - 1 then l ^ ")" else l) lines + | _ -> [ one ] + in + let bracket ?(pairs = false) o c items ~keep = let placed inner x = match layout spell inner x with | first :: more -> @@ -54,8 +154,27 @@ let rec layout ?(inside = fun _ -> false) spell col (f : Form.t) : string list = col + 1 + String.length (String.concat " " (List.map (flat spell) (List.filteri (fun i _ -> i < k) items))) in - let keep = if keep > 1 && head_len keep > width then 1 else keep in - if keep > 0 then + let hang = + (* [(Rule {.label "a"\n .applies f})]: a literal the head + names hangs on the head's line rather than dropping below it. *) + keep > 1 + && (match List.nth_opt items (keep - 1) with + | Some { Form.v = Form.Map _; _ } -> head_len (keep - 1) + 1 < width - 20 + | _ -> false) + in + let keep = if keep > 1 && head_len keep > width && not hang then 1 else keep in + if hang && head_len keep > width then + let first = List.filteri (fun i _ -> i < keep - 1) items in + let lit = List.nth items (keep - 1) in + let rest = List.filteri (fun i _ -> i >= keep) items in + let lead = o ^ String.concat " " (List.map (flat spell) first) ^ " " in + (match layout spell (col + String.length lead) lit with + | l1 :: more -> + let tags, b = Source_text.untag l1 in + List.fold_left (fun l t -> Source_text.tag t l) (lead ^ b) tags :: more + | [] -> [ lead ]) + @ List.concat_map (placed (col + 2)) rest + else if keep > 0 then let first = List.filteri (fun i _ -> i < keep) items in let rest = List.filteri (fun i _ -> i >= keep) items in let before = List.filteri (fun i _ -> i < keep - 1) first in @@ -80,10 +199,18 @@ let rec layout ?(inside = fun _ -> false) spell col (f : Form.t) : string list = @ List.concat_map (placed (col + 2)) rest | _ -> (o ^ String.concat " " (List.map (flat spell) first)) - :: List.concat_map (placed (col + 2)) rest + :: (if pairs then paired ~inside spell (col + 2) placed rest + else List.concat_map (placed (col + 2)) rest) else match items with | [] -> [ o ] + | _ when pairs -> + (match paired ~inside spell (col + 1) placed items with + | first :: more -> + let tags, body = Source_text.untag first in + let body = String.sub body (col + 1) (String.length body - col - 1) in + List.fold_left (fun l t -> Source_text.tag t l) (o ^ body) tags :: more + | [] -> [ o ]) | x :: xs -> (match layout spell (col + 1) x with | first :: more -> @@ -96,10 +223,94 @@ let rec layout ?(inside = fun _ -> false) spell col (f : Form.t) : string list = List.mapi (fun i l -> if i = n - 1 then l ^ c else l) lines in match f.v with - | Form.List (({ v = Form.Sym h; _ }) :: _ as items) -> - bracket "(" ")" items ~keep:(1 + min (kept h) (List.length items - 1)) + (* A let's binding vector opens on the head's line, a pair to a line, + each value hanging after its name, as the corpus writes them. *) + | Form.List (({ v = Form.Sym (("let" | "loop") as h); _ } as hd) + :: ({ v = Form.Vec bs; _ } as v) :: body) + when bs <> [] && List.length bs mod 2 = 0 && not (inside v) -> + let lead = "(" ^ h ^ " [" in + let vcol = col + String.length lead in + let rec pairs k = function + | (a : Form.t) :: b :: more -> + let an = flat spell a in + let pad = if k = 0 then lead else String.make vcol ' ' in + let lines = + match layout spell (vcol + String.length an + 1) b with + | first :: rest -> + let tags, bt = Source_text.untag first in + List.fold_left (fun l t -> Source_text.tag t l) + (Source_text.tag a.loc.Loc.line (pad ^ an ^ " " ^ bt)) tags + :: rest + | [] -> [ pad ^ an ] + in + lines @ pairs (k + 1) more + | _ -> [] + in + let flat_v = lead ^ String.concat " " (List.map (flat spell) bs) in + let bl = + if col + String.length flat_v + 1 <= width then [ flat_v ] else pairs 0 bs + in + let nb = List.length bl in + let bl = List.mapi (fun i l -> if i = nb - 1 then l ^ "]" else l) bl in + let placed x = + match layout spell (col + 2) x with + | first :: more -> + let tags, b = Source_text.untag first in + Source_text.tag x.loc.Loc.line + (List.fold_left (fun l t -> Source_text.tag t l) (String.make (col + 2) ' ' ^ b) tags) + :: more + | [] -> [] + in + let lines = + (match bl with + | first :: rest -> Source_text.tag hd.loc.Loc.line first :: rest + | [] -> []) + @ List.concat_map placed body + in + let n = List.length lines in + List.mapi (fun i l -> if i = n - 1 then l ^ ")" else l) lines + (* A match's arms and a cond's clauses go a pair to a line when the pair + fits, the way the corpus writes them. *) + | Form.List (({ v = Form.Sym "match"; _ }) :: _ :: rest as items) + when List.length rest mod 2 = 0 -> + bracket ~pairs:true "(" ")" items ~keep:2 + | Form.List (({ v = Form.Sym "cond"; _ }) :: rest as items) + when List.length rest mod 2 = 0 -> + bracket ~pairs:true "(" ")" items ~keep:1 + | Form.List (({ v = Form.Sym h; _ }) :: rest as items) -> + (* A loop's label stays with its test: [(while :outer (< i n)]. *) + let label = + match h, rest with + | ("while" | "until" | "dotimes"), { v = Form.Kw _; _ } :: _ :: _ -> 1 + | _ -> 0 + in + let stmt (a : Form.t) = + match a.v with + | Form.List ({ v = Form.Sym x; _ } :: _) -> List.mem x statement_heads + | _ -> false + in + let n = List.length rest in + if List.mem h statement_heads || List.mem h form_heads || List.exists stmt rest + || n < 2 || h.[0] = '.' + then + (* A body: the arguments before its first list stay on the head's + line, [(repeat i 2\n (set ...) ...)]. *) + let lead = + if List.mem h statement_heads || List.mem h form_heads then 0 + else + let rec go k = function + | { Form.v = Form.List _; _ } :: _ | [] -> k + | _ :: more -> go (k + 1) more + in + go 0 rest + in + bracket "(" ")" items + ~keep:(1 + label + max (min lead (n - 1)) (min (kept h) (n - label))) + else fill items | Form.List items -> bracket "(" ")" items ~keep:0 | Form.Vec items -> bracket "[" "]" items ~keep:0 + | Form.Map items when List.length items mod 2 = 0 -> + bracket ~pairs:true "{" "}" items ~keep:0 | Form.Map items -> bracket "{" "}" items ~keep:0 | _ -> [ one ] diff --git a/runtime/flan_rt.c b/runtime/flan_rt.c index 5d3d2576..1036c878 100644 --- a/runtime/flan_rt.c +++ b/runtime/flan_rt.c @@ -2430,14 +2430,25 @@ void flan_alloc_region_only(flan_allocator *a, const uint8_t *loc, if (a->caps & FLAN_CAN_FREE) flan_region_only_fail(loc, loclen); } +/* Whether a "file:line:col" location names an indented (.fln) file, so a + * suggestion is written in the syntax the reader's code is in. */ +static int rt_loc_is_fln(const uint8_t *loc, int64_t loclen) { + for (int64_t i = 0; i + 5 <= loclen; i++) + if (memcmp(loc + i, ".fln:", 5) == 0) return 1; + return 0; +} + _Noreturn void flan_region_only_fail(const uint8_t *loc, int64_t loclen) { rt_flush_out(); fprintf(stderr, "%.*s: this container's elements own storage, and this allocator " "frees one block at a time, so freeing it here would leak what the " - "elements hold. Build it against a region allocator: " - "(with-allocator context/temp ...) or an (arena-new n)\n", - (int)loclen, (const char *)loc); + "elements hold. Build it against a region allocator: %s\n", + (int)loclen, (const char *)loc, + rt_loc_is_fln(loc, loclen) + ? "with-allocator(context/temp): and the code under it, or an " + "arena-new(n)" + : "(with-allocator context/temp ...) or an (arena-new n)"); rt_die(); } diff --git a/test/syntax/handwritten/csv.fln b/test/syntax/handwritten/csv.fln new file mode 100644 index 00000000..2c63edc6 --- /dev/null +++ b/test/syntax/handwritten/csv.fln @@ -0,0 +1,93 @@ +; A CSV reader written as a state machine over bytes: quoted fields, doubled +; quotes inside them, and a count of rows kept in globals. + +enum State + start + bare + quoted + quote-in-quoted + +once rows-seen: i32 +def fields-seen: i32 = 0 +const separator = \, + +; Frame the body's output with a title line and a closing rule. +defmacro(with-section, [title & body]): + quote + println("--", ~title, "--") + ~@body + println("-----") + +fn flush(field: Ptr(Vec(u8)), row: Ptr(Vec(string))) -> () + push(deref(row), string(slice(deref(field)))) + fields-seen += 1 + deref(field) = vec-new(u8) + +fn parse-line(line: [const u8]) -> Vec(string) + let row = vec-new(string) + let field = vec-new(u8) + let state: State = :start + for i in range(length(line)) + let c = line[i] + match state + :start -> + if c == \" + state = :quoted + elif c == separator + flush(addr(field), addr(row)) + else + push(field, c) + state = :bare + :bare -> + if c == separator + flush(addr(field), addr(row)) + state = :start + else + push(field, c) + :quoted -> + if c == \" then state = :quote-in-quoted else push(field, c) + :quote-in-quoted -> + if c == \" + push(field, c) + state = :quoted + else + flush(addr(field), addr(row)) + state = :start + flush(addr(field), addr(row)) + rows-seen += 1 + row + +fn widest(rows: [Vec(string)]) -> i32 + let best = 0 + for r in range(length(rows)) + for f in range(length(rows[r])) + best = max(best, i32(length(rows[r][f]))) + best + +fn pad(s: string, width: i32) -> () + print(s) + let n = width - i32(length(s)) + until n <= 0 + print(" ") + n -= 1 + +fn main() -> i32 + let text = "name,qty,note\npear,3,\"ripe, soft\"\nfig,12,\"said \"\"hi\"\"\"\n,0,none" + let frame = arena-new(65536) + defer arena-destroy(frame) + with-allocator(frame): + let lines = split(bytes-view(text), \newline) + let rows = vec-new(Vec(string)) + for i in range(length(lines)) + push(rows, parse-line(lines[i])) + let w = widest(slice(rows)) + 1 + with-section("table"): + for r in range(length(rows)) + for f in range(length(rows[r])) + let last = f + 1 == length(rows[r]) + pad(rows[r][f], if last then 0 else w) + println("") + println("rows", rows-seen, "fields", fields-seen) + comment: + parse-line(bytes-view("a,\"b\",c")) + 0 diff --git a/test/syntax/handwritten/csv.out b/test/syntax/handwritten/csv.out new file mode 100644 index 00000000..3dd43ac8 --- /dev/null +++ b/test/syntax/handwritten/csv.out @@ -0,0 +1,7 @@ +-- table -- +name qty note +pear 3 ripe, soft +fig 12 said "hi" + 0 none +----- +rows 4 fields 12 diff --git a/test/syntax/handwritten/inventory.fln b/test/syntax/handwritten/inventory.fln new file mode 100644 index 00000000..6f23270d --- /dev/null +++ b/test/syntax/handwritten/inventory.fln @@ -0,0 +1,81 @@ +; An inventory report: items from the stock package, reorder rules held as +; function values, and the report's text built in an arena that is reset +; between runs. + +import stock "stock" + +struct Rule + label: string + applies: CFn(stock/Item) -> bool + +def report-width: i32 = 28 +once runs: i32 +const reorder-below = 5 + +; Run the body n times, counting passes in the name given. +defmacro(repeat, [i n & body]): + quote + for ~i in range(~n) + ~@body + +; Say what went wrong when a check does not hold. +defmacro(expect, [test message]): + quote + if not ~test + println("expected:", ~message) + +fn gcd(a: i32, b: i32) -> i32 + loop([x a y b]): + if y == 0 then x else recur(y, x % y) + +fn line(it: stock/Item) -> () + let price = stock/money(stock/value(it)) + defer + free(price) + let dots = report-width - i32(length(it.name)) - i32(length(price)) + print(it.name) + for i in range(max(dots, 1)) + print(".") + println(string(slice(price))) + +fn low?(it: stock/Item) -> bool = it.count < reorder-below + +fn count-if(items: [stock/Item], keep?: Fn(stock/Item) -> bool) -> i32 + let n = 0 + for i in range(length(items)) + if keep?(items[i]) + ++(n) + n + +fn main() -> i32 + let items = [stock/item("bolts", 12, 400), stock/item("nuts", 5, 3), + stock/item("gears", 1250, 7), stock/item("belts", 899, 0)] + let rules = [Rule{.label "reorder", .applies low?}, + Rule{.label "valuable", .applies fn(it) = stock/value(it) > 5000}] + let frame = arena-new(4096) + repeat(pass, 2): + runs += 1 + with-allocator(frame): + println("report", runs) + for i in range(length(items)) + line(items[i]) + for r in range(length(rules)) + let names = vec-new(string) + for i in range(length(items)) + if rules[r].applies(items[i]) + push(names, items[i].name) + println(rules[r].label, slice(names)) + free-all(frame) + arena-destroy(frame) + let total = 0 + for i in range(0, length(items), 2) + total += items[i].count + println("even rows hold", total, "and share a factor of", + gcd(items[0].count, items[2].count + 1)) + println("sign bits", stock/sign-bit(-2.5), stock/sign-bit(2.5), + "masked", bit-and(-total, 0xFF)) + let big = 1000 + println("worth over", big, count-if(slice(items), fn(it) = stock/value(it) > big)) + expect(total == 407, "407 on even rows") + expect(runs == 2, "two runs") + 0 diff --git a/test/syntax/handwritten/inventory.out b/test/syntax/handwritten/inventory.out new file mode 100644 index 00000000..42e4499f --- /dev/null +++ b/test/syntax/handwritten/inventory.out @@ -0,0 +1,17 @@ +report 1 +bolts..................48.00 +nuts....................0.15 +gears..................87.50 +belts...................0.00 +reorder ["nuts" "belts"] +valuable ["gears"] +report 2 +bolts..................48.00 +nuts....................0.15 +gears..................87.50 +belts...................0.00 +reorder ["nuts" "belts"] +valuable ["gears"] +even rows hold 407 and share a factor of 8 +sign bits 1 0 masked 105 +worth over 1000 2 diff --git a/test/syntax/handwritten/ledger.fln b/test/syntax/handwritten/ledger.fln new file mode 100644 index 00000000..bea43893 --- /dev/null +++ b/test/syntax/handwritten/ledger.fln @@ -0,0 +1,75 @@ +; A ledger that applies transfers between accounts. A transfer that would +; overdraw signals, and the caller picks a restart: skip it, cap it at what +; the account holds, or allow an overdraft up to a limit it supplies. + +defstruct(Overdraft, :parent, Error, [account i32 short i64]) + +struct Audit + account: i32 + amount: i64 + +once balances: [4 i64] +once audits: i32 +once log: i64 + +; Every transfer leaves a digit in the log when it is done with, however it +; ended: 1 applied, 2 left through a restart. +fn note(d: i64) -> () + log = log * 10 + d + +fn withdraw(account: i32, amount: i64) -> i64 + let have = balances[account] + if amount > have + let short = amount - have + restart-case + error(Overdraft{.account account, .short short}) + restart skip() + return 0 + restart cap() + return withdraw(account, have) + restart allow(limit: i64) + if short > limit + return 0 + if amount >= 100 + signal(Audit{.account account, .amount amount}) + balances[account] -= amount + amount + +fn transfer(from: i32, to: i32, amount: i64) -> i64 + let applied: i64 = 0 + defer note(if applied == amount then 1 else 2) + applied = withdraw(from, amount) + balances[to] += applied + applied + +fn run(policy) -> () + balances = [100 50 0 10] + log = 0 + handler-bind + transfer(0, 2, 30) + transfer(1, 2, 80) + transfer(3, 0, 25) + transfer(0, 1, 100) + on Overdraft(o) + match policy + :skip -> invoke-restart('skip) + :cap -> invoke-restart('cap) + _ -> invoke-restart('allow, i64(20)) + on Audit(a) + audits += 1 + println(policy, slice(balances), "log", log) + +fn main() -> i32 + run(:skip) + run(:cap) + run(:allow) + println("audited", audits) + let caught = + handler-case + balances = [0 0 0 0] + withdraw(2, 5) + on Overdraft(o) + println("unhandled overdraft on", o.account, "short by", o.short) + -1 + println("caught", caught) + 0 diff --git a/test/syntax/handwritten/ledger.out b/test/syntax/handwritten/ledger.out new file mode 100644 index 00000000..bcca8c53 --- /dev/null +++ b/test/syntax/handwritten/ledger.out @@ -0,0 +1,6 @@ +:skip [70 50 30 10] log 1222 +:cap [0 80 80 0] log 1222 +:allow [-5 150 30 -15] log 1211 +audited 1 +unhandled overdraft on 2 short by 5 +caught -1 diff --git a/test/syntax/handwritten/lisp.fln b/test/syntax/handwritten/lisp.fln new file mode 100644 index 00000000..9b7c8743 --- /dev/null +++ b/test/syntax/handwritten/lisp.fln @@ -0,0 +1,83 @@ +; A small interpreter over dyn values: a program is nested vectors whose +; first element is a keyword naming the operation, variables are keywords, +; and environments are dyn maps chained through a :parent key. + +defclass(lambda, [param body env]) + +defgeneric(describe, [v], dyn) + +defmethod(describe, lambda, [f]): + "a function of one argument" + +defmulti(kind, [v], dyn, type-of(v)) + +defmethod(kind, :int, [v]): + "number" + +defmethod(kind, :vec, [v]): + "form" + +defmethod(kind, :else, [v]): + "value" + +once steps = 0 + +fn lookup(env, name) -> dyn + if env == nil + println("unbound", name) + return 0 + if has-key?(env, name) then get(env, name) else lookup(get(env, :parent), name) + +fn extend(env, name, value) -> dyn + {:parent env name value} + +fn eval(e, env) -> dyn + steps += 1 + match type-of(e) + :keyword -> lookup(env, e) + :vec -> eval-form(e, env) + _ -> e + +fn eval-form(e, env) -> dyn + let op = e[0] + match op + :+ -> eval(e[1], env) + eval(e[2], env) + :- -> eval(e[1], env) - eval(e[2], env) + :* -> eval(e[1], env) * eval(e[2], env) + :< -> eval(e[1], env) < eval(e[2], env) + :if -> + if eval(e[1], env) then eval(e[2], env) else eval(e[3], env) + :let -> + let v = eval(e[2], env) + let inner = extend(env, e[1], v) + ; A function sees its own name, so it can call itself. + if type-of(v) == :lambda + put(v, :env, inner) + eval(e[3], inner) + :fn -> lambda(e[1], e[2], env) + :do -> + let last = nil + for i in range(1, length(e)) + last = eval(e[i], env) + last + _ -> + let f = eval(op, env) + let arg = eval(e[1], env) + eval(get(f, :body), extend(get(f, :env), get(f, :param), arg)) + +fn run(program) -> () + steps = 0 + let result = eval(program, {:parent nil}) + println(kind(program), "=>", result, "in", steps, "steps") + +fn main() -> i32 + run(42) + run([:+ 1 [:* 2 3]]) + run([:let :x 5 [:if [:< :x 3] :small [:* :x :x]]]) + let fact = [:let :fact [:fn :n [:if [:< :n 2] 1 [:* :n [:fact [:- :n 1]]]]] [:fact 6]] + run(fact) + run([:let :k 10 [:let :add-k [:fn :y [:+ :y :k]] [:do [:add-k 1] [:add-k 32]]]]) + let f = eval([:fn :x :x], {:parent nil}) + println(describe(f), "/", kind(f), "/", type-of(f)) + run([:let :greeting "hello" :greeting]) + 0 diff --git a/test/syntax/handwritten/lisp.out b/test/syntax/handwritten/lisp.out new file mode 100644 index 00000000..cf7645e0 --- /dev/null +++ b/test/syntax/handwritten/lisp.out @@ -0,0 +1,7 @@ +number => 42 in 1 steps +form => 7 in 5 steps +form => 25 in 9 steps +form => 720 in 65 steps +form => 42 in 17 steps +a function of one argument / value / :lambda +form => hello in 3 steps diff --git a/test/syntax/handwritten/ring.fln b/test/syntax/handwritten/ring.fln new file mode 100644 index 00000000..88940780 --- /dev/null +++ b/test/syntax/handwritten/ring.fln @@ -0,0 +1,85 @@ +; A fixed-size ring buffer of samples, generic over the element type, with +; the statistics a sensor log wants: a median, the distinct values, and a +; checksum over the raw bytes. + +struct Ring + items: [$n $t] + head: i32 + count: i32 + +struct Reading + sensor: u8 + value: i32 + +fn push-ring!(r: Ptr(Ring($n, $t)), x: $t) -> () + r.items[r.head] = x + r.head = (r.head + 1) % n + if r.count < n + r.count += 1 + +; The oldest sample first. +fn nth-oldest(r: Ptr(Ring($n, $t)), i: i32) -> $t + let start = if r.count < n then 0 else r.head + r.items[(start + i) % n] + +fn copy-out(r: Ptr(Ring($n, $t))) -> Vec($t) + let v = vec-new(t) + for i in range(r.count) + push(v, nth-oldest(r, i)) + v + +fn median(xs: [$t]) -> Option($t) where ordered?($t), equal?($t) + if length(xs) == 0 + return None + sort(xs) + Some(xs[length(xs) / 2]) + +fn distinct(xs: [const $t]) -> Vec($t) where equal?($t), hashable?($t) + let seen = map-new(t, bool) + defer free(seen) + let out = vec-new(t) + for i in range(length(xs)) + if not has-key?(seen, xs[i]) + put(seen, xs[i], true) + push(out, xs[i]) + out + +; FNV-1a over the bytes of any array of plain values. +fn checksum(p: Ptr(u8), size: i64) -> u32 + let bytes = slice-from(p, size) + let h: u32 = 2166136261 + for i in range(length(bytes)) + h = bit-xor(h, u32(bytes[i])) + h = h * 16777619 + h + +fn main() -> i32 + let r: Ring(5, i32) = zeroed() + let samples = [7 3 9 3 12 5 3 8] + for :fill i in range(length(samples)) + if samples[i] > 10 + continue :fill + push-ring!(addr(r), samples[i]) + let kept = copy-out(addr(r)) + defer free(kept) + println("kept", slice(kept)) + match median(slice(kept)) + Some(m) -> println("median", m) + None -> println("no samples") + let empty: [0 i32] = zeroed() + println("median of none", or-else(median(slice(empty)), -1)) + let d = distinct(slice(samples)) + println("distinct", slice(d)) + free(d) + let big = filter(slice(samples), fn(x) = x >= 7) + println("seven and up", slice(big), "sum", reduce(slice(big), 0, fn(a, b) = a + b)) + free(big) + let rs = [Reading{.sensor 2, .value 40} Reading{.sensor 1, .value 15} + Reading{.sensor 3, .value 22}] + sort-by(slice(rs), fn(a, b) = a.value < b.value) + for i in range(length(rs)) + println("sensor", rs[i].sensor, rs[i].value) + let raw: [4 u32] = [1 2 3 4] + let p = Ptr(u8)(addr(raw[0])) + println("checksum", checksum(p, 16)) + 0 diff --git a/test/syntax/handwritten/ring.out b/test/syntax/handwritten/ring.out new file mode 100644 index 00000000..68cae26e --- /dev/null +++ b/test/syntax/handwritten/ring.out @@ -0,0 +1,9 @@ +kept [9 3 5 3 8] +median 5 +median of none -1 +distinct [7 3 9 12 5 8] +seven and up [7 9 12 8] sum 36 +sensor 1 15 +sensor 3 22 +sensor 2 40 +checksum 1041505217 diff --git a/test/syntax/handwritten/rpn.fln b/test/syntax/handwritten/rpn.fln new file mode 100644 index 00000000..e98f2239 --- /dev/null +++ b/test/syntax/handwritten/rpn.fln @@ -0,0 +1,115 @@ +; A reverse-Polish calculator: a tokenizer, a data type for tokens, and an +; evaluator that signals on a bad program and lets the caller decide. + +data Token + Num(n: i64) + Op(c: u8) + Word(w: [const u8]) + End + +struct Underflow + op: u8 + +struct Unknown + word: [const u8] + +const max-depth = 16 + +struct Machine + stack: [max-depth i64] + depth: i32 + +; Read the token that starts at pos; the position after it comes back too. +fn next-token(src: [const u8], pos: Ptr(i32)) -> Token + let n = length(src) + while deref(pos) < n and space?(src[deref(pos)]) + ++(deref(pos)) + if deref(pos) >= n + return Token.End + let start = deref(pos) + until deref(pos) >= n or space?(src[deref(pos)]) + ++(deref(pos)) + let text = slice(src, start, deref(pos)) + let c = text[0] + if digit?(c) or (c == \- and length(text) > 1) + match parse-i64(text) + Some(v) -> Token.Num{.n v} + None -> Token.Word{.w text} + elif length(text) == 1 and some?(index-of(bytes-view("+-*/%"), c)) + Token.Op{.c c} + else + Token.Word{.w text} + +fn push!(m: Ptr(Machine), v: i64) -> () + m.stack[m.depth] = v + m.depth += 1 + +fn pop!(m: Ptr(Machine), op: u8) -> i64 + if m.depth == 0 + error(Underflow{.op op}) + m.depth -= 1 + m.stack[m.depth] + +fn apply(op: u8, a: i64, b: i64) -> i64 + match op + \+ -> a + b + \- -> a - b + \* -> a * b + \/ -> if b == 0 then 0 else a / b + _ -> a % b + +fn run(src: string) -> i64 + let m: Machine = zeroed() + let text = bytes-view(src) + let pos = 0 + while :tokens true + match next-token(text, addr(pos)) + End -> break :tokens + Num(n) -> push!(addr(m), n) + Op(c) -> + let b = pop!(addr(m), c) + let a = pop!(addr(m), c) + push!(addr(m), apply(c, a, b)) + Word(w) -> + if bytes=?(w, bytes-view("dup")) + let v = pop!(addr(m), \d) + push!(addr(m), v) + push!(addr(m), v) + elif bytes=?(w, bytes-view("drop")) + pop!(addr(m), \d) + continue + else + error(Unknown{.word w}) + pop!(addr(m), \=) + +fn show(src: string) -> () + let r = + handler-case + run(src) + on Underflow(u) + println(src, "=> stack empty at", string-of-byte(u.op)) + return + on Unknown(u) + println(src, "=> unknown word", string(u.word)) + return + println(src, "=>", r) + +fn string-of-byte(b: u8) -> string + match b + \+ -> "+" + \- -> "-" + \* -> "*" + \/ -> "/" + \d -> "dup" + _ -> "?" + +fn main() -> i32 + show("1 2 +") + show("3 4 * 5 -") + show("-7 2 /") + show("10 dup *") + show("1 2 drop 9 %") + show("1 +") + show("2 3 swap") + show("8 0 /") + 0 diff --git a/test/syntax/handwritten/rpn.out b/test/syntax/handwritten/rpn.out new file mode 100644 index 00000000..c2b54fcd --- /dev/null +++ b/test/syntax/handwritten/rpn.out @@ -0,0 +1,8 @@ +1 2 + => 3 +3 4 * 5 - => 7 +-7 2 / => -3 +10 dup * => 100 +1 2 drop 9 % => 1 +1 + => stack empty at + +2 3 swap => unknown word swap +8 0 / => 0 diff --git a/test/syntax/handwritten/stock/stock.fln b/test/syntax/handwritten/stock/stock.fln new file mode 100644 index 00000000..868ff437 --- /dev/null +++ b/test/syntax/handwritten/stock/stock.fln @@ -0,0 +1,37 @@ +; Stock items and prices kept in cents, imported by ../inventory.fln. + +struct Item + name: string + cents: i64 + count: i32 + +; A price read as a float without a division, by its bits. +union Bits + f: f32 + u: u32 + +const cents-per-unit = 100 + +fn- whole(cents: i64) -> i64 = cents / cents-per-unit + +fn- part(cents: i64) -> i64 = cents % cents-per-unit + +fn item(name: string, cents: i64, count: i32) -> Item + Item{.name name, .cents cents, .count count} + +fn value(it: Item) -> i64 = it.cents * i64(it.count) + +; 1234 as "12.34", into a buffer the caller frees. +fn money(cents: i64) -> Vec(u8) + let out = vec-new(u8) + append-i64(addr(out), whole(cents)) + append(addr(out), bytes-view(".")) + if part(cents) < 10 + append(addr(out), bytes-view("0")) + append-i64(addr(out), part(cents)) + out + +fn sign-bit(x: f32) -> u32 + let b: Bits = zeroed() + b.f = x + b.u >> 31 From 7e48f1eaf504c1bf65610f3dcd61743567362fac Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Fri, 25 Sep 2026 23:34:16 +0700 Subject: [PATCH 2/6] Eight hand-written .fln programs run the same on both backends and through a conversion to parens and back --- lib/check.ml | 11 +++- lib/indent_printer.ml | 13 ++++- lib/indent_reader.ml | 47 ++++++++++++++- test/syntax/handwritten/traffic.fln | 91 +++++++++++++++++++++++++++++ test/syntax/handwritten/traffic.out | 6 ++ test/syntax/handwritten/words.fln | 84 ++++++++++++++++++++++++++ test/syntax/handwritten/words.out | 8 +++ test/test_syntax.ml | 64 +++++++++++++++++++- 8 files changed, 319 insertions(+), 5 deletions(-) create mode 100644 test/syntax/handwritten/traffic.fln create mode 100644 test/syntax/handwritten/traffic.out create mode 100644 test/syntax/handwritten/words.fln create mode 100644 test/syntax/handwritten/words.out diff --git a/lib/check.ml b/lib/check.ml index e5c506ce..a47256b9 100644 --- a/lib/check.ml +++ b/lib/check.ml @@ -6200,6 +6200,13 @@ and check_fn ctx ~want ?gen loc (params : string list) body = | Some other when other <> Types.Never -> fail loc "expected %s, found an fn" (Types.to_string other) | _ -> + if fln_source loc then + fail loc + "nothing here says what this fn's parameters are — an fn takes \ + its types from the position it is written in. Pass it where a \ + Fn(T, ...) -> R is expected, or name the type where it is \ + bound: let f: Fn(T, ...) -> R = fn(...)" + else fail loc "nothing here says what this fn's parameters are — an fn takes \ its types from the position it is written in. Write it as an \ @@ -10701,8 +10708,10 @@ and named_call ?(qualified = false) ctx ~want loc name args = fail loc "a pattern cannot destructure %s — a slice's length is not known \ until the program runs, so nothing here can check it has %Ld \ - element%s. Use (at s i) and test (length s) yourself" + element%s. Use %s and test %s yourself" (Types.to_string target.Tast.ty) n (plural n) + (if fln_source loc then "s[i]" else "(at s i)") + (if fln_source loc then "length(s)" else "(length s)") | other -> fail loc "%s is not a fixed array, so [a b ...] cannot destructure it" diff --git a/lib/indent_printer.ml b/lib/indent_printer.ml index 439d2c52..e7d99832 100644 --- a/lib/indent_printer.ml +++ b/lib/indent_printer.ml @@ -398,6 +398,10 @@ and list _f h args = && (match t.v with | Form.Byte _ -> false | Form.Sym x -> name_ok x && not (String.contains x '.') && not (R.capitalised x) + (* A field of a field chains: [w.x.count]. *) + | Form.List [ { v = Form.Sym f; _ }; _ ] + when String.length f > 1 && f.[0] = '.' && tt <> "" && tt.[0] <> '.' -> + String.length tt > 0 && not (String.contains tt ' ') | _ -> let c = tt.[String.length tt - 1] in c = ')' || c = ']' || c = '}' || c = '"') @@ -760,8 +764,15 @@ and sugar n (f : Form.t) : string list option = | Form.List ({ v = Form.Sym h; _ } :: _) -> not (List.mem h sugar_heads) | _ -> true in + (* An else that is another if with an else chains on the line: + [if a then x else if b then y else z]. *) + let rec chain (x : Form.t) = + match x.v with + | Form.List [ { v = Form.Sym "if"; _ }; _; a; b ] -> simple a && chain b + | _ -> simple x + in let line = i ^ fst (expr f) in - if simple a && simple b && String.length line <= width && not (!inside f) + if simple a && chain b && String.length line <= width && not (!inside f) then Some [ line ] else Some diff --git a/lib/indent_reader.ml b/lib/indent_reader.ml index 8248ef3d..cfd21f3c 100644 --- a/lib/indent_reader.ml +++ b/lib/indent_reader.ml @@ -812,7 +812,21 @@ and items p closer open_loc ~what = | EOF -> unclosed p opener open_loc | _ -> let n = peek p in - if starts_value n.tok && n.sp && not (negative_literal n.tok) then + let block_lambda = + match e.v with + | Form.List ({ v = Form.Sym "fn"; _ } :: ps) -> + List.for_all (fun (a : Form.t) -> match a.v with Form.Sym _ -> true | _ -> false) ps + && n.loc.Loc.line > e.loc.Loc.eline + | _ -> false + in + if block_lambda then + failk "lambda-block-in-brackets" n.loc + "a lambda's block cannot go inside brackets, where a line break \ + is only a space. Name it first, with the block under it:\n\n\ + \ let f = %s\n ...\n\n\ + and pass f, or write it on one line: %s = value" + (text_of e) (text_of e) + else if starts_value n.tok && n.sp && not (negative_literal n.tok) then failk "missing-comma" n.loc "%s follows %s with no comma between them. Separate %s with \ commas: f(a, b)" @@ -897,6 +911,29 @@ let rec ty p : Form.t = as a call does not. *) type st = { p : p; mutable lets : Form.t list } +(* Whether the code line before [t] is a one-line [if c then a] with no + else: an else under it reads as written for that if, and is not. *) +let one_line_if_above p (t : token) = + let layout = function NEWLINE | INDENT | DEDENT -> true | _ -> false in + let rec prev j = + if j < 0 then None + else + let u = p.toks.(j) in + if u.loc.Loc.line < t.loc.Loc.line && not (layout u.tok) then Some u.loc.Loc.line + else prev (j - 1) + in + match prev (p.i - 1) with + | None -> false + | Some l -> + let rec line j acc = + if j < 0 || p.toks.(j).loc.Loc.line < l then acc + else line (j - 1) (if layout p.toks.(j).tok || p.toks.(j).loc.Loc.line > l then acc + else p.toks.(j).tok :: acc) + in + (match line (p.i - 1) [] with + | NAME "if" :: rest -> List.mem (NAME "then") rest && not (List.mem (NAME "else") rest) + | _ -> false) + (* A block of several lines is a [do] spanning its lines, from the first statement to the end of the last — not from the header above it, which is another form's. *) @@ -1132,6 +1169,14 @@ and stmt (s : st) : Form.t = let t = peek p in match t.tok with | NAME w when header_follow p w -> header s w + | NAME (("else" | "elif") as w) when one_line_if_above p t -> + failk "orphan-else" t.loc + "the if above is a one-line if, which ends with its line, so this %s \ + has no if to belong to. Keep the one-line form on one line:\n\n\ + \ if c then a else b\n\n\ + or give each branch a block:\n\n\ + \ if c\n a\n else\n b" + w | NAME (("else" | "elif") as w) -> failk "orphan-else" t.loc "%s is not under an if at this column. It goes at the same column as \ diff --git a/test/syntax/handwritten/traffic.fln b/test/syntax/handwritten/traffic.fln new file mode 100644 index 00000000..e0b56b23 --- /dev/null +++ b/test/syntax/handwritten/traffic.fln @@ -0,0 +1,91 @@ +; A traffic light at a crossing, driven by a clock and a pedestrian button. +; Each state carries how long it has left; a fault drops the light to +; flashing, and a supervisor decides whether to reset it. + +data Light + Green(left: i32) + Yellow(left: i32, walk: bool) + Red(left: i32, walk: bool) + Flashing() + +struct Fault + tick: i32 + +const green-time = 4 +const yellow-time = 1 +const red-time = 3 + +fn next(l: Light, pressed: bool) -> Light + match l + Green(left) -> + if left > 1 and not pressed + Light.Green{.left left - 1} + else + Light.Yellow{.left yellow-time, .walk pressed} + Yellow(left, walk) -> + if left > 1 + Light.Yellow{.left left - 1, .walk walk} + else + Light.Red{.left red-time, .walk walk} + Red(left, walk) -> + if left > 1 then Light.Red{.left left - 1, .walk walk} else Light.Green{.left green-time} + Flashing -> Light.Flashing{} + +fn show(l: Light) -> string + match l + Green(_) -> "G" + Yellow(_, _) -> "Y" + Red(_, walk) -> if walk then "W" else "R" + Flashing -> "*" + +; Runs the light for ticks steps; a fault at fault-at is signalled, and +; whoever handles it may reset the light to red. +fn run(ticks: i32, presses: [const i32], fault-at: i32) -> () + let l = Light.Red{.left 1, .walk false} + let p = 0 + let t = 0 + until :clock t >= ticks + let pressed = p < length(presses) + and presses[p] == t + if pressed + ++(p) + if t == fault-at + l = restart-case + error(Fault{.tick t}) + l + restart reset() + :report + "Put the light back to red and carry on" + Light.Red{.left red-time, .walk false} + restart flash() + Light.Flashing{} + match l + Flashing -> + print(show(l)) + break :clock + _ -> print(show(l)) + l = next(l, pressed) + t += 1 + println("") + +fn main() -> i32 + let none = [-1] + let two = [1 9] + run(12, slice(none), -1) + run(12, slice(two), -1) + handler-bind + run(12, slice(none), 5) + on Fault(f) + invoke-restart('reset) + handler-bind + run(12, slice(none), 5) + on Fault(f) + invoke-restart('flash) + println: + handler-case + run(12, slice(none), 2) + "no fault" + on Fault(f) + println("") + "fault at tick" + 0 diff --git a/test/syntax/handwritten/traffic.out b/test/syntax/handwritten/traffic.out new file mode 100644 index 00000000..3453bec5 --- /dev/null +++ b/test/syntax/handwritten/traffic.out @@ -0,0 +1,6 @@ +RGGGGYRRRGGG +RGYWWWGGGGYW +RGGGGRRRGGGG +RGGGG* +RG +fault at tick diff --git a/test/syntax/handwritten/words.fln b/test/syntax/handwritten/words.fln new file mode 100644 index 00000000..65d3773f --- /dev/null +++ b/test/syntax/handwritten/words.fln @@ -0,0 +1,84 @@ +; Word statistics over a paragraph: a frequency table, the longest words, +; and a grade for how varied the vocabulary is. + +enum Grade + poor = 1 + fair = 2 + rich = 3 + +struct Count + word: [const u8] + n: i32 + +fn letter?(c: u8) -> bool + (c >= \a and c <= \z) + or (c >= \A and c <= \Z) + or c == \' + +; The words of text, lowercased, in order. +fn words(text: [const u8]) -> Vec([const u8]) + let out = vec-new([const u8]) + let lower = to-lower(text) + let i = 0 + let n = length(lower) + while :scan i < n + until i >= n or letter?(lower[i]) + i += 1 + if i >= n + break :scan + let start = i + while i < n and letter?(lower[i]) + i += 1 + push(out, slice(lower, start, i)) + out + +fn tally(ws: [[const u8]]) -> Vec(Count) + let seen = map-new(string, i32) + defer free(seen) + let counts = vec-new(Count) + for i in range(length(ws)) + match get(seen, string(ws[i])) + Some(k) -> counts[k].n += 1 + None -> + put(seen, string(ws[i]), i32(length(counts))) + push(counts, Count{.word ws[i], .n 1}) + counts + +fn grade(distinct: i32, total: i32) -> Grade + let ratio = distinct * 10 / max(total, 1) + if ratio >= 7 then :rich else if ratio >= 4 then :fair else :poor + +fn describe(g: Grade) -> string + match i32(g) + 1 -> "repetitive" + 2 -> "ordinary" + _ -> "varied" + +fn main() -> i32 + let text = "The cat saw the dog. The dog didn't see the cat, but the bird saw both!" + let ws = words(bytes-view(text)) + let counts = tally(slice(ws)) + let by-count: Fn(Count, Count) -> bool = fn(a, b) + if a.n != b.n + return a.n > b.n + bytes length(a) then b else a) + println("longest", string(longest)) + let short = 0 < length(longest) < 5 + match short + true -> println("short words only") + false -> println("some long words") + println("three distinct counts?", !=(counts[0].n, counts[1].n, counts[2].n)) + 0 diff --git a/test/syntax/handwritten/words.out b/test/syntax/handwritten/words.out new file mode 100644 index 00000000..db6829dc --- /dev/null +++ b/test/syntax/handwritten/words.out @@ -0,0 +1,8 @@ +the 5 +cat 2 +dog 2 +most frequent seen 5 times, then [2 2] +9 of 16 distinct: ordinary +longest didn't +some long words +three distinct counts? false diff --git a/test/test_syntax.ml b/test/test_syntax.ml index 611a2161..16aee4a8 100644 --- a/test/test_syntax.ml +++ b/test/test_syntax.ml @@ -918,7 +918,7 @@ let () = (* ── Both directions of an import, on both backends ────────────────── *) -let run_both path want = +let run_both ?(backends = [ false; true ]) path want = List.iter (fun x86 -> let exe = @@ -939,7 +939,7 @@ let run_both path want = if code <> 0 || text <> want then fail "%s%s printed %S and exited %d, wanted %S" path (if x86 then " --x86" else "") text code want) - [ false; true ] + backends (* A program and its conversion print the same: the flat lets, the renames and the macro bodies they rest on keep what each name means. *) @@ -972,6 +972,66 @@ let run_converted path = | ((c, a), (d, b)) -> fail "%s printed %S (exit %d), and converted %S (exit %d)" path a c b d +(* ── Programs written by hand in the indented syntax ─────────────────── *) + +(* Each [syntax/handwritten/x.fln] prints [x.out] on both backends; its + conversion to parens reads back to the same forms, with every comment, + and converts back to indented text that reads to them again; and the + converted .flan builds and prints the same. *) +let handwritten () = + let dir = "syntax/handwritten" in + Sys.readdir dir |> Array.to_list + |> List.filter (fun f -> Filename.check_suffix f ".fln") + |> List.sort compare + |> List.map (Filename.concat dir) + +let converts_back path = + let src = In_channel.with_open_bin path In_channel.input_all in + let forms = Source.read_file path in + let norm_all fs = + macros := Body_macros.table ~file:path fs; + List.map norm fs + in + let want = norm_all forms in + let paren = Paren_printer.program ~source:src forms in + match Reader.read_all ~file:path paren with + | exception e -> fail "%s to parens: %s" path (diag_text e) + | again -> + if not (same_forms want (norm_all again)) then + fail "%s to parens: %s" path (describe_diff want (norm_all again)) + else if comment_texts paren <> comment_texts src then + fail "%s to parens: the comments did not all come through" path + else begin + let fln = Indent_printer.program ~source:paren ~macros:!macros again in + (match Indent_reader.read_all ~file:path fln with + | exception e -> fail "%s back to indented: %s" path (diag_text e) + | back -> + if not (same_forms want (norm_all back)) then + fail "%s back to indented: %s" path (describe_diff want (norm_all back))); + (* Beside the original, so its imports resolve the same way. *) + let flan = Filename.concat (Filename.dirname path) + (Printf.sprintf ".conv-%d-%s.flan" (Unix.getpid ()) + (Filename.remove_extension (Filename.basename path))) in + Out_channel.with_open_bin flan (fun oc -> output_string oc paren); + Fun.protect ~finally:(fun () -> try Sys.remove flan with Sys_error _ -> ()) + (fun () -> run_both ~backends:[ false ] flan + (In_channel.with_open_bin (Filename.remove_extension path ^ ".out") + In_channel.input_all)) + end + +let () = + List.iter + (fun p -> try converts_back p with e -> fail "%s: %s" p (diag_text e)) + (List.filter (fun _ -> Test_support.have "clang") (handwritten ())); + if List.length (handwritten ()) < 8 then + fail "only %d hand-written programs" (List.length (handwritten ())); + if Test_support.have "clang" then + List.iter + (fun p -> + run_both p (In_channel.with_open_bin (Filename.remove_extension p ^ ".out") + In_channel.input_all)) + (handwritten ()) + let () = if Test_support.have "clang" then begin List.iter run_converted From dca29a560516b2af23049013ef26e5508d9a4372 Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Fri, 25 Sep 2026 23:44:04 +0700 Subject: [PATCH 3/6] A .fln file's common mistakes are answered in .fln terms, a bare () in a body slot does nothing, and the syntax gaps found writing by hand are listed in TODO.org --- TODO.org | 46 ++++++++++++++++++++++++++++ lib/check.ml | 13 ++++++++ lib/indent_printer.ml | 29 ++++++++++++++++-- lib/indent_reader.ml | 63 ++++++++++++++++++++++++++++++++++---- spec-syntax.md | 6 ++-- test/test_syntax.ml | 70 +++++++++++++++++++++++++++++++++++++++++-- 6 files changed, 215 insertions(+), 12 deletions(-) diff --git a/TODO.org b/TODO.org index fed58224..a1d37892 100644 --- a/TODO.org +++ b/TODO.org @@ -628,6 +628,52 @@ awaiting confirmation, and the build order. Rules out Parinfer, wisp and sweet-expressions, and a simplified in-paren syntax — all thin the parens without removing them. +** TODO A one-line if cannot take its else on the next line +=if c then a= then =else b= under it is refused. Proposal: an =else=/=elif= at +the if's column continues a one-line if, as F#'s does. + +** TODO A lambda with a block cannot be a call's argument +=sort-by(xs, fn(a, b)= plus a block is refused; the lambda has to be bound first, +with its type written. Proposal: a call ending in =fn(...)= and a trailing =:= +hands the block to that lambda: =sort-by(xs, fn(a, b)):=. + +** TODO A lambda's parameters cannot be typed +=fn(a, b)= takes bare names, so a lambda bound by =let= needs +=let f: Fn(C, C) -> bool = fn(a, b)=. Proposal: =fn(a: C, b: C)= as in a +=fn= definition. + +** TODO A condition struct with a parent has no sugar +=defstruct(DiskFull, :parent, IoError, [free i64])= is the fallback, with a +paren field vector. Proposal: =struct DiskFull :parent IoError= plus field lines. + +** TODO defmacro has no sugar +=defmacro(repeat, [i n & body]):= with a space-separated parameter vector. +Proposal: =macro repeat(i, n, & body)= plus a block. + +** TODO loop/recur has no sugar +=loop([x a y b]):=. Proposal: =loop x = a, y = b= plus a block; =recur(...)= +stays a call. + +** TODO A restart's report string is a body line +=:report= and its string sit as two statements under =restart name()=. +Proposal: =restart name() "report text"= on the header line. + +** TODO An enum member has only a keyword spelling +=:north= works, =Dir.north= is an unknown name, while a data case is +=Shape.Rect=. Proposal: accept =Dir.north= as the member. + +** TODO Checker and runtime messages print types and fixes in parens +In a .fln file, =(Fn [A] R)=, =(Option i32)=, =(get 0 :body)=, =(/ x 0)= and most +usage hints still print paren syntax; a handful now print .fln spellings. +Proposal: =Types.to_string= and the hints take the syntax of the location's file. + +** TODO flan convert separates adjacent one-line globals with blank lines +=once a: i32= on consecutive lines come back one blank line apart. + +** TODO A bad map key type is followed by unknown-name errors for its parts +=map-new([const u8], i32)= reports the key, then "unknown name const" and +"unknown name i32" — in both syntaxes. + ** TODO The shims in sand.flan can go =sand.flan= defines =dyn->f64= and =dyn->u32=, one-line functions whose only job is that their parameter slot unboxes. Every call site can write =(f64 d)= and diff --git a/lib/check.ml b/lib/check.ml index a47256b9..fee8fb19 100644 --- a/lib/check.ml +++ b/lib/check.ml @@ -9036,6 +9036,19 @@ and unknown_name : 'a. ?setting:bool -> ctx -> Loc.t -> string -> 'a = name head field head end else + (* [x++]: a name may end in +, so the increment of another language + reads as one unknown name. *) + let n = String.length name in + let stem = if n > 2 then String.sub name 0 (n - 2) else "" in + let suffix = if n > 2 then String.sub name (n - 2) 2 else "" in + if (suffix = "++" || suffix = "--") && lookup ctx stem <> None then + Loc.failk "check/unknown-name" loc + "unknown name %s — to %s %s, write %s" + name (if suffix = "++" then "add one to" else "take one from") stem + (if Source.indented_at loc then + Printf.sprintf "%s(%s) or %s %s= 1" suffix stem stem (String.make 1 suffix.[0]) + else Printf.sprintf "(%s %s)" suffix stem) + else match nearest (value_candidates ctx) name with | Some m -> Loc.failk "check/unknown-name" loc "unknown name %s — did you mean %s?" name m diff --git a/lib/indent_printer.ml b/lib/indent_printer.ml index e7d99832..88b14e23 100644 --- a/lib/indent_printer.ml +++ b/lib/indent_printer.ml @@ -380,7 +380,16 @@ and list _f h args = | _ -> false in let ft = if fl < lvl || (fl = lvl && same) then paren ft else ft in - (String.concat (" " ^ op ^ " ") (ft :: List.map (at (lvl + 1)) rest), lvl) + (* [(a and b) or c]: the parentheses precedence makes optional are + written, as most readers expect them. *) + let and_in_or (x : Form.t) t = + match x.v with + | Form.List ({ v = Form.Sym "and"; _ } :: _ :: _ :: _) when s = "or" && t.[0] <> '(' -> paren t + | _ -> t + in + let ft = and_in_or first ft in + (String.concat (" " ^ op ^ " ") + (ft :: List.map (fun x -> and_in_or x (at (lvl + 1) x)) rest), lvl) | Form.Sym "-", [ x ] -> let t, l = expr x in if l >= 9 && t <> "" && R.is_neg_char t.[0] then ("-" ^ t, 8) @@ -410,7 +419,7 @@ and list _f h args = | 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) + ("fn(" ^ commas ps ^ ") = " ^ unit_text body, 0) | Form.Sym "if", [ c; a; b ] -> ("if " ^ at 1 c ^ " then " ^ inline_text ~lvl:1 a ^ " else " ^ inline_text b, 0) | _ -> call () @@ -420,6 +429,10 @@ and list _f h args = everything else as a value. [lvl] is what a value in the slot needs. *) and inline_text ?(lvl = 0) (f : Form.t) = match f.v with + (* In a one-line slot a bare [()] reads as [(do)]; the value [()] is + written [(())]. *) + | Form.List [] -> "(())" + | Form.List [ { v = Form.Sym "do"; _ } ] -> "()" | Form.List [ { v = Form.Sym (("break" | "continue" | "return") as w); _ } ] -> w | Form.List [ { v = Form.Sym (("break" | "continue") as w); _ }; { v = Form.Kw k; _ } ] when kw_ok k -> @@ -431,6 +444,13 @@ and inline_text ?(lvl = 0) (f : Form.t) = at 9 t ^ " " ^ op ^ "= " ^ at (max lvl 1) w | _ -> at lvl f +(* A body after [=]: [()] there reads as [(do)]. *) +and unit_text (f : Form.t) = + match f.v with + | Form.List [] -> "(())" + | Form.List [ { v = Form.Sym "do"; _ } ] -> "()" + | _ -> at 0 f + (* [t = v], or [t += w] when [v] is [(+ t w)]. *) and assign_text ?(lvl = 0) t v = let tt = at 9 t in @@ -653,6 +673,9 @@ and plain n (f : Form.t) : string list = (* No arguments before the block: [comment:] rather than [comment():], the author's decision 85. *) | Form.Sym s, [] when name_ok s && not (List.mem s reserved) -> s ^ ":" + (* A header word glued to its parenthesis is the fallback call, + [if(c):], so it needs no parentheses of its own. *) + | Form.Sym s, _ :: _ when List.mem s reserved -> s ^ "(" ^ commas fixed ^ "):" | _ -> head_text h ^ "(" ^ commas fixed ^ "):" in [ ind n ^ guard opener ] @ block ~seq (n + 2) rest @@ -916,7 +939,7 @@ and sugar n (f : Form.t) : string list option = | _ -> true) && String.length head + 3 + String.length (at 0 x) <= width && not (!inside f) -> - Some [ head ^ " = " ^ at 0 x ] + Some [ head ^ " = " ^ unit_text x ] | _ -> Some (head :: block (n + 2) body))) | Form.List ({ v = Form.Sym (("def" | "defonce" | "defconst") as d); _ } :: { v = Form.Sym name; _ } :: rest) diff --git a/lib/indent_reader.ml b/lib/indent_reader.ml index cfd21f3c..0b3be79e 100644 --- a/lib/indent_reader.ml +++ b/lib/indent_reader.ml @@ -208,9 +208,22 @@ let lex ?(line = 1) ?(col = 1) ~file src : token list = Reader.advance st; emit COLON (piece l0.Loc.line (l0.Loc.col + n) 1) end - else + else begin + (* [0..10]: a range from another language. *) + let text = String.sub src st.Reader.pos (stop - st.Reader.pos) in + (match String.index_opt text '.' with + | Some i when i + 1 < String.length text && text.[i + 1] = '.' -> + failk "dot-range" (piece l0.Loc.line l0.Loc.col (String.length text)) + "%s is not a number. A range of numbers is written range(%s, %s), \ + as in for i in range(%s, %s)" + text (String.sub text 0 i) + (String.sub text (i + 2) (String.length text - i - 2)) + (String.sub text 0 i) + (String.sub text (i + 2) (String.length text - i - 2)) + | _ -> ()); let f = Reader.read_number st in emit (ATOM f.v) f.loc + end | _ -> name_run () in let rec go () = @@ -477,9 +490,13 @@ let expect_eol p ~after = if (peek p).tok = INDENT then failk "stray-indent" (peek_at p 1).loc "this line is indented under %s, which takes no block. A call takes \ - an indented block only with a trailing colon, as in \ - rl/with-drawing():" + an indented block only with a trailing colon, as in %s:" after + (* The call itself when [after] is one, [f(a, b)]; else an example. *) + (match String.index_opt after '(', String.index_opt after ' ' with + | Some i, Some j when i < j -> after + | Some _, None when after.[String.length after - 1] = ')' -> after + | _ -> "rl/with-drawing()") | EOF -> () | _ -> stray p ~after @@ -725,6 +742,14 @@ and if_expr p = (* What a one-line slot takes — a match arm's value, a then or an else, the thing after defer: a value, or one of the statements that fit on a line, break, continue, return and an assignment. *) +(* A bare [()] written where a body goes — a one-line slot, a function's + [= ()] — is the empty statement, [(do)], as it is on a line of its own: + "do nothing" is what it says there. [(())] stays a value. *) +and unit_slot p i0 (t0 : token) (e : Form.t) = + if p.i - i0 = 2 && t0.tok = LP && e.v = Form.List [] then + Form.make (Form.List [ sym t0.loc "do" ]) e.loc + else e + and inline_stmt p : Form.t = let t = peek p in let glued = let n = peek_at p 1 in n.tok = LP && not n.sp in @@ -744,6 +769,7 @@ and inline_stmt p : Form.t = mk p t.loc (Form.List [ sym t.loc "return"; v ]) else mk p t.loc (Form.List [ sym t.loc "return" ]) | _ -> + let i0 = p.i in let e, _ = expr p in match (peek p).tok with | NAME "=" -> @@ -754,7 +780,7 @@ and inline_stmt p : Form.t = let eq = advance p in let v, _ = expr p in mk p t.loc (compound eq.loc (List.assoc op assign_ops) e v (span p e.loc)) - | _ -> e + | _ -> unit_slot p i0 t e (* [fn(a, b) = body] is a lambda; [fn(...)] followed by anything else is the fallback call spelling of [(fn ...)]. *) @@ -766,7 +792,9 @@ and fn_expr p = | NAME "=" -> ignore (advance p); let ps = lambda_params args in + let i0 = p.i and t0 = peek p in let body, _ = expr p in + let body = unit_slot p i0 t0 body in (mk p t.loc (Form.List [ sym t.loc "fn"; Form.make (Form.Vec ps) (span_of_list lp.loc args); body ]), @@ -826,6 +854,15 @@ and items p closer open_loc ~what = \ let f = %s\n ...\n\n\ and pass f, or write it on one line: %s = value" (text_of e) (text_of e) + else if starts_value n.tok && n.sp && not (negative_literal n.tok) + && n.loc.Loc.line > e.loc.Loc.eline then + (* Most often the bracket was never closed: the next statement + has been read as one more argument. *) + failk "missing-comma" n.loc + "%s on a new line follows %s with no comma between them. If the \ + %c on line %d was meant to close before this line, close it; \ + otherwise separate %s with commas" + (show n.tok) (text_of e) opener open_loc.Loc.line what else if starts_value n.tok && n.sp && not (negative_literal n.tok) then failk "missing-comma" n.loc "%s follows %s with no comma between them. Separate %s with \ @@ -883,6 +920,14 @@ and map_items p open_loc = | COMMA -> ignore (advance p); go (e :: acc) | RC -> ignore (advance p); List.rev (e :: acc) | EOF -> unclosed p '{' open_loc + (* [P{x = 1}] or [P{x: 1}]: another language's field syntax. *) + | (NAME "=" | COLON) as tk + when (match e.v with Form.Sym n -> n <> "" && n.[0] <> '.' | _ -> false) -> + let n = text_of e in + failk "brace-field" (peek p).loc + "a field in braces is written {.%s value}: a dot before the name, \ + and no %s between it and the value" + n (if tk = COLON then "colon" else "= sign") | tk when starts_value tk && (peek p).sp -> if lvl < 8 then refuse_ws ~brace:true t.loc e; go (e :: acc) @@ -1294,7 +1339,15 @@ and header (s : st) w : Form.t = ignore (advance p); block s ~after:"fn" end - else [ value_line s ~after:"=" ] + else begin + let i0 = p.i and t0 = peek p in + let v = value_line s ~after:"=" in + let bare = + t0.tok = LP && p.toks.(i0 + 1).tok = RP && v.v = Form.List [] + && (match p.toks.(i0 + 2).tok with NEWLINE | EOF | DEDENT -> true | _ -> false) + in + [ (if bare then Form.make (Form.List [ sym t0.loc "do" ]) v.loc else v) ] + end | NEWLINE -> ignore (advance p); if (peek p).tok = INDENT then block s ~after:"fn" else [] diff --git a/spec-syntax.md b/spec-syntax.md index 5f05b1ef..22218f78 100644 --- a/spec-syntax.md +++ b/spec-syntax.md @@ -206,7 +206,8 @@ Each item: the proposal, then the reason in one line. - **`for i in range(n)`**, `range(a, b)`, `range(a, b, step)` read as `dotimes`. `range` here is syntax, not a function. `..` is avoided because `a..b` would lex as one name. **Built** (a label goes first here too: - `for :outer i in range(n)`). + `for :outer i in range(n)`; in a macro template the variable may be an + unquote, `for ~i in range(~n)`). - **`return v`, `break`, `break :outer`, `continue`, `defer expr`** (or `defer` plus a block). **Built**; `defer` plus a block reads `(defer a b …)`. `break`, `continue`, `return v` and `x = v`/`x += v` also fit the one-line @@ -255,7 +256,8 @@ Each item: the proposal, then the reason in one line. 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 `(())`. + statement as `(())`. A bare `()` in a one-line body slot (`fn f() -> () = ()`, + `_ -> ()`, `fn() = ()`, `then ()`) is a statement too, and reads `(do)`. - **Lambda:** `fn(i, j) = i * 10 + j`, or `fn(i, j)` plus a block. **Built**; its parameters are bare names, as `(fn [i j] …)` wants, with no `dyn`. `fn(…)` followed by anything else is the fallback call. diff --git a/test/test_syntax.ml b/test/test_syntax.ml index 16aee4a8..fb8c886d 100644 --- a/test/test_syntax.ml +++ b/test/test_syntax.ml @@ -582,6 +582,25 @@ let () = reads "typed let" "let x: i32 = 5\nx" "(let [x (the i32 5)] x)"; refuses "a let takes no block" "fn f() -> ()\n let x = 1\n g(x)\n h(x)" "indent/let-block" "go at the let's column"; + (* Mistakes carried over from other languages, answered in this one. *) + refuses "a block without the colon names the call" "with-allocator(a, b)\n g()" + "indent/stray-indent" "as in with-allocator(a, b):"; + refuses "field with =" "p = P{x = 1}" "indent/brace-field" "{.x value}"; + refuses "field with a colon" "p = P{x: 1}" "indent/brace-field" "no colon"; + refuses "a dotted range" "for i in 0..10\n g(i)" "indent/dot-range" "range(0, 10)"; + refuses "a block lambda inside a call" "sort-by(xs, fn(a, b)\n a < b)" + "indent/lambda-block-in-brackets" "let f = fn(a, b)"; + refuses "an unclosed call swallows the next line" "fn f() -> ()\n push(v, 1\n g()" + "indent/missing-comma" "If the ( on line 2 was meant to close"; + refuses "else under a one-line if" "if a then b\nelse c" + "indent/orphan-else" "one-line if"; + reads "a bare () in a body slot does nothing" + "fn f() -> () = ()\nfn g(x) -> ()\n match x\n 1 -> h()\n _ -> ()\n k = fn() = ()" + "(defn f [] () (do))\n(defn g [x dyn] () (match x 1 (h) _ (do)) (set k (fn [] (do))))"; + reads "a parenthesised () stays a value" "x = (())" "(set x ())"; + reads "a template's for takes an unquoted variable" + "quote\n for ~i in range(~n)\n g(~i)" + "(quasiquote (dotimes [(unquote i) (unquote n)] (g (unquote i))))"; (* And back: the printer writes the idioms. *) let prints name src want = match Reader.read_all ~file:"

" src with @@ -718,7 +737,40 @@ let () = "(defn f [] i32\n (let [a 1 ; first\n b 2] ; second\n (+ a b)))" " let a = 1 ; first\n let b = 2 ; second"; back "comments to parens" "; head\n\nfn main() -> i32\n ; why\n g() ; note\n 0" - "; head\n\n(defn main [] i32\n ; why\n (g) ; note\n 0)" + "; head\n\n(defn main [] i32\n ; why\n (g) ; note\n 0)"; + (* Written the way the corpus writes them. *) + back "quasiquote as its reader sugar" + "defmacro(m, [x & body]):\n quote\n g(~x)\n ~@body" + "`(do (g ~x) ~@body)"; + back "arms a pair to a line" + ("fn f(s) -> dyn\n match s\n 1 -> \"one, a long string to break the line\"\n" + ^ " _ -> \"another long string to push it over\"") + " (match s\n 1 \"one, a long string to break the line\"\n _ \"another"; + back "a let's bindings hang after their names" + ("fn f() -> dyn\n let a = compute-something-long(1, 2, 3, 4, 5)\n" + ^ " let b = compute-something-long(5, 6, 7, 8, 9)\n a") + "(let [a (compute-something-long 1 2 3 4 5)\n b (compute-something-long 5 6 7 8 9)]"; + back "a label stays with its test" + "fn f() -> ()\n while :outer some-long-condition?(1, 2, 3) and another-long-one?(4, 5, 6)\n g()" + "(while :outer"; + back "a call's arguments fill the line" + "fn f() -> ()\n println(\"alpha\", \"beta\", \"gamma\", \"delta\", \"epsilon\", \"zeta\", \"eta\", \"theta\", \"iota\", g(1))" + "\"eta\" \"theta\" \"iota\"\n (g 1))"; + back "a comment between a cond's test and its branch stays there" + "fn f(x) -> dyn\n if x\n ; why\n 1\n elif y\n 2\n else\n 3" + "; why"; + prints "an if with no else keeps its test in the parentheses" + "(defn f [] () (if (> a 1) (let [k 2] (g k))))" " if(a > 1):\n let k = 2"; + prints "and inside or keeps its parentheses" + "(defn f [a bool b bool c bool] bool (or (and a b) c))" "= (a and b) or c"; + prints "a field of a field chains" "(defn f [] () (g (.count (.x w))))" "g(w.x.count)"; + prints "an else-if chain on one line" + "(defn f [r] dyn (if (> r 7) :rich (if (> r 4) :fair :poor)))" + "if r > 7 then :rich else if r > 4 then :fair else :poor"; + prints "a long vector wraps" ("(defn f [] () (let [v [" ^ String.concat " " (List.init 30 string_of_int) ^ "]] (g v)))") + " let v = [0 1 2 3"; + prints "a template's for keeps its unquotes" + "(defmacro m [i n & body] `(dotimes [~i ~n] ~@body))" "for ~i in range(~n)" (* ── Spans, for pause marks and error overlays ──────────────────────── *) @@ -914,7 +966,21 @@ let () = (* A unit argument deeper in the last form is about that argument. *) refused "unit-arg.flan" "(defn g [x dyn] dyn x)\n(defn f [coll] dyn (g (println 1)))\n(defn main [] () (f 1))\n" - [ "() does not box into dyn" ] + [ "() does not box into dyn" ]; + (* Checker messages about a .fln file are in its spelling. *) + refused "enum-none.fln" "fn main() -> i32\n let n = None\n 0\n" [ "the(Option(i32), None)" ]; + checks "enum-annotated.fln" + "enum Dir\n north\n south\n\nfn main() -> i32\n let d: Dir = :north\n i32(d)\n"; + refused "annotation-dyn.fln" "fn main() -> i32\n let d = the(dyn, 3)\n let x: i32 = d\n x\n" + [ "a type annotation checks a value as i32"; "write i32(d)" ]; + refused "narrowing.fln" "fn f() -> i64 = 1\n\nfn main() -> i32\n let x: i32 = 0\n x = f()\n x\n" + [ "it has to be written: i32(x)" ]; + refused "unknown-type.fln" "fn f(p: Keyword) -> i32 = 0\n\nfn main() -> i32 = 0\n" + [ "unknown type Keyword" ]; + refused "untyped-lambda.fln" "fn main() -> i32\n let f = fn(a)\n a\n 0\n" + [ "let f: Fn(T, ...) -> R = fn(...)" ]; + refused "plusplus.fln" "fn main() -> i32\n let x = 1\n x++\n x\n" + [ "write ++(x) or x += 1" ] (* ── Both directions of an import, on both backends ────────────────── *) From dbddc61b30fe876f31103cb2374c393dad85288d Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Fri, 25 Sep 2026 23:48:59 +0700 Subject: [PATCH 4/6] defvar in a .fln file suggests once and def in its spelling, and x++ on a global suggests ++(x) --- lib/check.ml | 2 +- lib/parse.ml | 15 +++++++++++++++ test/test_syntax.ml | 6 +++++- 3 files changed, 21 insertions(+), 2 deletions(-) diff --git a/lib/check.ml b/lib/check.ml index fee8fb19..6e093a0d 100644 --- a/lib/check.ml +++ b/lib/check.ml @@ -9041,7 +9041,7 @@ and unknown_name : 'a. ?setting:bool -> ctx -> Loc.t -> string -> 'a = let n = String.length name in let stem = if n > 2 then String.sub name 0 (n - 2) else "" in let suffix = if n > 2 then String.sub name (n - 2) 2 else "" in - if (suffix = "++" || suffix = "--") && lookup ctx stem <> None then + if (suffix = "++" || suffix = "--") && List.mem stem (value_candidates ctx) then Loc.failk "check/unknown-name" loc "unknown name %s — to %s %s, write %s" name (if suffix = "++" then "add one to" else "take one from") stem diff --git a/lib/parse.ml b/lib/parse.ml index 4651dd4c..400f894d 100644 --- a/lib/parse.ml +++ b/lib/parse.ml @@ -1972,7 +1972,22 @@ let rec decl (f : Form.t) : Ast.decl = rule against a suggestion that does not compile. The shapes alone then, which is what there is to say about a form that named too little. *) + let atom (x : Form.t) = match x.v with Form.List _ | Form.Vec _ | Form.Map _ -> false | _ -> true in (match args with + (* In a .fln file, the two definitions in its spelling. *) + | [ n; v ] when Source.indented_at f.loc && atom n -> + let rest = + Form.to_string n ^ " = " ^ (if atom v then Form.to_string v else "...") in + Loc.failk "parse/defvar-renamed" f.loc + "there is no defvar. Did you mean once? once %s initialises once and \ + keeps its value; def %s re-initialises on every re-run" rest rest + | [ n; t; v ] when Source.indented_at f.loc && atom n && atom t -> + let rest = + Form.to_string n ^ ": " ^ Form.to_string t ^ " = " + ^ (if atom v then Form.to_string v else "...") in + Loc.failk "parse/defvar-renamed" f.loc + "there is no defvar. Did you mean once? once %s initialises once and \ + keeps its value; def %s re-initialises on every re-run" rest rest | [] | [ _ ] -> Loc.failk "parse/defvar-renamed" f.loc "there is no defvar. Did you mean defonce? \ diff --git a/test/test_syntax.ml b/test/test_syntax.ml index fb8c886d..0602f8f0 100644 --- a/test/test_syntax.ml +++ b/test/test_syntax.ml @@ -980,7 +980,11 @@ let () = refused "untyped-lambda.fln" "fn main() -> i32\n let f = fn(a)\n a\n 0\n" [ "let f: Fn(T, ...) -> R = fn(...)" ]; refused "plusplus.fln" "fn main() -> i32\n let x = 1\n x++\n x\n" - [ "write ++(x) or x += 1" ] + [ "write ++(x) or x += 1" ]; + refused "plusplus-global.fln" "once g = 0\n\nfn main() -> i32\n g--\n 0\n" + [ "write --(g) or g -= 1" ]; + refused "defvar.fln" "defvar(x, 1)\n\nfn main() -> i32 = 0\n" + [ "once x = 1 initialises once"; "def x = 1 re-initialises" ] (* ── Both directions of an import, on both backends ────────────────── *) From fd1a7f2b36be6326cf79011f55fc2da4388bab41 Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Sat, 26 Sep 2026 00:07:28 +0700 Subject: [PATCH 5/6] A one-line if takes its else on the next line, lambdas state their types, a restart's report sits on its header, Dir.north names an enum member, messages spell types in the code's syntax, adjacent globals convert adjacent, and a bad map key is one error --- TODO.org | 53 ++-- lib/check.ml | 387 ++++++++++++++++------------ lib/indent_printer.ml | 46 +++- lib/indent_reader.ml | 224 +++++++++++----- lib/paren_printer.ml | 10 +- lib/source_text.ml | 20 ++ lib/types.ml | 32 ++- spec-syntax.md | 44 +++- test/syntax/handwritten/csv.fln | 4 +- test/syntax/handwritten/traffic.fln | 10 +- test/syntax/handwritten/words.fln | 2 +- test/test_syntax.ml | 54 +++- 12 files changed, 587 insertions(+), 299 deletions(-) diff --git a/TODO.org b/TODO.org index a1d37892..6bdf7bdc 100644 --- a/TODO.org +++ b/TODO.org @@ -628,51 +628,32 @@ awaiting confirmation, and the build order. Rules out Parinfer, wisp and sweet-expressions, and a simplified in-paren syntax — all thin the parens without removing them. -** TODO A one-line if cannot take its else on the next line -=if c then a= then =else b= under it is refused. Proposal: an =else=/=elif= at -the if's column continues a one-line if, as F#'s does. - -** TODO A lambda with a block cannot be a call's argument -=sort-by(xs, fn(a, b)= plus a block is refused; the lambda has to be bound first, -with its type written. Proposal: a call ending in =fn(...)= and a trailing =:= +** WAIT A lambda with a block cannot be a call's argument +On the author's decision. =sort-by(xs, fn(a, b)= plus a block is refused; the +lambda has to be bound first with =let=. Proposal: a call ending in =fn(...)= and a trailing =:= hands the block to that lambda: =sort-by(xs, fn(a, b)):=. -** TODO A lambda's parameters cannot be typed -=fn(a, b)= takes bare names, so a lambda bound by =let= needs -=let f: Fn(C, C) -> bool = fn(a, b)=. Proposal: =fn(a: C, b: C)= as in a -=fn= definition. - -** TODO A condition struct with a parent has no sugar -=defstruct(DiskFull, :parent, IoError, [free i64])= is the fallback, with a +** WAIT A condition struct with a parent has no sugar +On the author's decision. =defstruct(DiskFull, :parent, IoError, [free i64])= is the fallback, with a paren field vector. Proposal: =struct DiskFull :parent IoError= plus field lines. -** TODO defmacro has no sugar -=defmacro(repeat, [i n & body]):= with a space-separated parameter vector. +** WAIT defmacro has no sugar +On the author's decision. =defmacro(repeat, [i n & body]):= with a space-separated parameter vector. Proposal: =macro repeat(i, n, & body)= plus a block. -** TODO loop/recur has no sugar -=loop([x a y b]):=. Proposal: =loop x = a, y = b= plus a block; =recur(...)= +** WAIT loop/recur has no sugar +On the author's decision. =loop([x a y b]):=. Proposal: =loop x = a, y = b= plus a block; =recur(...)= stays a call. -** TODO A restart's report string is a body line -=:report= and its string sit as two statements under =restart name()=. -Proposal: =restart name() "report text"= on the header line. +** TODO Hard-coded code in messages is still paren syntax in a .fln file +Types follow the code's syntax now (=Types.spell=). Hints written into a message's +text — =(Ptr %s)=, =(clone v)=, =(the T x)= in most of =check.ml= and =parse.ml=, the +runtime's =(get 0 :body)= and =(/ x 0)= — still print parens; each is fixed per +message as it is met. -** TODO An enum member has only a keyword spelling -=:north= works, =Dir.north= is an unknown name, while a data case is -=Shape.Rect=. Proposal: accept =Dir.north= as the member. - -** TODO Checker and runtime messages print types and fixes in parens -In a .fln file, =(Fn [A] R)=, =(Option i32)=, =(get 0 :body)=, =(/ x 0)= and most -usage hints still print paren syntax; a handful now print .fln spellings. -Proposal: =Types.to_string= and the hints take the syntax of the location's file. - -** TODO flan convert separates adjacent one-line globals with blank lines -=once a: i32= on consecutive lines come back one blank line apart. - -** TODO A bad map key type is followed by unknown-name errors for its parts -=map-new([const u8], i32)= reports the key, then "unknown name const" and -"unknown name i32" — in both syntaxes. +** CANCELLED Sugar for defclass, defgeneric, defmulti and defmethod +CLOSED: [2026-09-26] +The fallback, =defmethod(area, point, [p]):=, reads well enough. ** TODO The shims in sand.flan can go =sand.flan= defines =dyn->f64= and =dyn->u32=, one-line functions whose only job diff --git a/lib/check.ml b/lib/check.ml index 6e093a0d..b0fa4688 100644 --- a/lib/check.ml +++ b/lib/check.ml @@ -20,6 +20,9 @@ let fail = Loc.fail +(* A type in a message about the code at [loc], in that code's syntax. *) +let tyname (loc : Loc.t) t = Types.spell ~indented:(Source.indented_at loc) t + (* "A literal could not be built at the type this site asked for": 300 at a u8, 1.5 at an i32, 3000000000 at the i32 an unconstrained integer defaults to. @@ -1064,6 +1067,17 @@ let one_edit a b = else ta a (!i + 1) = ta b !i end +(* [Dir.north] as the enum and the member's value, when [Dir] is an enum + with a member [north]. *) +let enum_member env name = + match String.rindex_opt name '.' with + | Some i when i > 0 && i < String.length name - 1 -> + let e = String.sub name 0 i and m = String.sub name (i + 1) (String.length name - i - 1) in + (match Hashtbl.find_opt env.enums e with + | Some members -> Option.map (fun v -> (e, v)) (List.assoc_opt m members) + | None -> None) + | _ -> None + (* The enum members' own near miss. One edit away is the usual typo; the second rule is for a package whose members carry a disambiguating prefix — raylib's Key spells them [key-r], [key-space] — where the natural mistake @@ -1207,7 +1221,7 @@ let map_type ?(preds = []) loc (k : Types.t) (v : Types.t) = if Types.equal v Types.Unit then fail loc "a map value cannot be () — write (Map %s bool) and ignore the value" - (Types.to_string k); + (tyname loc k); if Types.equal k Types.Unit then fail loc "a map key cannot be () — every key would be the same key"; (* The key, as far as the type alone can say. A struct passes here and is @@ -1225,7 +1239,7 @@ let map_type ?(preds = []) loc (k : Types.t) (v : Types.t) = fail loc "%s is not a map key. A key is an integer, an enum, a bool, a string, a \ fixed array of those, or a struct of those" - (Types.to_string k); + (tyname loc k); Types.Map (k, v) (* The positions a function value may not be written in, and the one reason @@ -1265,12 +1279,12 @@ let callable_ty t = fn_sig t <> None field that holds one. *) let rec no_zeroed_fn loc what (t : Types.t) = match t with - | Types.Fn _ -> + | Types.Fn (ps, r) -> fail loc "%s cannot be %s — it would be zeroed, and a zeroed function value is a \ null pointer. Pass it as a parameter, hold it in a let, or store a \ - (CFn ...) if it captures nothing" - what (Types.to_string t) + %s if it captures nothing" + what (tyname loc t) (tyname loc (Types.CFn (ps, r))) | Types.Array (_, e) -> no_zeroed_fn loc what e | _ -> () @@ -1404,7 +1418,8 @@ let struct_app g args = Hashtbl.replace struct_apps key (g, args); Hashtbl.replace Types.display key (Printf.sprintf "(%s %s)" g - (String.concat " " (List.map Types.to_string args))) + (String.concat " " (List.map Types.to_string args))); + Hashtbl.replace Types.display_app key (g, args) end; key @@ -1655,7 +1670,7 @@ and struct_copy ?(at_definition = false) env loc name targs = (List.map (fun (h, a) -> Printf.sprintf "(%s %s)" h - (String.concat " " (List.map Types.to_string a))) + (String.concat " " (List.map (tyname loc) a))) (env.schain @ [ (name, targs) ])) in if List.exists @@ -1716,7 +1731,7 @@ and struct_copy ?(at_definition = false) env loc name targs = Loc.notes = d.Loc.notes @ [ Loc.note loc - (Types.to_string (Types.Named key) ^ " is made here") ] } + (tyname loc (Types.Named key) ^ " is made here") ] } | e -> raise e) end @@ -1917,7 +1932,7 @@ and array_len env loc = function | Some (Types.Var _) -> abstract_len | Some t -> fail loc "%s is the type %s here, and an array length is an integer, a \ - constant or a length variable" n (Types.to_string t) + constant or a length variable" n (tyname loc t) | None when List.mem bare env.lenvars -> abstract_len | None when List.mem bare env.tyvars -> fail loc "%s is a type variable, and an array length is an integer, a \ @@ -2767,8 +2782,8 @@ let unconstrained env loc op ~needs (t : Types.t) = "%s over the type variable %s: nothing declares %s %s. Write \ {:where (%s %s)} at the head of the body, or take the operation as \ a parameter, a (Fn [%s %s] ...), and call it here" - op (Types.to_string t) (Types.to_string t) needs needs - (Types.to_string t) (Types.to_string t) (Types.to_string t) + op (tyname loc t) (tyname loc t) needs needs + (tyname loc t) (tyname loc t) (tyname loc t) (* ── The runaway instantiation, refused by name rather than by depth ──── @@ -2803,7 +2818,7 @@ let runaway env loc gname cparams = (List.map (fun (g, ps, l) -> Printf.sprintf "%s at (%s), asked for at %s" g - (String.concat " " (List.map Types.to_string ps)) + (String.concat " " (List.map (tyname loc) ps)) (Loc.to_string l)) (env.chain @ [ (gname, cparams, loc) ])) in @@ -3046,19 +3061,19 @@ let refuse_const_place env loc (view : Types.t) = Loc.failk "check/store-through-const" loc "this changes the %s behind a %s, which can only be read through. A \ container that has to change is handed over as a (Ptr %s)" - (Types.to_string t) (Types.to_string view) (Types.to_string t) + (tyname loc t) (tyname loc view) (tyname loc t) | Types.Ptr (_, t) -> Loc.failk "check/store-through-const" loc "this writes through a %s, which can only be read, so what it points at \ is a value and not a place. (deref p) copies the %s out, and the copy \ can be written" - (Types.to_string view) (Types.to_string t) + (tyname loc view) (tyname loc t) | _ -> let elem = match view with Types.Slice (_, t) -> t | t -> t in Loc.failk "check/store-through-const" loc "this writes through a %s, which can only be read, so the element is a \ value and not a place. %s" - (Types.to_string view) + (tyname loc view) (match const_copy env elem with | Some c -> Printf.sprintf @@ -3066,7 +3081,7 @@ let refuse_const_place env loc (view : Types.t) = into one" c | None -> Printf.sprintf "Where it has to be written, take it as a [%s] instead" - (Types.to_string elem)) + (tyname loc elem)) (* A runtime call, with the result type spelled at the site. *) let rt loc ty sym args = mk loc ty (Tast.Prim (Tast.Rt sym, args)) @@ -3433,7 +3448,7 @@ let widen loc (want : Types.t) (e : Tast.expr) = let no_dyn_yet loc ~into t extra = Loc.failk "check/dyn-not-yet" loc "%s does not cross into %s yet%s" - (Types.to_string t) (if into then "dyn" else "a written type") extra + (tyname loc t) (if into then "dyn" else "a written type") extra (* M2 item 3: a typed container crossing into dyn as a view. The element set is exactly the unboxable scalars — i64, f64, bool — and that is not a smaller @@ -3490,7 +3505,7 @@ let view_subject (e : Tast.expr) = | _ -> None let view_refusal kind loc (e : Tast.expr) reason = - let ty = Types.to_string e.Tast.ty in + let ty = tyname loc e.Tast.ty in let fln = fln_source loc in (* A parameter is made by the caller, so its fix is its declaration. The name is compared as well as the slot: a closure numbers its slots from @@ -3539,7 +3554,7 @@ let view_not_yet loc (e : Tast.expr) (elem : Types.t) = (Printf.sprintf "A dyn value can see into a typed container only when its elements \ are i64, f64 or bool, and these are %s" - (Types.to_string elem)) + (tyname loc elem)) (* M2 item 3's second guard, added on review: a view's descriptor holds an address into the container's own storage, chased fresh on every @@ -3952,7 +3967,7 @@ let box loc (e : Tast.expr) : Tast.expr = "%s does not cross into dyn: a dyn view can be written through, and a \ [const %s] can only be read. A dyn view is taken of the writable \ storage it came from" - (Types.to_string e.Tast.ty) (Types.to_string elem) + (tyname loc e.Tast.ty) (tyname loc elem) | Types.Slice (Types.Mut, elem) -> (match view_elem elem with | None -> view_not_yet loc e elem @@ -4123,7 +4138,7 @@ let box_option ctx loc (t : Types.t) (got : Tast.expr) : Tast.expr = Loc.failk "check/option-nested-dyn" loc "(Option (Option %s)) does not cross into dyn — Some None and None \ would both box as nil" - (Types.to_string inner) + (tyname loc inner) | _ -> (* A literal [Some]/[None] built right here skips the runtime check: the checker already knows which case it is, so there is nothing to test at @@ -4159,7 +4174,7 @@ let unbox_option ctx loc (t : Types.t) (got : Tast.expr) : Tast.expr = Loc.failk "check/option-nested-dyn" loc "(Option (Option %s)) does not cross from dyn — a dyn has one absence, \ nil, which cannot tell None from Some None apart" - (Types.to_string inner) + (tyname loc inner) | _ when is_nil_lit got -> mk loc oty Tast.None_ | _ -> let s = fresh_slot ctx Types.Dyn in @@ -4309,16 +4324,16 @@ let declare_env ctx = function let numeric_note ?(fln = false) ~(want : Types.t) ~(got : Types.t) () = let cast = - if fln then Printf.sprintf "%s(x)" (Types.to_string want) - else Printf.sprintf "(%s x)" (Types.to_string want) + if fln then Printf.sprintf "%s(x)" (Types.spell ~indented:fln want) + else Printf.sprintf "(%s x)" (Types.spell ~indented:fln want) in if not (Types.is_numeric want && Types.is_numeric got) then "" else if Types.widens_to ~from:want ~into:got then Printf.sprintf " — %s into %s can lose, so it has to be written: %s. The other way \ round, %s widens into %s by itself" - (Types.to_string got) (Types.to_string want) cast - (Types.to_string want) (Types.to_string got) + (Types.spell ~indented:fln got) (Types.spell ~indented:fln want) cast + (Types.spell ~indented:fln want) (Types.spell ~indented:fln got) else Printf.sprintf " — neither widens into the other, so the conversion has to be written: \ @@ -4326,30 +4341,32 @@ let numeric_note ?(fln = false) ~(want : Types.t) ~(got : Types.t) () = cast (* The rest of the sentence when a read-only slice meets a writable one. *) -let const_note env ~(want : Types.t) ~(got : Types.t) = +let const_note ?(fln = false) env ~(want : Types.t) ~(got : Types.t) = match want, got with | Types.Slice (Types.Mut, e), Types.Slice (Types.Const, e') when Types.equal e e' -> - let copy = const_copy env e in + let copy = + Option.map (fun c -> if fln then "clone(v)" else c) (const_copy env e) in Printf.sprintf " — a %s can only be read, and never becomes a %s that can be written \ through. %sWhere nothing writes through it, the %s can be declared %s \ instead" - (Types.to_string got) (Types.to_string want) + (Types.spell ~indented:fln got) (Types.spell ~indented:fln want) (match copy with | Some c -> Printf.sprintf "%s copies v into a %s of its own. " c - (Types.to_string want) + (Types.spell ~indented:fln want) | None -> "") - (Types.to_string want) (Types.to_string got) + (Types.spell ~indented:fln want) (Types.spell ~indented:fln got) | Types.Ptr (Types.Mut, e), Types.Ptr (Types.Const, e') when Types.equal e e' -> Printf.sprintf " — a %s can only be read through, and never becomes a %s that can be \ - written through. Copy the %s out with (deref p) and point at the copy; \ + written through. Copy the %s out with %s and point at the copy; \ where nothing writes through it, the %s can be declared %s instead" - (Types.to_string got) (Types.to_string want) (Types.to_string e) - (Types.to_string want) (Types.to_string got) + (Types.spell ~indented:fln got) (Types.spell ~indented:fln want) (Types.spell ~indented:fln e) + (if fln then "deref(p)" else "(deref p)") + (Types.spell ~indented:fln want) (Types.spell ~indented:fln got) | _ -> "" let expect ctx loc ~want (got : Tast.expr) = @@ -4375,7 +4392,7 @@ let expect ctx loc ~want (got : Tast.expr) = fail loc "nil has no None to become at %s — nil only converts to (Option T) \ or to dyn itself; wrap the type in Option, or keep the value dyn" - (Types.to_string w) + (tyname loc w) | _, Types.Dyn when Types.fits ~expected:w ~actual:Types.Dyn -> got | _, Types.Dyn -> unbox loc w got (* Implicit widening, and this single arm is the whole of its surface. @@ -4424,9 +4441,9 @@ let expect ctx loc ~want (got : Tast.expr) = reader who has just been told i64 and i32 are different types needs to be told, in the same breath, which direction needed nothing. *) Loc.failk "check/type-mismatch" loc "expected %s, found %s%s%s" - (Types.to_string w) (Types.to_string got.Tast.ty) + (tyname loc w) (tyname loc got.Tast.ty) (numeric_note ~fln:(Source.indented_at loc) ~want:w ~got:got.Tast.ty ()) - (const_note ctx.env ~want:w ~got:got.Tast.ty) + (const_note ~fln:(Source.indented_at loc) ctx.env ~want:w ~got:got.Tast.ty) (* Something a [break] may not jump out of, named so the refusal can say which. See [lentry]: it is a barrier and not a blanket refusal, so a loop written @@ -4693,7 +4710,7 @@ let rec key_pair env loc (k : Types.t) : Tast.fnref * Tast.fnref = fail loc "%s is not a map key. A key is an integer, an enum, a bool, a string, a \ fixed array of those, or a struct of those" - (Types.to_string other) + (tyname loc other) and struct_key_pair env loc n = let hname = "map/hash/" ^ n and ename = "map/eq/" ^ n in @@ -4821,7 +4838,7 @@ and array_key_pair env loc n e = if Int64.compare n 0L <= 0 then fail loc "%s has no elements, so it is not a map key — every value of it would be \ - the same key" (Types.to_string (Types.Array (n, e))); + the same key" (tyname loc (Types.Array (n, e))); let aty = Types.Array (n, e) in (* The type's printed form, with what a symbol cannot hold replaced. *) let tag = @@ -4829,7 +4846,7 @@ and array_key_pair env loc n e = (fun c -> match c with | 'a' .. 'z' | 'A' .. 'Z' | '0' .. '9' | '_' | '-' -> c | _ -> '_') - (Types.to_string aty) + (tyname loc aty) in (* The mangle is many-to-one — [a+b] and [a_b] come out alike — so a digest of the printed type, which is an identity, keeps two such keys apart. *) @@ -4964,7 +4981,7 @@ let deferred_key env loc what (k : Types.t) = Loc.failk "check/generic-map-key" loc "%s over a map keyed by the type variable %s needs %s to be hashable. \ Write {:where (hashable? $%s)} at the head of the body" - what (Types.to_string k) (Types.to_string k) v; + what (tyname loc k) (tyname loc k) v; true | _ -> false @@ -5235,7 +5252,7 @@ let note_grown ctx op loc (target : Tast.expr) = (List.exists (fun (d : Loc.diag) -> d.Loc.dloc = p.Ast.floc) !grow_warnings) -> - let ts = Types.to_string t in + let ts = tyname loc t in let msg = match target.Tast.e with | Tast.Local _ -> @@ -5247,7 +5264,7 @@ let note_grown ctx op loc (target : Tast.expr) = container c" p.Ast.fname ts op (Loc.to_string loc) ts op p.Ast.fname | _ -> - let pt = Types.to_string (List.nth ctx.slot_tys (ctx.slots - 1 - s)) in + let pt = tyname loc (List.nth ctx.slot_tys (ctx.slots - 1 - s)) in Printf.sprintf "%s is a %s passed by value, a copy of the caller's, so the %s \ at %s grows %s in this function's copy and the caller's never \ @@ -5294,6 +5311,12 @@ let rec check ctx ?want (e : Ast.expr) : Tast.expr = only what no expectation could change is kept: a name that is not there. *) match e.Ast.e with + (* A type written in a value position — [map-new([const u8], i32)] — + is not a value to look names up in. *) + | Ast.Call ({ Ast.e = Ast.Var ("map-new" | "builtin/map-new"); _ }, args) -> + recheck_args ctx (List.filteri (fun i _ -> i >= 2) args) + | Ast.Call ({ Ast.e = Ast.Var ("vec-new" | "builtin/vec-new"); _ }, args) -> + recheck_args ctx (List.filteri (fun i _ -> i >= 1) args) | Ast.Call (_, args) -> recheck_args ctx args | _ -> () end; @@ -5346,20 +5369,25 @@ and check_target ctx (e : Ast.expr) = and refuse_owned_copy ctx (r : Tast.expr) = match const_reached r with | Some view when owning ctx.env r.Tast.ty -> - let t = Types.to_string r.Tast.ty in + let fln = Source.indented_at r.Tast.loc in + let t = tyname r.Tast.loc r.Tast.ty in let fix = match r.Tast.ty with | (Types.Vec _ | Types.Map _) when not (region_only ctx.env r.Tast.ty) -> - Printf.sprintf "(clone v) copies it into a %s of its own" t + Printf.sprintf "%s copies it into a %s of its own" + (if fln then "clone(v)" else "(clone v)") t (* Nothing copies an array, an Option or a struct that owns storage, nor a container whose elements do: its address is the way to it. *) - | _ -> Printf.sprintf "(addr v) gives a (Ptr const %s) to read it through" t + | _ -> + Printf.sprintf "%s gives a %s to read it through" + (if fln then "addr(v)" else "(addr v)") + (tyname r.Tast.loc (Types.Ptr (Types.Const, r.Tast.ty))) in Loc.failk "check/const-owned-copy" r.Tast.loc "this copies a %s out of a %s, which can only be read, and the copy \ would share its storage with the original. Use it where it stands — \ index it, slice it or read its fields — or %s" - t (Types.to_string view) fix + t (tyname r.Tast.loc view) fix | _ -> () and check_value ctx ?want (e : Ast.expr) : Tast.expr = @@ -5390,14 +5418,14 @@ and check_value ctx ?want (e : Ast.expr) : Tast.expr = let gname, _, _ = List.nth ctx.env.chain (List.length ctx.env.chain - 1) in let var = match List.find_opt (fun (_, u) -> Types.equal u t) ctx.env.subst with - | Some (v, _) -> Printf.sprintf "$%s = %s" v (Types.to_string t) - | None -> Types.to_string t + | Some (v, _) -> Printf.sprintf "$%s = %s" v (tyname loc t) + | None -> tyname loc t in Loc.failk literal_at_want loc "%Ld does not fit in %s, which holds no negative number, and %s is called \ at %s — the body has to work at every type it is called at, so write \ it with no negative literal, as in (- x %Ld) in place of (+ x %Ld)" - n (Types.to_string t) gname var (Int64.neg n) n + n (tyname loc t) gname var (Int64.neg n) n | Ast.Int n -> int_literal loc ~want ~preds:ctx.env.tvpreds n | Ast.UInt (n, s) -> wide_literal loc ~want n s | Ast.Byte b -> @@ -5444,7 +5472,7 @@ and check_value ctx ?want (e : Ast.expr) : Tast.expr = else Printf.sprintf "$%s" v) | Some other when other <> Types.Never -> Loc.failk literal_at_want loc "expected %s, found the float literal %g" - (Types.to_string other) x + (tyname loc other) x | _ -> Types.F64 in mk loc (Types.Float k) (Tast.Float (x, k)) @@ -5486,7 +5514,7 @@ and check_value ctx ?want (e : Ast.expr) : Tast.expr = fail loc ":%s is an enum member where an enum is expected and a dyn keyword \ elsewhere, but %s is expected here" k - (Types.to_string other)) + (tyname loc other)) (* {:a 1 :b s} — a dyn map, built where it stands. Always dyn: the runtime owns the storage the way (vec-new dyn) does, keys and values are both dyn words, and a typed want other than dyn refuses through [expect] @@ -5603,7 +5631,7 @@ and check_value ctx ?want (e : Ast.expr) : Tast.expr = | None -> if not (Types.equal ctx.ret Types.Unit) then fail loc "this function returns %s, so return needs a value" - (Types.to_string ctx.ret); + (tyname loc ctx.ret); None | Some v -> Some (check ctx ~want:ctx.ret v) in @@ -5679,7 +5707,7 @@ and check_value ctx ?want (e : Ast.expr) : Tast.expr = fail loc "(get m k) is a place only on a class instance, and this is %s. A \ map's entries are written with put" - (Types.to_string target.Tast.ty); + (tyname loc target.Tast.ty); let k = check ctx ~want:Types.Dyn k in let v = check ctx ~want:Types.Dyn v in expect ctx loc ~want @@ -5694,7 +5722,7 @@ and check_value ctx ?want (e : Ast.expr) : Tast.expr = (match Tast.field_index s name with | None -> Loc.failk "check/unknown-field" loc ~notes:(declared_note ctx.env sname) - "%s has no field %s" (Types.to_string (Types.Named sname)) name + "%s has no field %s" (tyname loc (Types.Named sname)) name | Some i -> let fty = (List.nth s.Tast.fields i).Tast.fty in expect ctx loc ~want (mk loc fty (Tast.Field (target, i)))) @@ -5741,11 +5769,11 @@ and check_value ctx ?want (e : Ast.expr) : Tast.expr = | Types.Option t -> expect ctx loc ~want (mk loc t (Tast.UnwrapSome v)) | other -> - fail loc "some takes an (Option T), found %s" (Types.to_string other)) + fail loc "some takes an (Option T), found %s" (tyname loc other)) | other -> fail loc "some early-returns None, so the enclosing function must return an \ - Option; this one returns %s" (Types.to_string other)) + Option; this one returns %s" (tyname loc other)) | Ast.Unwrap (Ast.Utry, _) -> unimplemented loc "try (Result)" 6 | Ast.Fn (params, body) -> check_fn ctx ~want loc params body | Ast.Dotimes (label, name, bounds, body) -> @@ -5771,7 +5799,7 @@ and check_value ctx ?want (e : Ast.expr) : Tast.expr = condition's struct type, whose dyn fields are fine" | t -> fail c.Tast.loc - "a condition is a struct, not %s" (Types.to_string t) + "a condition is a struct, not %s" (tyname loc t) in (* A condition that *holds* a dyn is not refused. The condition crosses as a pointer to a value in the signalling frame, and that value is on the @@ -5815,7 +5843,7 @@ and check_value ctx ?want (e : Ast.expr) : Tast.expr = | Types.Unit | Types.Never -> fail a.Tast.loc "a restart argument must be a value, and this one is %s" - (Types.to_string a.Tast.ty) + (tyname loc a.Tast.ty) | _ -> ()) args; let sg = restart_sig (List.map (fun (a : Tast.expr) -> a.Tast.ty) args) in @@ -5905,7 +5933,7 @@ and int_literal loc ~want ?(preds = []) ?(default = Types.I32) n = n v v v | Some other when other <> Types.Never -> Loc.failk literal_at_want loc "expected %s, found the integer literal %Ld" - (Types.to_string other) n + (tyname loc other) n | _ -> mk loc (Types.Int default) (Tast.Int (in_range loc default n, default)) (* An integer written at or above 2^63, in decimal or in hex. Only a u64 holds @@ -5920,7 +5948,7 @@ and wide_literal loc ~want n s = Loc.failk literal_at_want loc "%s is too large for any integer type but u64, and an integer literal \ where %s is wanted is read as one — write (%s (u64 %s))" - s (Types.to_string t) (Types.to_string t) s + s (tyname loc t) (tyname loc t) s | Some Types.Never | None -> Loc.failk literal_at_want loc "%s does not fit in i32, the type an integer literal takes when nothing \ @@ -5935,7 +5963,7 @@ and wide_literal loc ~want n s = | Some other -> Loc.failk literal_at_want loc "expected %s, found the integer literal %s, which only a u64 holds" - (Types.to_string other) s + (tyname loc other) s (* Arithmetic wraps, but a literal that does not fit its type is a typo, not a wrap — 300 is never what someone meant by a u8. *) @@ -5998,6 +6026,11 @@ and var ctx ?(qualified = false) loc ~want name = item 4. *) | "nil" -> expect ctx loc ~want (rt loc Types.Dyn "flan_dyn_nil" []) + (* [Dir.north]: an enum's member named through its type, as a data case is + [Shape.Rect]; the same value as [:north] where a Dir is expected. *) + | _ when lookup ctx name = None && enum_member ctx.env name <> None -> + let e, v = Option.get (enum_member ctx.env name) in + expect ctx loc ~want (mk loc (Types.Enum e) (Tast.Int (v, Types.I32))) | "None" -> (match want with | Some (Types.Option t) -> mk loc (Types.Option t) Tast.None_ @@ -6006,7 +6039,7 @@ and var ctx ?(qualified = false) loc ~want name = absence and this is it, not an (Option T) that then gets boxed. *) | Some Types.Dyn -> rt loc Types.Dyn "flan_dyn_nil" [] | Some other when other <> Types.Never -> - fail loc "expected %s, found None" (Types.to_string other) + fail loc "expected %s, found None" (tyname loc other) | _ -> fail loc "nothing here says what None is an Option of — use it where an \ @@ -6193,12 +6226,12 @@ and check_fn ctx ~want ?gen loc (params : string list) body = "this fn has %d parameter%s and %s was wanted here" (List.length params) (if List.length params = 1 then "" else "s") - (Types.to_string + (tyname loc (if bare then Types.CFn (ps, r) else Types.Fn (ps, r))) | _ -> match want with | Some other when other <> Types.Never -> - fail loc "expected %s, found an fn" (Types.to_string other) + fail loc "expected %s, found an fn" (tyname loc other) | _ -> if fln_source loc then fail loc @@ -6246,7 +6279,7 @@ and check_fn ctx ~want ?gen loc (params : string list) body = fail loc "an fn with no body answers (), and this one is in a position \ that wants %s — write the value it should answer" - (Types.to_string r) + (tyname loc r) | _ -> fbody, Types.Unit) | last :: rest -> (match ret0 with @@ -6290,8 +6323,8 @@ and check_fn ctx ~want ?gen loc (params : string list) body = %s): a CFn is the bare address, one word, with nowhere for the \ copies to live. Widen the position to Fn, or pass %s in as a parameter" (String.concat ", " names) - (String.concat " " (List.map Types.to_string pts)) (Types.to_string ret) - (String.concat " " (List.map Types.to_string pts)) (Types.to_string ret) + (String.concat " " (List.map (tyname loc) pts)) (tyname loc ret) + (String.concat " " (List.map (tyname loc) pts)) (tyname loc ret) (match names with [ n ] -> n | _ -> "them") end; (* An [Fn]-position literal declares the environment whether or not it @@ -6365,7 +6398,7 @@ and check_handler_bind ctx ?want ?(what = "handler-bind") loc clauses body = | Types.Named n -> n | t -> fail c.Ast.hloc - "a handler matches a struct type, not %s" (Types.to_string t) + "a handler matches a struct type, not %s" (tyname loc t) in (* Its own context: a fresh frame, an empty scope, and no way to reach the enclosing one. *) @@ -6544,7 +6577,7 @@ and restart_clauses ctx ?want ?(hidden = false) ~what loc (tbody : Tast.expr) | Types.Unit | Types.Never -> fail p.Ast.floc "%s would be a restart parameter of type %s, which is \ - not a value" p.Ast.fname (Types.to_string ty) + not a value" p.Ast.fname (tyname loc ty) | _ -> ()); (bind ctx p.Ast.fname ty ~assignable:false, ty)) c.Ast.rparams @@ -6629,7 +6662,7 @@ and check_handler_case ctx ?want loc body clauses = | Types.Named n -> n | t -> fail c.Ast.hloc - "a handler matches a struct type, not %s" (Types.to_string t)) + "a handler matches a struct type, not %s" (tyname loc t)) clauses in (* Two clauses for one condition type: the first would take every one of @@ -6769,7 +6802,7 @@ and check_let ctx ?(tail = false) ?want ?(defer_ok = false) loc bs body = | Types.Never when is_poison v -> () | Types.Unit | Types.Never -> fail b.Ast.bloc "%s would be bound to %s, which is not a value" - b.Ast.bname (Types.to_string v.Tast.ty) + b.Ast.bname (tyname loc v.Tast.ty) | _ -> ()); (* Locals are assignable places; parameters are not. *) let slot = bind ctx b.Ast.bname v.Tast.ty ~assignable:true in @@ -7002,7 +7035,7 @@ and check_loop ctx ?want loc bs body = | Types.Never when is_poison v -> () | Types.Unit | Types.Never -> fail v.Tast.loc "%s would be bound to %s, which is not a value" n - (Types.to_string v.Tast.ty) + (tyname loc v.Tast.ty) | _ -> ()); (bind ctx n v.Tast.ty ~assignable:true, v)) bs @@ -7245,7 +7278,7 @@ and check_truthy_once ctx c = (try Loc.failk "check/condition-not-bool" loc "a condition is a bool or a dyn, and this is %s%s" - (Types.to_string c0.Tast.ty) how + (tyname loc c0.Tast.ty) how with Loc.Error d -> refuse_or_poison ctx.env loc d)) | exception Loc.Error _ -> check ctx ~want:Types.Bool c @@ -7383,7 +7416,7 @@ and check_if_once ctx ~tail ?want loc c t e = Loc.failk "check/shortcircuit-operand" t.Tast.loc "an and answers false or its last operand, so the two have to be \ one type — this operand is %s, and false is a bool" - (Types.to_string t.Tast.ty) + (tyname loc t.Tast.ty) with Loc.Error d -> refuse_or_poison ctx.env e.Ast.loc d) | exception Loc.Error d when reworded -> refuse_or_poison ctx.env e.Ast.loc d in @@ -7400,7 +7433,7 @@ and check_if_once ctx ~tail ?want loc c t e = else if Types.equal t.Tast.ty e.Tast.ty then t.Tast.ty else fail loc "the branches of this if have different types: %s and %s" - (Types.to_string t.Tast.ty) (Types.to_string e.Tast.ty) + (tyname loc t.Tast.ty) (tyname loc e.Tast.ty) in mk loc ty (Tast.If (c, t, e)) @@ -7507,13 +7540,13 @@ and generic_ctor ctx ~want loc name given = | Some (fname, at) -> [ Loc.note at (Printf.sprintf ".%s is %s here, which decides $%s" fname - (Types.to_string b) v) ] + (tyname loc b) v) ] | None -> [] in Loc.failk "check/generic-struct-field" a.Ast.loc ~notes "%s's .%s is $%s, which is %s here, and %g is a float literal. \ Write .%s as an integer, or give .%s a float type" - name f.Tast.fname v (Types.to_string b) x f.Tast.fname + name f.Tast.fname v (tyname loc b) x f.Tast.fname (match List.assoc_opt v !decided_by with | Some (fname, _) -> fname | None -> f.Tast.fname) @@ -7527,8 +7560,8 @@ and generic_ctor ctx ~want loc name given = | Some j -> subst := (v, j) :: List.remove_assoc v !subst | None -> fail a.Ast.loc "%s's .%s is %s here, and this is %s" - (Types.to_string (Types.Named open_key)) f.Tast.fname - (Types.to_string b) (Types.to_string t))) + (tyname loc (Types.Named open_key)) f.Tast.fname + (tyname loc b) (tyname loc t))) | _ -> if open_ty f.Tast.fty && not (literal a && subst_ty !subst f.Tast.fty |> open_ty |> not) @@ -7555,9 +7588,9 @@ and generic_ctor ctx ~want loc name given = !subst else fail a.Ast.loc "%s's .%s is %s here, and this is %s" - (Types.to_string (Types.Named open_key)) f.Tast.fname - (Types.to_string (subst_ty !subst f.Tast.fty)) - (Types.to_string t) + (tyname loc (Types.Named open_key)) f.Tast.fname + (tyname loc (subst_ty !subst f.Tast.fty)) + (tyname loc t) end) pairs; (match given with @@ -7624,7 +7657,7 @@ and positional_struct ctx ~want loc name args = | Some (g, _) when Hashtbl.mem ctx.env.copies name -> g | _ -> name in - let shown = Types.to_string (Types.Named name) in + let shown = tyname loc (Types.Named name) in if given < n then begin let missing = List.nth fields given in Loc.failk "check/positional-too-few" loc ~notes:note @@ -7709,7 +7742,7 @@ and check_bare ctx ~want loc kvs = Loc.failk "check/bare-struct-want" loc "%s is a struct field list and %s is expected here, which is not a \ struct type" - written (Types.to_string other) + written (tyname loc other) | None -> Loc.failk "check/bare-struct-untyped" loc "%s does not say which struct it builds — the fields alone do not name \ @@ -7804,7 +7837,7 @@ and check_struct ctx ~want loc name kvs = if Tast.field_index s k = None then Loc.failk "check/unknown-field" v.Ast.loc ~notes:(declared_note ctx.env name) - "%s has no field %s" (Types.to_string (Types.Named name)) k) + "%s has no field %s" (tyname loc (Types.Named name)) k) in let fields = zii_fill ctx loc seen s.Tast.fields in expect ctx loc ~want (mk loc (Types.Named name) (Tast.Make (name, fields))) @@ -7946,7 +7979,7 @@ and check_arr ctx ~want loc items = (fun (i : Tast.expr) -> if not (Types.fits ~expected:elem ~actual:i.Tast.ty) then fail i.Tast.loc "this array's elements are %s, but this one is %s" - (Types.to_string elem) (Types.to_string i.Tast.ty)) + (tyname loc elem) (tyname loc i.Tast.ty)) items; (match want with | Some (Types.Array (m, _)) when not (Int64.equal m n) -> @@ -8095,15 +8128,15 @@ and numbers_disagree : 'a. ctx -> (Ast.expr * Types.t) list -> 'a = | _ -> t1, second, t2, first in ignore ctx; - let tn = Types.to_string target in + let tn = tyname moved.Ast.loc target in Loc.failk "check/array-numbers-disagree" moved.Ast.loc ~notes:[ Loc.note other.Ast.loc (Printf.sprintf "this element is %s" tn) ] "this array's elements are %s and %s, and neither holds every value of \ the other — %s" - (Types.to_string moved_ty) tn + (tyname moved.Ast.loc moved_ty) tn (match spell_arg "" moved with | "" -> - Printf.sprintf "convert the %s element with the %s cast" (Types.to_string moved_ty) tn + Printf.sprintf "convert the %s element with the %s cast" (tyname moved.Ast.loc moved_ty) tn | x -> Printf.sprintf "convert one, as in (%s %s)" tn x) (* Elements that do not agree and cannot all become a dyn either: a struct @@ -8284,6 +8317,15 @@ and array_build ctx loc ns elem ~pre ~element = [n T] the literal is, since an array literal is never a slice. *) and check_the ctx ~want loc (t : Ast.texpr) (v : Ast.expr) = let ty = resolve ctx.env t in + (* A typed .fln lambda, [fn(c: C) -> bool = ...], reads as [(the (Fn [C] + bool) (fn ...))]; where a CFn of the same signature is wanted, the + literal is that CFn, as an untyped one would be. *) + let ty = + match ty, v.Ast.e, want with + | Types.Fn (ps, r), Ast.Fn _, Some (Types.CFn (ps', r') as c) + when Types.equal (Types.Fn (ps, r)) (Types.Fn (ps', r')) -> c + | _ -> ty + in let is_nil = match v.Ast.e with Ast.Var "nil" -> true | _ -> false in if ty <> Types.Dyn && not is_nil && probe ctx loc (fun () -> (check ctx v).Tast.ty) = Some Types.Dyn @@ -8291,7 +8333,7 @@ and check_the ctx ~want loc (t : Ast.texpr) (v : Ast.expr) = enum's type, not a dyn: [let d: Dir = :north]. *) && not (match ty, v.Ast.e with Types.Enum _, Ast.Kw _ -> true | _ -> false) then begin - let tn = Types.to_string ty in + let tn = tyname loc ty in let numeric = match ty with Types.Int _ | Types.Float _ -> true | _ -> false in (* In a .fln file the user wrote [x: T = v], not [the]. *) let fln = fln_source loc in @@ -8417,7 +8459,7 @@ and check_array_gen ctx ~want loc dims f = if not (Types.equal p index_ty) then fail f.Tast.loc "an index is an i32, and this generator's argument %d is %s" - (k + 1) (Types.to_string p)) + (k + 1) (tyname loc p)) ps; r | None -> @@ -8425,7 +8467,7 @@ and check_array_gen ctx ~want loc dims f = "array-gen's second element is a function value, called once per \ element with one i32 index per dimension, and this is %s — for one \ value repeated, write array-fill" - (Types.to_string f.Tast.ty) + (tyname loc f.Tast.ty) in no_zeroed_fn loc "a fixed array's element" elem; let fs = fresh_slot ctx f.Tast.ty in @@ -8475,7 +8517,7 @@ and check_match ctx ?(tail = false) ?want loc scrutinee arms = fail loc "match works on an Option, a data type, an enum, a bool, a number, a \ string or a dyn, not on %s" - (Types.to_string other) + (tyname loc other) in (* A literal arm, spelled as it was written, for the refusals that name one. *) let spell (e : Ast.expr) = @@ -8498,7 +8540,7 @@ and check_match ctx ?(tail = false) ?want loc scrutinee arms = | Ast.Var b -> b | _ -> "this literal" in - let what_ty t = match t with Types.Dyn -> "a dyn" | t -> Types.to_string t in + let what_ty t = match t with Types.Dyn -> "a dyn" | t -> tyname loc t in (* A literal match that compiles, over the scrutinee's own name where it has one, for the refusals that need to show the shape. *) let lit_arms_fix t = @@ -8538,7 +8580,7 @@ and check_match ctx ?(tail = false) ?want loc scrutinee arms = an f64, and %s fits in neither. Change the arm to a value an \ i64 holds, or remove it" (spell e) | _ -> ()); - let tn = Types.to_string t in + let tn = tyname loc t in let an = match tn.[0] with | 'a' | 'e' | 'f' | 'i' | 'o' -> "an " ^ tn @@ -8599,7 +8641,7 @@ and check_match ctx ?(tail = false) ?want loc scrutinee arms = (match t with | Types.Dyn -> "a dyn" | t -> - let tn = Types.to_string t in + let tn = tyname loc t in (match tn.[0] with | 'a' | 'e' | 'f' | 'i' | 'o' -> "an " ^ tn | _ -> "a " ^ tn)) @@ -8635,6 +8677,15 @@ and check_match ctx ?(tail = false) ?want loc scrutinee arms = | None -> fail a.Ast.aloc "%s has no member :%s — it has %s" n k all end; Some k, [] + (* [Dir.north ->], the member named through its enum. *) + | `Enum (n, members), Ast.Pctor (c, []) + when String.length c > String.length n + 1 + && String.sub c 0 (String.length n + 1) = n ^ "." -> + let k = String.sub c (String.length n + 1) (String.length c - String.length n - 1) in + if not (List.mem_assoc k members) then + fail a.Ast.aloc "%s has no member %s — it has %s" n k + (String.concat " " (List.map (fun (m, _) -> n ^ "." ^ m) members)); + Some k, [] | `Enum (n, members), Ast.Pctor (c, _) -> fail a.Ast.aloc "this match is over the enum %s, and %s is not one of its members. An \ @@ -8861,7 +8912,7 @@ and check_match ctx ?(tail = false) ?want loc scrutinee arms = Loc.failk "check/non-exhaustive-match" loc "this match is not exhaustive — its arms are literals, and no list of \ them covers every %s. Add a _ arm for the rest, as in %s" - (match t with Types.Dyn -> "dyn value" | t -> Types.to_string t) + (match t with Types.Dyn -> "dyn value" | t -> tyname loc t) (lit_arms_fix t) | _ -> ()); if not !saw_wild && missing <> [] then @@ -9028,7 +9079,7 @@ and unknown_name : 'a. ?setting:bool -> ctx -> Loc.t -> string -> 'a = "unknown name %s — a dot is part of the name here, not field access. \ A field is reached through an accessor, (.%s %s), and %s is %s, \ which has no fields" - name field head head (Types.to_string t) + name field head head (tyname loc t) | None, None -> Loc.failk "check/unknown-name" loc "unknown name %s — nothing named %s is in scope either. A field is \ @@ -9087,7 +9138,7 @@ and check_arg ctx name i (want : Types.t) (a : Ast.expr) = let p = List.nth ps i in [ Loc.note p.Ast.floc (Printf.sprintf "%s's %s parameter %s is declared %s" - name which p.Ast.fname (Types.to_string want)) ] + name which p.Ast.fname (tyname p.Ast.floc want)) ] | _ -> [] in refuse_or_poison ctx.env a.Ast.loc @@ -9184,7 +9235,7 @@ and refuse_const_change _ctx loc (target : Tast.expr) = match const_reached target with | None -> () | Some view -> - let t = Types.to_string target.Tast.ty in + let t = tyname loc target.Tast.ty in let holder = match view with Types.Slice (_, e) | Types.Ptr (_, e) -> e | t -> t in @@ -9192,8 +9243,8 @@ and refuse_const_change _ctx loc (target : Tast.expr) = "this changes a %s reached through a %s, which can only be read. Where \ it has to change, take the %s it lives in as a [%s] or a (Ptr %s) \ instead" - t (Types.to_string view) (Types.to_string holder) - (Types.to_string holder) (Types.to_string holder) + t (tyname loc view) (tyname loc holder) + (tyname loc holder) (tyname loc holder) and check_place ?(store = true) ctx loc (p : Ast.place) : Tast.place * Types.t = match p with @@ -9244,7 +9295,7 @@ and check_place ?(store = true) ctx loc (p : Ast.place) : Tast.place * Types.t = (match Tast.field_index s name with | None -> Loc.failk "check/unknown-field" loc ~notes:(declared_note ctx.env sname) - "%s has no field %s" (Types.to_string (Types.Named sname)) name + "%s has no field %s" (tyname loc (Types.Named sname)) name | Some i -> if store then Option.iter (refuse_const_place ctx.env loc) (const_reached target); Tast.Pfield (target, i), (List.nth s.Tast.fields i).Tast.fty) @@ -9268,7 +9319,7 @@ and check_place ?(store = true) ctx loc (p : Ast.place) : Tast.place * Types.t = refuse_const_place ctx.env loc view | Types.Ptr (_, t) -> Tast.Pderef target, t | other -> - fail loc "deref takes a (Ptr T), found %s" (Types.to_string other)) + fail loc "deref takes a (Ptr T), found %s" (tyname loc other)) (* Only [set] writes a class slot, and it has its own arm above. A slot lives in a map the collector may move entries of, so it has no address to hand out. *) @@ -9319,7 +9370,7 @@ and index_expr ctx (e : Ast.expr) = "an index is an i32, and %s is wider — write (i32 …)" (Types.ikind_name k) | other -> - fail e.Ast.loc "an index is an integer, found %s" (Types.to_string other) + fail e.Ast.loc "an index is an integer, found %s" (tyname e.Ast.loc other) (* [(at a i)] and [(at grid row col)]: one index per dimension. @@ -9345,7 +9396,7 @@ and indexed ?place ?(store = true) ctx (target : Tast.expr) (idx : Ast.expr list if store then Option.iter (fun l -> refuse_string_place l ty) place; Types.Int Types.U8 | other -> - fail i.Ast.loc "%s cannot be indexed" (Types.to_string other) + fail i.Ast.loc "%s cannot be indexed" (tyname i.Ast.loc other) in let loc = i.Ast.loc in let i = index_expr ctx i in @@ -9399,7 +9450,7 @@ and check_call ctx ~want loc (head : Ast.expr) (args : Ast.expr list) = | Ast.Call ({ Ast.e = Ast.Var "Ptr"; _ }, _) when (match type_of_expr head with Some _ -> true | None -> false) -> let target = resolve ctx.env (Option.get (type_of_expr head)) in - let spelled = Types.to_string target in + let spelled = tyname loc target in (match args with | [ a ] -> let a_loc = a.Ast.loc in @@ -9410,8 +9461,8 @@ and check_call ctx ~want loc (head : Ast.expr) (args : Ast.expr list) = fail loc "%s is a %s, which cannot be written through, and %s would allow \ writes. Write (%s %s)" - spelled_a (Types.to_string a.Tast.ty) spelled - (Types.to_string (Types.Ptr (Types.Const, u))) spelled_a + spelled_a (tyname loc a.Tast.ty) spelled + (tyname loc (Types.Ptr (Types.Const, u))) spelled_a | Types.Ptr _, _ -> expect ctx loc ~want (mk loc target (Tast.Prim (Tast.Cast target, [ a ]))) @@ -9419,12 +9470,12 @@ and check_call ctx ~want loc (head : Ast.expr) (args : Ast.expr list) = fail a_loc "%s converts a pointer, found %s. The address of the first \ element is (addr (at %s 0)); write (%s (addr (at %s 0)))" - spelled (Types.to_string a.Tast.ty) spelled_a spelled spelled_a + spelled (tyname loc a.Tast.ty) spelled_a spelled spelled_a | Types.Int _, _ -> fail a_loc "%s converts a pointer, found %s. There is no conversion between \ an integer and a pointer" - spelled (Types.to_string a.Tast.ty) + spelled (tyname loc a.Tast.ty) | Types.Dyn, _ -> fail a_loc "%s converts a pointer, found dyn. A dyn value never holds a \ @@ -9434,7 +9485,7 @@ and check_call ctx ~want loc (head : Ast.expr) (args : Ast.expr list) = fail a_loc "%s converts a pointer, found %s. The address of a place is \ (addr %s); write (%s (addr %s))" - spelled (Types.to_string other) spelled_a spelled spelled_a) + spelled (tyname loc other) spelled_a spelled spelled_a) | _ -> fail loc "%s takes one pointer, given %d" spelled (List.length args)) (* A computed head: ((choose k) 3). The head is an ordinary expression and @@ -9459,7 +9510,7 @@ and call_value ctx ~want loc (callee : Tast.expr) args = expect ctx loc ~want (mk loc ret (Tast.CallPtr (callee, args))) | None -> fail loc "this is a %s and not a function, so it cannot be called" - (Types.to_string callee.Tast.ty) + (tyname loc callee.Tast.ty) (* A builtin's arity. The count is the builtin's and can only be the builtin's: a defn of the same name written in the program now takes the @@ -9540,9 +9591,9 @@ and not_numeric name what (a : Tast.expr) = fail where "%s takes %s, and this is %s — there is no %s on text. The prelude \ concatenates with concat and join" - name what (Types.to_string a.Tast.ty) name + name what (tyname where a.Tast.ty) name else - fail where "%s takes %s, found %s" name what (Types.to_string a.Tast.ty) + fail where "%s takes %s, found %s" name what (tyname where a.Tast.ty) (* ── A conversion whose operand is a type variable ───────────────────── [(i32 x)] where [x] is a [$t]. The concrete question — is this a number — @@ -10018,7 +10069,7 @@ and type_of_expr ?(generic = fun _ -> false) (e : Ast.expr) : Ast.texpr option = and map_kv loc what (t : Types.t) = match t with | Types.Map (k, v) -> k, v - | other -> fail loc "%s takes a (Map K V), found %s" what (Types.to_string other) + | other -> fail loc "%s takes a (Map K V), found %s" what (tyname loc other) (* The key and value for [map-new]: two leading bare symbols naming types, or the expectation at the site. The same rule [vec-new] uses, with the same @@ -10060,7 +10111,7 @@ and map_new_types ctx ~want loc args = and vec_elem loc what (t : Types.t) = match t with | Types.Vec e -> e - | other -> fail loc "%s takes a (Vec T), found %s" what (Types.to_string other) + | other -> fail loc "%s takes a (Vec T), found %s" what (tyname loc other) (* The allocator an operation uses: the one named at the site, or the current implicit one. spec-memory.md: an operation never falls back to a hidden @@ -10392,11 +10443,11 @@ and named_call ?(qualified = false) ctx ~want loc name args = | "=" | "!=" -> fail loc "%s compares numbers, enums, strings and bools, and %s is none \ - of those" name (Types.to_string a.Tast.ty) + of those" name (tyname loc a.Tast.ty) | _ -> fail loc "%s orders machine numbers and enums, and %s is neither" name - (Types.to_string a.Tast.ty)); + (tyname loc a.Tast.ty)); match rest with | [] -> prim p Types.Bool [ a; b ] | _ -> @@ -10449,7 +10500,7 @@ and named_call ?(qualified = false) ctx ~want loc name args = | t when generic_ty t -> unconstrained ctx.env loc name ~needs:"integer?" t | other -> fail loc "%s takes integers, found %s" name - (Types.to_string other)); + (tyname loc other)); (* A shift by the operand's own width or more is poison in LLVM, which at -O2 turns the whole function into an undefined value rather than into a wrong number. A literal count is rejected here — that is the typo — and @@ -10461,7 +10512,7 @@ and named_call ?(qualified = false) ctx ~want loc name args = if Int64.unsigned_compare n w >= 0 then fail loc "%s by %Ld is out of range for %s, which is %d bits wide" name n - (Types.to_string a.Tast.ty) (Types.bits k) + (tyname loc a.Tast.ty) (Types.bits k) | _ -> ()); prim p a.Tast.ty [ a; b ] (* (min a b) and (max a b) evaluate each operand once — hence the slots — @@ -10564,7 +10615,7 @@ and named_call ?(qualified = false) ctx ~want loc name args = | _ -> fail a.Ast.loc "%s takes a numeric? type, and %s is not one — as in (%s i32)" name - (Types.to_string ty) name + (tyname loc ty) name in expect ctx loc ~want v (* (zeroed) is the all-bytes-zero value of whatever it is being stored into, @@ -10614,8 +10665,8 @@ and named_call ?(qualified = false) ctx ~want loc name args = "%s writes raw bytes over %s, and %s is not plain data — %s. \ Fill only numbers and pointers, and structs, unions and fixed \ arrays built out of them" - name (Types.to_string ty) - (if Types.equal bad ty then "it" else Types.to_string bad) + name (tyname loc ty) + (if Types.equal bad ty then "it" else tyname loc bad) (match bad with | Types.Dyn -> "a dyn is one word the collector walks by descriptor, and a \ @@ -10702,11 +10753,11 @@ and named_call ?(qualified = false) ctx ~want loc name args = "this pattern binds %Ld name%s, but %s has %Ld element%s — a \ pattern over a fixed array names every element, or ends in \ [& rest]" - n (plural n) (Types.to_string target.Tast.ty) m (plural m); + n (plural n) (tyname loc target.Tast.ty) m (plural m); if Int64.equal exact 0L && Int64.compare m n < 0 then fail loc "this pattern binds %Ld name%s before the &, but %s has only %Ld \ - element%s" n (plural n) (Types.to_string target.Tast.ty) m + element%s" n (plural n) (tyname loc target.Tast.ty) m (plural m); prim Tast.At elem [ target; mk loc index_ty (Tast.Int (i, Types.I32)) ] @@ -10722,13 +10773,13 @@ and named_call ?(qualified = false) ctx ~want loc name args = "a pattern cannot destructure %s — a slice's length is not known \ until the program runs, so nothing here can check it has %Ld \ element%s. Use %s and test %s yourself" - (Types.to_string target.Tast.ty) n (plural n) + (tyname loc target.Tast.ty) n (plural n) (if fln_source loc then "s[i]" else "(at s i)") (if fln_source loc then "length(s)" else "(length s)") | other -> fail loc "%s is not a fixed array, so [a b ...] cannot destructure it" - (Types.to_string other)) + (tyname loc other)) | _ -> fail loc "destructure~nth is written by the compiler and cannot be called") @@ -11042,7 +11093,7 @@ and named_call ?(qualified = false) ctx ~want loc name args = fail loc "a %s knows the allocator it came from, so free takes only the \ container. Write (free %s)" - (Types.to_string target.Tast.ty) (spell_arg "v" (List.hd args)) + (tyname loc target.Tast.ty) (spell_arg "v" (List.hd args)) | _ -> ()); (* A container of owning elements is refused here, and a reader will assume the opposite — that [free] recurses — so this says why it does @@ -11074,7 +11125,7 @@ and named_call ?(qualified = false) ctx ~want loc name args = "%s holds elements that own storage, and free releases only the \ block those elements sit in. Write (free-all a) on the region it \ was built against" - (Types.to_string target.Tast.ty) + (tyname loc target.Tast.ty) | Types.Vec elem -> expect ctx loc ~want (rt loc Types.Unit "flan_vec_free" @@ -11093,10 +11144,10 @@ and named_call ?(qualified = false) ctx ~want loc name args = fail loc "%s can only be read, so it cannot be freed. Free the [%s] it was \ copied into" - (Types.to_string target.Tast.ty) + (tyname loc target.Tast.ty) (match target.Tast.ty with - | Types.Slice (_, e) -> Types.to_string e - | t -> Types.to_string t) + | Types.Slice (_, e) -> tyname loc e + | t -> tyname loc t) (* A view written right here — (slice ...) or (slice-from ...) — is storage something else owns, known without running anything. *) | Types.Slice (Types.Mut, _) @@ -11118,7 +11169,7 @@ and named_call ?(qualified = false) ctx ~want loc name args = fail loc "free takes a Vec, a Map, or a slice (bytes s) or (clone xs) made — \ found %s" - (Types.to_string other)) + (tyname loc other)) (* Emitted by the prelude's [into] when no (map f) is in the chain, so that every element pushed is a source element as it stands. A push copies an element's header, and for an element that owns storage the copy and the @@ -11141,7 +11192,7 @@ and named_call ?(qualified = false) ctx ~want loc name args = (match elem with | Some e when owning ctx.env e -> let v = spell_arg "v" src in - let et = Types.to_string e in + let et = tyname loc e in let fix = if clone_accepts ctx.env e then match spell_form dst, List.map spell_form transforms with @@ -11206,7 +11257,7 @@ and named_call ?(qualified = false) ctx ~want loc name args = fail loc "%s cannot be cloned — its elements own storage, and nothing here \ can walk one to copy what it owns. %s" - (Types.to_string target.Tast.ty) + (tyname loc target.Tast.ty) (insert_copies ctx.env target.Tast.ty) (* A slice's elements, copied into a block from the allocator and answered as a slice over it — what (bytes s) does for a string's @@ -11216,7 +11267,7 @@ and named_call ?(qualified = false) ctx ~want loc name args = fail loc "%s cannot be cloned — its elements own storage, and nothing here \ can walk one to copy what it owns. %s" - (Types.to_string target.Tast.ty) + (tyname loc target.Tast.ty) (insert_copies ctx.env target.Tast.ty) (* The copy is a block from an allocator, which the collector does not walk, so a dyn in it would be a root nothing marks. *) @@ -11225,7 +11276,7 @@ and named_call ?(qualified = false) ctx ~want loc name args = "%s cannot be cloned — its elements hold a dyn, and the copy would \ live in allocator storage the collector does not look in. Build \ a dyn vector from the elements instead" - (Types.to_string target.Tast.ty) + (tyname loc target.Tast.ty) | Types.Slice (_, elem) -> expect ctx loc ~want (dup_elems ctx loc elem target a) (* A map's clone reinserts rather than copying the block, because the @@ -11403,7 +11454,7 @@ and named_call ?(qualified = false) ctx ~want loc name args = expect ctx loc ~want (rt loc Types.Dyn "flan_dyn_kw" [ s ]) | other -> fail loc "keyword takes a string or a [u8], found %s" - (Types.to_string other)) + (tyname loc other)) | _ -> assert false) (* (class-of v) -> the class's name as a keyword, or nil. It is the dyn @@ -11870,7 +11921,7 @@ and named_call ?(qualified = false) ctx ~want loc name args = | other -> fail loc "length takes an array, a slice, a string, a Vec or a Map, found %s" - (Types.to_string other)) + (tyname loc other)) | "at" -> (match args with | target :: idx when idx <> [] -> @@ -11957,7 +12008,7 @@ and named_call ?(qualified = false) ctx ~want loc name args = | other -> fail loc "slice takes an array, a slice, a string or a Vec, found %s" - (Types.to_string other) + (tyname loc other) in (* An array that came back from a call is a value in a temporary this expression does not own: the slice would outlive it and view @@ -12087,7 +12138,7 @@ and named_call ?(qualified = false) ctx ~want loc name args = "slice-from takes a (Ptr T) and the number of elements behind \ it, found %s. A slice or an array already has a length; \ (slice v lo hi) views part of one" - (Types.to_string other) + (tyname loc other) in let n_loc = n.Ast.loc in let spelled_n = spell_arg "n" n in @@ -12101,7 +12152,7 @@ and named_call ?(qualified = false) ctx ~want loc name args = fail n_loc "slice-from counts elements with an integer, found %s. Write \ (slice-from %s (i64 %s))" - (Types.to_string other) spelled_target spelled_n); + (tyname loc other) spelled_target spelled_n); (* A negative literal is a lie the checker can see, so it does not wait for the run-time test emit.ml plants beside it. *) (match literal n with @@ -12139,7 +12190,7 @@ and named_call ?(qualified = false) ctx ~want loc name args = (match a.Tast.ty with | Types.Ptr (_, t) -> expect ctx loc ~want (mk loc t (Tast.Deref a)) | other -> fail loc "deref takes a (Ptr T), found %s" - (Types.to_string other)) + (tyname loc other)) (* ── Option ────────────────────────────────────────────────────── *) (* (Some nil) cannot be built. Some marks a value present; nil is dyn's own @@ -12488,7 +12539,7 @@ and named_call ?(qualified = false) ctx ~want loc name args = Printf.sprintf "%s has no rendering, so it cannot be watched — watch the \ values you want out of it instead" - (Types.to_string t)) + (tyname loc t)) (render_ctx ctx emitter) 0 value in let begin_ = @@ -12569,7 +12620,7 @@ and named_call ?(qualified = false) ctx ~want loc name args = | other -> fail loc "%s converts an integer to an enum, found %s — an enum or a \ float goes through (i32 x) first" name - (Types.to_string other)); + (tyname loc other)); prim (Tast.Cast target) target [ a ] (* A cast to a *type variable*: [(t x)] or [($t x)] inside a generic body. The name is not one [is_cast] knows, because [is_cast] asks whether the @@ -12618,7 +12669,7 @@ and named_call ?(qualified = false) ctx ~want loc name args = | Types.Var v -> cast_operand ctx loc name ~needs:"numeric?" ~also:("enum?", "an enum") ~what:"a number or an enum" ~is:"a number" v - | t -> fail loc "%s converts a number, found %s" name (Types.to_string t)); + | t -> fail loc "%s converts a number, found %s" name (tyname loc t)); prim (Tast.Cast target) target [ a ] | _ when is_cast name && List.length args = 1 -> let target = resolve_name ctx.env ~seen:[] loc name in @@ -12650,7 +12701,7 @@ and named_call ?(qualified = false) ctx ~want loc name args = | Types.Var v -> cast_operand ctx loc name ~needs:"numeric?" ~also:("enum?", "an enum") ~what:"a number or an enum" ~is:"a number" v - | t -> fail loc "%s converts a number, found %s" name (Types.to_string t)); + | t -> fail loc "%s converts a number, found %s" name (tyname loc t)); (match a.Tast.ty with | Types.Dyn -> cast_dyn ctx loc target a | _ -> prim (Tast.Cast target) target [ a ]) @@ -13188,8 +13239,8 @@ and generic_call ctx ~want loc name vars pats pret args = exactly — the pair cannot join at the wider type there. \ Write the conversion — (%s x) — or pass the arguments at \ one type" - name v (Types.to_string p) (Types.to_string a.Tast.ty) v - (Types.to_string p) + name v (tyname loc p) (tyname loc a.Tast.ty) v + (tyname loc p) | None -> pending := (v, p, a.Tast.ty, a.Tast.loc) :: !pending; true) @@ -13199,13 +13250,13 @@ and generic_call ctx ~want loc name vars pats pret args = place a widening thunk can be built around it. See [bind_ty]. *) if (not handled) && not (bind_ty ~widen:true subst p a.Tast.ty) then fail a.Tast.loc "%s expects %s here, found %s%s" name - (Types.to_string p) (Types.to_string a.Tast.ty) + (tyname loc p) (tyname loc a.Tast.ty) (match p, a.Tast.ty with | Types.Slice (Types.Mut, _), Types.Slice (Types.Const, e) -> Printf.sprintf " — %s takes a slice it may write through, and a %s can \ only be read%s" - name (Types.to_string a.Tast.ty) + name (tyname loc a.Tast.ty) (match const_copy ctx.env e with | Some c -> Printf.sprintf ". %s copies v into one that can be written" c @@ -13239,7 +13290,7 @@ and generic_call ctx ~want loc name vars pats pret args = "this call binds %s's $%s to both %s and %s, and neither holds \ every value of the other. Write the conversion you mean at one \ of the arguments, or pass them at one type" - name v (Types.to_string t1) (Types.to_string t2)) + name v (tyname loc t1) (tyname loc t2)) !pending; (* The binding is final; the arguments it out-widened catch up. Only a bare [$t] parameter can be here — [bound_exactly] kept every container-bound @@ -13288,8 +13339,8 @@ and generic_call ctx ~want loc name vars pats pret args = (Tast.Thicken (thick_thunk ctx.env a.Tast.loc ps r, a)) else fail a.Tast.loc "%s expects %s here, found %s" name - (Types.to_string (Types.Fn (ps, r))) - (Types.to_string a.Tast.ty) + (tyname loc (Types.Fn (ps, r))) + (tyname loc a.Tast.ty) | _ -> a)) pats targs in @@ -13331,7 +13382,7 @@ and generic_call ctx ~want loc name vars pats pret args = "this call would instantiate %s at $%s = %s, and a type variable \ is not instantiated at dyn. Write the type the value has, or use \ a defgeneric with a defmethod per class" - name v (Types.to_string t)) + name v (tyname loc t)) !subst; let cparams = List.map (subst_ty !subst) pats in let cret = subst_ty !subst pret in @@ -13369,7 +13420,7 @@ and generic_call ctx ~want loc name vars pats pret args = Loc.failk "check/predicate-unsatisfied" loc "%s is written {:where (%s $%s)}, and this call passes %s, \ which is not %s" - name p.Ast.pname p.Ast.pvar (Types.to_string t) p.Ast.pname + name p.Ast.pname p.Ast.pvar (tyname loc t) p.Ast.pname | _ -> ()) gfn.Ast.fwhere); expect ctx loc ~want (mk loc cret (Tast.Call (name, targs))) @@ -13420,7 +13471,7 @@ and instantiate env loc gname vars subst cparams cret = Loc.failk "check/predicate-unsatisfied" loc "this call instantiates %s at $%s = %s, and %s is not %s. %s is \ written {:where (%s $%s)} — pass a type the predicate admits" - gname p.Ast.pvar (Types.to_string t) (Types.to_string t) + gname p.Ast.pvar (tyname loc t) (tyname loc t) p.Ast.pname gname p.Ast.pname p.Ast.pvar) fn.Ast.fwhere; if Hashtbl.mem env.fns sym then @@ -13471,7 +13522,7 @@ and instantiate env loc gname vars subst cparams cret = String.concat ", " (List.map (fun v -> Printf.sprintf "$%s = %s" v - (Types.to_string (List.assoc v subst))) + (tyname loc (List.assoc v subst))) vars) in let in_prelude (l : Loc.t) = String.equal l.Loc.file Prelude.file in @@ -14546,12 +14597,12 @@ let collect env (decls : Ast.decl list) = which is what a C function pointer would need, and not about \ crossing today. Write the callback in C, or give the binding \ a (Ptr ()) and let the shim pass C's own" - what fn.Ast.name (Types.to_string t) + what fn.Ast.name (tyname loc t) | _ -> fail loc "%s of %s is %s, which cannot cross to C directly — pass \ (Ptr %s) and let the shim read it" what fn.Ast.name - (Types.to_string t) (Types.to_string t) + (tyname loc t) (tyname loc t) in List.iter (crossable "a parameter") params; crossable "the return type" ret; @@ -14593,7 +14644,7 @@ let collect env (decls : Ast.decl list) = fail t.Ast.tloc "%s names %s as its parent, and a parent is a condition \ struct, such as Error, the root every error descends from" - n (Types.to_string pt))); + n (tyname loc pt))); let fields = List.map field fs in (* Recorded before the refusal below rather than after it, because the refusal asks [region_only], which walks this very declaration: a @@ -15251,7 +15302,7 @@ let container_global_init loc n (ty : Types.t) (init : Ast.init) = fail loc "the global %s is %s, and uninit on one is refused. Write (defonce \ %s %s) with no initialiser — a zeroed %s is an empty one" - n (Types.to_string ty) n (Types.to_string ty) (Types.to_string ty) + n (tyname loc ty) n (tyname loc ty) (tyname loc ty) | _ -> () (* A container global has to be a [defonce]. A [defconst] is not an assignable @@ -15266,8 +15317,8 @@ let no_container_defconst loc n (ty : Types.t) = "the global %s is %s, and a %s global is a defonce, not a defconst — a \ defconst would stay the empty %s it was declared as. Write (defonce %s \ %s) and fill it in a function" - n (Types.to_string ty) (Types.to_string ty) (Types.to_string ty) - n (Types.to_string ty) + n (tyname loc ty) (tyname loc ty) (tyname loc ty) + n (tyname loc ty) (* A union member written into a *constant* would have to be encoded into the blob at link time, which is the byte-level encoder a data type case does not @@ -16109,7 +16160,7 @@ let dyn_descriptors (p : Tast.program) = collector marks a struct's dyn fields by their byte offsets, which \ %s does not have — its storage is not part of the value. Hold the \ dyn in a struct field, or wait for the typed container view" - what (Types.to_string t) (Types.to_string at) (Types.to_string at) + what (tyname loc t) (tyname loc at) (tyname loc at) | None -> ()); (* The count is saturated, so the message says more-than rather than a figure the reader could check — which is the honest thing to print, @@ -16120,7 +16171,7 @@ let dyn_descriptors (p : Tast.program) = offsets of an array are flattened one element at a time, and %d is \ the most this compiler will write out — the repeat form that would \ avoid it arrives with the typed container view" - what (Types.to_string t) desc_offsets_max desc_offsets_max + what (tyname loc t) desc_offsets_max desc_offsets_max in (* The foreign boundary, which is the one place the note above admits an honest hole. Every slot, global and array this compiler hands out for a diff --git a/lib/indent_printer.ml b/lib/indent_printer.ml index 88b14e23..eab9fe7b 100644 --- a/lib/indent_printer.ml +++ b/lib/indent_printer.ml @@ -363,7 +363,7 @@ and head_text (h : Form.t) = | Form.Sym s -> fst (sym h s) | _ -> at 9 h -and list _f h args = +and list f h args = let call () = (head_text h ^ "(" ^ commas args ^ ")", 9) in match h.v, args with | Form.Sym "quote", [ x ] -> ("'" ^ Form.to_source x, 10) @@ -418,6 +418,10 @@ and list _f h args = if glued then (tt ^ s, 9) else call () | Form.Sym s, [ ({ v = Form.Map _; _ } as m) ] when name_ok s && R.capitalised s -> (s ^ fst (expr m), 9) + | Form.Sym "the", _ when (match typed_lambda f with Some (_, [ _ ]) -> true | _ -> false) -> + (match typed_lambda f with + | Some (head, [ body ]) -> (head ^ " = " ^ unit_text body, 0) + | _ -> assert false) | Form.Sym "fn", [ { v = Form.Vec ps; _ }; body ] when List.for_all sym_param ps -> ("fn(" ^ commas ps ^ ") = " ^ unit_text body, 0) | Form.Sym "if", [ c; a; b ] -> @@ -463,6 +467,26 @@ and assign_text ?(lvl = 0) t v = and sym_param (p : Form.t) = match p.v with Form.Sym s -> name_ok s | _ -> false +(* [(the (Fn [C dyn] R) (fn [a b] ...))] as [fn(a: C, b) -> R], the typed + lambda it reads from; [None] for any other shape. *) +and typed_lambda (f : Form.t) = + let rec tyt (t : Form.t) = + match t.v with + | Form.List [ { v = Form.Sym (("Fn" | "CFn") as h); _ }; { v = Form.Vec ps; _ }; r ] -> + h ^ "(" ^ String.concat ", " (List.map tyt ps) ^ ") -> " ^ tyt r + | _ -> at 9 t + in + match f.v with + | Form.List [ { v = Form.Sym "the"; _ }; + { v = Form.List [ { v = Form.Sym "Fn"; _ }; { v = Form.Vec ts; _ }; r ]; _ }; + { v = Form.List ({ v = Form.Sym "fn"; _ } :: { v = Form.Vec ps; _ } :: body); _ } ] + when List.length ts = List.length ps && List.for_all sym_param ps && body <> [] -> + let one (n : Form.t) (t : Form.t) = + if is_sym "dyn" t then fst (expr n) else fst (expr n) ^ ": " ^ tyt t + in + Some ("fn(" ^ String.concat ", " (List.map2 one ps ts) ^ ") -> " ^ tyt r, body) + | _ -> None + (* A type after [:] or [->]: the function-type arrow at the top, a postfix term below it. *) let rec ty (f : Form.t) = @@ -750,6 +774,9 @@ and value_lines n prefix (v : Form.t) = else if n + String.length inline <= width then [ ind n ^ inline ] else match v.v with + | _ when typed_lambda v <> None -> + let head, body = Option.get (typed_lambda v) in + [ ind n ^ prefix ^ " = " ^ head ] @ block (n + 2) body | Form.List ({ v = Form.Sym "fn"; _ } :: { v = Form.Vec ps; _ } :: (_ :: _ as body)) when List.for_all sym_param ps -> [ ind n ^ prefix ^ " = fn(" ^ commas ps ^ ")" ] @ block (n + 2) body @@ -894,8 +921,14 @@ and sugar n (f : Form.t) : string list option = match c.v with | Form.List ({ v = Form.Sym r; _ } :: { v = Form.Vec ps; _ } :: (_ :: _ as b)) when def_name r -> + let report, b = + match b with + | { v = Form.Kw "report"; _ } :: ({ v = Form.Str _; _ } as t) :: (_ :: _ as rest) -> + (" " ^ fst (expr t), rest) + | _ -> ("", b) + in Option.map - (fun pt -> (i ^ "restart " ^ r ^ "(" ^ pt ^ ")") :: block (n + 2) b) + (fun pt -> (i ^ "restart " ^ r ^ "(" ^ pt ^ ")" ^ report) :: block (n + 2) b) (params_text ps) | _ -> None in @@ -1026,7 +1059,8 @@ and let_lines n prs body = (* [(let [x (the T v)])] is [let x: T = v]. *) let bind ((t : Form.t), (v : Form.t)) = match t.v, v.v with - | Form.Sym x, Form.List [ { v = Form.Sym "the"; _ }; ty_; w ] when def_name x -> + | Form.Sym x, Form.List [ { v = Form.Sym "the"; _ }; ty_; w ] + when def_name x && typed_lambda v = None -> ("let " ^ x ^ ": " ^ ty ty_, w) | _ -> ("let " ^ guard (at 8 t), v) in @@ -1063,11 +1097,11 @@ let program ?source ?macros:m (fs : Form.t list) : string = in let rec go = function | [] -> [] - | [ x ] -> [ top x ] - | x :: rest -> top (if let_sugar x then in_do x else x) :: go rest + | [ x ] -> [ (x, top x) ] + | x :: rest -> (x, top (if let_sugar x then in_do x else x)) :: go rest in let text = - try String.concat "\n\n" (go fs) ^ "\n" + try Source_text.join_top (go fs) ^ "\n" with e -> spelling := (fun _ -> None); inside := (fun _ -> false); raise e in spelling := (fun _ -> None); diff --git a/lib/indent_reader.ml b/lib/indent_reader.ml index 0b3be79e..d2e7e675 100644 --- a/lib/indent_reader.ml +++ b/lib/indent_reader.ml @@ -386,6 +386,9 @@ let layout ?(snippet = false) ?(base = 1) ?indent (toks : token list) : token ar type p = { toks : token array; mutable i : int } +(* Set below [params] and [ty], which the expression parser comes before. *) +let typed_fn_expr : (p -> Form.t * int) ref = ref (fun _ -> assert false) + let peek p = p.toks.(p.i) let peek_at p k = p.toks.(min (p.i + k) (Array.length p.toks - 1)) let advance p = @@ -785,6 +788,7 @@ and inline_stmt p : Form.t = (* [fn(a, b) = body] is a lambda; [fn(...)] followed by anything else is the fallback call spelling of [(fn ...)]. *) and fn_expr p = + if typed_lambda p then !typed_fn_expr p else let t = advance p in let lp = advance p in let args = items p RP lp.loc ~what:"parameters" in @@ -801,6 +805,21 @@ and fn_expr p = 0) | _ -> (mk p t.loc (Form.List (sym t.loc "fn" :: args)), 9) +(* Whether the [fn(] at point has a [:] among its parameters or a [->] + after them: a lambda that states its types. *) +and typed_lambda p = + let rec go k depth = + let t = peek_at p k in + match t.tok with + | EOF -> false + | COLON when depth = 1 -> true + | LP | LB | LC -> go (k + 1) (depth + 1) + | RP when depth = 1 -> (peek_at p (k + 1)).tok = NAME "->" + | RP | RB | RC -> go (k + 1) (depth - 1) + | _ -> go (k + 1) depth + in + go 1 0 + and span_of_list l args = match List.rev args with | [] -> l @@ -1068,6 +1087,49 @@ let params p (lp : token) = in go [] +(* [fn(a: C, b) -> R = body] is [(the (Fn [C dyn] R) (fn [a b] body))]: the + paren [fn] takes its parameters' types from where it is written, and [the] + is the form that says what a value is, as in [let x: T = v]. An untyped + parameter is dyn, as in a definition, and the return type is required. A + block body is added by [lambda_block]. *) +let () = typed_fn_expr := fun p -> + let t = advance p in + let lp = advance p in + let ps = params p lp in + let rec split = function + | n :: ty :: rest -> let ns, ts = split rest in (n :: ns, ty :: ts) + | _ -> ([], []) + in + let names, tys = split ps in + let r = + match (peek p).tok with + | NAME "->" -> ignore (advance p); ty p + | _ -> + failk "lambda-return" (where_ p) + "a lambda that states its parameters' types states its return type \ + too: fn(%s) -> R = value" + (String.concat ", " + (List.map2 (fun n (ty : Form.t) -> + if ty.v = Form.Sym "dyn" then text_of n else text_of n ^ ": " ^ text_of ty) + names tys)) + in + let fty = mk p lp.loc (Form.List [ sym t.loc "Fn"; Form.make (Form.Vec tys) lp.loc; r ]) in + let vec = Form.make (Form.Vec names) lp.loc in + let wrap body = + mk p t.loc (Form.List [ sym t.loc "the"; fty; + mk p t.loc (Form.List (sym t.loc "fn" :: vec :: body)) ]) + in + match (peek p).tok with + | NAME "=" -> + ignore (advance p); + let i0 = p.i and t0 = peek p in + let body, _ = expr p in + (wrap [ unit_slot p i0 t0 body ], 0) + | NEWLINE when (peek_at p 1).tok = INDENT -> (wrap [], 0) + | _ -> + failk "lambda-body" (where_ p) + "a lambda's body follows = on its line, or is the block under it" + let rec stmts (s : st) : Form.t list = let p = s.p in match (peek p).tok with @@ -1143,6 +1205,15 @@ and then_on_line p = and lambda_block ?(block_ok = false) (s : st) (e : Form.t) ~after = let p = s.p in + match e.v with + (* A typed lambda waiting for its block, from [typed_fn_expr]. *) + | Form.List [ ({ v = Form.Sym "the"; _ } as th); fty; + ({ v = Form.List [ ({ v = Form.Sym "fn"; _ } as fh); ({ v = Form.Vec _; _ } as vec) ]; _ } as fn_) ] + when (peek p).tok = NEWLINE && (peek_at p 1).tok = INDENT -> + ignore (advance p); + let body = block s ~after in + mk p e.loc (Form.List [ th; fty; { fn_ with v = Form.List (fh :: vec :: body) } ]) + | _ -> if is_lambda_candidate e && (last p).tok = RP && (peek p).tok = NEWLINE && (peek_at p 1).tok = INDENT then begin @@ -1216,11 +1287,9 @@ and stmt (s : st) : Form.t = | NAME w when header_follow p w -> header s w | NAME (("else" | "elif") as w) when one_line_if_above p t -> failk "orphan-else" t.loc - "the if above is a one-line if, which ends with its line, so this %s \ - has no if to belong to. Keep the one-line form on one line:\n\n\ - \ if c then a else b\n\n\ - or give each branch a block:\n\n\ - \ if c\n a\n else\n b" + "this %s is not at the column of the one-line if above it. An else or \ + elif that continues a one-line if goes at the if's column:\n\n\ + \ if c then a\n else b" w | NAME (("else" | "elif") as w) -> failk "orphan-else" t.loc @@ -1455,72 +1524,88 @@ and header (s : st) w : Form.t = form [ alias; path ] | "if" -> let c, _ = binary p 1 in + (* The elif and else clauses at the if's column, then the whole form. + [oneline] when the if was [if c then a]: its clauses may then be + one-line too, [elif c then x] and [else y], or take blocks. *) + let clauses ~oneline body = + let rec elifs acc = + match (peek p).tok with + | NAME "elif" -> + ignore (advance p); + let c, _ = binary p 1 in + (match (peek p).tok with + | NAME "then" when oneline -> + ignore (advance p); + let x = inline_stmt p in + expect_eol p ~after:(text_of x); + elifs ((c, [ x ]) :: acc) + | NAME "then" -> + failk "elif-then" (peek p).loc + "elif takes its block on the indented lines under it, with no \ + then. Put the branch on the next line, indented" + | _ -> + expect_line_end p ~after:("elif " ^ text_of c); + let b = block s ~after:"elif" in + elifs ((c, b) :: acc)) + | _ -> List.rev acc + in + let els_ = elifs [] in + let else_ = + match (peek p).tok with + | NAME "else" -> + let et = advance p in + (match (peek p).tok with + | NEWLINE -> ignore (advance p); Some (et.loc, block s ~after:"else") + | NAME "if" when not oneline -> + failk "else-if" (where_ p) + "else takes its block on the lines under it. For another test \ + at this level, write elif c" + | _ when oneline -> + let x = inline_stmt p in + expect_eol p ~after:(text_of x); + Some (et.loc, [ x ]) + | _ -> stray p ~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) + in (match (peek p).tok with | NAME "then" -> ignore (advance p); let a = inline_stmt p in - let f = - match (peek p).tok with - | NAME "else" -> - ignore (advance p); - let b = inline_stmt p in - form [ c; a; b ] - | NAME "elif" -> - failk "one-line-elif" (peek p).loc - "a one-line if has then and else and no elif. Chain another if \ - after the else — if a then x else if b then y else z — or write \ - the if over several lines, where elif goes" - | _ -> named "when" [ c; a ] - in - expect_eol p ~after:(text_of f); - f + (match (peek p).tok with + | NAME "else" -> + ignore (advance p); + let b = inline_stmt p in + let f = form [ c; a; b ] in + expect_eol p ~after:(text_of f); + f + | NAME "elif" -> + failk "one-line-elif" (peek p).loc + "a one-line if has then and else and no elif. Chain another if \ + after the else — if a then x else if b then y else z — or write \ + the if over several lines, where elif goes" + | _ -> + expect_eol p ~after:(text_of (named "when" [ c; a ])); + (* An else or elif on the next line, at the if's column, + continues it. *) + clauses ~oneline:true [ a ]) | _ -> expect_line_end p ~after:("if " ^ text_of c); let body = block s ~after:("if " ^ text_of c) in - let rec elifs acc = - match (peek p).tok with - | NAME "elif" -> - ignore (advance p); - let c, _ = binary p 1 in - (match (peek p).tok with - | NAME "then" -> - failk "elif-then" (peek p).loc - "elif takes its block on the indented lines under it, with no \ - then. Put the branch on the next line, indented" - | _ -> ()); - expect_line_end p ~after:("elif " ^ text_of c); - let b = block s ~after:"elif" in - elifs ((c, b) :: acc) - | _ -> List.rev acc - in - let els_ = elifs [] in - let else_ = - match (peek p).tok with - | NAME "else" -> - let et = advance p in - (match (peek p).tok with - | NEWLINE -> ignore (advance p) - | NAME "if" -> - failk "else-if" (where_ p) - "else takes its block on the lines under it. For another test \ - at this level, write elif c" - | _ -> stray p ~after:"else"); - Some (et.loc, block s ~after:"else") - | _ -> None - in - (match els_, else_ with - | [], None -> named "when" (c :: body) - | [], Some (el, e) -> form [ c; blk s l0 body; blk s el e ] - | _ -> - let pairs = - List.concat_map (fun (c, b) -> [ c; blk s c.Form.loc b ]) ((c, body) :: els_) - in - let tail = - match else_ with - | Some (el, e) -> [ Form.make (Form.Kw "else") el; blk s el e ] - | None -> [] - in - named "cond" (pairs @ tail))) + clauses ~oneline:false body) | "while" | "until" -> let label = match (peek p).tok, (peek_at p 1).tok with @@ -1639,10 +1724,19 @@ and header (s : st) w : Form.t = let name = name_tok p ~what:"the restart's name" in let lp = glued_lp p ~what:"the restart's parameters in parentheses" in let ps = params p lp in + (* [restart name() "text"]: the report the break loop shows, + [:report "text"] in the clause. *) + let report = + match (peek p).tok with + | ATOM (Form.Str _ as v) -> + let st = advance p in + [ Form.make (Form.Kw "report") st.loc; Form.make v st.loc ] + | _ -> [] + in clause_end p ("restart " ^ text_of name ^ "(...)"); let b = block s ~after:"restart" in let c = - mk p name.loc (Form.List (name :: Form.make (Form.Vec ps) lp.loc :: b)) + mk p name.loc (Form.List (name :: Form.make (Form.Vec ps) lp.loc :: (report @ b))) in clauses (c :: acc) | _ -> List.rev acc diff --git a/lib/paren_printer.ml b/lib/paren_printer.ml index 78df2da9..fd32ae83 100644 --- a/lib/paren_printer.ml +++ b/lib/paren_printer.ml @@ -327,13 +327,13 @@ let program ?source (fs : Form.t list) : string = cs in let text = - String.concat "\n\n" + Source_text.join_top (List.map (fun (f : Form.t) -> - String.concat "\n" - (match layout ~inside spell 0 f with - | first :: rest -> Source_text.tag f.loc.Loc.line first :: rest - | [] -> [])) + (f, String.concat "\n" + (match layout ~inside spell 0 f with + | first :: rest -> Source_text.tag f.loc.Loc.line first :: rest + | [] -> []))) fs) ^ "\n" in diff --git a/lib/source_text.ml b/lib/source_text.ml index e876f58f..16617d1a 100644 --- a/lib/source_text.ml +++ b/lib/source_text.ml @@ -206,3 +206,23 @@ let weave ?(starts = []) (cs : comment list) (text : string) : string = else s in trim s + +(** Top-level forms' printed texts joined with a blank line between them, + except that one-line globals written on adjacent lines stay adjacent. *) +let join_top (items : (Form.t * string) list) : string = + let global (f : Form.t) = + match f.v with + | Form.List ({ v = Form.Sym ("def" | "defonce" | "defconst"); _ } :: _) -> true + | _ -> false + in + let rec go = function + | [] -> [] + | [ (_, t) ] -> [ t ] + | ((a : Form.t), ta) :: (((b : Form.t), tb) :: _ as rest) -> + let tight = + global a && global b && (not (String.contains ta '\n')) + && (not (String.contains tb '\n')) && b.loc.Loc.line = a.loc.Loc.eline + 1 + in + ta :: (if tight then "\n" else "\n\n") :: go rest + in + String.concat "" (go items) diff --git a/lib/types.ml b/lib/types.ml index 37162cd5..7ba99ed4 100644 --- a/lib/types.ml +++ b/lib/types.ml @@ -229,6 +229,10 @@ let rec equal a b = and then only in how a message spells it. *) let display : (string, string) Hashtbl.t = Hashtbl.create 16 +(* The same copies as the template and its arguments, for [spell] to write + in either syntax. *) +let display_app : (string, string * t list) Hashtbl.t = Hashtbl.create 16 + (* A struct's name as a printed value's head: its own name, or for a generic struct's copy the template and its arguments, [Pair i32] — so a value prints as [(Pair i32 {.a 1 .b 2})], the way its type is written. *) @@ -238,7 +242,33 @@ let struct_head n = String.sub d 1 (String.length d - 2) | _ -> n -let rec to_string = function +(* A type as the code it is written in spells it: [(Fn [i32] bool)] in a + .flan file, [Fn(i32) -> bool] in a .fln one. Messages use it; a spelling + that is a key, a symbol or a runtime string stays [to_string]'s. *) +let rec spell ~indented t = + if not indented then to_string t + else + let sp = spell ~indented in + let call h args = h ^ "(" ^ String.concat ", " args ^ ")" in + match t with + | Named n -> + (match Hashtbl.find_opt display_app n with + | Some (g, args) -> call g (List.map sp args) + | None -> to_string t) + | Slice (Mut, t) -> "[" ^ sp t ^ "]" + | Slice (Const, t) -> "[const " ^ sp t ^ "]" + | Array (n, t) -> Printf.sprintf "[%Ld %s]" n (sp t) + | LArray (n, t) -> Printf.sprintf "[$%s %s]" n (sp t) + | Map (k, v) -> call "Map" [ sp k; sp v ] + | Ptr (Mut, t) -> call "Ptr" [ sp t ] + | Ptr (Const, t) -> call "Ptr" [ "const " ^ sp t ] + | Vec t -> call "Vec" [ sp t ] + | Option t -> call "Option" [ sp t ] + | Fn (ps, r) -> call "Fn" (List.map sp ps) ^ " -> " ^ sp r + | CFn (ps, r) -> call "CFn" (List.map sp ps) ^ " -> " ^ sp r + | _ -> to_string t + +and to_string = function | Int k -> ikind_name k | Float k -> fkind_name k | Bool -> "bool" diff --git a/spec-syntax.md b/spec-syntax.md index 22218f78..bb6bac9f 100644 --- a/spec-syntax.md +++ b/spec-syntax.md @@ -88,9 +88,10 @@ reads as `(rl/with-drawing (rl/clear-background rl/black) (game-draw))`. Replacing macros with built-in constructs is **not** part of this work. **Diagnostics may print paren syntax** during the test drive. `Form.to_string`, -`Types.to_string`, the usage strings in `parse.ml` and `check.ml`, and -`Render` all print parens today (inventory in section 5). Fixing that waits on -the author deciding to switch. +the usage strings in `parse.ml` and `check.ml`, and `Render` print parens +today (inventory in section 5). Types in `check.ml`'s messages do not: they +are spelled by `Types.spell`, in the syntax of the code the message is about +(section 3, item 9). ## 2. Proposed (confirm before building the piece it governs) @@ -201,7 +202,10 @@ Each item: the proposal, then the reason in one line. - **`if`/`elif`/`else`.** `else` and `elif` sit at the `if`'s column. No `elif` reads as `if` (with else) or `when` (without); with `elif` it reads as `cond`. One-line form: `if c then a else b`, for use in a `let`. **Built** (a block - of one line is that line; of more, `(do …)`). + of one line is that line; of more, `(do …)`). An `else` or `elif` on the + line after a one-line `if c then a`, at its column, continues it (section + 3, item 6); each such clause is one-line (`elif c then x`, `else y`) or + takes a block. - **`while c`, `until c`**, optional label first: `while :outer c`. **Built.** - **`for i in range(n)`**, `range(a, b)`, `range(a, b, step)` read as `dotimes`. `range` here is syntax, not a function. `..` is avoided because @@ -253,14 +257,17 @@ Each item: the proposal, then the reason in one line. v * 2 ``` `handler-bind` takes the same `on` clauses; the reader moves them in front of - the body, where the form wants them. **Built.** + the body, where the form wants them. **Built.** A restart's report text goes + on its header, `restart retry() "Try the load again"`, and reads + `(retry [] :report "Try the load again" …)`. - **Unit:** `()` as a statement reads `(do)`; in a type it is `()`. **Built**; inside an expression `()` stays `()`, and the printer writes a lone `()` statement as `(())`. A bare `()` in a one-line body slot (`fn f() -> () = ()`, `_ -> ()`, `fn() = ()`, `then ()`) is a statement too, and reads `(do)`. - **Lambda:** `fn(i, j) = i * 10 + j`, or `fn(i, j)` plus a block. **Built**; its parameters are bare names, as `(fn [i j] …)` wants, with no `dyn`. - `fn(…)` followed by anything else is the fallback call. + `fn(…)` followed by anything else is the fallback call. A lambda may state + its types, `fn(a: C, b) -> bool = …` or plus a block (section 3, item 7). ### Definitions @@ -274,10 +281,14 @@ Each item: the proposal, then the reason in one line. - `struct Cell` with a `name: Type` line per field. `data Shape` with a line per case: `Circle(r: f32)`, `Empty`. `enum K` with `lo = -1`, `mid`. `union U` like `struct`. **Built** (an untyped field is `dyn`; `Empty()` is `(Empty [])`). + A member is `:mid` or `K.mid`, in a value and in a match arm, in both + syntaxes (section 3, item 8). - `import rl "vendor:raylib"`. **Built.** - **Every other form uses the fallback** (next item) until someone asks for sugar: `defclass`, `defgeneric`, `defmulti`, `defmethod`, `declare`, `declare-c`, `defalias`, `defmacro`, `loop`/`recur`, `array-fill`. **Built.** + The class forms keep the fallback for good (2026-09-26): + `defmethod(area, point, [p]):` reads well enough. ### The fallback @@ -341,6 +352,27 @@ after it, so `~name(x)` is `((unquote name) x)`, and `~(f(x))` unquotes a call. omitted. `_` in type position means "fill this in" in Rust and OCaml too, and no type can be named `_`. +Settled 2026-09-26, after writing programs by hand (`test/syntax/handwritten/`): + +6. **A one-line if continues on the next line.** `if c then a` followed by + `else b` (or `elif c2 then d`, or either with a block) at the if's column + is one if. An `else` left of that column is refused. +7. **Typed lambdas.** `fn(a: C, b) -> R = body`, or plus a block, reads + `(the (Fn [C dyn] R) (fn [a b] body))`: the paren `fn` has no typed + parameters, and `the` is how a value states its type, as in + `let x: T = v`. An untyped parameter is `dyn`; the return type is + required. Where a `CFn` of the same signature is wanted, the literal is + that `CFn`. The printer writes that form back as the typed lambda. +8. **`Dir.north` is the enum member `:north`**, in a value and in a match + pattern, in both syntaxes. `:north` stays. +9. **Types in messages follow the code's syntax.** `Types.spell ~indented` is + the one printer, `Fn(A) -> R`, `Option(i32)`, `Small(4, i32)` for a .fln + location and `(Fn [A] R)` for a .flan one; `Types.to_string` stays the + spelling for keys, symbols and runtime strings. Hard-coded code in a hint + is written per message. +10. **`flan convert` keeps adjacent one-line globals adjacent**, in both + directions. + ## 4. Build order Each step lands on its own, with `dune test --root .` green. diff --git a/test/syntax/handwritten/csv.fln b/test/syntax/handwritten/csv.fln index 2c63edc6..bb1a54cb 100644 --- a/test/syntax/handwritten/csv.fln +++ b/test/syntax/handwritten/csv.fln @@ -26,7 +26,7 @@ fn flush(field: Ptr(Vec(u8)), row: Ptr(Vec(string))) -> () fn parse-line(line: [const u8]) -> Vec(string) let row = vec-new(string) let field = vec-new(u8) - let state: State = :start + let state = State.start for i in range(length(line)) let c = line[i] match state @@ -38,7 +38,7 @@ fn parse-line(line: [const u8]) -> Vec(string) else push(field, c) state = :bare - :bare -> + State.bare -> if c == separator flush(addr(field), addr(row)) state = :start diff --git a/test/syntax/handwritten/traffic.fln b/test/syntax/handwritten/traffic.fln index e0b56b23..efcf64fa 100644 --- a/test/syntax/handwritten/traffic.fln +++ b/test/syntax/handwritten/traffic.fln @@ -18,10 +18,8 @@ const red-time = 3 fn next(l: Light, pressed: bool) -> Light match l Green(left) -> - if left > 1 and not pressed - Light.Green{.left left - 1} - else - Light.Yellow{.left yellow-time, .walk pressed} + if left > 1 and not pressed then Light.Green{.left left - 1} + else Light.Yellow{.left yellow-time, .walk pressed} Yellow(left, walk) -> if left > 1 Light.Yellow{.left left - 1, .walk walk} @@ -53,9 +51,7 @@ fn run(ticks: i32, presses: [const i32], fault-at: i32) -> () l = restart-case error(Fault{.tick t}) l - restart reset() - :report - "Put the light back to red and carry on" + restart reset() "Put the light back to red and carry on" Light.Red{.left red-time, .walk false} restart flash() Light.Flashing{} diff --git a/test/syntax/handwritten/words.fln b/test/syntax/handwritten/words.fln index 65d3773f..e090d550 100644 --- a/test/syntax/handwritten/words.fln +++ b/test/syntax/handwritten/words.fln @@ -58,7 +58,7 @@ fn main() -> i32 let text = "The cat saw the dog. The dog didn't see the cat, but the bird saw both!" let ws = words(bytes-view(text)) let counts = tally(slice(ws)) - let by-count: Fn(Count, Count) -> bool = fn(a, b) + let by-count = fn(a: Count, b: Count) -> bool if a.n != b.n return a.n > b.n bytes ()\n push(v, 1\n g()" "indent/missing-comma" "If the ( on line 2 was meant to close"; - refuses "else under a one-line if" "if a then b\nelse c" - "indent/orphan-else" "one-line if"; + reads "else on the line after a one-line if" "if a then b\nelse c" "(if a b c)"; + reads "elif and else continuing a one-line if" + "if a then b\nelif c then d\nelif e\n f()\n g()\nelse\n h()" + "(cond a b c d e (do (f) (g)) :else (h))"; + refuses "else left of a one-line if" "while x\n if a then b\nelse c" + "indent/orphan-else" "goes at the if's column"; + reads "a typed lambda" "f = fn(a: C, b) -> bool = a.n < b" + "(set f (the (Fn [C dyn] bool) (fn [a b] (< (.n a) b))))"; + reads "a typed lambda with a block" "let f = fn(x: i32) -> i32\n let y = x + 1\n y\ng(f)" + "(let [f (the (Fn [i32] i32) (fn [x] (let [y (+ x 1)] y)))] (g f))"; + refuses "a typed lambda states its return type" "f = fn(a: C) = a" + "indent/lambda-return" "fn(a: C) -> R = value"; + reads "a restart's report on its header" + "restart-case\n go()\nrestart retry(n: i32) \"Try again\"\n n" + "(restart-case (go) (retry [n i32] :report \"Try again\" n))"; reads "a bare () in a body slot does nothing" "fn f() -> () = ()\nfn g(x) -> ()\n match x\n 1 -> h()\n _ -> ()\n k = fn() = ()" "(defn f [] () (do))\n(defn g [x dyn] () (match x 1 (h) _ (do)) (set k (fn [] (do))))"; @@ -763,6 +776,18 @@ let () = "(defn f [] () (if (> a 1) (let [k 2] (g k))))" " if(a > 1):\n let k = 2"; prints "and inside or keeps its parentheses" "(defn f [a bool b bool c bool] bool (or (and a b) c))" "= (a and b) or c"; + prints "a typed lambda prints as one" + "(defn f [] () (let [g (the (Fn [C] bool) (fn [c] (> (.n c) 3)))] (h g)))" + "let g = fn(c: C) -> bool = c.n > 3"; + prints "a restart's report goes on its header" + "(defn f [] i32 (restart-case (go) (retry [] :report \"Try again\" 7)))" + "restart retry() \"Try again\"\n 7"; + prints "adjacent one-line globals stay adjacent" + "(defonce a i32)\n(def b i32 2)\n\n(defconst c 3)\n" + "once a: i32\ndef b: i32 = 2\n\nconst c = 3"; + back "adjacent one-line globals stay adjacent in parens" + "once a: i32\ndef b: i32 = 2\n\nconst c = 3\n" + "(defonce a i32)\n(def b i32 2)\n\n(defconst c 3)"; prints "a field of a field chains" "(defn f [] () (g (.count (.x w))))" "g(w.x.count)"; prints "an else-if chain on one line" "(defn f [r] dyn (if (> r 7) :rich (if (> r 4) :fair :poor)))" @@ -983,6 +1008,31 @@ let () = [ "write ++(x) or x += 1" ]; refused "plusplus-global.fln" "once g = 0\n\nfn main() -> i32\n g--\n 0\n" [ "write --(g) or g -= 1" ]; + (* Types in a message are in the syntax of the code it is about. *) + refused "types.fln" "fn g(x: Option(i32)) -> i32 = 0\n\nfn main() -> i32\n let v = vec-new(i32)\n g(v)\n" + [ "expected Option(i32), found Vec(i32)" ]; + refused "types.flan" "(defn g [x (Option i32)] i32 0)\n(defn main [] i32 (let [v (vec-new i32)] (g v)))\n" + [ "expected (Option i32), found (Vec i32)" ]; + refused "fn-field.fln" "struct R\n f: Fn(i32) -> bool\n\nfn main() -> i32 = 0\n" + [ "cannot be Fn(i32) -> bool"; "store a CFn(i32) -> bool" ]; + refused "generic-struct.fln" + "struct Small\n items: [$n $t]\n\nfn main() -> i32\n let s: Small(4, i32) = zeroed()\n let q: i32 = s\n 0\n" + [ "found Small(4, i32)" ]; + (* Dir.north is the member :north. *) + checks "enum-qualified.fln" + ("enum Dir\n north\n south\n\nfn name(d: Dir) -> i32\n match d\n Dir.north -> 1\n :south -> 2\n\n" + ^ "fn main() -> i32\n let d = Dir.north\n let e: Dir = Dir.south\n name(d) + name(e)\n"); + refused "enum-qualified-miss.fln" + "enum Dir\n north\n\nfn f(d: Dir) -> i32\n match d\n Dir.west -> 1\n _ -> 0\n\nfn main() -> i32 = 0\n" + [ "Dir has no member west — it has Dir.north" ]; + (* A bad key type is one error, not three. *) + refused "map-key.fln" "fn main() -> i32\n let m = map-new([const u8], i32)\n 0\n" + [ "[const u8] is not a map key" ]; + (match Front.checked (Filename.concat scratch "map-key.fln") with + | exception Loc.Errors (_ :: _ :: _ as ds) -> + fail "map-key.fln: %d errors, wanted one" (List.length ds) + | exception _ -> () + | _ -> ()); refused "defvar.fln" "defvar(x, 1)\n\nfn main() -> i32 = 0\n" [ "once x = 1 initialises once"; "def x = 1 re-initialises" ] From 6c323835391a148afa490218b41f4b6381b0a546 Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Sat, 26 Sep 2026 00:36:21 +0700 Subject: [PATCH 6/6] Typed lambdas bind a generic's CFn variables, a local shadows an enum of its name, the lambda-in-brackets fix is the typed let that compiles, an else deeper than a one-line if or after else-if is refused by name, a block if takes a one-line else, and messages spell every type in the code's syntax --- lib/check.ml | 106 +++++++++++++++++++++---------- lib/indent_reader.ml | 84 ++++++++++++++++++++---- spec-syntax.md | 25 +++++++- test/syntax/handwritten/ring.fln | 10 +++ test/syntax/handwritten/ring.out | 1 + test/test_syntax.ml | 48 +++++++++++++- 6 files changed, 226 insertions(+), 48 deletions(-) diff --git a/lib/check.ml b/lib/check.ml index 24416ca7..a23f2e83 100644 --- a/lib/check.ml +++ b/lib/check.ml @@ -1165,6 +1165,21 @@ let one_edit a b = else ta a (!i + 1) = ta b !i end +(* Whether [got] could be [want] once [want]'s type variables are bound: + the same shape, a variable matching anything. Binding them consistently is + the generic call's business; this only says a literal may take the shape. *) +let rec fits_shape (want : Types.t) (got : Types.t) = + match want, got with + | Types.Var _, _ -> true + | Types.Fn (ps, r), Types.Fn (qs, s) | Types.CFn (ps, r), Types.CFn (qs, s) -> + List.length ps = List.length qs && List.for_all2 fits_shape ps qs && fits_shape r s + | Types.Slice (a, x), Types.Slice (b, y) | Types.Ptr (a, x), Types.Ptr (b, y) -> + a = b && fits_shape x y + | Types.Vec x, Types.Vec y | Types.Option x, Types.Option y -> fits_shape x y + | Types.Array (n, x), Types.Array (m, y) -> n = m && fits_shape x y + | Types.Map (k, v), Types.Map (k', v') -> fits_shape k k' && fits_shape v v' + | _ -> Types.equal want got + (* [Dir.north] as the enum and the member's value, when [Dir] is an enum with a member [north]. *) let enum_member env name = @@ -1527,10 +1542,10 @@ let struct_app g args = let finite_from env name0 = let rec walk seen name = if List.mem name seen then - (let shown = Types.to_string (Types.Named name) in - fail (Option.value (Hashtbl.find_opt env.locs name) ~default:Loc.unknown) - "%s contains itself by value, so it has no size — go through (Ptr %s)" - shown shown); + (let l = Option.value (Hashtbl.find_opt env.locs name) ~default:Loc.unknown in + fail l "%s contains itself by value, so it has no size — go through %s" + (tyname l (Types.Named name)) + (tyname l (Types.Ptr (Types.Mut, Types.Named name)))); let seen = name :: seen in match Hashtbl.find_opt env.structs name with | Some s -> List.iter (fun (f : Tast.field) -> ty seen f.Tast.fty) s.Tast.fields @@ -1739,7 +1754,7 @@ and struct_len_arg env name p (a : Ast.texpr) = (match List.assoc_opt bare env.subst with | Some (Types.Len _ as l) -> l | Some (Types.Var v) -> Types.Var v - | Some t -> not_one ("the type " ^ Types.to_string t) + | Some t -> not_one ("the type " ^ tyname a.Ast.tloc t) | None -> if List.mem bare env.lenvars then Types.Var bare else if List.mem bare env.tyvars then not_one "a type variable" @@ -2301,7 +2316,7 @@ let rec slot_of env ~classes cls fname (t : Ast.texpr) : slot_ty = (match resolve env t with | Types.Dyn -> Sany | (Types.Bool | Types.Int _ | Types.Float _ | Types.String) as t -> Sval t - | other -> refuse (Types.to_string other)) + | other -> refuse (tyname t.Ast.tloc other)) (* The type's word in the string the runtime reads: the scalar type's name, [#name] for a class, [?] in front for an Option. See [slot_type_of] in @@ -3154,7 +3169,7 @@ let clone_accepts env (t : Types.t) = the elements themselves into a second container would copy their headers and share their blocks, so the advice is a copy of each element where clone takes one, and otherwise that there is no copy to make. *) -let insert_copies env (t : Types.t) = +let insert_copies ?(loc = Loc.unknown) env (t : Types.t) = let elem = match t with | Types.Vec e | Types.Slice (_, e) | Types.Map (_, e) -> Some e @@ -3167,7 +3182,7 @@ let insert_copies env (t : Types.t) = Printf.sprintf "Nothing copies what a %s owns either, so read the elements where they \ are" - (Types.to_string e) + (tyname loc e) | None -> "Build a second container and insert into it" (* A call written back out as source, for a fix that has to repeat what the @@ -3949,8 +3964,8 @@ let refuse_frame_escapes (f : Tast.fn) = | _, _, `Addr, _ -> let pointee = match e.Tast.ty with - | Types.Ptr (_, t) -> Types.to_string t - | t -> Types.to_string t + | Types.Ptr (_, t) -> tyname e.Tast.loc t + | t -> tyname e.Tast.loc t in fix_addr pointee in @@ -6252,8 +6267,15 @@ and var ctx ?(qualified = false) loc ~want name = (* [Dir.north]: an enum's member named through its type, as a data case is [Shape.Rect]; the same value as [:north] where a Dir is expected. *) | _ when lookup ctx name = None && enum_member ctx.env name <> None -> - let e, v = Option.get (enum_member ctx.env name) in - expect ctx loc ~want (mk loc (Types.Enum e) (Tast.Int (v, Types.I32))) + let head = String.sub name 0 (String.rindex name '.') in + let field = String.sub name (String.length head + 1) (String.length name - String.length head - 1) in + (* A local named like the enum shadows it, as a local shadows any + global: [Dir.north] is then that local's field. *) + if lookup ctx head <> None then + check ctx ?want { Ast.e = Ast.Field ({ Ast.e = Ast.Var head; loc }, field); loc } + else + let e, v = Option.get (enum_member ctx.env name) in + expect ctx loc ~want (mk loc (Types.Enum e) (Tast.Int (v, Types.I32))) | "None" -> (match want with | Some (Types.Option t) -> mk loc (Types.Option t) Tast.None_ @@ -6542,12 +6564,11 @@ and check_fn ctx ~want ?gen loc (params : string list) body = if bare && fctx.caught <> [] then begin let names = List.map fst fctx.caught in Loc.failk "check/cfn-captures" loc - "this fn captures %s, so it is a (Fn [%s] %s) and not a (CFn [%s] \ - %s): a CFn is the bare address, one word, with nowhere for the \ - copies to live. Widen the position to Fn, or pass %s in as a parameter" + "this fn captures %s, so it is a %s and not a %s: a CFn is the bare \ + address, one word, with nowhere for the copies to live. Widen the \ + position to Fn, or pass %s in as a parameter" (String.concat ", " names) - (String.concat " " (List.map (tyname loc) pts)) (tyname loc ret) - (String.concat " " (List.map (tyname loc) pts)) (tyname loc ret) + (tyname loc (Types.Fn (pts, ret))) (tyname loc (Types.CFn (pts, ret))) (match names with [ n ] -> n | _ -> "them") end; (* An [Fn]-position literal declares the environment whether or not it @@ -8459,7 +8480,7 @@ and mixed_refusal : 'a. ctx -> Ast.expr list -> Loc.diag -> 'a = (match want with | Some t when not (Types.fits ~expected:t ~actual:v.Tast.ty) -> fail i.Ast.loc "this array's elements are %s, but this one is %s" - (Types.to_string t) (Types.to_string v.Tast.ty) + (tyname i.Ast.loc t) (tyname i.Ast.loc v.Tast.ty) | _ -> ()) | exception Loc.Error e when e.Loc.dloc = i.Ast.loc && want <> None -> raise @@ -8471,7 +8492,7 @@ and mixed_refusal : 'a. ctx -> Ast.expr list -> Loc.diag -> 'a = (Printf.sprintf "this array's first element is %s, so every \ element is" - (Types.to_string first.Tast.ty)) ] })) + (tyname first.Tast.loc first.Tast.ty)) ] })) rest; raise (Loc.Error d) @@ -8620,8 +8641,12 @@ and check_the ctx ~want loc (t : Ast.texpr) (v : Ast.expr) = literal is that CFn, as an untyped one would be. *) let ty = match ty, v.Ast.e, want with - | Types.Fn (ps, r), Ast.Fn _, Some (Types.CFn (ps', r') as c) - when Types.equal (Types.Fn (ps, r)) (Types.Fn (ps', r')) -> c + | Types.Fn (ps, r), Ast.Fn _, Some (Types.CFn (ps', r')) + when List.length ps = List.length ps' + && fits_shape (Types.Fn (ps', r')) (Types.Fn (ps, r)) -> + (* A generic's [CFn($t) -> $t] binds [$t] from the literal's own + types, as it would from any other argument's. *) + Types.CFn (ps, r) | _ -> ty in let is_nil = match v.Ast.e with Ast.Var "nil" -> true | _ -> false in @@ -9572,11 +9597,11 @@ and struct_target ctx (target : Ast.expr) : Tast.expr * string = fail target.Ast.loc "%s is %s — the pattern bound it to %s, so the value is already \ in hand and there is no field left to read" - n (Types.to_string other) w + n (tyname target.Ast.loc other) w | _ -> ()) | _ -> ()); fail target.Ast.loc "%s is not a struct, so it has no fields" - (Types.to_string other) + (tyname target.Ast.loc other) (* (at s i) reads a string's byte, and reading is the whole of what a string does here: it is a view of bytes the program does not own — a literal's @@ -11647,7 +11672,7 @@ and named_call ?(qualified = false) ctx ~want loc name args = "%s cannot be cloned — its elements own storage, and nothing here \ can walk one to copy what it owns. %s" (tyname loc target.Tast.ty) - (insert_copies ctx.env target.Tast.ty) + (insert_copies ~loc:target.Tast.loc ctx.env target.Tast.ty) (* A slice's elements, copied into a block from the allocator and answered as a slice over it — what (bytes s) does for a string's bytes, and the same lowering. The same refusal as a Vec's, for the @@ -11657,7 +11682,7 @@ and named_call ?(qualified = false) ctx ~want loc name args = "%s cannot be cloned — its elements own storage, and nothing here \ can walk one to copy what it owns. %s" (tyname loc target.Tast.ty) - (insert_copies ctx.env target.Tast.ty) + (insert_copies ~loc:target.Tast.loc ctx.env target.Tast.ty) (* The copy is a block from an allocator, which the collector does not walk, so a dyn in it would be a root nothing marks. *) | Types.Slice (_, elem) when holds_dyn ctx.env elem -> @@ -13576,8 +13601,22 @@ and generic_call ctx ~want loc name vars pats pret args = when not (open_ty p || bound_exactly v) -> Some v | _ -> None in + (* A typed .fln lambda, [(the (Fn [i32] i32) (fn ...))], at a + [CFn($t) -> $t] parameter: the literal is a CFn at its own types, + and those bind [$t] below as any argument's type would. *) + let typed_cfn = + match p, a.Ast.e with + | Types.CFn _, Ast.The (t, { Ast.e = Ast.Fn _; _ }) -> + (match resolve ctx.env t with + | Types.Fn (ps, r) when fits_shape p (Types.CFn (ps, r)) -> + Some (Types.CFn (ps, r)) + | _ -> None + | exception Loc.Error _ -> None) + | _ -> None + in let a = - if open_ty p || bound_view <> None then check ctx a + if typed_cfn <> None then check ctx ~want:(Option.get typed_cfn) a + else if open_ty p || bound_view <> None then check ctx a else if bound_scalar <> None && not untyped_literal then (* On its own terms first. A form that has no type without a want — [(zeroed)] is the one that matters — refuses here and is @@ -15555,7 +15594,7 @@ let rec check_fn ?sign env (fn : Ast.fn) : Tast.fn = | [] -> if Types.equal ret Types.Unit || ret == infer_ret then [] else fail fn.Ast.nloc "%s returns %s but has no body" fn.Ast.name - (Types.to_string ret) + (tyname fn.Ast.nloc ret) | body -> (* The last form is the return value, unless the function returns Unit, in which case whatever it evaluates to is discarded. *) @@ -15812,11 +15851,11 @@ and read_return env (fn : Ast.fn) params = (match List.find_opt unit arrive, List.find_opt (fun x -> not (unit x)) arrive with | Some (_, bare, _), Some (t, valued, _) -> Loc.failk "check/infer-mixed" bare - ~notes:[ Loc.note valued ("this gives " ^ Types.to_string t) ] + ~notes:[ Loc.note valued ("this gives " ^ tyname valued t) ] "%s gives no value here and %s on another path, and its return \ type is read off its body. Give this path a value too, or write \ the return type" - fn.Ast.name (Types.to_string t) + fn.Ast.name (tyname bare t) | _ -> ()); match arrive with | [] -> (Types.Unit, fn.Ast.nloc) @@ -16370,7 +16409,7 @@ let check_global env (d : Ast.decl) : Tast.global option = fail d.Ast.dloc "%s is a data type, and uninit on one is refused. Drop the \ uninit — a zeroed %s is %s" - (Types.to_string ty) un + (tyname d.Ast.dloc ty) un (match Hashtbl.find_opt env.datas un with | Some { Tast.cases = c :: _; _ } -> un ^ "." ^ c.Tast.vname | _ -> "its first case") @@ -16469,11 +16508,12 @@ let check_main env decls = if not ok_params then fail at "main takes no parameters or one [string], not (%s)" - (String.concat " " (List.map Types.to_string params)); + (String.concat (if Source.indented_at at then ", " else " ") + (List.map (tyname at) params)); if not (Types.equal ret Types.Unit || Types.equal ret (Types.Int Types.I32)) then fail at "main returns i32 or nothing, not %s" - (Types.to_string ret) + (tyname at ret) (* The environment as well as the program. A session needs it to check an expression typed at a REPL against the program the process is running — and @@ -17017,7 +17057,7 @@ let dyn_descriptors (p : Tast.program) = "%s of %s (the C symbol %s) is %s, and a dyn is reachable through \ it. %s, so the collector cannot mark that word and will free what \ it names — pass the fields across at written types instead" - what e.Tast.ename e.Tast.esym (Types.to_string t) why + what e.Tast.ename e.Tast.esym (tyname e.Tast.eloc t) why in (* One level in, because that level is the compiler's own: what a foreign parameter of pointer or slice type receives is the address diff --git a/lib/indent_reader.ml b/lib/indent_reader.ml index 02ddd75c..4aaa75f0 100644 --- a/lib/indent_reader.ml +++ b/lib/indent_reader.ml @@ -805,6 +805,18 @@ and fn_expr p = 0) | _ -> (mk p t.loc (Form.List (sym t.loc "fn" :: args)), 9) +(* A lambda with a block written inside a call's brackets, where no block can + open. The fix shown is the typed form, since a lambda bound by [let] has + no call to take its types from; [header] is [fn(a: T) -> R] or the + header as written. *) +and lambda_in_brackets : 'a. Loc.t -> string -> 'a = fun at header -> + failk "lambda-block-in-brackets" at + "a lambda's block cannot go inside brackets, where a line break is only \ + a space. Name it first, with its types and the block under it:\n\n\ + \ let f = %s\n ...\n\n\ + and pass f, or write it on one line: %s = value" + header header + (* Whether the [fn(] at point has a [:] among its parameters or a [->] after them: a lambda that states its types. *) and typed_lambda p = @@ -867,12 +879,13 @@ and items p closer open_loc ~what = | _ -> false in if block_lambda then - failk "lambda-block-in-brackets" n.loc - "a lambda's block cannot go inside brackets, where a line break \ - is only a space. Name it first, with the block under it:\n\n\ - \ let f = %s\n ...\n\n\ - and pass f, or write it on one line: %s = value" - (text_of e) (text_of e) + let names = + match e.v with + | Form.List (_ :: ps) -> List.map text_of ps + | _ -> [] + in + lambda_in_brackets n.loc + ("fn(" ^ String.concat ", " (List.map (fun x -> x ^ ": T") names) ^ ") -> R") else if starts_value n.tok && n.sp && not (negative_literal n.tok) && n.loc.Loc.line > e.loc.Loc.eline then (* Most often the bracket was never closed: the next statement @@ -998,6 +1011,28 @@ let one_line_if_above p (t : token) = | NAME "if" :: rest -> List.mem (NAME "then") rest && not (List.mem (NAME "else") rest) | _ -> false) +(* Whether the code line before [t] is [else if c then a]: that else took + the one-line if as its value, and an else under it has no if left. *) +let else_if_above p (t : token) = + let layout = function NEWLINE | INDENT | DEDENT -> true | _ -> false in + let rec prev j = + if j < 0 then None + else + let u = p.toks.(j) in + if u.loc.Loc.line < t.loc.Loc.line && not (layout u.tok) then Some u.loc.Loc.line + else prev (j - 1) + in + match prev (p.i - 1) with + | None -> false + | Some l -> + let rec first j = + if j <= 0 || p.toks.(j - 1).loc.Loc.line < l then j else first (j - 1) + in + let j = first (p.i - 1) in + let j = if layout p.toks.(j).tok then j + 1 else j in + j + 1 < Array.length p.toks + && p.toks.(j).tok = NAME "else" && p.toks.(j + 1).tok = NAME "if" + (* A block of several lines is a [do] spanning its lines, from the first statement to the end of the last — not from the header above it, which is another form's. *) @@ -1126,6 +1161,17 @@ let () = typed_fn_expr := fun p -> let body, _ = expr p in (wrap [ unit_slot p i0 t0 body ], 0) | NEWLINE when (peek_at p 1).tok = INDENT -> (wrap [], 0) + (* Inside brackets a line break is no token: the next line's first token + is what follows. *) + | tk when (peek p).loc.Loc.line > (last p).loc.Loc.eline && tk <> EOF -> + let header = + "fn(" ^ String.concat ", " + (List.map2 (fun n (ty : Form.t) -> + if ty.v = Form.Sym "dyn" then text_of n else text_of n ^ ": " ^ text_of ty) + names tys) + ^ ") -> " ^ text_of r + in + lambda_in_brackets (peek p).loc header | _ -> failk "lambda-body" (where_ p) "a lambda's body follows = on its line, or is the block under it" @@ -1285,6 +1331,12 @@ and stmt (s : st) : Form.t = let t = peek p in match t.tok with | NAME w when header_follow p w -> header s w + | NAME (("else" | "elif") as w) when else_if_above p t -> + failk "orphan-else" t.loc + "the else above took the one-line if after it as its value, so this %s \ + has no if to belong to. Write that line as elif:\n\n\ + \ if a then x\n elif b then y\n else z" + w | NAME (("else" | "elif") as w) when one_line_if_above p t -> failk "orphan-else" t.loc "this %s is not at the column of the one-line if above it. An else or \ @@ -1554,13 +1606,13 @@ and header (s : st) w : Form.t = | NEWLINE -> ignore (advance p); Some (et.loc, block s ~after:"else") | NAME "if" when not oneline -> failk "else-if" (where_ p) - "else takes its block on the lines under it. For another test \ - at this level, write elif c" - | _ when oneline -> + "after an if with a block, another test at this level is \ + written elif c, with its own block" + (* [else x] on one line, after a one-line if or a block. *) + | _ -> let x = inline_stmt p in expect_eol p ~after:(text_of x); - Some (et.loc, [ x ]) - | _ -> stray p ~after:"else") + Some (et.loc, [ x ])) | _ -> None in match els_, else_ with @@ -1594,6 +1646,16 @@ and header (s : st) w : Form.t = after the else — if a then x else if b then y else z — or write \ the if over several lines, where elif goes" | _ -> + (* An else or elif indented under the one-line if: it continues + that if only at the if's own column. *) + (match (peek p).tok, (peek_at p 1).tok, (peek_at p 2).tok with + | NEWLINE, INDENT, NAME (("else" | "elif") as w) -> + failk "else-column" (peek_at p 2).loc + "this %s is indented deeper than the one-line if it continues. \ + Put it at the if's column:\n\n\ + \ if c then a\n %s ..." + w w + | _ -> ()); expect_eol p ~after:(text_of (named "when" [ c; a ])); (* An else or elif on the next line, at the if's column, continues it. *) diff --git a/spec-syntax.md b/spec-syntax.md index f420a8e7..0416c89a 100644 --- a/spec-syntax.md +++ b/spec-syntax.md @@ -361,15 +361,34 @@ Settled 2026-09-26, after writing programs by hand (`test/syntax/handwritten/`): 6. **A one-line if continues on the next line.** `if c then a` followed by `else b` (or `elif c2 then d`, or either with a block) at the if's column - is one if. An `else` left of that column is refused. + is one if. An `else` left of that column, or indented deeper, is refused. + After an if with a block, `else x` on one line is accepted too. + **Binding:** an `else` or `elif` on a line of its own belongs to the if + that starts at its column. An if inside a one-line slot (after `then`, + after `else`, in an arm) ends with its line and takes no later clause, so + + ``` + if a then x + else if b then y + else z + ``` + + is refused at its last line: the first `else` took `if b then y` as its + value, and the chain is `if a then x else if b then y else z` on one line, + or `elif b then y` on the second. 7. **Typed lambdas.** `fn(a: C, b) -> R = body`, or plus a block, reads `(the (Fn [C dyn] R) (fn [a b] body))`: the paren `fn` has no typed parameters, and `the` is how a value states its type, as in `let x: T = v`. An untyped parameter is `dyn`; the return type is required. Where a `CFn` of the same signature is wanted, the literal is - that `CFn`. The printer writes that form back as the typed lambda. + that `CFn`; at a generic's `CFn($t) -> $t` parameter the literal is a + `CFn` at its own types, which bind `$t` as any argument's would. The + printer writes that form back as the typed lambda. A block lambda cannot + sit inside a call's brackets; the refusal shows the typed `let` form to + bind it with. 8. **`Dir.north` is the enum member `:north`**, in a value and in a match - pattern, in both syntaxes. `:north` stays. + pattern, in both syntaxes. `:north` stays. A local named `Dir` shadows the + enum as a local shadows any global: `Dir.north` is then its field. 9. **Types in messages follow the code's syntax.** `Types.spell ~indented` is the one printer, `Fn(A) -> R`, `Option(i32)`, `Small(4, i32)` for a .fln location and `(Fn [A] R)` for a .flan one; `Types.to_string` stays the diff --git a/test/syntax/handwritten/ring.fln b/test/syntax/handwritten/ring.fln index 88940780..bc80797c 100644 --- a/test/syntax/handwritten/ring.fln +++ b/test/syntax/handwritten/ring.fln @@ -53,6 +53,15 @@ fn checksum(p: Ptr(u8), size: i64) -> u32 h = h * 16777619 h +; Apply f n times, for any element type. +fn repeat-apply(f: CFn($t) -> $t, x: $t, n: i32) -> $t + let v = x + for i in range(n) + v = f(v) + v + +fn halve-all(x: $t) -> $t where numeric?($t) = repeat-apply(fn(a: $t) -> $t = a / 2, x, 3) + fn main() -> i32 let r: Ring(5, i32) = zeroed() let samples = [7 3 9 3 12 5 3 8] @@ -82,4 +91,5 @@ fn main() -> i32 let raw: [4 u32] = [1 2 3 4] let p = Ptr(u8)(addr(raw[0])) println("checksum", checksum(p, 16)) + println("doubled", repeat-apply(fn(a: i32) -> i32 = a * 2, 1, 10), "halved", halve-all(800.0)) 0 diff --git a/test/syntax/handwritten/ring.out b/test/syntax/handwritten/ring.out index 68cae26e..df34a718 100644 --- a/test/syntax/handwritten/ring.out +++ b/test/syntax/handwritten/ring.out @@ -7,3 +7,4 @@ sensor 1 15 sensor 3 22 sensor 2 40 checksum 1041505217 +doubled 1024 halved 100 diff --git a/test/test_syntax.ml b/test/test_syntax.ml index ac8a215c..1b3843a1 100644 --- a/test/test_syntax.ml +++ b/test/test_syntax.ml @@ -593,7 +593,15 @@ let () = refuses "field with a colon" "p = P{x: 1}" "indent/brace-field" "no colon"; refuses "a dotted range" "for i in 0..10\n g(i)" "indent/dot-range" "range(0, 10)"; refuses "a block lambda inside a call" "sort-by(xs, fn(a, b)\n a < b)" - "indent/lambda-block-in-brackets" "let f = fn(a, b)"; + "indent/lambda-block-in-brackets" "let f = fn(a: T, b: T) -> R"; + refuses "a typed block lambda inside a call" "sort-by(xs, fn(a: C, b: C) -> bool\n a < b)" + "indent/lambda-block-in-brackets" "let f = fn(a: C, b: C) -> bool"; + refuses "an else after else-if on one line" "if a then x\nelse if b then y\nelse z" + "indent/orphan-else" "Write that line as elif"; + refuses "else deeper than a one-line if" "if a then b\n else c" + "indent/else-column" "Put it at the if's column"; + reads "a one-line else after an if with a block" "if a\n b()\n c()\nelse d()" + "(if a (do (b) (c)) (d))"; refuses "an unclosed call swallows the next line" "fn f() -> ()\n push(v, 1\n g()" "indent/missing-comma" "If the ( on line 2 was meant to close"; reads "else on the line after a one-line if" "if a then b\nelse c" "(if a b c)"; @@ -1037,6 +1045,26 @@ let () = fail "map-key.fln: %d errors, wanted one" (List.length ds) | exception _ -> () | _ -> ()); + (* The fix the lambda-in-brackets refusal shows compiles, with its + placeholders filled in. *) + (match read "sort-by(xs, fn(a, b)\n a.n < b.n)" with + | _ -> fail "lambda in brackets: read" + | exception Loc.Error d -> + let header = + let m = d.Loc.dmsg in + let i = String.index m '=' + 2 in + String.sub m i (String.index_from m i '\n' - i) + in + let header = + String.concat "C" (String.split_on_char 'T' header) + |> String.split_on_char 'R' |> String.concat "bool" + in + checks "lambda-fix.fln" + ("struct C\n n: i32\n\nfn main() -> i32\n let xs = [C{.n 2} C{.n 1}]\n" + ^ " let f = " ^ header ^ "\n a.n < b.n\n sort-by(slice(xs), f)\n xs[0].n\n")); + refused "cfn-captures.fln" + "fn app(f: CFn(Option(i32)) -> i32) -> i32 = f(None)\n\nfn main() -> i32\n let k = 1\n app(fn(o) = k)\n" + [ "so it is a Fn(Option(i32)) -> i32 and not a CFn(Option(i32)) -> i32" ]; refused "defvar.fln" "defvar(x, 1)\n\nfn main() -> i32 = 0\n" [ "once x = 1 initialises once"; "def x = 1 re-initialises" ] @@ -1169,4 +1197,22 @@ let () = end else print_endline "syntax: no clang, the import programs are not built" +let () = + (* A local named like an enum shadows it. *) + List.iter + (fun (name, text) -> + let f = Filename.concat scratch name in + write f text; + match Test_support.linked f with + | exception e -> fail "%s: %s" name (diag_text e) + | _ -> run_both f "5 true\n") + (if Test_support.have "clang" then + [ ("shadow-enum.fln", + "enum Dir\n north\n south\n\nstruct P\n north: i32\n\nfn main() -> i32\n" + ^ " let a = Dir.north\n let Dir = P{.north 5}\n println(Dir.north, a == :north)\n 0\n"); + ("shadow-enum.flan", + "(defenum Dir [north south])\n(defstruct P [north i32])\n(defn main [] i32 " + ^ "(let [a Dir.north Dir (P {.north 5})] (println Dir.north (= a :north)) 0))\n") ] + else []) + let () = Test_support.report ~label:"syntax" ()