Hand-written .fln programs exist, flan convert writes corpus-shaped paren text, and several .fln diagnostics suggest .fln spellings
This commit is contained in:
parent
c1beb602a7
commit
8fe8062a0c
@ -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
|
(* Core forms whose trailing arguments are a body run in order, and how many
|
||||||
arguments come before it. *)
|
arguments come before it. *)
|
||||||
let core = [ ("do", 0); ("let", 1); ("fn", 1); ("when", 1); ("while", 1); ("loop", 1);
|
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 =
|
let body_start (t : t) h =
|
||||||
match List.assoc_opt h core with Some k -> Some k | None -> Hashtbl.find_opt t.bodies h
|
match List.assoc_opt h core with Some k -> Some k | None -> Hashtbl.find_opt t.bodies h
|
||||||
|
|||||||
52
lib/check.ml
52
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
|
| Some m when has_digit m && not (has_digit n) -> None
|
||||||
| m -> m
|
| m -> m
|
||||||
in
|
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
|
match suggestion with
|
||||||
|
| Some m when fln ->
|
||||||
|
Loc.failk "check/unknown-type" loc "unknown type %s — did you mean %s?" n m
|
||||||
| Some m ->
|
| Some m ->
|
||||||
Loc.failk "check/unknown-type" loc
|
Loc.failk "check/unknown-type" loc
|
||||||
"unknown type %s — did you mean %s? Otherwise %s reads as a second \
|
"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]
|
if n <> "" && n.[0] = Char.uppercase_ascii n.[0]
|
||||||
&& n.[0] <> Char.lowercase_ascii n.[0]
|
&& n.[0] <> Char.lowercase_ascii n.[0]
|
||||||
then
|
then
|
||||||
|
if fln then Loc.failk "check/unknown-type" loc "unknown type %s" n
|
||||||
|
else
|
||||||
Loc.failk "check/unknown-type" loc
|
Loc.failk "check/unknown-type" loc
|
||||||
"unknown type %s. A capitalised name in a parameter vector is a type; \
|
"unknown type %s. A capitalised name in a parameter vector is a type; \
|
||||||
parameters are lowercase"
|
parameters are lowercase"
|
||||||
@ -4300,19 +4307,23 @@ let declare_env ctx = function
|
|||||||
| Some _ as s -> s
|
| Some _ as s -> s
|
||||||
| None -> Some (fresh_slot ctx (Types.Ptr (Types.Mut, Types.Unit)))
|
| 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 ""
|
if not (Types.is_numeric want && Types.is_numeric got) then ""
|
||||||
else if Types.widens_to ~from:want ~into:got then
|
else if Types.widens_to ~from:want ~into:got then
|
||||||
Printf.sprintf
|
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"
|
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)
|
(Types.to_string want) (Types.to_string got)
|
||||||
else
|
else
|
||||||
Printf.sprintf
|
Printf.sprintf
|
||||||
" — neither widens into the other, so the conversion has to be written: \
|
" — neither widens into the other, so the conversion has to be written: \
|
||||||
(%s x)"
|
%s"
|
||||||
(Types.to_string want)
|
cast
|
||||||
|
|
||||||
(* The rest of the sentence when a read-only slice meets a writable one. *)
|
(* 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 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. *)
|
to be told, in the same breath, which direction needed nothing. *)
|
||||||
Loc.failk "check/type-mismatch" loc "expected %s, found %s%s%s"
|
Loc.failk "check/type-mismatch" loc "expected %s, found %s%s%s"
|
||||||
(Types.to_string w) (Types.to_string got.Tast.ty)
|
(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)
|
(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.
|
(* 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
|
fail loc
|
||||||
"nothing here says what None is an Option of — use it where an \
|
"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
|
(* spec-memory.md puts the allocator in the calling convention as
|
||||||
[context/allocator] and [context/temp]. They read as names rather than
|
[context/allocator] and [context/temp]. They read as names rather than
|
||||||
calls because that is how the spec writes them, and they are dynamic
|
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
|
let is_nil = match v.Ast.e with Ast.Var "nil" -> true | _ -> false in
|
||||||
if ty <> Types.Dyn && not is_nil
|
if ty <> Types.Dyn && not is_nil
|
||||||
&& probe ctx loc (fun () -> (check ctx v).Tast.ty) = Some Types.Dyn
|
&& 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
|
then begin
|
||||||
let tn = Types.to_string ty in
|
let tn = Types.to_string ty in
|
||||||
let numeric = match ty with Types.Int _ | Types.Float _ -> true | _ -> false 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
|
if numeric then
|
||||||
fail v.Ast.loc
|
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"
|
— %s"
|
||||||
tn
|
the_ tn
|
||||||
(match spell_arg "" v with
|
(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)
|
| s -> Printf.sprintf "write (%s %s) to convert it" tn s)
|
||||||
else
|
else
|
||||||
(* What a dyn does at this type is the boundary's own answer, asked of
|
(* 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
|
match crosses with
|
||||||
| Some () ->
|
| Some () ->
|
||||||
fail v.Ast.loc
|
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"
|
dyn — a dyn becomes a %s where a %s is passed, returned or stored"
|
||||||
tn tn tn
|
the_ tn tn tn
|
||||||
| None ->
|
| None ->
|
||||||
(match speculate ctx.env (fun () -> check ctx ~want:ty v) with
|
(match speculate ctx.env (fun () -> check ctx ~want:ty v) with
|
||||||
| _ ->
|
| _ ->
|
||||||
fail v.Ast.loc
|
fail v.Ast.loc
|
||||||
"the checks a value as %s and does not convert one, and this is \
|
"%s checks a value as %s and does not convert one, and this is \
|
||||||
a dyn" tn
|
a dyn" the_ tn
|
||||||
| exception Loc.Error d ->
|
| exception Loc.Error d ->
|
||||||
fail v.Ast.loc
|
fail v.Ast.loc
|
||||||
"the checks a value as %s and does not convert one, and this is \
|
"%s checks a value as %s and does not convert one, and this is \
|
||||||
a dyn — %s" tn d.Loc.dmsg)
|
a dyn — %s" the_ tn d.Loc.dmsg)
|
||||||
end;
|
end;
|
||||||
let r =
|
let r =
|
||||||
match ty, v.Ast.e with
|
match ty, v.Ast.e with
|
||||||
|
|||||||
@ -537,15 +537,26 @@ let body_guess (h : Form.t) args =
|
|||||||
match List.rev args with a :: _ -> stmt_like a | [] -> false
|
match List.rev args with a :: _ -> stmt_like a | [] -> false
|
||||||
in
|
in
|
||||||
ignore lead;
|
ignore lead;
|
||||||
if is_with || last_stmt then begin
|
|
||||||
let k = ref 0 in
|
let k = ref 0 in
|
||||||
List.iteri
|
List.iteri
|
||||||
(fun i (a : Form.t) ->
|
(fun i (a : Form.t) ->
|
||||||
match a.v with Form.List (_ :: _) -> () | _ -> k := i + 1)
|
match a.v with Form.List (_ :: _) -> () | _ -> k := i + 1)
|
||||||
args;
|
args;
|
||||||
Some !k
|
(* The block starts at the first statement among the trailing lists,
|
||||||
end
|
so what comes before it — an if's test — stays in the parentheses:
|
||||||
else None)
|
[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
|
| _ -> None
|
||||||
|
|
||||||
let let_sugar (f : Form.t) =
|
let let_sugar (f : Form.t) =
|
||||||
@ -679,6 +690,24 @@ and wrapped n prefix (f : Form.t) =
|
|||||||
List.map (fun l ->
|
List.map (fun l ->
|
||||||
let k = String.length l in
|
let k = String.length l in
|
||||||
if k > 0 && l.[k - 1] = ' ' then String.sub l 0 (k - 1) else l) lines
|
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 ]
|
| _ -> [ ind n ^ prefix ^ at 0 f ]
|
||||||
|
|
||||||
(* [prefix = v], or [prefix =] and the value as an indented block when it is
|
(* [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") ->
|
when not (List.mem h sugar_heads || h = "fn" || h = "if") ->
|
||||||
wrapped n (prefix ^ " = ") v
|
wrapped n (prefix ^ " = ") v
|
||||||
| Form.List (_ :: _) -> [ ind n ^ prefix ^ " =" ] @ block (n + 2) (stmts_of v)
|
| Form.List (_ :: _) -> [ ind n ^ prefix ^ " =" ] @ block (n + 2) (stmts_of v)
|
||||||
|
| Form.Vec (_ :: _ :: _) -> wrapped n (prefix ^ " = ") v
|
||||||
| _ -> [ ind n ^ inline ]
|
| _ -> [ ind n ^ inline ]
|
||||||
|
|
||||||
and slot n (f : Form.t) = block n (stmts_of f)
|
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)
|
| _ -> None)
|
||||||
| Form.List ({ v = Form.Sym "dotimes"; _ } :: rest) ->
|
| Form.List ({ v = Form.Sym "dotimes"; _ } :: rest) ->
|
||||||
let lbl, rest = label_of rest in
|
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
|
(match rest with
|
||||||
| { v = Form.Vec ({ v = Form.Sym v; _ } :: bs); _ } :: (_ :: _ as body)
|
| { v = Form.Vec (vf :: bs); _ } :: (_ :: _ as body)
|
||||||
when def_name v && bs <> [] && List.length bs <= 3 && v <> "in" ->
|
when var vf <> None && bs <> [] && List.length bs <= 3 ->
|
||||||
|
let v = Option.get (var vf) in
|
||||||
Some
|
Some
|
||||||
((i ^ "for " ^ lbl ^ v ^ " in range(" ^ commas bs ^ ")") :: block (n + 2) body)
|
((i ^ "for " ^ lbl ^ v ^ " in range(" ^ commas bs ^ ")") :: block (n + 2) body)
|
||||||
| _ -> None)
|
| _ -> None)
|
||||||
|
|||||||
@ -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 ]
|
| KW k -> let kt = advance p in [ Form.make (Form.Kw k) kt.loc ]
|
||||||
| _ -> []
|
| _ -> []
|
||||||
in
|
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)";
|
expect_name p "in" ~what:"in, as in for i in range(n)";
|
||||||
let rt = peek p in
|
let rt = peek p in
|
||||||
expect_name p "range" ~what:"range(n), range(a, b) or range(a, b, step)";
|
expect_name p "range" ~what:"range(n), range(a, b) or range(a, b, step)";
|
||||||
|
|||||||
@ -7,9 +7,27 @@
|
|||||||
|
|
||||||
let width = 80
|
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 rec flat spell (f : Form.t) =
|
||||||
let seq l = String.concat " " (List.map (flat spell) l) in
|
let seq l = String.concat " " (List.map (flat spell) l) in
|
||||||
match f.v with
|
match f.v with
|
||||||
|
| _ when sugar f <> None ->
|
||||||
|
let p, x = Option.get (sugar f) in
|
||||||
|
p ^ flat spell x
|
||||||
| Form.Int _ | Form.Float _ ->
|
| Form.Int _ | Form.Float _ ->
|
||||||
(match spell f with Some t -> t | None -> Form.to_source f)
|
(match spell f with Some t -> t | None -> Form.to_source f)
|
||||||
| Form.List l -> "(" ^ seq l ^ ")"
|
| Form.List l -> "(" ^ seq l ^ ")"
|
||||||
@ -17,6 +35,19 @@ let rec flat spell (f : Form.t) =
|
|||||||
| Form.Map l -> "{" ^ seq l ^ "}"
|
| Form.Map l -> "{" ^ seq l ^ "}"
|
||||||
| _ -> Form.to_source f
|
| _ -> 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. *)
|
(* How many arguments stay on the head's line when the form is broken. *)
|
||||||
let kept head =
|
let kept head =
|
||||||
match head with
|
match head with
|
||||||
@ -26,6 +57,24 @@ let kept head =
|
|||||||
| "do" | "cond" | "comment" | "restart-case" | "handler-case" -> 0
|
| "do" | "cond" | "comment" | "restart-case" | "handler-case" -> 0
|
||||||
| _ -> 1
|
| _ -> 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,
|
(* [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. *)
|
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 =
|
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
|
in
|
||||||
if col + String.length one <= width && not (inside f) then [ one ]
|
if col + String.length one <= width && not (inside f) then [ one ]
|
||||||
else
|
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 =
|
let placed inner x =
|
||||||
match layout spell inner x with
|
match layout spell inner x with
|
||||||
| first :: more ->
|
| first :: more ->
|
||||||
@ -54,8 +154,27 @@ let rec layout ?(inside = fun _ -> false) spell col (f : Form.t) : string list =
|
|||||||
col + 1 + String.length
|
col + 1 + String.length
|
||||||
(String.concat " " (List.map (flat spell) (List.filteri (fun i _ -> i < k) items)))
|
(String.concat " " (List.map (flat spell) (List.filteri (fun i _ -> i < k) items)))
|
||||||
in
|
in
|
||||||
let keep = if keep > 1 && head_len keep > width then 1 else keep in
|
let hang =
|
||||||
if keep > 0 then
|
(* [(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 first = List.filteri (fun i _ -> i < keep) items in
|
||||||
let rest = 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
|
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
|
@ List.concat_map (placed (col + 2)) rest
|
||||||
| _ ->
|
| _ ->
|
||||||
(o ^ String.concat " " (List.map (flat spell) first))
|
(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
|
else
|
||||||
match items with
|
match items with
|
||||||
| [] -> [ o ]
|
| [] -> [ 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 ->
|
| x :: xs ->
|
||||||
(match layout spell (col + 1) x with
|
(match layout spell (col + 1) x with
|
||||||
| first :: more ->
|
| 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
|
List.mapi (fun i l -> if i = n - 1 then l ^ c else l) lines
|
||||||
in
|
in
|
||||||
match f.v with
|
match f.v with
|
||||||
| Form.List (({ v = Form.Sym h; _ }) :: _ as items) ->
|
(* A let's binding vector opens on the head's line, a pair to a line,
|
||||||
bracket "(" ")" items ~keep:(1 + min (kept h) (List.length items - 1))
|
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.List items -> bracket "(" ")" items ~keep:0
|
||||||
| Form.Vec 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
|
| Form.Map items -> bracket "{" "}" items ~keep:0
|
||||||
| _ -> [ one ]
|
| _ -> [ one ]
|
||||||
|
|
||||||
|
|||||||
@ -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);
|
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) {
|
_Noreturn void flan_region_only_fail(const uint8_t *loc, int64_t loclen) {
|
||||||
rt_flush_out();
|
rt_flush_out();
|
||||||
fprintf(stderr,
|
fprintf(stderr,
|
||||||
"%.*s: this container's elements own storage, and this allocator "
|
"%.*s: this container's elements own storage, and this allocator "
|
||||||
"frees one block at a time, so freeing it here would leak what the "
|
"frees one block at a time, so freeing it here would leak what the "
|
||||||
"elements hold. Build it against a region allocator: "
|
"elements hold. Build it against a region allocator: %s\n",
|
||||||
"(with-allocator context/temp ...) or an (arena-new n)\n",
|
(int)loclen, (const char *)loc,
|
||||||
(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();
|
rt_die();
|
||||||
}
|
}
|
||||||
|
|
||||||
|
|||||||
93
test/syntax/handwritten/csv.fln
Normal file
93
test/syntax/handwritten/csv.fln
Normal file
@ -0,0 +1,93 @@
|
|||||||
|
; A CSV reader written as a state machine over bytes: quoted fields, doubled
|
||||||
|
; quotes inside them, and a count of rows kept in globals.
|
||||||
|
|
||||||
|
enum State
|
||||||
|
start
|
||||||
|
bare
|
||||||
|
quoted
|
||||||
|
quote-in-quoted
|
||||||
|
|
||||||
|
once rows-seen: i32
|
||||||
|
def fields-seen: i32 = 0
|
||||||
|
const separator = \,
|
||||||
|
|
||||||
|
; Frame the body's output with a title line and a closing rule.
|
||||||
|
defmacro(with-section, [title & body]):
|
||||||
|
quote
|
||||||
|
println("--", ~title, "--")
|
||||||
|
~@body
|
||||||
|
println("-----")
|
||||||
|
|
||||||
|
fn flush(field: Ptr(Vec(u8)), row: Ptr(Vec(string))) -> ()
|
||||||
|
push(deref(row), string(slice(deref(field))))
|
||||||
|
fields-seen += 1
|
||||||
|
deref(field) = vec-new(u8)
|
||||||
|
|
||||||
|
fn parse-line(line: [const u8]) -> Vec(string)
|
||||||
|
let row = vec-new(string)
|
||||||
|
let field = vec-new(u8)
|
||||||
|
let state: State = :start
|
||||||
|
for i in range(length(line))
|
||||||
|
let c = line[i]
|
||||||
|
match state
|
||||||
|
:start ->
|
||||||
|
if c == \"
|
||||||
|
state = :quoted
|
||||||
|
elif c == separator
|
||||||
|
flush(addr(field), addr(row))
|
||||||
|
else
|
||||||
|
push(field, c)
|
||||||
|
state = :bare
|
||||||
|
:bare ->
|
||||||
|
if c == separator
|
||||||
|
flush(addr(field), addr(row))
|
||||||
|
state = :start
|
||||||
|
else
|
||||||
|
push(field, c)
|
||||||
|
:quoted ->
|
||||||
|
if c == \" then state = :quote-in-quoted else push(field, c)
|
||||||
|
:quote-in-quoted ->
|
||||||
|
if c == \"
|
||||||
|
push(field, c)
|
||||||
|
state = :quoted
|
||||||
|
else
|
||||||
|
flush(addr(field), addr(row))
|
||||||
|
state = :start
|
||||||
|
flush(addr(field), addr(row))
|
||||||
|
rows-seen += 1
|
||||||
|
row
|
||||||
|
|
||||||
|
fn widest(rows: [Vec(string)]) -> i32
|
||||||
|
let best = 0
|
||||||
|
for r in range(length(rows))
|
||||||
|
for f in range(length(rows[r]))
|
||||||
|
best = max(best, i32(length(rows[r][f])))
|
||||||
|
best
|
||||||
|
|
||||||
|
fn pad(s: string, width: i32) -> ()
|
||||||
|
print(s)
|
||||||
|
let n = width - i32(length(s))
|
||||||
|
until n <= 0
|
||||||
|
print(" ")
|
||||||
|
n -= 1
|
||||||
|
|
||||||
|
fn main() -> i32
|
||||||
|
let text = "name,qty,note\npear,3,\"ripe, soft\"\nfig,12,\"said \"\"hi\"\"\"\n,0,none"
|
||||||
|
let frame = arena-new(65536)
|
||||||
|
defer arena-destroy(frame)
|
||||||
|
with-allocator(frame):
|
||||||
|
let lines = split(bytes-view(text), \newline)
|
||||||
|
let rows = vec-new(Vec(string))
|
||||||
|
for i in range(length(lines))
|
||||||
|
push(rows, parse-line(lines[i]))
|
||||||
|
let w = widest(slice(rows)) + 1
|
||||||
|
with-section("table"):
|
||||||
|
for r in range(length(rows))
|
||||||
|
for f in range(length(rows[r]))
|
||||||
|
let last = f + 1 == length(rows[r])
|
||||||
|
pad(rows[r][f], if last then 0 else w)
|
||||||
|
println("")
|
||||||
|
println("rows", rows-seen, "fields", fields-seen)
|
||||||
|
comment:
|
||||||
|
parse-line(bytes-view("a,\"b\",c"))
|
||||||
|
0
|
||||||
7
test/syntax/handwritten/csv.out
Normal file
7
test/syntax/handwritten/csv.out
Normal file
@ -0,0 +1,7 @@
|
|||||||
|
-- table --
|
||||||
|
name qty note
|
||||||
|
pear 3 ripe, soft
|
||||||
|
fig 12 said "hi"
|
||||||
|
0 none
|
||||||
|
-----
|
||||||
|
rows 4 fields 12
|
||||||
81
test/syntax/handwritten/inventory.fln
Normal file
81
test/syntax/handwritten/inventory.fln
Normal file
@ -0,0 +1,81 @@
|
|||||||
|
; An inventory report: items from the stock package, reorder rules held as
|
||||||
|
; function values, and the report's text built in an arena that is reset
|
||||||
|
; between runs.
|
||||||
|
|
||||||
|
import stock "stock"
|
||||||
|
|
||||||
|
struct Rule
|
||||||
|
label: string
|
||||||
|
applies: CFn(stock/Item) -> bool
|
||||||
|
|
||||||
|
def report-width: i32 = 28
|
||||||
|
once runs: i32
|
||||||
|
const reorder-below = 5
|
||||||
|
|
||||||
|
; Run the body n times, counting passes in the name given.
|
||||||
|
defmacro(repeat, [i n & body]):
|
||||||
|
quote
|
||||||
|
for ~i in range(~n)
|
||||||
|
~@body
|
||||||
|
|
||||||
|
; Say what went wrong when a check does not hold.
|
||||||
|
defmacro(expect, [test message]):
|
||||||
|
quote
|
||||||
|
if not ~test
|
||||||
|
println("expected:", ~message)
|
||||||
|
|
||||||
|
fn gcd(a: i32, b: i32) -> i32
|
||||||
|
loop([x a y b]):
|
||||||
|
if y == 0 then x else recur(y, x % y)
|
||||||
|
|
||||||
|
fn line(it: stock/Item) -> ()
|
||||||
|
let price = stock/money(stock/value(it))
|
||||||
|
defer
|
||||||
|
free(price)
|
||||||
|
let dots = report-width - i32(length(it.name)) - i32(length(price))
|
||||||
|
print(it.name)
|
||||||
|
for i in range(max(dots, 1))
|
||||||
|
print(".")
|
||||||
|
println(string(slice(price)))
|
||||||
|
|
||||||
|
fn low?(it: stock/Item) -> bool = it.count < reorder-below
|
||||||
|
|
||||||
|
fn count-if(items: [stock/Item], keep?: Fn(stock/Item) -> bool) -> i32
|
||||||
|
let n = 0
|
||||||
|
for i in range(length(items))
|
||||||
|
if keep?(items[i])
|
||||||
|
++(n)
|
||||||
|
n
|
||||||
|
|
||||||
|
fn main() -> i32
|
||||||
|
let items = [stock/item("bolts", 12, 400), stock/item("nuts", 5, 3),
|
||||||
|
stock/item("gears", 1250, 7), stock/item("belts", 899, 0)]
|
||||||
|
let rules = [Rule{.label "reorder", .applies low?},
|
||||||
|
Rule{.label "valuable", .applies fn(it) = stock/value(it) > 5000}]
|
||||||
|
let frame = arena-new(4096)
|
||||||
|
repeat(pass, 2):
|
||||||
|
runs += 1
|
||||||
|
with-allocator(frame):
|
||||||
|
println("report", runs)
|
||||||
|
for i in range(length(items))
|
||||||
|
line(items[i])
|
||||||
|
for r in range(length(rules))
|
||||||
|
let names = vec-new(string)
|
||||||
|
for i in range(length(items))
|
||||||
|
if rules[r].applies(items[i])
|
||||||
|
push(names, items[i].name)
|
||||||
|
println(rules[r].label, slice(names))
|
||||||
|
free-all(frame)
|
||||||
|
arena-destroy(frame)
|
||||||
|
let total = 0
|
||||||
|
for i in range(0, length(items), 2)
|
||||||
|
total += items[i].count
|
||||||
|
println("even rows hold", total, "and share a factor of",
|
||||||
|
gcd(items[0].count, items[2].count + 1))
|
||||||
|
println("sign bits", stock/sign-bit(-2.5), stock/sign-bit(2.5),
|
||||||
|
"masked", bit-and(-total, 0xFF))
|
||||||
|
let big = 1000
|
||||||
|
println("worth over", big, count-if(slice(items), fn(it) = stock/value(it) > big))
|
||||||
|
expect(total == 407, "407 on even rows")
|
||||||
|
expect(runs == 2, "two runs")
|
||||||
|
0
|
||||||
17
test/syntax/handwritten/inventory.out
Normal file
17
test/syntax/handwritten/inventory.out
Normal file
@ -0,0 +1,17 @@
|
|||||||
|
report 1
|
||||||
|
bolts..................48.00
|
||||||
|
nuts....................0.15
|
||||||
|
gears..................87.50
|
||||||
|
belts...................0.00
|
||||||
|
reorder ["nuts" "belts"]
|
||||||
|
valuable ["gears"]
|
||||||
|
report 2
|
||||||
|
bolts..................48.00
|
||||||
|
nuts....................0.15
|
||||||
|
gears..................87.50
|
||||||
|
belts...................0.00
|
||||||
|
reorder ["nuts" "belts"]
|
||||||
|
valuable ["gears"]
|
||||||
|
even rows hold 407 and share a factor of 8
|
||||||
|
sign bits 1 0 masked 105
|
||||||
|
worth over 1000 2
|
||||||
75
test/syntax/handwritten/ledger.fln
Normal file
75
test/syntax/handwritten/ledger.fln
Normal file
@ -0,0 +1,75 @@
|
|||||||
|
; A ledger that applies transfers between accounts. A transfer that would
|
||||||
|
; overdraw signals, and the caller picks a restart: skip it, cap it at what
|
||||||
|
; the account holds, or allow an overdraft up to a limit it supplies.
|
||||||
|
|
||||||
|
defstruct(Overdraft, :parent, Error, [account i32 short i64])
|
||||||
|
|
||||||
|
struct Audit
|
||||||
|
account: i32
|
||||||
|
amount: i64
|
||||||
|
|
||||||
|
once balances: [4 i64]
|
||||||
|
once audits: i32
|
||||||
|
once log: i64
|
||||||
|
|
||||||
|
; Every transfer leaves a digit in the log when it is done with, however it
|
||||||
|
; ended: 1 applied, 2 left through a restart.
|
||||||
|
fn note(d: i64) -> ()
|
||||||
|
log = log * 10 + d
|
||||||
|
|
||||||
|
fn withdraw(account: i32, amount: i64) -> i64
|
||||||
|
let have = balances[account]
|
||||||
|
if amount > have
|
||||||
|
let short = amount - have
|
||||||
|
restart-case
|
||||||
|
error(Overdraft{.account account, .short short})
|
||||||
|
restart skip()
|
||||||
|
return 0
|
||||||
|
restart cap()
|
||||||
|
return withdraw(account, have)
|
||||||
|
restart allow(limit: i64)
|
||||||
|
if short > limit
|
||||||
|
return 0
|
||||||
|
if amount >= 100
|
||||||
|
signal(Audit{.account account, .amount amount})
|
||||||
|
balances[account] -= amount
|
||||||
|
amount
|
||||||
|
|
||||||
|
fn transfer(from: i32, to: i32, amount: i64) -> i64
|
||||||
|
let applied: i64 = 0
|
||||||
|
defer note(if applied == amount then 1 else 2)
|
||||||
|
applied = withdraw(from, amount)
|
||||||
|
balances[to] += applied
|
||||||
|
applied
|
||||||
|
|
||||||
|
fn run(policy) -> ()
|
||||||
|
balances = [100 50 0 10]
|
||||||
|
log = 0
|
||||||
|
handler-bind
|
||||||
|
transfer(0, 2, 30)
|
||||||
|
transfer(1, 2, 80)
|
||||||
|
transfer(3, 0, 25)
|
||||||
|
transfer(0, 1, 100)
|
||||||
|
on Overdraft(o)
|
||||||
|
match policy
|
||||||
|
:skip -> invoke-restart('skip)
|
||||||
|
:cap -> invoke-restart('cap)
|
||||||
|
_ -> invoke-restart('allow, i64(20))
|
||||||
|
on Audit(a)
|
||||||
|
audits += 1
|
||||||
|
println(policy, slice(balances), "log", log)
|
||||||
|
|
||||||
|
fn main() -> i32
|
||||||
|
run(:skip)
|
||||||
|
run(:cap)
|
||||||
|
run(:allow)
|
||||||
|
println("audited", audits)
|
||||||
|
let caught =
|
||||||
|
handler-case
|
||||||
|
balances = [0 0 0 0]
|
||||||
|
withdraw(2, 5)
|
||||||
|
on Overdraft(o)
|
||||||
|
println("unhandled overdraft on", o.account, "short by", o.short)
|
||||||
|
-1
|
||||||
|
println("caught", caught)
|
||||||
|
0
|
||||||
6
test/syntax/handwritten/ledger.out
Normal file
6
test/syntax/handwritten/ledger.out
Normal file
@ -0,0 +1,6 @@
|
|||||||
|
:skip [70 50 30 10] log 1222
|
||||||
|
:cap [0 80 80 0] log 1222
|
||||||
|
:allow [-5 150 30 -15] log 1211
|
||||||
|
audited 1
|
||||||
|
unhandled overdraft on 2 short by 5
|
||||||
|
caught -1
|
||||||
83
test/syntax/handwritten/lisp.fln
Normal file
83
test/syntax/handwritten/lisp.fln
Normal file
@ -0,0 +1,83 @@
|
|||||||
|
; A small interpreter over dyn values: a program is nested vectors whose
|
||||||
|
; first element is a keyword naming the operation, variables are keywords,
|
||||||
|
; and environments are dyn maps chained through a :parent key.
|
||||||
|
|
||||||
|
defclass(lambda, [param body env])
|
||||||
|
|
||||||
|
defgeneric(describe, [v], dyn)
|
||||||
|
|
||||||
|
defmethod(describe, lambda, [f]):
|
||||||
|
"a function of one argument"
|
||||||
|
|
||||||
|
defmulti(kind, [v], dyn, type-of(v))
|
||||||
|
|
||||||
|
defmethod(kind, :int, [v]):
|
||||||
|
"number"
|
||||||
|
|
||||||
|
defmethod(kind, :vec, [v]):
|
||||||
|
"form"
|
||||||
|
|
||||||
|
defmethod(kind, :else, [v]):
|
||||||
|
"value"
|
||||||
|
|
||||||
|
once steps = 0
|
||||||
|
|
||||||
|
fn lookup(env, name) -> dyn
|
||||||
|
if env == nil
|
||||||
|
println("unbound", name)
|
||||||
|
return 0
|
||||||
|
if has-key?(env, name) then get(env, name) else lookup(get(env, :parent), name)
|
||||||
|
|
||||||
|
fn extend(env, name, value) -> dyn
|
||||||
|
{:parent env name value}
|
||||||
|
|
||||||
|
fn eval(e, env) -> dyn
|
||||||
|
steps += 1
|
||||||
|
match type-of(e)
|
||||||
|
:keyword -> lookup(env, e)
|
||||||
|
:vec -> eval-form(e, env)
|
||||||
|
_ -> e
|
||||||
|
|
||||||
|
fn eval-form(e, env) -> dyn
|
||||||
|
let op = e[0]
|
||||||
|
match op
|
||||||
|
:+ -> eval(e[1], env) + eval(e[2], env)
|
||||||
|
:- -> eval(e[1], env) - eval(e[2], env)
|
||||||
|
:* -> eval(e[1], env) * eval(e[2], env)
|
||||||
|
:< -> eval(e[1], env) < eval(e[2], env)
|
||||||
|
:if ->
|
||||||
|
if eval(e[1], env) then eval(e[2], env) else eval(e[3], env)
|
||||||
|
:let ->
|
||||||
|
let v = eval(e[2], env)
|
||||||
|
let inner = extend(env, e[1], v)
|
||||||
|
; A function sees its own name, so it can call itself.
|
||||||
|
if type-of(v) == :lambda
|
||||||
|
put(v, :env, inner)
|
||||||
|
eval(e[3], inner)
|
||||||
|
:fn -> lambda(e[1], e[2], env)
|
||||||
|
:do ->
|
||||||
|
let last = nil
|
||||||
|
for i in range(1, length(e))
|
||||||
|
last = eval(e[i], env)
|
||||||
|
last
|
||||||
|
_ ->
|
||||||
|
let f = eval(op, env)
|
||||||
|
let arg = eval(e[1], env)
|
||||||
|
eval(get(f, :body), extend(get(f, :env), get(f, :param), arg))
|
||||||
|
|
||||||
|
fn run(program) -> ()
|
||||||
|
steps = 0
|
||||||
|
let result = eval(program, {:parent nil})
|
||||||
|
println(kind(program), "=>", result, "in", steps, "steps")
|
||||||
|
|
||||||
|
fn main() -> i32
|
||||||
|
run(42)
|
||||||
|
run([:+ 1 [:* 2 3]])
|
||||||
|
run([:let :x 5 [:if [:< :x 3] :small [:* :x :x]]])
|
||||||
|
let fact = [:let :fact [:fn :n [:if [:< :n 2] 1 [:* :n [:fact [:- :n 1]]]]] [:fact 6]]
|
||||||
|
run(fact)
|
||||||
|
run([:let :k 10 [:let :add-k [:fn :y [:+ :y :k]] [:do [:add-k 1] [:add-k 32]]]])
|
||||||
|
let f = eval([:fn :x :x], {:parent nil})
|
||||||
|
println(describe(f), "/", kind(f), "/", type-of(f))
|
||||||
|
run([:let :greeting "hello" :greeting])
|
||||||
|
0
|
||||||
7
test/syntax/handwritten/lisp.out
Normal file
7
test/syntax/handwritten/lisp.out
Normal file
@ -0,0 +1,7 @@
|
|||||||
|
number => 42 in 1 steps
|
||||||
|
form => 7 in 5 steps
|
||||||
|
form => 25 in 9 steps
|
||||||
|
form => 720 in 65 steps
|
||||||
|
form => 42 in 17 steps
|
||||||
|
a function of one argument / value / :lambda
|
||||||
|
form => hello in 3 steps
|
||||||
85
test/syntax/handwritten/ring.fln
Normal file
85
test/syntax/handwritten/ring.fln
Normal file
@ -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
|
||||||
9
test/syntax/handwritten/ring.out
Normal file
9
test/syntax/handwritten/ring.out
Normal file
@ -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
|
||||||
115
test/syntax/handwritten/rpn.fln
Normal file
115
test/syntax/handwritten/rpn.fln
Normal file
@ -0,0 +1,115 @@
|
|||||||
|
; A reverse-Polish calculator: a tokenizer, a data type for tokens, and an
|
||||||
|
; evaluator that signals on a bad program and lets the caller decide.
|
||||||
|
|
||||||
|
data Token
|
||||||
|
Num(n: i64)
|
||||||
|
Op(c: u8)
|
||||||
|
Word(w: [const u8])
|
||||||
|
End
|
||||||
|
|
||||||
|
struct Underflow
|
||||||
|
op: u8
|
||||||
|
|
||||||
|
struct Unknown
|
||||||
|
word: [const u8]
|
||||||
|
|
||||||
|
const max-depth = 16
|
||||||
|
|
||||||
|
struct Machine
|
||||||
|
stack: [max-depth i64]
|
||||||
|
depth: i32
|
||||||
|
|
||||||
|
; Read the token that starts at pos; the position after it comes back too.
|
||||||
|
fn next-token(src: [const u8], pos: Ptr(i32)) -> Token
|
||||||
|
let n = length(src)
|
||||||
|
while deref(pos) < n and space?(src[deref(pos)])
|
||||||
|
++(deref(pos))
|
||||||
|
if deref(pos) >= n
|
||||||
|
return Token.End
|
||||||
|
let start = deref(pos)
|
||||||
|
until deref(pos) >= n or space?(src[deref(pos)])
|
||||||
|
++(deref(pos))
|
||||||
|
let text = slice(src, start, deref(pos))
|
||||||
|
let c = text[0]
|
||||||
|
if digit?(c) or (c == \- and length(text) > 1)
|
||||||
|
match parse-i64(text)
|
||||||
|
Some(v) -> Token.Num{.n v}
|
||||||
|
None -> Token.Word{.w text}
|
||||||
|
elif length(text) == 1 and some?(index-of(bytes-view("+-*/%"), c))
|
||||||
|
Token.Op{.c c}
|
||||||
|
else
|
||||||
|
Token.Word{.w text}
|
||||||
|
|
||||||
|
fn push!(m: Ptr(Machine), v: i64) -> ()
|
||||||
|
m.stack[m.depth] = v
|
||||||
|
m.depth += 1
|
||||||
|
|
||||||
|
fn pop!(m: Ptr(Machine), op: u8) -> i64
|
||||||
|
if m.depth == 0
|
||||||
|
error(Underflow{.op op})
|
||||||
|
m.depth -= 1
|
||||||
|
m.stack[m.depth]
|
||||||
|
|
||||||
|
fn apply(op: u8, a: i64, b: i64) -> i64
|
||||||
|
match op
|
||||||
|
\+ -> a + b
|
||||||
|
\- -> a - b
|
||||||
|
\* -> a * b
|
||||||
|
\/ -> if b == 0 then 0 else a / b
|
||||||
|
_ -> a % b
|
||||||
|
|
||||||
|
fn run(src: string) -> i64
|
||||||
|
let m: Machine = zeroed()
|
||||||
|
let text = bytes-view(src)
|
||||||
|
let pos = 0
|
||||||
|
while :tokens true
|
||||||
|
match next-token(text, addr(pos))
|
||||||
|
End -> break :tokens
|
||||||
|
Num(n) -> push!(addr(m), n)
|
||||||
|
Op(c) ->
|
||||||
|
let b = pop!(addr(m), c)
|
||||||
|
let a = pop!(addr(m), c)
|
||||||
|
push!(addr(m), apply(c, a, b))
|
||||||
|
Word(w) ->
|
||||||
|
if bytes=?(w, bytes-view("dup"))
|
||||||
|
let v = pop!(addr(m), \d)
|
||||||
|
push!(addr(m), v)
|
||||||
|
push!(addr(m), v)
|
||||||
|
elif bytes=?(w, bytes-view("drop"))
|
||||||
|
pop!(addr(m), \d)
|
||||||
|
continue
|
||||||
|
else
|
||||||
|
error(Unknown{.word w})
|
||||||
|
pop!(addr(m), \=)
|
||||||
|
|
||||||
|
fn show(src: string) -> ()
|
||||||
|
let r =
|
||||||
|
handler-case
|
||||||
|
run(src)
|
||||||
|
on Underflow(u)
|
||||||
|
println(src, "=> stack empty at", string-of-byte(u.op))
|
||||||
|
return
|
||||||
|
on Unknown(u)
|
||||||
|
println(src, "=> unknown word", string(u.word))
|
||||||
|
return
|
||||||
|
println(src, "=>", r)
|
||||||
|
|
||||||
|
fn string-of-byte(b: u8) -> string
|
||||||
|
match b
|
||||||
|
\+ -> "+"
|
||||||
|
\- -> "-"
|
||||||
|
\* -> "*"
|
||||||
|
\/ -> "/"
|
||||||
|
\d -> "dup"
|
||||||
|
_ -> "?"
|
||||||
|
|
||||||
|
fn main() -> i32
|
||||||
|
show("1 2 +")
|
||||||
|
show("3 4 * 5 -")
|
||||||
|
show("-7 2 /")
|
||||||
|
show("10 dup *")
|
||||||
|
show("1 2 drop 9 %")
|
||||||
|
show("1 +")
|
||||||
|
show("2 3 swap")
|
||||||
|
show("8 0 /")
|
||||||
|
0
|
||||||
8
test/syntax/handwritten/rpn.out
Normal file
8
test/syntax/handwritten/rpn.out
Normal file
@ -0,0 +1,8 @@
|
|||||||
|
1 2 + => 3
|
||||||
|
3 4 * 5 - => 7
|
||||||
|
-7 2 / => -3
|
||||||
|
10 dup * => 100
|
||||||
|
1 2 drop 9 % => 1
|
||||||
|
1 + => stack empty at +
|
||||||
|
2 3 swap => unknown word swap
|
||||||
|
8 0 / => 0
|
||||||
37
test/syntax/handwritten/stock/stock.fln
Normal file
37
test/syntax/handwritten/stock/stock.fln
Normal file
@ -0,0 +1,37 @@
|
|||||||
|
; Stock items and prices kept in cents, imported by ../inventory.fln.
|
||||||
|
|
||||||
|
struct Item
|
||||||
|
name: string
|
||||||
|
cents: i64
|
||||||
|
count: i32
|
||||||
|
|
||||||
|
; A price read as a float without a division, by its bits.
|
||||||
|
union Bits
|
||||||
|
f: f32
|
||||||
|
u: u32
|
||||||
|
|
||||||
|
const cents-per-unit = 100
|
||||||
|
|
||||||
|
fn- whole(cents: i64) -> i64 = cents / cents-per-unit
|
||||||
|
|
||||||
|
fn- part(cents: i64) -> i64 = cents % cents-per-unit
|
||||||
|
|
||||||
|
fn item(name: string, cents: i64, count: i32) -> Item
|
||||||
|
Item{.name name, .cents cents, .count count}
|
||||||
|
|
||||||
|
fn value(it: Item) -> i64 = it.cents * i64(it.count)
|
||||||
|
|
||||||
|
; 1234 as "12.34", into a buffer the caller frees.
|
||||||
|
fn money(cents: i64) -> Vec(u8)
|
||||||
|
let out = vec-new(u8)
|
||||||
|
append-i64(addr(out), whole(cents))
|
||||||
|
append(addr(out), bytes-view("."))
|
||||||
|
if part(cents) < 10
|
||||||
|
append(addr(out), bytes-view("0"))
|
||||||
|
append-i64(addr(out), part(cents))
|
||||||
|
out
|
||||||
|
|
||||||
|
fn sign-bit(x: f32) -> u32
|
||||||
|
let b: Bits = zeroed()
|
||||||
|
b.f = x
|
||||||
|
b.u >> 31
|
||||||
Loading…
x
Reference in New Issue
Block a user