1311 lines
45 KiB
OCaml
1311 lines
45 KiB
OCaml
(** The indented reader: [.fln] text to exactly the [Form.t] tree the paren
|
|
reader ([Reader]) makes. Nothing after the reader knows which syntax a form
|
|
came from. spec-syntax.md is the grammar; this comment is only the shape.
|
|
|
|
Three passes. [lex] turns text into tokens, reusing [Reader]'s own string,
|
|
character, number and quoted-datum readers so the atoms mean exactly what
|
|
they mean in a [.flan] file. [layout] adds NEWLINE, INDENT and DEDENT at
|
|
bracket depth zero from an indent stack of columns. The parser is a
|
|
statement parser (soft keywords at the start of a line) over a precedence
|
|
climber for expressions.
|
|
|
|
Locations are spans, as [Reader] makes them: a form starts at its first
|
|
token and ends where its last one does. A form this reader invents — the
|
|
[dyn] of an untyped parameter, the [do] around a block, the [set] of an
|
|
assignment — takes the location of the text that asked for it. *)
|
|
|
|
type tok =
|
|
| NAME of string (* a name run, after field splitting *)
|
|
| KW of string
|
|
| ATOM of Form.value (* number, string, character *)
|
|
| DATUM of Form.t (* 'x and '(a b), read by the paren reader *)
|
|
| LP | RP | LB | RB | LC | RC
|
|
| COMMA
|
|
| COLON (* x: T, and the trailing : of a call's block *)
|
|
| UNQ | SPLICE (* ~ and ~@ *)
|
|
| NEG (* the - glued to the front of a name *)
|
|
| NEWLINE | INDENT | DEDENT | EOF
|
|
|
|
type token = { tok : tok; loc : Loc.t; sp : bool (* whitespace before it *) }
|
|
|
|
let failk ?notes kind loc fmt = Loc.failk ?notes ("indent/" ^ kind) loc fmt
|
|
|
|
let show = function
|
|
| NAME s -> s
|
|
| KW s -> ":" ^ s
|
|
| ATOM v -> Form.to_source (Form.make v Loc.unknown)
|
|
| DATUM f -> Form.to_source f
|
|
| LP -> "(" | RP -> ")" | LB -> "[" | RB -> "]" | LC -> "{" | RC -> "}"
|
|
| COMMA -> "," | COLON -> ":" | UNQ -> "~" | SPLICE -> "~@" | NEG -> "-"
|
|
| NEWLINE -> "the end of the line"
|
|
| INDENT -> "an indented line"
|
|
| DEDENT -> "the end of the block"
|
|
| EOF -> "the end of the file"
|
|
|
|
(* ── Names ─────────────────────────────────────────────────────────── *)
|
|
|
|
(* Binary operators and their levels, low to high (spec §2 "Precedence").
|
|
[not] sits at 3 and unary minus at 8; neither is binary. *)
|
|
let binops =
|
|
[ ("or", 1); ("and", 2);
|
|
("==", 4); ("!=", 4); ("<", 4); ("<=", 4); (">", 4); (">=", 4);
|
|
("<<", 5); (">>", 5); ("+", 6); ("-", 6); ("*", 7); ("/", 7); ("%", 7) ]
|
|
|
|
let binop_level s = List.assoc_opt s binops
|
|
let is_binop s = binop_level s <> None
|
|
|
|
(* [==] is Flan's [=]; every other operator is its own name. *)
|
|
let op_sym = function "==" -> "=" | s -> s
|
|
|
|
(* Words that are operators rather than names wherever a value is read. Alone
|
|
before a comma or a closer they are the symbol itself, [reduce(+, 0, xs)];
|
|
glued to a parenthesis they are a call, [+(a, b, c)]. *)
|
|
let is_op_word s = is_binop s || s = "not" || s = "="
|
|
|
|
let assign_ops = [ ("+=", "+"); ("-=", "-"); ("*=", "*"); ("/=", "/") ]
|
|
|
|
(* A [-] glued to one of these starts a negation: [-x] is [(- x)]. Anything
|
|
else keeps the Lisp reading, so [--], [->] and [-=] stay names. *)
|
|
let is_neg_char c =
|
|
(c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z') || c = '$' || c = '_'
|
|
|| c = '*'
|
|
|
|
(* The segment a dot splits after, checked for a capital: [Shape.Rect] and
|
|
[tree/Node.Branch] are one qualified name, [camera.target.x] is two field
|
|
accesses. The part after a package's [/] is what is checked. *)
|
|
let capitalised seg =
|
|
let base =
|
|
match String.rindex_opt seg '/' with
|
|
| Some i -> String.sub seg (i + 1) (String.length seg - i - 1)
|
|
| None -> seg
|
|
in
|
|
base <> "" && base.[0] >= 'A' && base.[0] <= 'Z'
|
|
|
|
let split_fields text =
|
|
if text = "" || text.[0] = '.' then [ text ]
|
|
else
|
|
let segs = String.split_on_char '.' text in
|
|
if List.length segs < 2 || List.mem "" segs || capitalised (List.hd segs)
|
|
then [ text ]
|
|
else segs
|
|
|
|
(* ── Lexing ────────────────────────────────────────────────────────── *)
|
|
|
|
let lex ~file src : token list =
|
|
let st = Reader.of_string ~file src in
|
|
let out = ref [] in
|
|
let sp = ref true in
|
|
let line_start = ref true in
|
|
let tab = ref None in
|
|
let emit tok loc = out := { tok; loc; sp = !sp } :: !out; sp := false in
|
|
let piece line col len =
|
|
{ (Loc.make file line col) with Loc.eline = line; ecol = col + len }
|
|
in
|
|
let name_run () =
|
|
let l0 = Reader.here st in
|
|
let text = Reader.take_while st (fun c -> not (Reader.is_delimiter c)) in
|
|
let n = String.length text in
|
|
let line = l0.Loc.line and col = l0.Loc.col in
|
|
if n = 0 then
|
|
failk "unexpected-character" l0 "unexpected character %C" (Reader.peek st);
|
|
if text = ":" then emit COLON (piece line col 1)
|
|
else if text.[0] = ':' then emit (KW (String.sub text 1 (n - 1))) (piece line col n)
|
|
else begin
|
|
let body, colon =
|
|
if text.[n - 1] = ':' then (String.sub text 0 (n - 1), true)
|
|
else (text, false)
|
|
in
|
|
let bn = String.length body in
|
|
let bcol, body =
|
|
if bn > 1 && body.[0] = '-' && is_neg_char body.[1] then begin
|
|
emit NEG (piece line col 1);
|
|
(col + 1, String.sub body 1 (bn - 1))
|
|
end
|
|
else (col, body)
|
|
in
|
|
let off = ref 0 in
|
|
List.iteri
|
|
(fun i seg ->
|
|
let s = if i = 0 then seg else "." ^ seg in
|
|
emit (NAME s) (piece line (bcol + !off) (String.length s));
|
|
off := !off + String.length s)
|
|
(split_fields body);
|
|
if colon then emit COLON (piece line (col + n - 1) 1)
|
|
end
|
|
in
|
|
let token c =
|
|
let l0 = Reader.here st in
|
|
let simple t = Reader.advance st; emit t (Loc.upto l0 (Reader.here st)) in
|
|
match c with
|
|
| '(' -> simple LP | ')' -> simple RP
|
|
| '[' -> simple LB | ']' -> simple RB
|
|
| '{' -> simple LC | '}' -> simple RC
|
|
| ',' -> simple COMMA
|
|
| '"' -> let f = Reader.read_string st in emit (ATOM f.v) f.loc
|
|
| '\\' -> let f = Reader.read_byte st in emit (ATOM f.v) f.loc
|
|
(* The paren reader reads the quoted datum whole, so ['(a (b c))] is the
|
|
Lisp list it always was and nothing here re-invents it. *)
|
|
| '\'' -> let f = Reader.read_form st in emit (DATUM f) f.loc
|
|
| '`' ->
|
|
failk "backquote" l0
|
|
"` is not read in a .fln file. A quasiquote is quote followed by an \
|
|
indented block, or quasiquote(x) on one line"
|
|
| '~' ->
|
|
Reader.advance st;
|
|
if Reader.peek st = '@' then begin
|
|
Reader.advance st;
|
|
emit SPLICE (Loc.upto l0 (Reader.here st))
|
|
end
|
|
else emit UNQ (Loc.upto l0 (Reader.here st))
|
|
| c when Reader.is_digit c
|
|
|| ((c = '-' || c = '+') && Reader.is_digit (Reader.peek2 st)) ->
|
|
let f = Reader.read_number st in
|
|
emit (ATOM f.v) f.loc
|
|
| _ -> name_run ()
|
|
in
|
|
let rec go () =
|
|
if not (Reader.at_end st) then
|
|
match Reader.peek st with
|
|
| ' ' | '\r' -> Reader.advance st; sp := true; go ()
|
|
| '\t' ->
|
|
if !line_start && !tab = None then tab := Some (Reader.here st);
|
|
Reader.advance st; sp := true; go ()
|
|
| '\n' ->
|
|
Reader.advance st; sp := true; line_start := true; tab := None; go ()
|
|
| ';' ->
|
|
while (not (Reader.at_end st)) && Reader.peek st <> '\n' do
|
|
Reader.advance st
|
|
done;
|
|
go ()
|
|
| c ->
|
|
(match !tab with
|
|
| Some l when !line_start ->
|
|
failk "tab" l
|
|
"this line is indented with a tab. Indentation in a .fln file is \
|
|
measured in columns, and a tab has no one width, so only spaces \
|
|
indent. Replace the tab with spaces"
|
|
| _ -> ());
|
|
line_start := false;
|
|
token c;
|
|
go ()
|
|
in
|
|
go ();
|
|
List.rev !out
|
|
|
|
(* ── Layout ────────────────────────────────────────────────────────── *)
|
|
|
|
let point (l : Loc.t) = { l with Loc.line = l.Loc.eline; col = l.Loc.ecol }
|
|
|
|
(* NEWLINE, INDENT and DEDENT, at bracket depth zero only: inside ( [ { a
|
|
line break is whitespace. A line continues the one before it when either
|
|
side of the break is a spaced binary operator (spec §2 "Continuation"). *)
|
|
let layout ?(base = 1) (toks : token list) : token array =
|
|
let arr = Array.of_list toks in
|
|
let n = Array.length arr in
|
|
let out = ref [] in
|
|
let add tok loc = out := { tok; loc; sp = true } :: !out in
|
|
let stack = ref [ base ] in
|
|
let depth = ref 0 in
|
|
let binop t = match t.tok with NAME s -> is_binop s | _ -> false in
|
|
for i = 0 to n - 1 do
|
|
let t = arr.(i) in
|
|
(if i = 0 then begin
|
|
if t.loc.Loc.col <> base then
|
|
failk "unexpected-indent" t.loc
|
|
"the first line starts at column %d, and a file's top-level lines \
|
|
start at column %d. Remove the indentation"
|
|
t.loc.Loc.col base
|
|
end
|
|
else
|
|
let p = arr.(i - 1) in
|
|
if !depth = 0 && t.loc.Loc.line > p.loc.Loc.eline then begin
|
|
let spaced_after =
|
|
i + 1 < n && arr.(i + 1).loc.Loc.line = t.loc.Loc.line
|
|
&& arr.(i + 1).sp
|
|
in
|
|
let continues = (binop p && p.sp) || (binop t && spaced_after) in
|
|
if not continues then begin
|
|
let at = point p.loc in
|
|
add NEWLINE at;
|
|
let col = t.loc.Loc.col in
|
|
let top = List.hd !stack in
|
|
if col > top then begin
|
|
stack := col :: !stack;
|
|
add INDENT at
|
|
end
|
|
else if col < top then begin
|
|
let rec pop () =
|
|
match !stack with
|
|
| top :: (_ :: _ as rest) when col < top ->
|
|
stack := rest; add DEDENT at; pop ()
|
|
| _ -> ()
|
|
in
|
|
pop ();
|
|
if col <> List.hd !stack then
|
|
failk "dedent" t.loc
|
|
"this line starts at column %d, which is not where any \
|
|
enclosing block starts — those start at column%s %s. Line \
|
|
it up with one of them"
|
|
col
|
|
(if List.length !stack > 1 then "s" else "")
|
|
(String.concat ", "
|
|
(List.rev_map string_of_int !stack))
|
|
end
|
|
end
|
|
end);
|
|
out := t :: !out;
|
|
(match t.tok with
|
|
| LP | LB | LC -> incr depth
|
|
| RP | RB | RC -> if !depth > 0 then decr depth
|
|
| _ -> ())
|
|
done;
|
|
(if n > 0 then
|
|
let at = point arr.(n - 1).loc in
|
|
add NEWLINE at;
|
|
List.iter (fun _ -> add DEDENT at) (List.tl !stack));
|
|
let eof_loc = if n > 0 then point arr.(n - 1).loc else Loc.unknown in
|
|
add EOF eof_loc;
|
|
Array.of_list (List.rev !out)
|
|
|
|
(* ── Parsing ───────────────────────────────────────────────────────── *)
|
|
|
|
type p = { toks : token array; mutable i : int }
|
|
|
|
let peek p = p.toks.(p.i)
|
|
let peek_at p k = p.toks.(min (p.i + k) (Array.length p.toks - 1))
|
|
let advance p =
|
|
let t = peek p in
|
|
if t.tok <> EOF then p.i <- p.i + 1;
|
|
t
|
|
let last p = p.toks.(max 0 (p.i - 1))
|
|
|
|
(* From [l] to the end of the last token consumed. *)
|
|
let span p (l : Loc.t) =
|
|
let e = (last p).loc in
|
|
if e.Loc.eline > l.Loc.line
|
|
|| (e.Loc.eline = l.Loc.line && e.Loc.ecol > l.Loc.col)
|
|
then { l with Loc.eline = e.Loc.eline; ecol = e.Loc.ecol }
|
|
else l
|
|
|
|
let mk p l v = Form.make v (span p l)
|
|
let sym l s = Form.make (Form.Sym s) l
|
|
|
|
(* Where a stray token is, pointing at the real token after a layout one. *)
|
|
let where_ p =
|
|
let t = peek p in
|
|
match t.tok with
|
|
| NEWLINE | INDENT | DEDENT -> (peek_at p 1).loc
|
|
| _ -> t.loc
|
|
|
|
let starts_value = function
|
|
| NAME _ | KW _ | ATOM _ | DATUM _ | LP | LB | LC | UNQ | SPLICE | NEG -> true
|
|
| _ -> false
|
|
|
|
let ends_value = function
|
|
| RP | RB | RC | COMMA | NEWLINE | EOF | INDENT | DEDENT -> true
|
|
| _ -> false
|
|
|
|
let negative_literal = function
|
|
| ATOM (Form.Int i) -> Int64.compare i 0L < 0
|
|
| ATOM (Form.Float f) -> f < 0.
|
|
| _ -> false
|
|
|
|
(* Something followed a complete value where nothing may. The two shapes that
|
|
get their own sentence are the ones a Lisp hand writes: [a -1] and
|
|
[f (x)]. *)
|
|
let stray p ~after =
|
|
let t = peek p in
|
|
match t.tok with
|
|
| ATOM _ when t.sp && negative_literal t.tok ->
|
|
let text = show t.tok in
|
|
let digits = String.sub text 1 (String.length text - 1) in
|
|
failk "glued-minus" t.loc
|
|
"%s is read as the number %s, right after %s with nothing between them. \
|
|
To subtract, space the minus: %s - %s. For two values, separate them \
|
|
with a comma: %s, %s"
|
|
text text after after digits after text
|
|
| LP when t.sp ->
|
|
failk "spaced-call" t.loc
|
|
"there is a space before this (, so it does not call %s — a call has \
|
|
none. Write %s(...), or put a comma before the ( if it is a separate \
|
|
value"
|
|
after after
|
|
| LB when t.sp ->
|
|
failk "spaced-index" t.loc
|
|
"there is a space before this [, so it does not index %s — indexing has \
|
|
none. Write %s[i]"
|
|
after after
|
|
| NEWLINE | INDENT | DEDENT | EOF ->
|
|
failk "unexpected-end" (where_ p) "the line ends after %s, which is not \
|
|
finished here" after
|
|
| _ ->
|
|
failk "unexpected-token" t.loc
|
|
"%s follows %s, and two values cannot sit side by side here. Separate \
|
|
them with a comma, or join them with an operator"
|
|
(show t.tok) after
|
|
|
|
let expect p tok ~what =
|
|
let t = peek p in
|
|
if t.tok = tok then ignore (advance p)
|
|
else
|
|
failk "expected" (where_ p) "expected %s here, and found %s" what
|
|
(show t.tok)
|
|
|
|
let expect_name p s ~what =
|
|
match (peek p).tok with
|
|
| NAME n when n = s -> ignore (advance p)
|
|
| t -> failk "expected" (where_ p) "expected %s here, and found %s" what (show t)
|
|
|
|
(* The end of a line that is not followed by a block. *)
|
|
let expect_eol p ~after =
|
|
match (peek p).tok with
|
|
| NEWLINE ->
|
|
ignore (advance p);
|
|
if (peek p).tok = INDENT then
|
|
failk "stray-indent" (peek_at p 1).loc
|
|
"this line is indented under %s, which takes no block. A call takes \
|
|
an indented block only with a trailing colon, as in \
|
|
rl/with-drawing():"
|
|
after
|
|
| EOF -> ()
|
|
| _ -> stray p ~after
|
|
|
|
let check_name (t : token) s =
|
|
if String.contains s ':' then
|
|
failk "colon-in-name" t.loc
|
|
"%s has a colon inside it, and a name cannot. A type annotation puts a \
|
|
space after the colon: %s"
|
|
s
|
|
(match String.index_opt s ':' with
|
|
| Some i -> String.sub s 0 (i + 1) ^ " " ^ String.sub s (i + 1) (String.length s - i - 1)
|
|
| None -> s)
|
|
|
|
(* A form's own text, for the "after" half of a message. *)
|
|
let text_of (f : Form.t) =
|
|
let s = Form.to_source f in
|
|
if String.length s > 40 then String.sub s 0 37 ^ "..." else s
|
|
|
|
let unclosed p c l0 =
|
|
failk "unclosed" l0
|
|
~notes:[ Loc.note (where_ p) "the input ends here, still inside it" ]
|
|
"unclosed %C" c
|
|
|
|
let refuse_ws loc e =
|
|
failk "separate-elements" loc
|
|
"%s has an operator in it and sits in a list separated by spaces, where \
|
|
only single values are. Separate the elements with commas: [a - 1, b]"
|
|
(text_of e)
|
|
|
|
(* Expressions come back with their syntactic level: 10 an atom or a bracket,
|
|
9 a postfix chain, 8 a unary minus, 1-7 a binary operator's level, 3 a
|
|
[not], 0 a one-line [if] or a lambda. Anything under 8 is "compound": it
|
|
has an operator at its top, so it cannot sit in a list separated only by
|
|
whitespace. *)
|
|
let rec expr p : Form.t * int = binary p 1
|
|
|
|
and binary p lvl : Form.t * int =
|
|
if lvl = 3 then not_ p
|
|
else if lvl > 7 then unary p
|
|
else
|
|
let l0 = (peek p).loc in
|
|
let ((first, _) as fst_) = binary p (lvl + 1) in
|
|
let close op operands =
|
|
match List.rev operands with
|
|
| [ x ] -> (x, lvl)
|
|
| ops ->
|
|
if op = "!=" && List.length ops > 2 then
|
|
failk "chained-not-equal" l0
|
|
"a != b != c is not read. != with more than two values means all \
|
|
of them are distinct, which is not what the chain says, so it is \
|
|
written as a call: !=(a, b, c)";
|
|
(mk p l0 (Form.List (sym l0 (op_sym op) :: ops)), lvl)
|
|
in
|
|
(* An operator glued to a parenthesis is a call, [+(a, b)], and never
|
|
the operator between two values. *)
|
|
let binary_here s =
|
|
binop_level s = Some lvl
|
|
&& not ((peek_at p 1).tok = LP && not (peek_at p 1).sp)
|
|
in
|
|
let rec run op operands =
|
|
match (peek p).tok with
|
|
| NAME s when binary_here s ->
|
|
let ot = advance p in
|
|
if not (ot.sp && (peek p).sp) then
|
|
failk "unspaced-operator" ot.loc
|
|
"%s is an operator here, and a binary operator has a space on each \
|
|
side: a %s b. Without them a-b is one name"
|
|
s s;
|
|
let rhs, _ = binary p (lvl + 1) in
|
|
if s = op then run op (rhs :: operands)
|
|
else begin
|
|
if lvl = 4 then
|
|
failk "mixed-comparison" ot.loc
|
|
"%s follows %s in one chain, and a chain compares with one \
|
|
operator. Join the tests with and, or parenthesise one side"
|
|
s op;
|
|
let folded, _ = close op operands in
|
|
run s [ rhs; folded ]
|
|
end
|
|
| _ -> close op operands
|
|
in
|
|
(* [run] folds a different operator at the same level into the left
|
|
operand, so the first operator here only starts the first run. *)
|
|
match (peek p).tok with
|
|
| NAME s when binary_here s -> run s [ first ]
|
|
| _ -> fst_
|
|
|
|
and not_ p =
|
|
let t = peek p in
|
|
match t.tok with
|
|
| NAME "not" when (peek_at p 1).sp && starts_value (peek_at p 1).tok ->
|
|
ignore (advance p);
|
|
let x, _ = not_ p in
|
|
(mk p t.loc (Form.List [ sym t.loc "not"; x ]), 3)
|
|
| _ -> binary p 4
|
|
|
|
and unary p =
|
|
let t = peek p in
|
|
match t.tok with
|
|
| NEG ->
|
|
ignore (advance p);
|
|
let x, _ = postfix p in
|
|
(mk p t.loc (Form.List [ sym t.loc "-"; x ]), 8)
|
|
| _ -> postfix p
|
|
|
|
and postfix p =
|
|
let l0 = (peek p).loc in
|
|
let rec loop ((f, _) as fp) =
|
|
let t = peek p in
|
|
if t.sp then fp
|
|
else
|
|
match t.tok with
|
|
| LP ->
|
|
ignore (advance p);
|
|
let args = items p RP t.loc ~what:"arguments" in
|
|
loop (mk p l0 (Form.List (f :: args)), 9)
|
|
| LB ->
|
|
ignore (advance p);
|
|
let idx = items p RB t.loc ~what:"indices" in
|
|
loop (mk p l0 (Form.List (sym t.loc "at" :: f :: idx)), 9)
|
|
| NAME s when String.length s > 1 && s.[0] = '.' ->
|
|
ignore (advance p);
|
|
loop (mk p l0 (Form.List [ sym t.loc s; f ]), 9)
|
|
| LC ->
|
|
ignore (advance p);
|
|
let m = map_items p t.loc in
|
|
loop (mk p l0 (Form.List [ f; Form.make (Form.Map m) (span p t.loc) ]), 9)
|
|
| _ -> fp
|
|
in
|
|
loop (primary p)
|
|
|
|
and primary p : Form.t * int =
|
|
let t = peek p in
|
|
let l0 = t.loc in
|
|
match t.tok with
|
|
| NAME s ->
|
|
let nxt = peek_at p 1 in
|
|
let glued_lp = nxt.tok = LP && not nxt.sp in
|
|
if s = "if" && nxt.sp && starts_value nxt.tok then if_expr p
|
|
else if s = "fn" && glued_lp then fn_expr p
|
|
else if is_op_word s then begin
|
|
if glued_lp || ends_value nxt.tok then begin
|
|
ignore (advance p);
|
|
(sym l0 (op_sym s), 10)
|
|
end
|
|
else
|
|
failk "operator-operand" l0
|
|
"%s is an operator, and nothing is on its left. As a value on its \
|
|
own it goes before a comma or a closing bracket, reduce(%s, xs); \
|
|
as a call it is glued to its parenthesis, %s(a, b)"
|
|
s s s
|
|
end
|
|
else begin
|
|
ignore (advance p);
|
|
check_name t s;
|
|
(sym l0 s, 10)
|
|
end
|
|
| KW k -> ignore (advance p); (Form.make (Form.Kw k) l0, 10)
|
|
| ATOM v ->
|
|
ignore (advance p);
|
|
(Form.make v l0, if negative_literal t.tok then 8 else 10)
|
|
| DATUM f -> ignore (advance p); (f, 10)
|
|
| LP ->
|
|
ignore (advance p);
|
|
if (peek p).tok = RP then begin
|
|
ignore (advance p);
|
|
(mk p l0 (Form.List []), 10)
|
|
end
|
|
else
|
|
let e, _ = expr p in
|
|
(match (peek p).tok with
|
|
| RP -> ignore (advance p)
|
|
| EOF -> unclosed p '(' l0
|
|
| _ -> stray p ~after:(text_of e));
|
|
(e, 10)
|
|
| LB ->
|
|
ignore (advance p);
|
|
let xs = vec_items p l0 in
|
|
(mk p l0 (Form.Vec xs), 10)
|
|
| LC ->
|
|
ignore (advance p);
|
|
let xs = map_items p l0 in
|
|
(mk p l0 (Form.Map xs), 10)
|
|
| UNQ | SPLICE ->
|
|
ignore (advance p);
|
|
let x, _ = primary p in
|
|
let name = if t.tok = UNQ then "unquote" else "unquote-splicing" in
|
|
(mk p l0 (Form.List [ sym l0 name; x ]), 10)
|
|
| NEG -> unary p
|
|
| tk ->
|
|
failk "expected-value" (where_ p) "expected a value here, and found %s"
|
|
(show tk)
|
|
|
|
(* [if c then a else b]: the one-line form, for a value. *)
|
|
and if_expr p =
|
|
let t = advance p in
|
|
let c, _ = binary p 1 in
|
|
(match (peek p).tok with
|
|
| NAME "then" -> ignore (advance p)
|
|
| _ ->
|
|
failk "if-then" (where_ p)
|
|
"an if inside a line is if c then a else b, and there is no then \
|
|
after %s. Write the then, or start the if on its own line with its \
|
|
branches indented under it"
|
|
(text_of c));
|
|
let a, _ = binary p 1 in
|
|
match (peek p).tok with
|
|
| NAME "else" ->
|
|
ignore (advance p);
|
|
let b, _ = expr p in
|
|
(mk p t.loc (Form.List [ sym t.loc "if"; c; a; b ]), 0)
|
|
| _ -> (mk p t.loc (Form.List [ sym t.loc "when"; c; a ]), 0)
|
|
|
|
(* [fn(a, b) = body] is a lambda; [fn(...)] followed by anything else is the
|
|
fallback call spelling of [(fn ...)]. *)
|
|
and fn_expr p =
|
|
let t = advance p in
|
|
let lp = advance p in
|
|
let args = items p RP lp.loc ~what:"parameters" in
|
|
match (peek p).tok with
|
|
| NAME "=" ->
|
|
ignore (advance p);
|
|
let ps = lambda_params args in
|
|
let body, _ = expr p in
|
|
(mk p t.loc
|
|
(Form.List
|
|
[ sym t.loc "fn"; Form.make (Form.Vec ps) (span_of_list lp.loc args); body ]),
|
|
0)
|
|
| _ -> (mk p t.loc (Form.List (sym t.loc "fn" :: args)), 9)
|
|
|
|
and span_of_list l args =
|
|
match List.rev args with
|
|
| [] -> l
|
|
| (x : Form.t) :: _ -> { l with Loc.eline = x.loc.Loc.eline; ecol = x.loc.Loc.ecol }
|
|
|
|
and lambda_params args =
|
|
List.map
|
|
(fun (a : Form.t) ->
|
|
match a.v with
|
|
| Form.Sym _ -> a
|
|
| _ ->
|
|
failk "lambda-param" a.loc
|
|
"a lambda's parameter is a name, and this is %s. Take the value \
|
|
under a name and destructure it in the body"
|
|
(text_of a))
|
|
args
|
|
|
|
(* Comma-separated values up to [closer]. [const T] is two elements without a
|
|
comma, for [Ptr(const u8)]: const is a reserved word in a type and never a
|
|
value. *)
|
|
and items p closer open_loc ~what =
|
|
let opener = if closer = RB then '[' else '(' in
|
|
let rec go acc =
|
|
let t = peek p in
|
|
if t.tok = closer then (ignore (advance p); List.rev acc)
|
|
else if t.tok = EOF then unclosed p opener open_loc
|
|
else
|
|
match t.tok, peek_at p 1 with
|
|
| NAME "const", n when n.sp && starts_value n.tok ->
|
|
ignore (advance p);
|
|
go (sym t.loc "const" :: acc)
|
|
| _ ->
|
|
let e, _ = expr p in
|
|
(match (peek p).tok with
|
|
| COMMA -> ignore (advance p); go (e :: acc)
|
|
| tk when tk = closer -> ignore (advance p); List.rev (e :: acc)
|
|
| EOF -> unclosed p opener open_loc
|
|
| _ ->
|
|
let n = peek p in
|
|
if starts_value n.tok && n.sp && not (negative_literal n.tok) then
|
|
failk "missing-comma" n.loc
|
|
"%s follows %s with no comma between them. Separate %s with \
|
|
commas: f(a, b)"
|
|
(show n.tok) (text_of e) what
|
|
else stray p ~after:(text_of e))
|
|
in
|
|
go []
|
|
|
|
(* [[a b c]] or [[a, b + 1]]: whitespace separates only single terms. *)
|
|
and vec_items p open_loc =
|
|
let rec go acc prev_ws =
|
|
let t = peek p in
|
|
match t.tok with
|
|
| RB -> ignore (advance p); List.rev acc
|
|
| EOF -> unclosed p '[' open_loc
|
|
| _ ->
|
|
let e, lvl = expr p in
|
|
if lvl < 8 && prev_ws then refuse_ws t.loc e;
|
|
(match (peek p).tok with
|
|
| COMMA -> ignore (advance p); go (e :: acc) false
|
|
| RB -> ignore (advance p); List.rev (e :: acc)
|
|
| EOF -> unclosed p '[' open_loc
|
|
| tk when starts_value tk && (peek p).sp ->
|
|
if lvl < 8 then refuse_ws t.loc e;
|
|
go (e :: acc) true
|
|
| _ -> stray p ~after:(text_of e))
|
|
in
|
|
go [] false
|
|
|
|
(* Braces pair a key with a value, so a value may be any expression; after
|
|
one that has an operator in it, the next entry needs a comma. *)
|
|
and map_items p open_loc =
|
|
let rec go acc =
|
|
let t = peek p in
|
|
match t.tok with
|
|
| RC -> ignore (advance p); List.rev acc
|
|
| EOF -> unclosed p '{' open_loc
|
|
| _ ->
|
|
let e, lvl = expr p in
|
|
(match (peek p).tok with
|
|
| COMMA -> ignore (advance p); go (e :: acc)
|
|
| RC -> ignore (advance p); List.rev (e :: acc)
|
|
| EOF -> unclosed p '{' open_loc
|
|
| tk when starts_value tk && (peek p).sp ->
|
|
if lvl < 8 then refuse_ws t.loc e;
|
|
go (e :: acc)
|
|
| _ -> stray p ~after:(text_of e))
|
|
in
|
|
go []
|
|
|
|
|
|
(* A type after [:] or [->]: a postfix term, plus the arrow of a function
|
|
type, [Fn(A, B) -> R], which reads as [(Fn [A B] R)]. *)
|
|
let rec ty p : Form.t =
|
|
let l0 = (peek p).loc in
|
|
let f, _ = postfix p in
|
|
match f.v, (peek p).tok with
|
|
| Form.List (({ v = Form.Sym ("Fn" | "CFn"); _ } as h) :: args), NAME "->"
|
|
when (last p).tok = RP ->
|
|
ignore (advance p);
|
|
let r = ty p in
|
|
mk p l0 (Form.List [ h; Form.make (Form.Vec args) h.loc; r ])
|
|
| _ -> f
|
|
|
|
(* ── Statements ────────────────────────────────────────────────────── *)
|
|
|
|
(* The let-statements this reader built, so that a [let] whose whole body is
|
|
another one merges into one binding vector (spec §2), and a [let] written
|
|
as a call does not. *)
|
|
type st = { p : p; mutable lets : Form.t list }
|
|
|
|
let blk (s : st) l (ss : Form.t list) =
|
|
match ss with
|
|
| [ x ] -> x
|
|
| _ -> mk s.p l (Form.List (sym l "do" :: ss))
|
|
|
|
let is_lambda_candidate (e : Form.t) =
|
|
match e.v with
|
|
| Form.List ({ v = Form.Sym "fn"; _ } :: args) ->
|
|
List.for_all (fun (a : Form.t) -> match a.v with Form.Sym _ -> true | _ -> false) args
|
|
| _ -> false
|
|
|
|
let header_follow p s =
|
|
let n = peek_at p 1 in
|
|
let plain_name = function
|
|
| NAME x -> not (is_op_word x || x = "=" || List.mem_assoc x assign_ops)
|
|
| _ -> false
|
|
in
|
|
match s with
|
|
| "fn" | "fn-" | "def" | "once" | "const" | "struct" | "union" | "data"
|
|
| "enum" | "import" ->
|
|
n.sp && plain_name n.tok
|
|
| "if" | "while" | "until" | "match" | "let" | "for" ->
|
|
n.sp && starts_value n.tok
|
|
&& (match n.tok with
|
|
| NAME x when x = "=" || List.mem_assoc x assign_ops -> false
|
|
| NAME x when is_binop x ->
|
|
let a = peek_at p 2 in
|
|
a.tok = LP && not a.sp
|
|
| _ -> true)
|
|
| "return" -> n.tok = NEWLINE || (n.sp && starts_value n.tok)
|
|
| "break" | "continue" ->
|
|
n.tok = NEWLINE || (n.sp && (match n.tok with KW _ -> true | _ -> false))
|
|
| "defer" ->
|
|
(n.tok = NEWLINE && (peek_at p 2).tok = INDENT) || (n.sp && starts_value n.tok)
|
|
| "handler-case" | "handler-bind" | "restart-case" -> n.tok = NEWLINE
|
|
| "quote" -> n.tok = NEWLINE && (peek_at p 2).tok = INDENT
|
|
| _ -> false
|
|
|
|
let name_tok p ~what =
|
|
let t = peek p in
|
|
match t.tok with
|
|
| NAME s when not (String.length s > 0 && s.[0] = '.') ->
|
|
ignore (advance p);
|
|
check_name t s;
|
|
sym t.loc s
|
|
| tk -> failk "expected-name" (where_ p) "expected %s here, and found %s" what (show tk)
|
|
|
|
let glued_lp p ~what =
|
|
let t = peek p in
|
|
if t.tok = LP && not t.sp then advance p
|
|
else failk "expected" (where_ p) "expected %s here, and found %s" what (show t.tok)
|
|
|
|
(* [(a: i32, b)] as name/type pairs, [dyn] written out for the untyped: the
|
|
reader never leaves a vector for [Check.pair_params] to guess at. *)
|
|
let params p (lp : token) =
|
|
let rec go acc =
|
|
let t = peek p in
|
|
match t.tok with
|
|
| RP -> ignore (advance p); List.rev acc
|
|
| EOF -> unclosed p '(' lp.loc
|
|
| _ ->
|
|
let n = name_tok p ~what:"a parameter's name" in
|
|
let tyf =
|
|
match (peek p).tok with
|
|
| COLON -> ignore (advance p); ty p
|
|
| _ -> sym n.loc "dyn"
|
|
in
|
|
(match (peek p).tok with
|
|
| COMMA -> ignore (advance p)
|
|
| RP -> ()
|
|
| _ -> stray p ~after:(text_of tyf));
|
|
go (tyf :: n :: acc)
|
|
in
|
|
go []
|
|
|
|
let rec stmts (s : st) : Form.t list =
|
|
let p = s.p in
|
|
match (peek p).tok with
|
|
| DEDENT -> ignore (advance p); []
|
|
| EOF -> []
|
|
| NAME "let" when header_follow p "let" -> let_stmt s
|
|
| _ ->
|
|
let f = stmt s in
|
|
f :: stmts s
|
|
|
|
and block (s : st) ~after : Form.t list =
|
|
let p = s.p in
|
|
match (peek p).tok with
|
|
| INDENT -> ignore (advance p); stmts s
|
|
| _ ->
|
|
failk "expected-block" (where_ p)
|
|
"%s takes an indented block on the lines under it, and the next line is \
|
|
not indented"
|
|
after
|
|
|
|
(* The rest of a line read as a value, through its end: [= v], or [=] and an
|
|
indented block that reduces to one form, or a lambda with a block body. *)
|
|
and value_line ?(block_ok = false) (s : st) ~after : Form.t =
|
|
let p = s.p in
|
|
let l0 = where_ p in
|
|
if (peek p).tok = NEWLINE && (peek_at p 1).tok = INDENT then begin
|
|
ignore (advance p);
|
|
blk s l0 (block s ~after)
|
|
end
|
|
else
|
|
let e, _ = expr p in
|
|
lambda_block ~block_ok s e ~after:(text_of e)
|
|
|
|
and lambda_block ?(block_ok = false) (s : st) (e : Form.t) ~after =
|
|
let p = s.p in
|
|
if is_lambda_candidate e && (last p).tok = RP && (peek p).tok = NEWLINE
|
|
&& (peek_at p 1).tok = INDENT
|
|
then begin
|
|
ignore (advance p);
|
|
let body = block s ~after in
|
|
match e.v with
|
|
| Form.List (h :: args) ->
|
|
mk p e.loc
|
|
(Form.List (h :: Form.make (Form.Vec args) (span_of_list e.loc args) :: body))
|
|
| _ -> assert false
|
|
end
|
|
else begin
|
|
if block_ok && (peek p).tok = NEWLINE then ignore (advance p)
|
|
else expect_eol p ~after;
|
|
e
|
|
end
|
|
|
|
and let_stmt (s : st) : Form.t list =
|
|
let p = s.p in
|
|
let t = advance p in
|
|
let target, _ = unary p in
|
|
(match (peek p).tok with
|
|
| NAME "=" -> ignore (advance p)
|
|
| _ ->
|
|
failk "let-equals" (where_ p)
|
|
"a let is let name = value, and %s is not followed by =" (text_of target));
|
|
let v = value_line ~block_ok:true s ~after:("let " ^ text_of target) in
|
|
let make bindings body =
|
|
let f =
|
|
mk p t.loc
|
|
(Form.List
|
|
(sym t.loc "let" :: Form.make (Form.Vec bindings) (span_of_list target.loc bindings)
|
|
:: body))
|
|
in
|
|
s.lets <- f :: s.lets;
|
|
f
|
|
in
|
|
let merged body =
|
|
match body with
|
|
| [ ({ Form.v = Form.List (_ :: { v = Form.Vec bs; _ } :: body); _ } as inner) ]
|
|
when List.memq inner s.lets ->
|
|
make (target :: v :: bs) body
|
|
| _ -> make [ target; v ] body
|
|
in
|
|
if (peek p).tok = INDENT then begin
|
|
let f = merged (block s ~after:"let") in
|
|
f :: stmts s
|
|
end
|
|
else [ merged (stmts s) ]
|
|
|
|
and stmt (s : st) : Form.t =
|
|
let p = s.p in
|
|
let t = peek p in
|
|
match t.tok with
|
|
| NAME w when header_follow p w -> header s w
|
|
| NAME (("else" | "elif") as w) ->
|
|
failk "orphan-else" t.loc
|
|
"%s is not under an if at this column. It goes at the same column as \
|
|
the if it belongs to, right after that if's block"
|
|
w
|
|
| _ -> expr_stmt s
|
|
|
|
and expr_stmt (s : st) : Form.t =
|
|
let p = s.p in
|
|
let i0 = p.i in
|
|
let t0 = peek p in
|
|
let e, _ = expr p in
|
|
match (peek p).tok with
|
|
| NAME "=" ->
|
|
let eq = advance p in
|
|
let v = value_line s ~after:(text_of e ^ " =") in
|
|
mk p t0.loc (Form.List [ sym eq.loc "set"; e; v ])
|
|
| NAME op when List.mem_assoc op assign_ops ->
|
|
let eq = advance p in
|
|
let v = value_line s ~after:(text_of e ^ " " ^ op) in
|
|
let o = List.assoc op assign_ops in
|
|
mk p t0.loc
|
|
(Form.List
|
|
[ sym eq.loc "set"; e;
|
|
Form.make (Form.List [ sym eq.loc o; e; v ]) (span p e.loc) ])
|
|
| COLON ->
|
|
let before = (last p).tok in
|
|
let c = advance p in
|
|
(match e.v, before with
|
|
| Form.List (_ :: _), RP -> ()
|
|
| _ ->
|
|
failk "colon-block" c.loc
|
|
"a trailing colon gives a call an indented block, and %s is not a \
|
|
call. Write it as one, as in %s():"
|
|
(text_of e) (text_of e));
|
|
(match (peek p).tok with
|
|
| NEWLINE -> ignore (advance p)
|
|
| _ -> stray p ~after:":");
|
|
let body = block s ~after:(text_of e ^ ":") in
|
|
(match e.v with
|
|
| Form.List items -> mk p t0.loc (Form.List (items @ body))
|
|
| _ -> assert false)
|
|
| _ ->
|
|
(* [()] alone on a line is the empty statement, spec §2 "Unit". *)
|
|
let e =
|
|
if p.i - i0 = 2 && t0.tok = LP && e.v = Form.List [] then
|
|
Form.make (Form.List [ sym t0.loc "do" ]) e.loc
|
|
else e
|
|
in
|
|
lambda_block s e ~after:(text_of e)
|
|
|
|
and header (s : st) w : Form.t =
|
|
let p = s.p in
|
|
let t = advance p in
|
|
let l0 = t.loc in
|
|
let form items = mk p l0 (Form.List (sym l0 w :: items)) in
|
|
let named head items = mk p l0 (Form.List (sym l0 head :: items)) in
|
|
match w with
|
|
| "fn" | "fn-" ->
|
|
let name = name_tok p ~what:"the function's name" in
|
|
let lp = glued_lp p ~what:"the parameters, in parentheses glued to the name" in
|
|
let ps = params p lp in
|
|
let rp = last p in
|
|
let ret =
|
|
match (peek p).tok with
|
|
| NAME "->" -> ignore (advance p); ty p
|
|
| _ ->
|
|
let n = match name.v with Form.Sym n -> n | _ -> "" in
|
|
failk "return-type" rp.loc
|
|
"fn %s has no return type after its parameters, and a .fln \
|
|
function states one for now. Write it after an arrow: fn %s(...) \
|
|
-> i32, or -> dyn, or -> () when it returns nothing"
|
|
n n
|
|
in
|
|
let where_clause =
|
|
match (peek p).tok with
|
|
| NAME "where" ->
|
|
let wt = advance p in
|
|
let rec preds acc =
|
|
let e, _ = expr p in
|
|
match (peek p).tok with
|
|
| COMMA -> ignore (advance p); preds (e :: acc)
|
|
| _ -> List.rev (e :: acc)
|
|
in
|
|
let es = preds [] in
|
|
let v =
|
|
match es with
|
|
| [ e ] -> e
|
|
| _ -> Form.make (Form.Vec es) (span p wt.loc)
|
|
in
|
|
[ mk p wt.loc (Form.Map [ Form.make (Form.Kw "where") wt.loc; v ]) ]
|
|
| _ -> []
|
|
in
|
|
let body =
|
|
match (peek p).tok with
|
|
| NAME "=" ->
|
|
ignore (advance p);
|
|
if (peek p).tok = NEWLINE && (peek_at p 1).tok = INDENT then begin
|
|
ignore (advance p);
|
|
block s ~after:"fn"
|
|
end
|
|
else [ value_line s ~after:"=" ]
|
|
| NEWLINE ->
|
|
ignore (advance p);
|
|
if (peek p).tok = INDENT then block s ~after:"fn" else []
|
|
| _ -> stray p ~after:(text_of ret)
|
|
in
|
|
named (if w = "fn" then "defn" else "defn-")
|
|
(name :: Form.make (Form.Vec ps) lp.loc :: ret :: (where_clause @ body))
|
|
| "def" | "once" | "const" ->
|
|
let name = name_tok p ~what:"the name being defined" in
|
|
let tyf =
|
|
match (peek p).tok with
|
|
| COLON -> ignore (advance p); Some (ty p)
|
|
| _ -> None
|
|
in
|
|
let v =
|
|
match (peek p).tok with
|
|
| NAME "=" ->
|
|
ignore (advance p);
|
|
Some (value_line s ~after:(w ^ " " ^ text_of name ^ " ="))
|
|
| _ ->
|
|
expect_eol p ~after:(match tyf with Some f -> text_of f | None -> text_of name);
|
|
None
|
|
in
|
|
let head =
|
|
match w with "def" -> "def" | "once" -> "defonce" | _ -> "defconst"
|
|
in
|
|
let items =
|
|
match w, tyf, v with
|
|
| "const", None, Some v -> [ name; v ]
|
|
| "const", Some t, Some v -> [ name; t; v ]
|
|
| "const", _, None ->
|
|
failk "const-value" l0
|
|
"a const needs its value: const %s = 3" (text_of name)
|
|
| _, None, Some v -> [ name; sym name.loc "dyn"; v ]
|
|
| _, Some t, None -> [ name; t ]
|
|
| _, Some t, Some v -> [ name; t; v ]
|
|
| _, None, None ->
|
|
failk "def-empty" l0
|
|
"%s %s names neither a type nor a value. Give it one or both: %s %s: \
|
|
i32 = 0"
|
|
w (text_of name) w (text_of name)
|
|
in
|
|
named head items
|
|
| "struct" | "union" ->
|
|
let name = name_tok p ~what:"the type's name" in
|
|
expect_eol_block p ~after:(w ^ " " ^ text_of name);
|
|
let fields =
|
|
lines s (fun () ->
|
|
let f = name_tok p ~what:"a field's name" in
|
|
let tf =
|
|
match (peek p).tok with
|
|
| COLON -> ignore (advance p); ty p
|
|
| _ -> sym f.loc "dyn"
|
|
in
|
|
expect_eol p ~after:(text_of tf);
|
|
[ f; tf ])
|
|
in
|
|
named (if w = "struct" then "defstruct" else "defunion")
|
|
[ name; Form.make (Form.Vec fields) (span p name.loc) ]
|
|
| "data" ->
|
|
let name = name_tok p ~what:"the type's name" in
|
|
expect_eol_block p ~after:("data " ^ text_of name);
|
|
let cases =
|
|
lines s (fun () ->
|
|
let c = name_tok p ~what:"a case's name" in
|
|
let f =
|
|
match (peek p).tok with
|
|
| LP when not (peek p).sp ->
|
|
let lp = advance p in
|
|
let ps = params p lp in
|
|
mk p c.loc (Form.List [ c; Form.make (Form.Vec ps) lp.loc ])
|
|
| _ -> c
|
|
in
|
|
expect_eol p ~after:(text_of f);
|
|
[ f ])
|
|
in
|
|
named "defdata" [ name; Form.make (Form.Vec cases) (span p name.loc) ]
|
|
| "enum" ->
|
|
let name = name_tok p ~what:"the enum's name" in
|
|
expect_eol_block p ~after:("enum " ^ text_of name);
|
|
let members =
|
|
lines s (fun () ->
|
|
let m = name_tok p ~what:"a member's name" in
|
|
match (peek p).tok with
|
|
| NAME "=" ->
|
|
ignore (advance p);
|
|
let v, _ = unary p in
|
|
expect_eol p ~after:(text_of v);
|
|
[ m; v ]
|
|
| _ -> expect_eol p ~after:(text_of m); [ m ])
|
|
in
|
|
named "defenum" [ name; Form.make (Form.Vec members) (span p name.loc) ]
|
|
| "import" ->
|
|
let alias = name_tok p ~what:"the package's alias" in
|
|
let path =
|
|
match (peek p).tok with
|
|
| ATOM (Form.Str _ as v) -> let pt = advance p in Form.make v pt.loc
|
|
| tk ->
|
|
failk "import-path" (where_ p)
|
|
"an import is import alias \"collection:path\", and found %s where \
|
|
the path goes"
|
|
(show tk)
|
|
in
|
|
expect_eol p ~after:(text_of path);
|
|
form [ alias; path ]
|
|
| "if" ->
|
|
let c, _ = binary p 1 in
|
|
(match (peek p).tok with
|
|
| NAME "then" ->
|
|
ignore (advance p);
|
|
let a, _ = binary p 1 in
|
|
let f =
|
|
match (peek p).tok with
|
|
| NAME "else" ->
|
|
ignore (advance p);
|
|
let b, _ = expr p in
|
|
form [ c; a; b ]
|
|
| _ -> named "when" [ c; a ]
|
|
in
|
|
expect_eol p ~after:(text_of f);
|
|
f
|
|
| _ ->
|
|
expect_line_end p ~after:("if " ^ text_of c);
|
|
let body = block s ~after:("if " ^ text_of c) in
|
|
let rec elifs acc =
|
|
match (peek p).tok with
|
|
| NAME "elif" ->
|
|
ignore (advance p);
|
|
let c, _ = binary p 1 in
|
|
expect_line_end p ~after:("elif " ^ text_of c);
|
|
let b = block s ~after:"elif" in
|
|
elifs ((c, b) :: acc)
|
|
| _ -> List.rev acc
|
|
in
|
|
let els_ = elifs [] in
|
|
let else_ =
|
|
match (peek p).tok with
|
|
| NAME "else" ->
|
|
let et = advance p in
|
|
(match (peek p).tok with
|
|
| NEWLINE -> ignore (advance p)
|
|
| NAME "if" ->
|
|
failk "else-if" (where_ p)
|
|
"else takes its block on the lines under it. For another test \
|
|
at this level, write elif c"
|
|
| _ -> stray p ~after:"else");
|
|
Some (et.loc, block s ~after:"else")
|
|
| _ -> None
|
|
in
|
|
(match els_, else_ with
|
|
| [], None -> named "when" (c :: body)
|
|
| [], Some (el, e) -> form [ c; blk s l0 body; blk s el e ]
|
|
| _ ->
|
|
let pairs =
|
|
List.concat_map (fun (c, b) -> [ c; blk s c.Form.loc b ]) ((c, body) :: els_)
|
|
in
|
|
let tail =
|
|
match else_ with
|
|
| Some (el, e) -> [ Form.make (Form.Kw "else") el; blk s el e ]
|
|
| None -> []
|
|
in
|
|
named "cond" (pairs @ tail)))
|
|
| "while" | "until" ->
|
|
let label =
|
|
match (peek p).tok, (peek_at p 1).tok with
|
|
| KW k, n when n <> NEWLINE -> let kt = advance p in [ Form.make (Form.Kw k) kt.loc ]
|
|
| _ -> []
|
|
in
|
|
let c, _ = expr p in
|
|
expect_line_end p ~after:(w ^ " " ^ text_of c);
|
|
let body = block s ~after:w in
|
|
form (label @ (c :: body))
|
|
| "for" ->
|
|
let label =
|
|
match (peek p).tok with
|
|
| KW k -> let kt = advance p in [ Form.make (Form.Kw k) kt.loc ]
|
|
| _ -> []
|
|
in
|
|
let v = name_tok p ~what:"the loop variable" in
|
|
expect_name p "in" ~what:"in, as in for i in range(n)";
|
|
let rt = peek p in
|
|
expect_name p "range" ~what:"range(n), range(a, b) or range(a, b, step)";
|
|
let lp = glued_lp p ~what:"range's bounds in parentheses" in
|
|
let bs = items p RP lp.loc ~what:"bounds" in
|
|
if bs = [] || List.length bs > 3 then
|
|
failk "range-arity" rt.loc
|
|
"range takes one, two or three bounds: range(stop), range(start, stop) \
|
|
or range(start, stop, step)";
|
|
expect_line_end p ~after:"range(...)";
|
|
let body = block s ~after:"for" in
|
|
named "dotimes"
|
|
(label @ (Form.make (Form.Vec (v :: bs)) (span_of_list v.loc bs) :: body))
|
|
| "return" ->
|
|
(match (peek p).tok with
|
|
| NEWLINE -> expect_eol p ~after:"return"; form []
|
|
| _ ->
|
|
let e, _ = expr p in
|
|
expect_eol p ~after:(text_of e);
|
|
form [ e ])
|
|
| "break" | "continue" ->
|
|
(match (peek p).tok with
|
|
| KW k ->
|
|
let kt = advance p in
|
|
expect_eol p ~after:(":" ^ k);
|
|
form [ Form.make (Form.Kw k) kt.loc ]
|
|
| _ -> expect_eol p ~after:w; form [])
|
|
| "defer" ->
|
|
(match (peek p).tok with
|
|
| NEWLINE ->
|
|
ignore (advance p);
|
|
form (block s ~after:"defer")
|
|
| _ ->
|
|
let e, _ = expr p in
|
|
expect_eol p ~after:(text_of e);
|
|
form [ e ])
|
|
| "match" ->
|
|
let scrut, _ = expr p in
|
|
expect_eol_block p ~after:("match " ^ text_of scrut);
|
|
let arms =
|
|
lines s (fun () ->
|
|
let pat, _ = unary p in
|
|
expect_name p "->" ~what:"-> and the arm's value";
|
|
let body =
|
|
if (peek p).tok = NEWLINE && (peek_at p 1).tok = INDENT then begin
|
|
let nl = advance p in
|
|
blk s nl.loc (block s ~after:"->")
|
|
end
|
|
else begin
|
|
let e, _ = expr p in
|
|
expect_eol p ~after:(text_of e);
|
|
e
|
|
end
|
|
in
|
|
[ pat; body ])
|
|
in
|
|
form (scrut :: arms)
|
|
| "handler-case" | "handler-bind" ->
|
|
expect_line_end p ~after:w;
|
|
let body = block s ~after:w in
|
|
let rec clauses acc =
|
|
match (peek p).tok, (peek_at p 1) with
|
|
| NAME "on", n when n.sp ->
|
|
let ot = advance p in
|
|
let head, _ = postfix p in
|
|
let ty, var =
|
|
match head.v with
|
|
| Form.List [ ty; ({ v = Form.Sym _; _ } as var) ] -> (ty, var)
|
|
| _ ->
|
|
failk "on-clause" head.loc
|
|
"a handler clause is on Type(name), naming the condition type \
|
|
and the name it is bound to, as in on FileError(c)"
|
|
in
|
|
expect_line_end p ~after:("on " ^ text_of head);
|
|
let b = block s ~after:"on" in
|
|
let c =
|
|
mk p ot.loc
|
|
(Form.List (ty :: Form.make (Form.Vec [ var ]) var.loc :: b))
|
|
in
|
|
clauses (c :: acc)
|
|
| _ -> List.rev acc
|
|
in
|
|
let cs = clauses [] in
|
|
let vec = Form.make (Form.Vec cs) (span p l0) in
|
|
if w = "handler-case" then form [ blk s l0 body; vec ]
|
|
else form (vec :: body)
|
|
| "restart-case" ->
|
|
expect_line_end p ~after:w;
|
|
let body = block s ~after:w in
|
|
let rec clauses acc =
|
|
match (peek p).tok, (peek_at p 1) with
|
|
| NAME "restart", n when n.sp ->
|
|
ignore (advance p);
|
|
let name = name_tok p ~what:"the restart's name" in
|
|
let lp = glued_lp p ~what:"the restart's parameters in parentheses" in
|
|
let ps = params p lp in
|
|
expect_line_end p ~after:("restart " ^ text_of name);
|
|
let b = block s ~after:"restart" in
|
|
let c =
|
|
mk p name.loc (Form.List (name :: Form.make (Form.Vec ps) lp.loc :: b))
|
|
in
|
|
clauses (c :: acc)
|
|
| _ -> List.rev acc
|
|
in
|
|
let cs = clauses [] in
|
|
form (blk s l0 body :: cs)
|
|
| "quote" ->
|
|
expect_line_end p ~after:"quote";
|
|
let body = block s ~after:"quote" in
|
|
named "quasiquote" [ blk s l0 body ]
|
|
| _ -> assert false
|
|
|
|
(* The end of a header line whose block must follow. *)
|
|
and expect_line_end p ~after =
|
|
match (peek p).tok with
|
|
| NEWLINE -> ignore (advance p)
|
|
| _ -> stray p ~after
|
|
|
|
and expect_eol_block p ~after =
|
|
expect_line_end p ~after
|
|
|
|
(* An indented run of one-line entries — a struct's fields, a match's arms.
|
|
None at all is allowed for the declarations and is refused later, by the
|
|
form, where it matters. *)
|
|
and lines (s : st) (one : unit -> Form.t list) : Form.t list =
|
|
let p = s.p in
|
|
if (peek p).tok <> INDENT then []
|
|
else begin
|
|
ignore (advance p);
|
|
let rec go acc =
|
|
match (peek p).tok with
|
|
| DEDENT -> ignore (advance p); List.rev acc
|
|
| EOF -> List.rev acc
|
|
| _ -> go (List.rev_append (one ()) acc)
|
|
in
|
|
go []
|
|
end
|
|
|
|
(** All top-level forms in a [.fln] source string. [col] is the column the
|
|
text's top level starts at, 1 for a file. *)
|
|
let read_all ?(col = 1) ~file src =
|
|
let toks = layout ~base:col (lex ~file src) in
|
|
let s = { p = { toks; i = 0 }; lets = [] } in
|
|
let fs = stmts s in
|
|
(match (peek s.p).tok with
|
|
| EOF -> ()
|
|
| tk -> failk "unexpected-token" (where_ s.p) "unexpected %s" (show tk));
|
|
fs
|
|
|
|
let read_file path =
|
|
let ic = open_in_bin path in
|
|
Fun.protect ~finally:(fun () -> close_in ic) (fun () ->
|
|
let n = in_channel_length ic in
|
|
read_all ~file:path (really_input_string ic n))
|