3186 lines
125 KiB
OCaml
3186 lines
125 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 ~@ *)
|
|
| BNOT (* ~~, bit-not; a nested unquote is ~(~x) *)
|
|
| NEG (* the - glued to the front of a name *)
|
|
| QUEST (* T? and a?.b: a ? glued after a name or a closer *)
|
|
| BANG (* x!: a ! glued after a value *)
|
|
| 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 -> "~@" | BNOT -> "~~" | NEG -> "-"
|
|
| QUEST -> "?" | BANG -> "!"
|
|
| 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 the prefix [-] and [~~] at 11; neither is binary. The
|
|
bit operators sit between the comparisons and the shifts, Python's and
|
|
Rust's order, so [x && mask == 0] is [(x && mask) == 0]. *)
|
|
let binops =
|
|
[ ("or", 1); ("and", 2);
|
|
("==", 4); ("!=", 4); ("<", 4); ("<=", 4); (">", 4); (">=", 4);
|
|
("||", 5); ("^^", 6); ("&&", 7);
|
|
("<<", 8); (">>", 8); ("+", 9); ("-", 9); ("*", 10); ("/", 10); ("%", 10);
|
|
(* [??] is here for the line rules — a line ending in it, or one starting
|
|
with it, continues — and is read by [operand] between 4 and 5, so no
|
|
level of [binary]'s is its own. *)
|
|
("??", 0) ]
|
|
|
|
let binop_level s = List.assoc_opt s binops
|
|
let is_binop s = binop_level s <> None
|
|
|
|
(* [==] is Flan's [=], and the bit operators are the words the Lisp side
|
|
writes; every other operator is its own name. *)
|
|
let op_sym = function
|
|
| "==" -> "=" | "&&" -> "bit-and" | "||" -> "bit-or" | "^^" -> "bit-xor"
|
|
| 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 place whose parts are all names and literals reads the same however
|
|
often it is evaluated, so [x += v] over one is [(set x (+ x v))], the form
|
|
the Lisp side writes. Any other place — an index that is a call — reads
|
|
[(update p + v)], which evaluates each part of the place once. The printer
|
|
asks the same question, so the round trip is exact either way. *)
|
|
let rec simple_place (f : Form.t) =
|
|
let atom (x : Form.t) =
|
|
match x.v with
|
|
| Form.Sym _ | Form.Int _ | Form.Kw _ | Form.Byte _ -> true
|
|
| _ -> false
|
|
in
|
|
match f.v with
|
|
| Form.Sym _ -> true
|
|
| Form.List [ { v = Form.Sym h; _ }; t ]
|
|
when (String.length h > 1 && h.[0] = '.') || h = "deref" ->
|
|
simple_place t
|
|
| Form.List ({ v = Form.Sym "at"; _ } :: t :: (_ :: _ as idx)) ->
|
|
simple_place t && List.for_all atom idx
|
|
| _ -> false
|
|
|
|
let compound (at : Loc.t) op (e : Form.t) (v : Form.t) span =
|
|
if simple_place e then
|
|
Form.List
|
|
[ Form.make (Form.Sym "set") at; e;
|
|
Form.make (Form.List [ Form.make (Form.Sym op) at; e; v ]) span ]
|
|
else
|
|
Form.List
|
|
[ Form.make (Form.Sym "update") at; e; Form.make (Form.Sym op) at; v ]
|
|
|
|
(* A comparison chain that mixes [<] with [<=], or [>] with [>=], is the
|
|
[and] of its neighbouring pairs: [0 <= r < rows] is
|
|
[(and (<= 0 r) (< r rows))]. It is evaluated as [(< a b c)] is: every
|
|
operand once, left to right, before any test, with no short-circuit. When
|
|
an operand is more than a name or a literal, every operand but a literal
|
|
is bound first, in order, to a fresh [~cmp] name, which no reader can
|
|
produce: a name too, since a call to its right may change it. The printer
|
|
rebuilds a candidate with this same function and prints the chain only
|
|
when the two agree. *)
|
|
let cmp_dir = function
|
|
| "<" | "<=" -> Some `Up
|
|
| ">" | ">=" -> Some `Down
|
|
| _ -> None
|
|
|
|
let cmp_chain ~fresh (l : Loc.t) (xs : Form.t list) (ops : string list) =
|
|
let mkf v = Form.make v l in
|
|
let s x = mkf (Form.Sym x) in
|
|
let literal (x : Form.t) =
|
|
match x.v with
|
|
| Form.Int _ | Form.UInt _ | Form.Float _ | Form.Str _ | Form.Byte _
|
|
| Form.Kw _ | Form.Sym ("true" | "false" | "nil") -> true
|
|
| _ -> false
|
|
in
|
|
let simple (x : Form.t) = literal x || (match x.v with Form.Sym _ -> true | _ -> false) in
|
|
let keep = if List.for_all simple xs then simple else literal in
|
|
let bound =
|
|
List.map (fun x -> if keep x then (None, x) else
|
|
let t = s (fresh ()) in (Some (t, x), t)) xs
|
|
in
|
|
let refs = List.map snd bound in
|
|
let rec tests = function
|
|
| a :: (b :: _ as rest), op :: ops -> mkf (Form.List [ s op; a; b ]) :: tests (rest, ops)
|
|
| _ -> []
|
|
in
|
|
let body = mkf (Form.List (s "and" :: tests (refs, ops))) in
|
|
match List.concat_map (function (Some (t, x), _) -> [ t; x ] | _ -> []) bound with
|
|
| [] -> body
|
|
| bs -> mkf (Form.List [ s "let"; mkf (Form.Vec bs); body ])
|
|
|
|
(* The reader's fresh names for [cmp_chain], counted per [read_all]. *)
|
|
let cmp_n = ref 0
|
|
let cmp_fresh () = incr cmp_n; Printf.sprintf "~cmp%d" !cmp_n
|
|
|
|
(* The reader's fresh names for an optional chain's payload, per [read_all]. *)
|
|
let opt_n = ref 0
|
|
|
|
(* Whether a type is being read, set for [ty]'s extent: there a [?] after
|
|
any name is [Option], [grain?] included. *)
|
|
let in_type = ref false
|
|
|
|
(* 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
|
|
|
|
(* ── Names without ? or ! ──────────────────────────────────────────── *)
|
|
|
|
(* What a [?] may follow to mean [Option]: a type's name. A capital after
|
|
any [pkg/], a type variable, or a primitive. *)
|
|
let type_like s =
|
|
let base =
|
|
match String.rindex_opt s '/' with
|
|
| Some i -> String.sub s (i + 1) (String.length s - i - 1)
|
|
| None -> s
|
|
in
|
|
base <> ""
|
|
&& ((base.[0] >= 'A' && base.[0] <= 'Z') || base.[0] = '$'
|
|
|| List.mem base ("char" :: Types.primitive_names))
|
|
|
|
(* The name a question is spelled with: [is-] in front, unless it already
|
|
starts with a verb. The table holds the prelude's and raylib's names that
|
|
do not follow that rule, so the fix for one of them is the real name. *)
|
|
let question_fix name =
|
|
let pkg, base =
|
|
match String.rindex_opt name '/' with
|
|
| Some i -> (String.sub name 0 (i + 1), String.sub name (i + 1) (String.length name - i - 1))
|
|
| None -> ("", name)
|
|
in
|
|
let starts p = String.starts_with ~prefix:p base in
|
|
let fixed =
|
|
match base with
|
|
| "starts-with" -> "has-prefix"
|
|
| "ends-with" -> "has-suffix"
|
|
| "file-exists" | "window-should-close" -> base
|
|
| "bytes<" -> "is-bytes-less"
|
|
| "into-maps" -> "has-map-step"
|
|
| "form-sym" -> "is-form-named"
|
|
| "form-is-sym" -> "is-form-sym"
|
|
| _ when starts "is-" || starts "has-" || starts "can-" -> base
|
|
| _ when starts "collision-" -> "check-" ^ base
|
|
| _ when String.ends_with ~suffix:"=" base ->
|
|
"is-" ^ String.sub base 0 (String.length base - 1) ^ "-equal"
|
|
| _ -> "is-" ^ base
|
|
in
|
|
pkg ^ fixed
|
|
|
|
let name_refused ?(typed = false) loc whole =
|
|
let drop c s = String.concat "" (String.split_on_char c s) in
|
|
let n = String.length whole in
|
|
if n > 1 && whole.[n - 1] = '?' && not (String.contains (String.sub whole 0 (n - 1)) '?')
|
|
&& not (String.contains whole '!') then
|
|
let base = String.sub whole 0 (n - 1) in
|
|
Loc.failk "indent/question-name" loc
|
|
"%s is not a name: a name cannot contain ?.\n\n\
|
|
A name for a yes-or-no question starts with is- or has- instead: %s%s"
|
|
whole (question_fix base)
|
|
(if typed then
|
|
Printf.sprintf "\n\nIf %s is a type, %s is Option(%s), written where a \
|
|
type goes, after : or ->" base whole base
|
|
else "")
|
|
else
|
|
let c = if String.contains whole '!' then '!' else '?' in
|
|
Loc.failk "indent/mark-in-name" loc
|
|
"%s is not a name: a name cannot contain %c.\n\nLeave it out: %s"
|
|
whole c (drop '!' (drop '?' whole))
|
|
|
|
(* ── Lexing ────────────────────────────────────────────────────────── *)
|
|
|
|
let lex ?(line = 1) ?(col = 1) ~file src : token list =
|
|
let st = Reader.of_string ~file src in
|
|
(* Text taken from the middle of a buffer starts where it was written, so
|
|
every location read from it is the buffer's own. *)
|
|
st.Reader.line <- line;
|
|
st.Reader.col <- col;
|
|
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 plain col body =
|
|
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)
|
|
in
|
|
(* [.b.c] after a [?] or a [!]: one field access per segment. *)
|
|
let fields col s =
|
|
let segs = String.split_on_char '.' (String.sub s 1 (String.length s - 1)) in
|
|
if List.mem "" segs then emit (NAME s) (piece line col (String.length s))
|
|
else
|
|
List.fold_left
|
|
(fun c seg ->
|
|
emit (NAME ("." ^ seg)) (piece line c (String.length seg + 1));
|
|
c + String.length seg + 1)
|
|
col segs
|
|
|> ignore
|
|
in
|
|
(* Before the first mark a leading dot is the name's own, [.field] as
|
|
an accessor; after one it starts a field access. *)
|
|
let some_part ~after col s =
|
|
if s = "" then () else if after && s.[0] = '.' then fields col s else plain col s
|
|
in
|
|
(* The name a [?] or a [!] at [i] of [s] belongs to: back to the dot
|
|
or the start before it, on to the dot or the end after it. *)
|
|
let word s i =
|
|
let a = match String.rindex_from_opt s i '.' with Some d -> d + 1 | None -> 0 in
|
|
let b = match String.index_from_opt s i '.' with Some d -> d | None -> String.length s in
|
|
(a, String.sub s a (b - a))
|
|
in
|
|
let next = if Reader.at_end st then ' ' else Reader.peek st in
|
|
(* A [?] ends a type's name, [T?], or starts a chain, [a?.b] and
|
|
[a?[i]]; a [!] unwraps, [x!]. Anywhere else each is inside a name,
|
|
which is refused (spec-syntax.md, "Names"). *)
|
|
let rec marks ?(after = false) col s =
|
|
match String.index_opt s '?', String.index_opt s '!' with
|
|
| None, None -> some_part ~after col s
|
|
| q, b ->
|
|
let i = match q, b with
|
|
| Some q, Some b -> min q b | Some q, None -> q | None, Some b -> b
|
|
| None, None -> assert false
|
|
in
|
|
let pre = String.sub s 0 i and ch = s.[i] in
|
|
let rest = String.sub s (i + 1) (String.length s - i - 1) in
|
|
let at = col + i in
|
|
let wa, whole = word s i in
|
|
let last = match String.rindex_opt pre '.' with
|
|
| Some d -> String.sub pre (d + 1) (String.length pre - d - 1)
|
|
| None -> pre
|
|
in
|
|
(* The word after this run, for an operator written without its
|
|
spaces: [x!= y] is [x != y]. *)
|
|
let after_word r =
|
|
if r <> "" then r
|
|
else
|
|
let j = ref st.Reader.pos in
|
|
while !j < String.length src && src.[!j] = ' ' do incr j done;
|
|
let k = ref !j in
|
|
while !k < String.length src && not (Reader.is_delimiter src.[!k]) do incr k done;
|
|
if !k > !j then String.sub src !j (!k - !j) else "b"
|
|
in
|
|
let tail r = String.sub r 1 (String.length r - 1) in
|
|
if ch = '?' then begin
|
|
if rest = "?" && pre <> "" && type_like last && next <> '(' then
|
|
failk "nested-option" (piece line (col + wa) (String.length whole))
|
|
"%s is not read: ?? is the default operator. An Option of an \
|
|
Option is written Option(%s?)" whole last;
|
|
if rest <> "" && rest.[0] = '?' && pre <> "" then
|
|
failk "unspaced-operator" (piece line at 2)
|
|
"?? is an operator here, and a binary operator has a space on \
|
|
each side: %s ?? %s" pre (after_word (tail rest));
|
|
(* A [?] at the end of a name is a type's, [T?], or one the
|
|
parser refuses as part of a name; which, only the parser
|
|
knows. Before [(] or inside a name it is a name's. *)
|
|
let ends = rest = "" && next <> '(' in
|
|
let chain = (rest <> "" && rest.[0] = '.') || (rest = "" && next = '[') in
|
|
if ends || chain then begin
|
|
some_part ~after col pre;
|
|
emit QUEST (piece line at 1);
|
|
marks ~after:true (at + 1) rest
|
|
end
|
|
else name_refused (piece line (col + wa) (String.length whole)) whole
|
|
end
|
|
else begin
|
|
if rest <> "" && rest.[0] = '=' then
|
|
failk "unspaced-operator" (piece line at 2)
|
|
"!= is an operator here, and a binary operator has a space on \
|
|
each side: %s != %s" pre (after_word (tail rest));
|
|
if rest <> "" && rest.[0] = '!' then
|
|
failk "double-unwrap" (piece line at 2)
|
|
"!! is not read. To unwrap an Option of an Option, unwrap \
|
|
each level: (%s!)!" (if pre = "" then "x" else pre);
|
|
if (rest = "" && next <> '(') || (rest <> "" && rest.[0] = '.') then begin
|
|
some_part ~after col pre;
|
|
emit BANG (piece line at 1);
|
|
marks ~after:true (at + 1) rest
|
|
end
|
|
else name_refused (piece line (col + wa) (String.length whole)) whole
|
|
end
|
|
in
|
|
let wordy = String.exists (fun c -> Reader.is_digit c || (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z')) body in
|
|
if wordy || body = "?" || body = "!" || body = "!!" then marks col body else plain col 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 BNOT (Loc.upto l0 (Reader.here st))
|
|
end
|
|
else if Reader.peek st = '@' then begin
|
|
Reader.advance st;
|
|
emit SPLICE (Loc.upto l0 (Reader.here st))
|
|
end
|
|
else emit UNQ (Loc.upto l0 (Reader.here st))
|
|
| c when Reader.is_digit c
|
|
|| ((c = '-' || c = '+') && Reader.is_digit (Reader.peek2 st)) ->
|
|
(* [while x < 3:] — the colon is a mistake the parser explains, and not
|
|
part of the number, so the number is read without it. *)
|
|
let rec run i =
|
|
if i < String.length src && not (Reader.is_delimiter src.[i]) then run (i + 1)
|
|
else i
|
|
in
|
|
let stop = run st.Reader.pos in
|
|
if stop - st.Reader.pos > 1 && src.[stop - 1] = ':' then begin
|
|
let text = String.sub src st.Reader.pos (stop - st.Reader.pos - 1) in
|
|
let f = Reader.read_number (Reader.of_string ~file text) in
|
|
let n = String.length text in
|
|
for _ = 1 to n do Reader.advance st done;
|
|
emit (ATOM f.v) (piece l0.Loc.line l0.Loc.col n);
|
|
Reader.advance st;
|
|
emit COLON (piece l0.Loc.line (l0.Loc.col + n) 1)
|
|
end
|
|
else begin
|
|
(* [0..10]: a range from another language. *)
|
|
let text = String.sub src st.Reader.pos (stop - st.Reader.pos) in
|
|
(match String.index_opt text '.' with
|
|
| Some i when i + 1 < String.length text && text.[i + 1] = '.' ->
|
|
failk "dot-range" (piece l0.Loc.line l0.Loc.col (String.length text))
|
|
"%s is not a number. A range of numbers is written range(%s, %s), \
|
|
as in for i in range(%s, %s)"
|
|
text (String.sub text 0 i)
|
|
(String.sub text (i + 2) (String.length text - i - 2))
|
|
(String.sub text 0 i)
|
|
(String.sub text (i + 2) (String.length text - i - 2))
|
|
| _ -> ());
|
|
let f = Reader.read_number st in
|
|
emit (ATOM f.v) f.loc
|
|
end
|
|
| _ -> name_run ()
|
|
in
|
|
let rec go () =
|
|
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 ────────────────────────────────────────────────────────── *)
|
|
|
|
(* The text being read, so that a message quotes what the user wrote rather
|
|
than the paren form it became. Set for the length of one [read_all]. *)
|
|
let source : (string * string array) ref = ref ("", [||])
|
|
|
|
(* Line [l] of the text being read, trimmed, and the column its text starts
|
|
at. *)
|
|
let source_line l =
|
|
let _, lines = !source in
|
|
if l < 1 || l > Array.length lines then ("", 1)
|
|
else
|
|
let t = lines.(l - 1) in
|
|
let n = String.length t in
|
|
let rec first i = if i < n && t.[i] = ' ' then first (i + 1) else i in
|
|
(String.trim t, first 0 + 1)
|
|
|
|
(* A line under a let that is not at its first name's column [name_col]:
|
|
the fix is the let's line and this one, lined up. *)
|
|
let let_misaligned loc ~let_line ~name ~name_col =
|
|
let lt, lc = source_line let_line in
|
|
let bt, _ = source_line loc.Loc.line in
|
|
failk "let-align" loc
|
|
"this line starts at column %d, under the let on line %d, whose bindings \
|
|
line up with its first name, %s, at column %d. Move it to column %d:\n\n\
|
|
\ %s\n %s%s"
|
|
loc.Loc.col let_line name name_col name_col lt
|
|
(String.make (max 0 (name_col - lc)) ' ') bt
|
|
|
|
(* A line at a let's first name's column, after a value that took the
|
|
lines under the let: it is the value's, not one more binding. *)
|
|
let let_after_block loc ~let_line ~name =
|
|
let bt, _ = source_line loc.Loc.line in
|
|
failk "let-after-block" loc
|
|
"this line lines up as one more binding of the let on line %d, after %s, \
|
|
whose value is the block above it. A binding whose value is a block ends \
|
|
its let's bindings, so this one needs a let of its own, at that let's \
|
|
column:\n\n let %s"
|
|
let_line name bt
|
|
|
|
(* Whether the tokens from [i] start a line shaped as a binding: [name =],
|
|
[name:], a [[...]], [{...}] or [(op)] pattern, or [~x]. The alignment
|
|
advice is for such lines only; any other line under a let is some other
|
|
mistake. *)
|
|
let binding_shaped (arr : token array) i =
|
|
let n = Array.length arr in
|
|
let at k = if i + k < n then arr.(i + k).tok else EOF in
|
|
match at 0, at 1 with
|
|
| NAME s, (NAME "=" | COLON) -> s <> "" && s.[0] <> '.'
|
|
| (LB | LC | LP | UNQ), _ -> true
|
|
| _ -> false
|
|
|
|
(* A tab between [let] and its first name: the bindings under the let line
|
|
up with that name, and a tab has no one width to line up with. *)
|
|
let let_gap_tab (t : token) (nm : token) =
|
|
if t.loc.Loc.eline = nm.loc.Loc.line then begin
|
|
let _, lines = !source in
|
|
if nm.loc.Loc.line <= Array.length lines then
|
|
let line = lines.(nm.loc.Loc.line - 1) in
|
|
let a = t.loc.Loc.ecol - 1 and b = nm.loc.Loc.col - 1 in
|
|
if a >= 0 && b <= String.length line && b > a
|
|
&& String.contains (String.sub line a (b - a)) '\t' then
|
|
failk "tab" t.loc
|
|
"there is a tab between let and %s. The bindings under a let line up \
|
|
with its first name, and a tab has no one width, so put a space \
|
|
there: let %s"
|
|
(show nm.tok) (show nm.tok)
|
|
end
|
|
|
|
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").
|
|
|
|
The one exception is a lambda's block. A [=>] that ends its line inside
|
|
brackets opens a block there: the lines under it are laid out as they
|
|
would be at depth zero, against a base of their own (the column the [=>]
|
|
line starts at), until the bracket around the lambda closes. That closer
|
|
ends the block, whether it ends the block's last line or has a line of
|
|
its own. The block is the last thing in its brackets: a comma after it,
|
|
or a line back at the header's column, is refused. *)
|
|
type frame = {
|
|
f_base : int;
|
|
f_stack : int list;
|
|
f_opens : token list; (* the brackets open around the lambda *)
|
|
f_arrow : token; (* the [=>] that opened the block *)
|
|
}
|
|
|
|
let lambda_not_last (fr : frame) (t : token) =
|
|
failk "lambda-block-last" t.loc
|
|
"%s follows the block of the lambda on line %d, inside the same \
|
|
brackets. A lambda with a block is the last thing in its brackets, and \
|
|
its block ends where they close. Name the lambda with a let first and \
|
|
pass the name:\n\n\
|
|
\ let f = fn(a) =>\n ...\n g(f, x)"
|
|
(if t.tok = COMMA then "a comma" else show t.tok) fr.f_arrow.loc.Loc.line
|
|
|
|
let layout ?(snippet = false) ?(base = 1) ?indent (toks : token list) : token array =
|
|
let arr = Array.of_list toks in
|
|
let n = Array.length arr in
|
|
(* A snippet from the editor starts wherever it was written, and its first
|
|
line is its base: a later line may not go left of it. One cut from the
|
|
middle of a line (see [indent]) has that line's start as its base, so a
|
|
block under the line, a [let]'s [match] arms or a lambda's, reads as it
|
|
does in the file. *)
|
|
let base =
|
|
ref (if snippet && n > 0 then
|
|
match indent with
|
|
| Some c -> min c arr.(0).loc.Loc.col
|
|
| None -> arr.(0).loc.Loc.col
|
|
else base)
|
|
in
|
|
let out = ref [] in
|
|
let add tok loc = out := { tok; loc; sp = true } :: !out in
|
|
let stack = ref [ !base ] in
|
|
(* [indent] is the column of the statement a snippet was cut out of, when
|
|
the snippet starts after that statement's first word (an elif's
|
|
condition, an arm's value). Its first joined line continues as it does
|
|
in the file: deeper than the statement, not than the cut. *)
|
|
let first_line = ref true in
|
|
(* The brackets open in the current layout, innermost first. A lambda's
|
|
block starts with none, and [frames] holds what it interrupted. *)
|
|
let opens = ref [] in
|
|
let frames = ref [] in
|
|
let binop t = match t.tok with NAME s -> is_binop s | _ -> false in
|
|
let closer t = match t.tok with RP | RB | RC -> true | _ -> false in
|
|
(* The column [i]'s line starts at. *)
|
|
let line_col i =
|
|
let rec go j =
|
|
if j > 0 && arr.(j - 1).loc.Loc.eline = arr.(i).loc.Loc.line then go (j - 1) else j
|
|
in
|
|
arr.(go i).loc.Loc.col
|
|
in
|
|
for i = 0 to n - 1 do
|
|
let t = arr.(i) in
|
|
(if i = 0 then begin
|
|
if t.loc.Loc.col <> !base && indent = None 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
|
|
(* The closer that ends a lambda's block takes the block's end with
|
|
it, below: the line break before it is nothing. *)
|
|
let ends_block = !frames <> [] && !opens = [] && closer t in
|
|
if !opens = [] && t.loc.Loc.line > p.loc.Loc.eline && not ends_block 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
|
|
let top =
|
|
match indent with
|
|
| Some c when !first_line && List.length !stack = 1 -> min c (List.hd !stack)
|
|
| _ -> List.hd !stack
|
|
in
|
|
(* A continuation line sits deeper than the statement it continues.
|
|
One at or left of that statement's column is not read as joining
|
|
it: that would pull a line into a block it was written outside
|
|
of, silently. *)
|
|
if continues && t.loc.Loc.col <= top then
|
|
failk "continuation" t.loc
|
|
"%s"
|
|
(if binop t then
|
|
Printf.sprintf
|
|
"this line starts with the operator %s, so it continues the \
|
|
line above, but it is not indented past the start of that \
|
|
line (column %d). Indent it further to continue the line, \
|
|
or give %s a value on its left"
|
|
(show t.tok) top (show t.tok)
|
|
else
|
|
Printf.sprintf
|
|
"the line above ends with the operator %s, so this line \
|
|
continues it, but it is not indented past the start of \
|
|
that line (column %d). Indent it further, or finish the \
|
|
line above"
|
|
(show p.tok) top);
|
|
if not continues then begin
|
|
first_line := false;
|
|
let at = point p.loc in
|
|
let col = t.loc.Loc.col in
|
|
(* Inside a lambda's brackets, a line at or left of the line its
|
|
header is on would be a statement beside the lambda. *)
|
|
(match !frames with
|
|
(* Left of the block's own column, after the block: the next
|
|
element of the brackets, which the block must end. *)
|
|
| fr :: _ when List.length !stack > 1
|
|
&& col < List.nth !stack (List.length !stack - 2) ->
|
|
lambda_not_last fr t
|
|
| fr :: _ when col <= !base ->
|
|
if t.tok = COMMA then lambda_not_last fr t
|
|
else
|
|
failk "lambda-block-left" t.loc
|
|
"this line starts at column %d and is still inside the \
|
|
brackets of the lambda on line %d, whose block is indented \
|
|
past column %d. Indent it into the block, or close the \
|
|
brackets at the end of the block's last line"
|
|
col fr.f_arrow.loc.Loc.line !base
|
|
| _ -> ());
|
|
add NEWLINE at;
|
|
let top = List.hd !stack in
|
|
if col > top then begin
|
|
stack := col :: !stack;
|
|
add INDENT at
|
|
end
|
|
else if col < top then begin
|
|
if col < !base then
|
|
failk "dedent" t.loc
|
|
"%s"
|
|
(if snippet then
|
|
Printf.sprintf
|
|
"this line starts at column %d, left of column %d where \
|
|
the code sent starts. Its first line sets its left \
|
|
edge, and no later line can go left of it: send the \
|
|
enclosing form, or line this up at column %d or right \
|
|
of it"
|
|
col !base !base
|
|
else
|
|
Printf.sprintf
|
|
"this line starts at column %d, left of the top level at \
|
|
column %d" col !base);
|
|
let closed = ref top in
|
|
let rec pop () =
|
|
match !stack with
|
|
| top :: (_ :: _ as rest) when col < top ->
|
|
closed := top; stack := rest; add DEDENT at; pop ()
|
|
| _ -> ()
|
|
in
|
|
pop ();
|
|
(* Between a let's column and the block under it: a binding
|
|
meant for that let, if the let owns the block. *)
|
|
(if col <> List.hd !stack then
|
|
let first_on_line j =
|
|
j = 0 || arr.(j - 1).loc.Loc.eline < arr.(j).loc.Loc.line
|
|
in
|
|
let rec owner j =
|
|
if j < 0 then None
|
|
else if first_on_line j && arr.(j).loc.Loc.col <= List.hd !stack then
|
|
Some j
|
|
else owner (j - 1)
|
|
in
|
|
match owner (i - 1) with
|
|
| Some j when arr.(j).tok = NAME "let" && j + 1 < n
|
|
&& arr.(j).loc.Loc.col = List.hd !stack
|
|
&& binding_shaped arr i ->
|
|
let nm = arr.(j + 1) in
|
|
let let_line = arr.(j).loc.Loc.line and name = show nm.tok in
|
|
if col = nm.loc.Loc.col then let_after_block t.loc ~let_line ~name
|
|
else let_misaligned t.loc ~let_line ~name ~name_col:nm.loc.Loc.col
|
|
| _ -> ());
|
|
if col <> List.hd !stack then
|
|
failk "dedent" t.loc
|
|
"this line starts at column %d, between the block at column \
|
|
%d and the one at column %d it would close, so it belongs \
|
|
to neither. The enclosing blocks start at column%s %s: line \
|
|
it up with one of them"
|
|
col (List.hd !stack) !closed
|
|
(if List.length !stack > 1 then "s" else "")
|
|
(String.concat ", "
|
|
(List.rev_map string_of_int !stack))
|
|
end
|
|
end
|
|
end);
|
|
(match !frames with
|
|
(* A comma at the top of a lambda's block, on one of the block's lines. *)
|
|
| fr :: _ when !opens = [] && t.tok = COMMA -> lambda_not_last fr t
|
|
(* The closer of the brackets a lambda's block is in: the block ends. *)
|
|
| fr :: rest when !opens = [] && closer t ->
|
|
let at = point arr.(i - 1).loc in
|
|
add NEWLINE at;
|
|
List.iter (fun _ -> add DEDENT at) (List.tl !stack);
|
|
base := fr.f_base;
|
|
stack := fr.f_stack;
|
|
opens := fr.f_opens;
|
|
frames := rest
|
|
| _ -> ());
|
|
out := t :: !out;
|
|
(match t.tok with
|
|
| LP | LB | LC -> opens := t :: !opens
|
|
| RP | RB | RC -> (match !opens with _ :: r -> opens := r | [] -> ())
|
|
| NAME "=>" when !opens <> [] && i + 1 < n
|
|
&& arr.(i + 1).loc.Loc.line > t.loc.Loc.eline ->
|
|
frames := { f_base = !base; f_stack = !stack; f_opens = !opens; f_arrow = t }
|
|
:: !frames;
|
|
(* A snippet cut from the middle of a line starts where its line
|
|
does in the file, [indent], not where the cut does. *)
|
|
base :=
|
|
(match indent with
|
|
| Some c when t.loc.Loc.line = arr.(0).loc.Loc.line -> min c (line_col i)
|
|
| _ -> line_col i);
|
|
stack := [ !base ];
|
|
opens := []
|
|
| _ -> ())
|
|
done;
|
|
(match !frames with
|
|
| fr :: _ ->
|
|
let o = match fr.f_opens with o :: _ -> o | [] -> fr.f_arrow in
|
|
failk "unclosed" o.loc
|
|
~notes:[ Loc.note (point arr.(n - 1).loc) "the input ends here, still inside it" ]
|
|
"unclosed %s: the block of the lambda on line %d ends where this \
|
|
bracket closes"
|
|
(show o.tok) fr.f_arrow.loc.Loc.line
|
|
| [] -> ());
|
|
(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 ───────────────────────────────────────────────────────── *)
|
|
|
|
(* [closed] is where a lambda's block that ended its statement stopped:
|
|
the block took the line's end with it, so a check for that end passes
|
|
there. *)
|
|
type p = { toks : token array; mutable i : int; mutable closed : int }
|
|
|
|
(* Set below [params] and [ty], which the expression parser comes before. *)
|
|
let typed_fn_expr : (p -> Form.t * int) ref = ref (fun _ -> assert false)
|
|
|
|
(* A block's statements, for a lambda's; set once the statement parser is. *)
|
|
let block_of : (p -> Form.t list) ref = ref (fun _ -> assert false)
|
|
|
|
let peek p = p.toks.(p.i)
|
|
let peek_at p k = p.toks.(min (p.i + k) (Array.length p.toks - 1))
|
|
let advance p =
|
|
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 | BNOT | 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)]. *)
|
|
(* A [?] glued to the name just read, somewhere a type is not: the name
|
|
is what was meant, [let ok? = 1] or [fn f(ok?: bool)]. *)
|
|
let mark_after p =
|
|
let t = peek p in
|
|
match t.tok, (last p).tok with
|
|
| QUEST, NAME n when (not t.sp) && p.i > 0 && n <> "" ->
|
|
let l = (last p).loc in
|
|
let n = if n.[0] = '.' then String.sub n 1 (String.length n - 1) else n in
|
|
name_refused ~typed:(type_like n) { l with Loc.eline = t.loc.Loc.eline; ecol = t.loc.Loc.ecol } (n ^ "?")
|
|
| _ -> ()
|
|
|
|
let stray p ~after =
|
|
mark_after p;
|
|
let t = peek p in
|
|
match t.tok with
|
|
| ATOM _ when t.sp && negative_literal t.tok ->
|
|
let text = show t.tok in
|
|
let digits = String.sub text 1 (String.length text - 1) in
|
|
failk "glued-minus" t.loc
|
|
"%s is read as the number %s, right after %s with nothing between them. \
|
|
To subtract, space the minus: %s - %s. For two values, separate them \
|
|
with a comma: %s, %s"
|
|
text text after after digits after text
|
|
| LP when t.sp ->
|
|
failk "spaced-call" t.loc
|
|
"there is a space before this (, so it does not call %s — a call has \
|
|
none. Write %s(...), or put a comma before the ( if it is a separate \
|
|
value"
|
|
after after
|
|
| LB when t.sp ->
|
|
failk "spaced-index" t.loc
|
|
"there is a space before this [, so it does not index %s — indexing has \
|
|
none. Write %s[i]"
|
|
after after
|
|
| NEWLINE | INDENT | DEDENT | EOF ->
|
|
failk "unexpected-end" (where_ p) "the line ends after %s, which is not \
|
|
finished here" after
|
|
| NAME "=" ->
|
|
failk "assign-in-test" t.loc
|
|
"this = follows %s, where it cannot assign: an assignment is a line \
|
|
of its own, with one =. To compare two values, write == instead"
|
|
after
|
|
| COLON ->
|
|
failk "header-colon" t.loc
|
|
"this line ends in a colon after %s. A header (if, elif, else, while, \
|
|
until, for, fn, match, ...) opens its block with no colon; only a call \
|
|
takes one, as in f(x):. Remove the colon"
|
|
after
|
|
| _ ->
|
|
failk "unexpected-token" t.loc
|
|
"%s follows %s, and two values cannot sit side by side here. Separate \
|
|
them with a comma, or join them with an operator"
|
|
(show t.tok) after
|
|
|
|
let expect p tok ~what =
|
|
let t = peek p in
|
|
if t.tok = tok then ignore (advance p)
|
|
else
|
|
let () = mark_after p in
|
|
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 -> mark_after p; failk "expected" (where_ p) "expected %s here, and found %s" what (show t)
|
|
|
|
(* The lets whose first value is being read, innermost first: the column
|
|
of the let's first name, the name, and the let's line. A line at that
|
|
column under the value's block looks like one more binding and is not. *)
|
|
let let_values : (int * string * int) list ref = ref []
|
|
|
|
(* The end of a line that is not followed by a block. *)
|
|
let expect_eol p ~after =
|
|
if p.i = p.closed then () else
|
|
match (peek p).tok with
|
|
| NEWLINE ->
|
|
ignore (advance p);
|
|
(match (peek p).tok, !let_values with
|
|
| INDENT, (name_col, name, let_line) :: _ ->
|
|
let t = peek_at p 1 in
|
|
let shaped =
|
|
match t.tok, (peek_at p 2).tok with
|
|
| NAME _, (NAME "=" | COLON) | (LB | LC | LP | UNQ), _ -> true
|
|
| _ -> false
|
|
in
|
|
if t.loc.Loc.col = name_col && shaped then let_after_block t.loc ~let_line ~name
|
|
| _ -> ());
|
|
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 %s:"
|
|
after
|
|
(* The call itself when [after] is one, [f(a, b)]; else an example. *)
|
|
(match String.index_opt after '(', String.index_opt after ' ' with
|
|
| Some i, Some j when i < j -> after
|
|
| Some _, None when after.[String.length after - 1] = ')' -> after
|
|
| _ -> "rl/with-drawing()")
|
|
| EOF -> ()
|
|
| _ -> stray p ~after
|
|
|
|
(* A target's first token, for a message: [(not)] is shown whole. *)
|
|
let text_of_tok (t : token) =
|
|
match t.tok with LP -> "the name in parentheses" | tk -> show tk
|
|
|
|
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 file, lines = !source in
|
|
let l = f.loc in
|
|
let from_source =
|
|
if l.Loc.file <> file || l.Loc.line < 1 || l.Loc.line > Array.length lines then None
|
|
else
|
|
let text = lines.(l.Loc.line - 1) in
|
|
let a = l.Loc.col - 1 in
|
|
let b = if l.Loc.eline = l.Loc.line then l.Loc.ecol - 1 else String.length text in
|
|
if a < 0 || b > String.length text || b <= a then None
|
|
else
|
|
let t = String.trim (String.sub text a (b - a)) in
|
|
Some (if l.Loc.eline > l.Loc.line then t ^ " ..." else t)
|
|
in
|
|
let s = match from_source with Some t -> t | None -> Form.to_source f in
|
|
if String.length s > 40 then String.sub s 0 37 ^ "..." else s
|
|
|
|
(* An assignment's place that is an optional chain or an unwrap: neither
|
|
names storage, and the forms they read to would show the reader's names. *)
|
|
let no_place (e : Form.t) =
|
|
match e.v with
|
|
| Form.List ({ v = Form.Sym "?."; _ } :: _) ->
|
|
failk "chain-assign" e.loc
|
|
"%s is an optional chain, and a chain cannot be assigned to: when it \
|
|
holds nothing there is no place to write. Unwrap it first with if let, \
|
|
then assign through the name it binds"
|
|
(text_of e)
|
|
| Form.List [ { v = Form.Sym "!!"; _ }; _ ] ->
|
|
failk "chain-assign" e.loc
|
|
"%s unwraps a value, and a value cannot be assigned to. Unwrap it with \
|
|
if let, then assign through the name it binds"
|
|
(text_of e)
|
|
| _ -> ()
|
|
|
|
let unclosed p c l0 =
|
|
failk "unclosed" l0
|
|
~notes:[ Loc.note (where_ p) "the input ends here, still inside it" ]
|
|
"unclosed %C" c
|
|
|
|
let refuse_ws ?(brace = false) loc e =
|
|
failk "separate-elements" loc
|
|
"%s has an operator in it and sits in a list separated by spaces, where \
|
|
only single values are. Separate the %s with commas: %s"
|
|
(text_of e)
|
|
(if brace then "entries" else "elements")
|
|
(if brace then "{.x a + 1, .y 2}" else "[a - 1, b]")
|
|
|
|
(* [loop] and [recur] are Lisp-syntax forms. A .fln loop is a [while],
|
|
[until], [dotimes] or [for]; [read_all] refuses any that gets past the
|
|
parser, in a [quote] or a quoted datum too. *)
|
|
let no_loop loc word =
|
|
failk "no-loop" loc
|
|
"%s is not part of the indented syntax. A loop here is a while, until, \
|
|
dotimes or for, with let variables it changes:\n\n\
|
|
\ let i = 0\n let total = 0\n while i < 10\n total += i\n i += 1\n\n\
|
|
break leaves the loop early, and continue goes on to the next round."
|
|
word
|
|
|
|
(* A [when] has one branch; an else under one is an if's. *)
|
|
let when_else p =
|
|
failk "when-else" (peek p).loc
|
|
"a when has no else — it answers Some of its value when the test holds \
|
|
and None when it does not. For two branches write if c then a else b, \
|
|
or an if with an else block"
|
|
|
|
(* A refused chain written out as the [and] of all its tests. A middle
|
|
operand that is more than a name or a literal is named by a [let] first,
|
|
so the rewrite does not run it twice. *)
|
|
let and_rewrite (xs : Form.t list) ops =
|
|
let n = List.length xs in
|
|
let lets = ref [] in
|
|
let texts =
|
|
List.mapi
|
|
(fun i (x : Form.t) ->
|
|
let plain = match x.v with Form.List _ | Form.Vec _ | Form.Map _ -> false | _ -> true in
|
|
if plain || i = 0 || i = n - 1 then text_of x
|
|
else begin
|
|
let m = if !lets = [] then "mid" else Printf.sprintf "mid%d" (List.length !lets + 1) in
|
|
lets := Printf.sprintf " let %s = %s\n" m (text_of x) :: !lets;
|
|
m
|
|
end)
|
|
xs
|
|
in
|
|
let rec tests = function
|
|
| a :: (b :: _ as rest), op :: ops -> Printf.sprintf "%s %s %s" a op b :: tests (rest, ops)
|
|
| _ -> []
|
|
in
|
|
String.concat "" (List.rev !lets) ^ " " ^ String.concat " and " (tests (texts, ops))
|
|
|
|
(* Expressions come back with their syntactic level: 13 an atom or a bracket,
|
|
12 a postfix chain, 11 a prefix [-] or [~~], 1-10 a binary operator's
|
|
level, 3 a [not], 0 a one-line [if] or a lambda. Anything under 11 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 > 10 then unary p
|
|
else
|
|
let l0 = (peek p).loc in
|
|
let ((first, _) as fst_) = operand p lvl 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 operator 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, _ = operand p lvl in
|
|
(ot, rhs)
|
|
in
|
|
let rec run op operands =
|
|
match (peek p).tok with
|
|
| NAME s when binary_here s ->
|
|
let _, rhs = operator s in
|
|
if s = op then run op (rhs :: operands)
|
|
else
|
|
let folded, _ = close op operands in
|
|
run s [ rhs; folded ]
|
|
| _ -> close op operands
|
|
in
|
|
(* A comparison chain is read whole, then judged: one operator throughout
|
|
is the variadic call, one direction is [cmp_chain], anything else is
|
|
refused at the first operator that breaks it. *)
|
|
let rec chain acc =
|
|
match (peek p).tok with
|
|
| NAME s when binary_here s ->
|
|
let ot, rhs = operator s in
|
|
chain ((s, ot, rhs) :: acc)
|
|
| _ -> List.rev acc
|
|
in
|
|
let comparison () =
|
|
let links = chain [] in
|
|
let ops = List.map (fun (s, _, _) -> s) links in
|
|
let xs = first :: List.map (fun (_, _, x) -> x) links in
|
|
let op1 = List.hd ops in
|
|
if List.for_all (( = ) op1) ops then close op1 (List.rev xs)
|
|
else
|
|
let d = cmp_dir op1 in
|
|
Array.iteri
|
|
(fun i (op, (ot : token), _) ->
|
|
if i > 0 && (d = None || cmp_dir op <> d) then begin
|
|
let prev, _, _ = List.nth links (i - 1) in
|
|
failk "mixed-comparison" ot.loc
|
|
"%s follows %s in one chain. A chain may repeat one operator, \
|
|
or mix < with <=, or > with >=, as in 0 <= i < n. Write this \
|
|
one as tests joined with and:\n\n%s"
|
|
op prev (and_rewrite xs ops)
|
|
end)
|
|
(Array.of_list links);
|
|
(cmp_chain ~fresh:cmp_fresh (span p l0) xs ops, lvl)
|
|
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 && (cmp_dir s <> None || s = "==" || s = "!=") ->
|
|
comparison ()
|
|
| NAME s when binary_here s -> run s [ first ]
|
|
| _ -> fst_
|
|
|
|
(* An operand of level [lvl]'s operators. [??] sits between the comparisons
|
|
(4) and the bit operators (5), Swift's place for it: [a ?? b == c] is
|
|
[(a ?? b) == c] and [a ?? b + 1] is [a ?? (b + 1)]. A chain is one
|
|
variadic form, [(?? a b c)], which the checker reads from the right. *)
|
|
and operand p lvl =
|
|
if lvl <> 4 then binary p (lvl + 1)
|
|
else
|
|
let l0 = (peek p).loc in
|
|
let ((first, _) as fp) = binary p 5 in
|
|
let rec more acc =
|
|
match (peek p).tok with
|
|
| NAME "??" when not ((peek_at p 1).tok = LP && not (peek_at p 1).sp) ->
|
|
let ot = advance p in
|
|
if not (ot.sp && (peek p).sp) then
|
|
failk "unspaced-operator" ot.loc
|
|
"?? is an operator here, and a binary operator has a space on each \
|
|
side: a ?? b";
|
|
let rhs, _ = binary p 5 in
|
|
more (rhs :: acc)
|
|
| _ -> List.rev acc
|
|
in
|
|
match more [] with
|
|
| [] -> fp
|
|
| rest -> (mk p l0 (Form.List (sym l0 "??" :: first :: rest)), 4)
|
|
|
|
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 ]), 11)
|
|
| BNOT ->
|
|
ignore (advance p);
|
|
let x, _ = unary p in
|
|
(mk p t.loc (Form.List [ sym t.loc "bit-not"; x ]), 11)
|
|
| _ -> 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)), 12)
|
|
| LB ->
|
|
ignore (advance p);
|
|
let idx = index_items p t.loc ~head:(text_of f) in
|
|
loop (mk p l0 (Form.List (sym t.loc "at" :: f :: idx)), 12)
|
|
| NAME s when String.length s > 1 && s.[0] = '.' ->
|
|
ignore (advance p);
|
|
loop (mk p l0 (Form.List [ sym t.loc s; f ]), 12)
|
|
| 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) ]), 12)
|
|
(* [a?.b.c(x)] and [a?[i]]: the rest of the chain is read over a fresh
|
|
name, [~o1], bound to what [a] holds — [(?. [~o1 a] (.c ...))]. No
|
|
reader can produce a [~] name, so it shadows nothing. A [?.] later
|
|
in the rest nests, and the checker flattens it. *)
|
|
| QUEST
|
|
when (let n = peek_at p 1 in
|
|
(not n.sp)
|
|
&& (match n.tok with
|
|
| NAME s -> String.length s > 1 && s.[0] = '.'
|
|
| LB -> true
|
|
| _ -> false)) ->
|
|
ignore (advance p);
|
|
incr opt_n;
|
|
let h = Printf.sprintf "~o%d" !opt_n in
|
|
let rest, _ = loop (sym t.loc h, 12) in
|
|
(mk p l0
|
|
(Form.List
|
|
[ sym t.loc "?.";
|
|
Form.make (Form.Vec [ sym t.loc h; f ]) f.loc;
|
|
rest ]), 12)
|
|
(* [T?] where a type is read, and after what can only be a type
|
|
where a value is, [vec-new(i32?)]. On a value, [x?] tests that it
|
|
holds one (decision 133): [(? x)]. *)
|
|
| QUEST ->
|
|
let typish =
|
|
match f.v with
|
|
| Form.Sym n -> type_like n
|
|
| Form.Vec _ -> true
|
|
| Form.List ({ v = Form.Sym h; _ } :: _) ->
|
|
h <> "" && h.[0] >= 'A' && h.[0] <= 'Z'
|
|
| _ -> false
|
|
in
|
|
ignore (advance p);
|
|
if !in_type || typish then
|
|
loop (mk p l0 (Form.List [ sym l0 "Option"; f ]), 12)
|
|
else loop (mk p l0 (Form.List [ sym t.loc "?"; f ]), 12)
|
|
| BANG ->
|
|
ignore (advance p);
|
|
loop (mk p l0 (Form.List [ sym t.loc "!!"; f ]), 12)
|
|
| _ -> 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" || s = "when") && nxt.sp && starts_value nxt.tok then if_expr p
|
|
else if s = "fn" && glued_lp then fn_expr p
|
|
(* Only the Lisp loop's spellings are refused here, for a message at the
|
|
word: [loop x = a, ...], [loop([...]):], a bare [loop] over a block
|
|
where a statement or a let's value starts, and [recur(...)]. Anywhere
|
|
else [loop] and [recur] are names; [refuse_loops] catches the rest. *)
|
|
else if glued_lp && (s = "loop" || s = "recur") then no_loop l0 s
|
|
else if s = "loop"
|
|
&& ((nxt.sp
|
|
&& (match nxt.tok with NAME x -> not (is_op_word x) | _ -> false)
|
|
&& (match (peek_at p 2).tok with NAME "=" | COMMA -> true | _ -> false))
|
|
|| (nxt.tok = NEWLINE && (peek_at p 2).tok = INDENT
|
|
&& (p.i = 0
|
|
|| (match (last p).tok with
|
|
| NEWLINE | INDENT | DEDENT | NAME "=" -> true
|
|
| _ -> false)))) then
|
|
no_loop l0 s
|
|
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), 13)
|
|
end
|
|
else if s = "not" && nxt.sp && starts_value nxt.tok then begin
|
|
(* [a == not b]: [not] binds looser than the operator before it, so
|
|
it cannot start that operator's right side. The fix is the line
|
|
with the [not] and its operand in parentheses. *)
|
|
ignore (advance p);
|
|
let x, _ = not_ p in
|
|
let e = (last p).loc in
|
|
let _, lines = !source in
|
|
let fix =
|
|
if e.Loc.eline <> l0.Loc.line || l0.Loc.line > Array.length lines then
|
|
"(not " ^ text_of x ^ ")"
|
|
else
|
|
let line = lines.(l0.Loc.line - 1) in
|
|
let a = l0.Loc.col - 1 and b = e.Loc.ecol - 1 in
|
|
String.trim
|
|
(String.sub line 0 a ^ "(" ^ String.sub line a (b - a) ^ ")"
|
|
^ String.sub line b (String.length line - b))
|
|
in
|
|
failk "not-operand" l0
|
|
"not follows an operator here, and it binds looser than any \
|
|
operator but and and or, so it cannot start that operator's right \
|
|
side. Put it in parentheses with what it negates:\n\n %s"
|
|
fix
|
|
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, 13)
|
|
end
|
|
| KW k -> ignore (advance p); (Form.make (Form.Kw k) l0, 13)
|
|
| ATOM v ->
|
|
ignore (advance p);
|
|
(Form.make v l0, if negative_literal t.tok then 11 else 13)
|
|
| DATUM f -> ignore (advance p); (f, 13)
|
|
| LP ->
|
|
ignore (advance p);
|
|
if (peek p).tok = RP then begin
|
|
ignore (advance p);
|
|
(mk p l0 (Form.List []), 13)
|
|
end
|
|
else
|
|
let e, _ = expr p in
|
|
(match (peek p).tok with
|
|
| RP -> ignore (advance p)
|
|
| EOF -> unclosed p '(' l0
|
|
| COMMA ->
|
|
failk "tuple" (peek p).loc
|
|
"parentheses group one value, and this comma starts a second. \
|
|
Several values in a list are written in brackets, [a, b]; \
|
|
arguments go glued to a name, f(a, b)"
|
|
| _ -> stray p ~after:(text_of e));
|
|
(e, 13)
|
|
| LB ->
|
|
ignore (advance p);
|
|
let xs = vec_items p l0 in
|
|
(mk p l0 (Form.Vec xs), 13)
|
|
| LC ->
|
|
ignore (advance p);
|
|
let xs = map_items p l0 in
|
|
(mk p l0 (Form.Map xs), 13)
|
|
| 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 ]), 13)
|
|
| NEG | BNOT -> 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. [if let P = v then
|
|
a else b] and [when c then a] too. *)
|
|
and if_expr p =
|
|
let t = advance p in
|
|
let word = match t.tok with NAME w -> w | _ -> "if" in
|
|
let letp = if word = "if" then if_let_head p else None in
|
|
let c = match letp with Some m -> m | None -> fst (binary p 1) in
|
|
let letp, c =
|
|
match letp with
|
|
| Some _ -> (letp, c)
|
|
| None -> (match as_head p c with Some m when word = "if" -> (Some m, m) | _ -> (None, c))
|
|
in
|
|
(match (peek p).tok with
|
|
| NAME "then" -> ignore (advance p)
|
|
| _ ->
|
|
failk "if-then" (where_ p)
|
|
"an %s inside a line is %s, and there is no then \
|
|
after %s. Write the then, or start the %s on its own line with its \
|
|
branches indented under it"
|
|
word
|
|
(if word = "when" then "when c then a" else "if c then a else b")
|
|
(text_of c) word);
|
|
let a = inline_stmt p in
|
|
match (peek p).tok with
|
|
| NAME ("else" | "elif") when word = "when" -> when_else p
|
|
| NAME "else" ->
|
|
ignore (advance p);
|
|
let b = inline_stmt p in
|
|
(if_let_wrap letp (mk p t.loc (Form.List [ sym t.loc "if"; c; a; b ])), 0)
|
|
| NAME "elif" ->
|
|
failk "one-line-elif" (peek p).loc
|
|
"a one-line if has then and else and no elif. Chain another if after \
|
|
the else — if a then x else if b then y else z — or write the if over \
|
|
several lines, where elif goes"
|
|
| _ -> (if_let_wrap letp (mk p t.loc (Form.List [ sym t.loc "when"; c; a ])), 0)
|
|
|
|
(* [if let P = v]: after the [if], the pattern and the value, as the one form
|
|
[[P v]] that stands where the test would. [None] when no [let] follows. *)
|
|
and if_let_head p =
|
|
match (peek p).tok, (peek_at p 1) with
|
|
| NAME "let", n when n.sp ->
|
|
let lt = advance p in
|
|
let pat, _ = unary p in
|
|
expect_name p "=" ~what:"= and the value the pattern is matched against";
|
|
let v, _ = binary p 1 in
|
|
(match pat.v with
|
|
| Form.Sym g
|
|
when g <> "" && g.[0] >= 'a' && g.[0] <= 'z' && not (String.contains g '.')
|
|
&& g <> "true" && g <> "false" ->
|
|
failk "if-let-name" pat.loc
|
|
"if let %s = %s has no pattern to test. To test that %s holds a \
|
|
value, write if %s?, and in the block it is what it holds; to name \
|
|
what it holds, write if %s? as %s"
|
|
g (text_of v) (text_of v) (text_of v) (text_of v) g
|
|
| _ -> ());
|
|
Some (mk p lt.loc (Form.Vec [ pat; v ]))
|
|
| _ -> None
|
|
|
|
(* [e? as g]: after a test [e?], the name what [e] holds is bound to, as
|
|
the head [[g e]] an [if let] over a plain name stands as (decision 133). *)
|
|
and as_head p (c : Form.t) =
|
|
match (peek p).tok with
|
|
| NAME "as" ->
|
|
let at = advance p in
|
|
(match c.v with
|
|
| Form.List [ { v = Form.Sym "?"; _ }; e ] ->
|
|
let g =
|
|
match (peek p).tok with
|
|
| NAME g when g <> "" && g.[0] <> '.' ->
|
|
let gt = advance p in
|
|
check_name gt g;
|
|
sym gt.loc g
|
|
| tk ->
|
|
failk "as-name" (where_ p) "as takes the name to bind, and found %s" (show tk)
|
|
in
|
|
Some (Form.make (Form.Vec [ g; e ]) c.loc)
|
|
| _ ->
|
|
failk "as-test" at.loc
|
|
"as names what a test found, and %s is not one. Write %s? as name"
|
|
(text_of c) (text_of c))
|
|
| _ -> None
|
|
|
|
(* The if an [if let] head was read into, rewritten to (if-let [P v] then
|
|
else): [(if [P v] a b)], [(when [P v] body ...)] and an elif chain's
|
|
[(cond [P v] a c2 b2 ...)], whose rest is the else. *)
|
|
and if_let_wrap letp (f : Form.t) =
|
|
match letp with
|
|
| None -> f
|
|
| Some m ->
|
|
let il (h : Form.t) items =
|
|
{ f with Form.v = Form.List (sym h.Form.loc "if-let" :: m :: items) }
|
|
in
|
|
let body (h : Form.t) = function
|
|
| [ x ] -> x
|
|
| (x : Form.t) :: _ as xs ->
|
|
Form.make (Form.List (sym x.Form.loc "do" :: xs)) x.Form.loc
|
|
| [] -> Form.make (Form.List [ sym h.Form.loc "do" ]) h.Form.loc
|
|
in
|
|
match f.Form.v with
|
|
| Form.List (({ v = Form.Sym "if"; _ } as h) :: c :: rest) when c == m -> il h rest
|
|
| Form.List (({ v = Form.Sym "when"; _ } as h) :: c :: b) when c == m ->
|
|
il h [ body h b ]
|
|
| Form.List (({ v = Form.Sym "cond"; _ } as h) :: c :: b1 :: rest) when c == m ->
|
|
(match rest with
|
|
| [] -> il h [ b1 ]
|
|
| [ { v = Form.Kw "else"; _ }; e ] -> il h [ b1; e ]
|
|
| (c2 : Form.t) :: _ ->
|
|
il h [ b1; Form.make (Form.List (sym c2.Form.loc "cond" :: rest)) c2.Form.loc ])
|
|
| _ -> f
|
|
|
|
(* What a one-line slot takes — a match arm's value, a then or an else, the
|
|
thing after defer: a value, or one of the statements that fit on a line,
|
|
break, continue, return and an assignment. *)
|
|
(* A bare [()] written where a body goes — a one-line slot, a function's
|
|
[= ()] — is the empty statement, [(do)], as it is on a line of its own:
|
|
"do nothing" is what it says there. [(())] stays a value. *)
|
|
and unit_slot p i0 (t0 : token) (e : Form.t) =
|
|
if p.i - i0 = 2 && t0.tok = LP && e.v = Form.List [] then
|
|
Form.make (Form.List [ sym t0.loc "do" ]) e.loc
|
|
else e
|
|
|
|
and inline_stmt p : Form.t =
|
|
let t = peek p in
|
|
let glued = let n = peek_at p 1 in n.tok = LP && not n.sp in
|
|
match t.tok with
|
|
| NAME (("break" | "continue") as w) when not glued ->
|
|
ignore (advance p);
|
|
(match (peek p).tok with
|
|
| KW k ->
|
|
let kt = advance p in
|
|
mk p t.loc (Form.List [ sym t.loc w; Form.make (Form.Kw k) kt.loc ])
|
|
| _ -> mk p t.loc (Form.List [ sym t.loc w ]))
|
|
| NAME "return" when not glued ->
|
|
ignore (advance p);
|
|
let n = peek p in
|
|
if starts_value n.tok && not (n.tok = NAME "else") then
|
|
let v, _ = expr p in
|
|
mk p t.loc (Form.List [ sym t.loc "return"; v ])
|
|
else mk p t.loc (Form.List [ sym t.loc "return" ])
|
|
| _ ->
|
|
let i0 = p.i in
|
|
let e, _ = expr p in
|
|
match (peek p).tok with
|
|
| NAME "=" ->
|
|
no_place e;
|
|
let eq = advance p in
|
|
let v, _ = expr p in
|
|
mk p t.loc (Form.List [ sym eq.loc "set"; e; v ])
|
|
| NAME op when List.mem_assoc op assign_ops ->
|
|
no_place e;
|
|
let eq = advance p in
|
|
let v, _ = expr p in
|
|
mk p t.loc (compound eq.loc (List.assoc op assign_ops) e v (span p e.loc))
|
|
| _ -> unit_slot p i0 t e
|
|
|
|
(* [fn(a, b) => body] is a lambda; [fn(...)] followed by anything else is the
|
|
fallback call spelling of [(fn ...)]. *)
|
|
and fn_expr p =
|
|
if typed_lambda p then !typed_fn_expr p else
|
|
let t = advance p in
|
|
let lp = advance p in
|
|
let args = items p RP lp.loc ~what:"parameters" in
|
|
let rp = last p in
|
|
let names = List.for_all (fun (a : Form.t) -> match a.v with Form.Sym _ -> true | _ -> false) args in
|
|
let header () = "fn(" ^ String.concat ", " (List.map text_of args) ^ ")" in
|
|
let n = peek p in
|
|
match n.tok with
|
|
| NAME "=>" ->
|
|
ignore (advance p);
|
|
let ps = lambda_params args in
|
|
let body = lambda_body p ~header:(header ()) in
|
|
(mk p t.loc
|
|
(Form.List
|
|
(sym t.loc "fn" :: Form.make (Form.Vec ps) (span_of_list lp.loc args) :: body)),
|
|
0)
|
|
| NAME "=" when names -> lambda_equals p (header ())
|
|
| NAME w when names && glued_arrow w -> lambda_glued n (header ()) w
|
|
| NEWLINE when names && (peek_at p 1).tok = INDENT ->
|
|
lambda_arrow (peek_at p 2).loc (header ())
|
|
(* Inside brackets a line break is no token: the next line's first token
|
|
is what follows. *)
|
|
| tk when names && n.loc.Loc.line > rp.loc.Loc.eline && starts_value tk ->
|
|
lambda_arrow n.loc (header ())
|
|
| _ -> (mk p t.loc (Form.List (sym t.loc "fn" :: args)), 12)
|
|
|
|
(* What follows a lambda's [=>]: a value on the line, or the indented block
|
|
under it. [header] is the lambda's header as written, for a message. *)
|
|
and lambda_body p ~header =
|
|
match (peek p).tok, (peek_at p 1).tok with
|
|
| NEWLINE, INDENT ->
|
|
ignore (advance p);
|
|
let body = !block_of p in
|
|
p.closed <- p.i;
|
|
body
|
|
| (NEWLINE | EOF | DEDENT), _ ->
|
|
failk "lambda-body" (where_ p)
|
|
"the line ends after %s =>, and the lambda's body is not under it. Put \
|
|
the body after the =>, or on the lines under it, indented:\n\n\
|
|
\ %s =>\n ..."
|
|
header header
|
|
| _ ->
|
|
let i0 = p.i and t0 = peek p in
|
|
let body, _ = expr p in
|
|
[ unit_slot p i0 t0 body ]
|
|
|
|
(* [fn(a) = x]: a lambda written with a named function's [=]. *)
|
|
and lambda_equals : 'a. p -> string -> 'a = fun p header ->
|
|
let eq = advance p in
|
|
let body =
|
|
match expr p with
|
|
| b, _ -> text_of b
|
|
| exception _ -> "..."
|
|
in
|
|
failk "lambda-equals" eq.loc
|
|
"a lambda's body follows =>, and this one has =, which is how a named \
|
|
function is written. Write:\n\n %s => %s"
|
|
header body
|
|
|
|
(* [fn(a) =>x]: the body glued to the arrow reads as one name. *)
|
|
and glued_arrow w = String.length w > 2 && String.sub w 0 2 = "=>"
|
|
|
|
and lambda_glued : 'a. token -> string -> string -> 'a = fun t header w ->
|
|
failk "lambda-arrow-space" t.loc
|
|
"%s is one name, with nothing between => and the body. Put a space \
|
|
after the arrow: %s => %s"
|
|
w header (String.sub w 2 (String.length w - 2))
|
|
|
|
(* A lambda header with lines under it and no [=>]. *)
|
|
and lambda_arrow : 'a. Loc.t -> string -> 'a = fun at header ->
|
|
failk "lambda-arrow" at
|
|
"the lines under %s are a lambda's body only after =>. End the header \
|
|
with it:\n\n %s =>\n ..."
|
|
header header
|
|
|
|
(* Whether the [fn(] at point has a [:] among its parameters or a [->]
|
|
after them: a lambda that states its types. *)
|
|
and typed_lambda p =
|
|
let rec go k depth =
|
|
let t = peek_at p k in
|
|
match t.tok with
|
|
| EOF -> false
|
|
| COLON when depth = 1 -> true
|
|
| LP | LB | LC -> go (k + 1) (depth + 1)
|
|
| RP when depth = 1 -> (peek_at p (k + 1)).tok = NAME "->"
|
|
| RP | RB | RC -> go (k + 1) (depth - 1)
|
|
| _ -> go (k + 1) depth
|
|
in
|
|
go 1 0
|
|
|
|
and span_of_list l args =
|
|
match List.rev args with
|
|
| [] -> l
|
|
| (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)
|
|
&& n.loc.Loc.line > e.loc.Loc.eline then
|
|
(* Most often the bracket was never closed: the next statement
|
|
has been read as one more argument. *)
|
|
failk "missing-comma" n.loc
|
|
"%s on a new line follows %s with no comma between them. If the \
|
|
%c on line %d was meant to close before this line, close it; \
|
|
otherwise separate %s with commas"
|
|
(show n.tok) (text_of e) opener open_loc.Loc.line what
|
|
else if starts_value n.tok && n.sp && not (negative_literal n.tok) then
|
|
failk "missing-comma" n.loc
|
|
"%s follows %s with no comma between them. Separate %s with \
|
|
commas: f(a, b)"
|
|
(show n.tok) (text_of e) what
|
|
else stray p ~after:(text_of e))
|
|
in
|
|
go []
|
|
|
|
(* An index's values, [grid[r c]] or [grid[r + 1, c]]: separated as a
|
|
vector's elements are, by commas or, between single values only, by
|
|
spaces. The whole list is read before a mistake is named, so the fix can
|
|
be the index as written, commas put in. [head] is the text of what is
|
|
indexed. *)
|
|
and index_items p open_loc ~head =
|
|
let rec go acc =
|
|
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
|
|
(* The element as written, parentheses and all. *)
|
|
let src = text_of (Form.make (Form.Sym "") (span p t.loc)) in
|
|
let n = peek p in
|
|
match n.tok with
|
|
| COMMA -> ignore (advance p); go ((e, src, lvl, t.loc, Some n.loc) :: acc)
|
|
| RB -> ignore (advance p); List.rev ((e, src, lvl, t.loc, None) :: acc)
|
|
| EOF -> unclosed p '[' open_loc
|
|
(* [grid[i -1]]: most likely [i - 1] with its minus glued. *)
|
|
| (ATOM _ | NEG) when n.sp && (negative_literal n.tok || n.tok = NEG) ->
|
|
let x, _ = unary p in
|
|
let digits =
|
|
let s = text_of x in String.sub s 1 (String.length s - 1)
|
|
in
|
|
failk "glued-minus" n.loc
|
|
"%s is read as the value %s, right after %s with nothing between \
|
|
the minus and it. To subtract, space the minus: %s[%s - %s]. For \
|
|
two indices, separate them with a comma: %s[%s, %s]"
|
|
(text_of x) (text_of x) src head src digits head src (text_of x)
|
|
| tk when starts_value tk && n.sp -> go ((e, src, lvl, t.loc, None) :: acc)
|
|
| _ -> stray p ~after:(text_of e)
|
|
in
|
|
let xs = go [] in
|
|
let commas = List.exists (fun (_, _, _, _, c) -> c <> None) xs in
|
|
let spaces =
|
|
List.exists (fun (_, _, _, _, c) -> c = None) (match List.rev xs with _ :: r -> r | [] -> [])
|
|
in
|
|
let with_commas () =
|
|
Printf.sprintf "%s[%s]" head
|
|
(String.concat ", " (List.map (fun (_, s, _, _, _) -> s) xs))
|
|
in
|
|
if commas && spaces then begin
|
|
let at = match List.find_opt (fun (_, _, _, _, c) -> c <> None) xs with
|
|
| Some (_, _, _, _, Some l) -> l | _ -> open_loc
|
|
in
|
|
failk "mixed-separators" at
|
|
"these indices are separated some with commas and some with only \
|
|
spaces. Use one: %s%s"
|
|
(with_commas ())
|
|
(if List.for_all (fun (_, _, l, _, _) -> l >= 11) xs then
|
|
Printf.sprintf " or %s[%s]" head
|
|
(String.concat " " (List.map (fun (_, s, _, _, _) -> s) xs))
|
|
else "")
|
|
end;
|
|
(match List.find_opt (fun (_, _, l, _, _) -> l < 11) xs with
|
|
| Some (_, src, _, at, _) when spaces ->
|
|
failk "separate-elements" at
|
|
"%s has an operator in it and sits among indices separated by spaces, \
|
|
where only single values are. Separate the indices with commas: %s"
|
|
src (with_commas ())
|
|
| _ -> ());
|
|
List.map (fun (e, _, _, _, _) -> e) xs
|
|
|
|
(* [[a b c]] or [[a, b + 1]]: whitespace separates only single terms. *)
|
|
and vec_items p open_loc =
|
|
(* One separator per bracket: [1 2, 3] mixes them, and which elements the
|
|
comma was meant to part is a guess. *)
|
|
let commas = ref false and spaces = ref false in
|
|
let mixed at =
|
|
failk "mixed-separators" at
|
|
"this bracket separates some elements with commas and some with only \
|
|
spaces. Use one: [1, 2, 3] or [1 2 3]"
|
|
in
|
|
let rec go acc prev_ws =
|
|
let t = peek p in
|
|
match t.tok with
|
|
| RB -> ignore (advance p); List.rev acc
|
|
| EOF -> unclosed p '[' open_loc
|
|
| _ ->
|
|
let e, lvl = expr p in
|
|
if lvl < 11 && prev_ws then refuse_ws t.loc e;
|
|
(match (peek p).tok with
|
|
| COMMA ->
|
|
if !spaces then mixed (peek p).loc;
|
|
commas := true;
|
|
ignore (advance p); go (e :: acc) false
|
|
| RB -> ignore (advance p); List.rev (e :: acc)
|
|
| EOF -> unclosed p '[' open_loc
|
|
| tk when starts_value tk && (peek p).sp ->
|
|
if lvl < 11 then refuse_ws t.loc e;
|
|
if !commas then mixed (peek p).loc;
|
|
spaces := true;
|
|
go (e :: acc) true
|
|
| _ -> stray p ~after:(text_of e))
|
|
in
|
|
go [] false
|
|
|
|
(* Braces pair a key with a value, so a value may be any expression; after
|
|
one that has an operator in it, the next entry needs a comma. *)
|
|
and map_items p open_loc =
|
|
let rec go acc =
|
|
let t = peek p in
|
|
match t.tok with
|
|
| RC -> ignore (advance p); List.rev acc
|
|
| EOF -> unclosed p '{' open_loc
|
|
| _ ->
|
|
let e, lvl = expr p in
|
|
(match (peek p).tok with
|
|
| COMMA -> ignore (advance p); go (e :: acc)
|
|
| RC -> ignore (advance p); List.rev (e :: acc)
|
|
| EOF -> unclosed p '{' open_loc
|
|
(* [P{x = 1}] or [P{x: 1}]: another language's field syntax. *)
|
|
| (NAME "=" | COLON) as tk
|
|
when (match e.v with Form.Sym n -> n <> "" && n.[0] <> '.' | _ -> false) ->
|
|
let n = text_of e in
|
|
failk "brace-field" (peek p).loc
|
|
"a field in braces is written {.%s value}: a dot before the name, \
|
|
and no %s between it and the value"
|
|
n (if tk = COLON then "colon" else "= sign")
|
|
| tk when starts_value tk && (peek p).sp ->
|
|
if lvl < 11 then refuse_ws ~brace:true t.loc e;
|
|
go (e :: acc)
|
|
| _ -> stray p ~after:(text_of e))
|
|
in
|
|
go []
|
|
|
|
|
|
(* A type after [:] or [->]: a postfix term, plus the arrow of a function
|
|
type, [Fn(A, B) -> R], which reads as [(Fn [A B] R)]. *)
|
|
let rec ty p : Form.t =
|
|
let l0 = (peek p).loc in
|
|
let was = !in_type in
|
|
in_type := true;
|
|
let f, _ = Fun.protect ~finally:(fun () -> in_type := was) (fun () -> 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 }
|
|
|
|
(* Whether the code line before [t] is a one-line [if c then a] with no
|
|
else: an else under it reads as written for that if, and is not. *)
|
|
let one_line_if_above p (t : token) =
|
|
let layout = function NEWLINE | INDENT | DEDENT -> true | _ -> false in
|
|
let rec prev j =
|
|
if j < 0 then None
|
|
else
|
|
let u = p.toks.(j) in
|
|
if u.loc.Loc.line < t.loc.Loc.line && not (layout u.tok) then Some u.loc.Loc.line
|
|
else prev (j - 1)
|
|
in
|
|
match prev (p.i - 1) with
|
|
| None -> false
|
|
| Some l ->
|
|
let rec line j acc =
|
|
if j < 0 || p.toks.(j).loc.Loc.line < l then acc
|
|
else line (j - 1) (if layout p.toks.(j).tok || p.toks.(j).loc.Loc.line > l then acc
|
|
else p.toks.(j).tok :: acc)
|
|
in
|
|
(match line (p.i - 1) [] with
|
|
| NAME "if" :: rest -> List.mem (NAME "then") rest && not (List.mem (NAME "else") rest)
|
|
| _ -> false)
|
|
|
|
(* Whether the code line before [t] is [else if c then a]: that else took
|
|
the one-line if as its value, and an else under it has no if left. *)
|
|
let else_if_above p (t : token) =
|
|
let layout = function NEWLINE | INDENT | DEDENT -> true | _ -> false in
|
|
let rec prev j =
|
|
if j < 0 then None
|
|
else
|
|
let u = p.toks.(j) in
|
|
if u.loc.Loc.line < t.loc.Loc.line && not (layout u.tok) then Some u.loc.Loc.line
|
|
else prev (j - 1)
|
|
in
|
|
match prev (p.i - 1) with
|
|
| None -> false
|
|
| Some l ->
|
|
let rec first j =
|
|
if j <= 0 || p.toks.(j - 1).loc.Loc.line < l then j else first (j - 1)
|
|
in
|
|
let j = first (p.i - 1) in
|
|
let j = if layout p.toks.(j).tok then j + 1 else j in
|
|
j + 1 < Array.length p.toks
|
|
&& p.toks.(j).tok = NAME "else" && p.toks.(j + 1).tok = NAME "if"
|
|
|
|
(* A block of several lines is a [do] spanning its lines, from the first
|
|
statement to the end of the last — not from the header above it, which is
|
|
another form's. *)
|
|
let blk (s : st) l (ss : Form.t list) =
|
|
match ss with
|
|
| [ x ] -> x
|
|
| (first : Form.t) :: _ -> mk s.p first.loc (Form.List (sym first.loc "do" :: ss))
|
|
| [] -> mk s.p l (Form.List [ sym l "do" ])
|
|
|
|
(* The word at the head of the line is a variable being assigned, [data = 3]
|
|
or [on += 1], whatever else it could start. *)
|
|
let assigns p =
|
|
let n = peek_at p 1 in
|
|
n.sp && (match n.tok with NAME x -> x = "=" || List.mem_assoc x assign_ops | _ -> false)
|
|
|
|
let header_follow p s =
|
|
let n = peek_at p 1 in
|
|
(not (assigns p)) &&
|
|
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" | "when" | "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)
|
|
(* [macro name(...)]: the name and its glued parenthesis. *)
|
|
| "macro" ->
|
|
n.sp && plain_name n.tok
|
|
&& (let a = peek_at p 2 in a.tok = LP && not a.sp)
|
|
(* [class Lambda(...)] or [class Lambda] over its slot lines. *)
|
|
| "class" -> n.sp && plain_name n.tok
|
|
(* [generic describe(v)], [multi kind(v)], [method describe(f: C)]: the
|
|
name and its glued parenthesis. *)
|
|
| "generic" | "multi" | "method" ->
|
|
n.sp && plain_name n.tok
|
|
&& (let a = peek_at p 2 in a.tok = LP && not a.sp)
|
|
(* [type Row = Vec(i32)]: a name and its [=]. *)
|
|
| "type" -> n.sp && plain_name n.tok && (peek_at p 2).tok = NAME "="
|
|
| "return" -> n.tok = NEWLINE || (n.sp && starts_value n.tok)
|
|
| "break" | "continue" ->
|
|
n.tok = NEWLINE || (n.sp && (match n.tok with KW _ -> true | _ -> false))
|
|
| "defer" ->
|
|
(n.tok = NEWLINE && (peek_at p 2).tok = INDENT) || (n.sp && starts_value n.tok)
|
|
| "handler-case" | "handler-bind" | "restart-case" ->
|
|
n.tok = NEWLINE || (n.sp && starts_value n.tok)
|
|
| "quote" ->
|
|
(n.tok = NEWLINE && (peek_at p 2).tok = INDENT) || (n.sp && starts_value n.tok)
|
|
| _ -> false
|
|
|
|
let name_tok p ~what =
|
|
let t = peek p in
|
|
match t.tok with
|
|
| NAME s when not (String.length s > 0 && s.[0] = '.') ->
|
|
ignore (advance p);
|
|
check_name t s;
|
|
sym t.loc s
|
|
| tk -> failk "expected-name" (where_ p) "expected %s here, and found %s" what (show tk)
|
|
|
|
let glued_lp p ~what =
|
|
let t = peek p in
|
|
if t.tok = LP && not t.sp then advance p
|
|
else failk "expected" (where_ p) "expected %s here, and found %s" what (show t.tok)
|
|
|
|
(* [(a: i32, b)] as name/type pairs, [dyn] written out for the untyped: the
|
|
reader never leaves a vector for [Check.pair_params] to guess at. *)
|
|
let params p (lp : token) =
|
|
let rec go acc =
|
|
let t = peek p in
|
|
match t.tok with
|
|
| RP -> ignore (advance p); List.rev acc
|
|
| EOF -> unclosed p '(' lp.loc
|
|
| _ ->
|
|
(match t.tok with
|
|
| NAME "&" ->
|
|
failk "rest-parameter" t.loc
|
|
"a function's parameters are a fixed list of names, each with an \
|
|
optional : Type, and & (a rest parameter) is not one. Take the rest \
|
|
as one parameter, xs: [T]"
|
|
| _ -> ());
|
|
let n = name_tok p ~what:"a parameter's name" in
|
|
let typed = (peek p).tok = COLON in
|
|
let tyf =
|
|
match (peek p).tok with
|
|
| COLON -> ignore (advance p); ty p
|
|
| _ -> sym n.loc "dyn"
|
|
in
|
|
(match (peek p).tok with
|
|
| COMMA -> ignore (advance p)
|
|
| RP -> ()
|
|
| _ -> stray p ~after:(text_of (if typed then tyf else n)));
|
|
go (tyf :: n :: acc)
|
|
in
|
|
go []
|
|
|
|
(* [(a, b: T)] as each name and its type when one is written. *)
|
|
let named_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); Some (ty p)
|
|
| _ -> None
|
|
in
|
|
(match (peek p).tok with
|
|
| COMMA -> ignore (advance p)
|
|
| RP -> ()
|
|
| _ -> stray p ~after:(text_of (match tyf with Some t -> t | None -> n)));
|
|
go ((n, tyf) :: acc)
|
|
in
|
|
go []
|
|
|
|
(* [fn(a: C, b) -> R => body] is [(the (Fn [C dyn] R) (fn [a b] body))]: the
|
|
paren [fn] takes its parameters' types from where it is written, and [the]
|
|
is the form that says what a value is, as in [let x: T = v]. An untyped
|
|
parameter is dyn, as in a definition, and the return type is required. *)
|
|
let () = typed_fn_expr := fun p ->
|
|
let t = advance p in
|
|
let lp = advance p in
|
|
let ps = params p lp in
|
|
let rec split = function
|
|
| n :: ty :: rest -> let ns, ts = split rest in (n :: ns, ty :: ts)
|
|
| _ -> ([], [])
|
|
in
|
|
let names, tys = split ps in
|
|
let params_text () =
|
|
String.concat ", "
|
|
(List.map2 (fun n (ty : Form.t) ->
|
|
if ty.v = Form.Sym "dyn" then text_of n else text_of n ^ ": " ^ text_of ty)
|
|
names tys)
|
|
in
|
|
let r =
|
|
match (peek p).tok with
|
|
| NAME "->" -> ignore (advance p); ty p
|
|
| _ ->
|
|
failk "lambda-return" (where_ p)
|
|
"a lambda that states its parameters' types states its return type \
|
|
too: fn(%s) -> R => value"
|
|
(params_text ())
|
|
in
|
|
let header () = "fn(" ^ params_text () ^ ") -> " ^ text_of r in
|
|
let fty = mk p lp.loc (Form.List [ sym t.loc "Fn"; Form.make (Form.Vec tys) lp.loc; r ]) in
|
|
let vec = Form.make (Form.Vec names) lp.loc in
|
|
let wrap body =
|
|
mk p t.loc (Form.List [ sym t.loc "the"; fty;
|
|
mk p t.loc (Form.List (sym t.loc "fn" :: vec :: body)) ])
|
|
in
|
|
match (peek p).tok with
|
|
| NAME "=>" ->
|
|
ignore (advance p);
|
|
let body = lambda_body p ~header:(header ()) in
|
|
(wrap body, 0)
|
|
| NAME "=" -> lambda_equals p (header ())
|
|
| NAME w when glued_arrow w -> lambda_glued (peek p) (header ()) w
|
|
| NEWLINE when (peek_at p 1).tok = INDENT -> lambda_arrow (peek_at p 2).loc (header ())
|
|
(* Inside brackets a line break is no token: the next line's first token
|
|
is what follows. *)
|
|
| tk when (peek p).loc.Loc.line > (last p).loc.Loc.eline && tk <> EOF ->
|
|
lambda_arrow (peek p).loc (header ())
|
|
| _ ->
|
|
failk "lambda-body" (where_ p)
|
|
"a lambda's body follows => on its line, or is the block under it: \
|
|
%s => value" (header ())
|
|
|
|
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
|
|
match (peek p).tok with
|
|
(* [let r = match a] with its arms under it, and [let r = if c] with its
|
|
branches: a header read as the value, block and all. *)
|
|
| NAME (("match" | "handler-case" | "handler-bind" | "restart-case") as w)
|
|
when header_follow p w ->
|
|
header s w
|
|
| NAME (("if" | "when") as w) when header_follow p w && not (then_on_line p) ->
|
|
header s w
|
|
| _ ->
|
|
let e, _ = expr p in
|
|
match (peek p).tok with
|
|
(* [let v = with-foo(a):] and its block: the call takes the block, as it
|
|
would on a line of its own. *)
|
|
| COLON when (match e.v, (last p).tok with
|
|
| Form.List (_ :: _), RP | Form.Sym _, NAME _ -> true
|
|
| _ -> false) ->
|
|
ignore (advance p);
|
|
(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 e.loc (Form.List (items @ body))
|
|
| _ -> mk p e.loc (Form.List (e :: body)))
|
|
| COMMA ->
|
|
let c = (peek p).loc in
|
|
(* On a let's line, the fix is the let's group: the rest of the line
|
|
under the first name. *)
|
|
let group =
|
|
let file, lines = !source in
|
|
if c.Loc.file <> file || c.Loc.line > Array.length lines then None
|
|
else
|
|
let line = lines.(c.Loc.line - 1) in
|
|
let head = String.trim (String.sub line 0 (c.Loc.col - 1)) in
|
|
let rest = String.trim (String.sub line c.Loc.col (String.length line - c.Loc.col)) in
|
|
if String.length head > 4 && String.sub head 0 4 = "let " && rest <> "" then
|
|
Some (Printf.sprintf ":\n\n %s\n %s" head rest)
|
|
else None
|
|
in
|
|
failk "one-binding" c
|
|
"%s is followed by a comma, and one line binds one name. Put each \
|
|
binding on its own line%s"
|
|
(text_of e)
|
|
(match group with
|
|
| Some g -> ", the ones after the first under its name" ^ g
|
|
| None -> ", one after the other")
|
|
| _ -> lambda_block ~block_ok s e ~after:(text_of e)
|
|
|
|
(* Whether this line has a [then] at depth zero: a one-line if. *)
|
|
and then_on_line p =
|
|
let rec go k depth =
|
|
let t = peek_at p k in
|
|
match t.tok with
|
|
| NEWLINE | EOF -> false
|
|
| NAME "then" when depth = 0 -> true
|
|
| LP | LB | LC -> go (k + 1) (depth + 1)
|
|
| RP | RB | RC -> go (k + 1) (max 0 (depth - 1))
|
|
| _ -> go (k + 1) depth
|
|
in
|
|
go 1 0
|
|
|
|
(* The end of a statement's line, which a lambda's block may already have
|
|
taken. *)
|
|
and lambda_block ?(block_ok = false) (s : st) (e : Form.t) ~after =
|
|
let p = s.p in
|
|
if block_ok && p.i <> p.closed && (peek p).tok = NEWLINE then ignore (advance p)
|
|
else expect_eol p ~after;
|
|
e
|
|
|
|
(* One binding of a let, [x = v], [x: T = v] or [{a .x} = p], through the
|
|
end of its line (and the block its value takes). *)
|
|
and binding (s : st) : Form.t * Form.t =
|
|
let p = s.p in
|
|
let target, _ = unary p in
|
|
(* [let x: T = v] is [(let [x (the T v)])]: a let binding has no type slot
|
|
of its own, and [the] is the form that says what a value is. *)
|
|
let annot =
|
|
match (peek p).tok with
|
|
| COLON -> ignore (advance p); Some (ty p)
|
|
| _ -> None
|
|
in
|
|
(match (peek p).tok with
|
|
| NAME "=" -> ignore (advance p)
|
|
| _ ->
|
|
failk "let-equals" (where_ p)
|
|
"a let is let name = value, and %s is not followed by =" (text_of target));
|
|
let v = value_line ~block_ok:true s ~after:("let " ^ text_of target) in
|
|
let v =
|
|
match annot with
|
|
| Some tyf ->
|
|
Form.make (Form.List [ sym tyf.loc "the"; tyf; v ]) (span p tyf.loc)
|
|
| None -> v
|
|
in
|
|
(target, v)
|
|
|
|
(* The lines indented under a let, each one more binding of it: [let a = 1]
|
|
and under it [b = a + 1], lined up with [a]. Anything else there is
|
|
refused; [first] is the let's first target, for the message. *)
|
|
and binding_lines : 'a. ?global:bool -> st -> first:Form.t -> name_col:int -> one:(unit -> 'a) -> 'a list =
|
|
fun ?(global = false) s ~first ~name_col ~one ->
|
|
let p = s.p in
|
|
if (peek p).tok <> INDENT then []
|
|
else begin
|
|
ignore (advance p);
|
|
let misaligned (t : token) =
|
|
let_misaligned t.loc ~let_line:first.loc.Loc.line ~name:(text_of first)
|
|
~name_col
|
|
in
|
|
(* [block] is the binding before this line when its value ended in a
|
|
block still open at its end — a trailing [fn(x) =>], [match], [if],
|
|
[x =] or [f():] — which ends the let's bindings. A block lambda whose
|
|
brackets close after its block does not. *)
|
|
let rec go ?block acc =
|
|
match (peek p).tok with
|
|
| DEDENT -> ignore (advance p); List.rev acc
|
|
| EOF -> List.rev acc
|
|
| INDENT when binding_shaped p.toks (p.i + 1) -> misaligned (peek_at p 1)
|
|
| INDENT -> ignore (advance p); not_binding ()
|
|
| _ when binding_line ~global p ->
|
|
if (peek p).loc.Loc.col <> name_col then misaligned (peek p);
|
|
(match block with
|
|
| Some name -> let_after_block (peek p).loc ~let_line:first.loc.Loc.line ~name
|
|
| None -> ());
|
|
let t0 = peek p in
|
|
let x = one () in
|
|
(* The last token the value took, past its line's end. *)
|
|
let rec last_real k =
|
|
if k > 0 && p.toks.(k).tok = NEWLINE then last_real (k - 1) else k
|
|
in
|
|
let open_block = p.toks.(last_real (p.i - 1)).tok = DEDENT in
|
|
go ?block:(if open_block then Some (text_of_tok t0) else None) (x :: acc)
|
|
| _ -> not_binding ()
|
|
and not_binding () =
|
|
failk "let-block" (where_ p)
|
|
"this line is indented under let %s, and the only lines that go \
|
|
there are more bindings of the let, lined up with its first name:\n\n\
|
|
\ let a = 1\n b = a + 1\n\n\
|
|
A let's names last to the end of the block the let is in, so any \
|
|
other line after it goes at the let's column"
|
|
(text_of first)
|
|
in
|
|
go []
|
|
end
|
|
|
|
(* Whether the line at point is a binding: a name, a [[...]] or [{...}]
|
|
pattern, or an operator word in parentheses, [(not) = 3], then [=] or
|
|
[: T =]. [x += 1] and [f(x)] are not. A [global]'s line may be [x: T]
|
|
alone, as a top-level let's may. *)
|
|
and binding_line ?(global = false) p =
|
|
(* An [=] at the line's own depth, from token [k] on. *)
|
|
let rec eq k depth =
|
|
match (peek_at p k).tok with
|
|
| EOF | NEWLINE | INDENT | DEDENT -> false
|
|
| NAME "=" when depth = 0 -> true
|
|
| LP | LB | LC -> eq (k + 1) (depth + 1)
|
|
| RP | RB | RC -> eq (k + 1) (depth - 1)
|
|
| _ -> eq (k + 1) depth
|
|
in
|
|
match (peek p).tok with
|
|
| NAME s when s <> "" && s.[0] <> '.' && not (is_op_word s) ->
|
|
(match (peek_at p 1).tok with
|
|
| NAME "=" -> (peek_at p 1).sp
|
|
| COLON -> global || eq 2 0
|
|
| _ -> false)
|
|
(* [~g = a] in a template. *)
|
|
| UNQ -> eq 1 0
|
|
| LB | LC | LP ->
|
|
let rec close k depth =
|
|
match (peek_at p k).tok with
|
|
| EOF | NEWLINE -> false
|
|
| LP | LB | LC -> close (k + 1) (depth + 1)
|
|
| RP | RB | RC when depth = 1 -> (peek_at p (k + 1)).tok = NAME "="
|
|
| RP | RB | RC -> close (k + 1) (depth - 1)
|
|
| _ -> close (k + 1) depth
|
|
in
|
|
close 0 0
|
|
| _ -> false
|
|
|
|
and let_stmt (s : st) : Form.t list =
|
|
let p = s.p in
|
|
let t = advance p in
|
|
let_gap_tab t (peek p);
|
|
let name_col = (peek p).loc.Loc.col in
|
|
let (target, v) =
|
|
let_values := (name_col, text_of_tok (peek p), t.loc.Loc.line) :: !let_values;
|
|
Fun.protect ~finally:(fun () -> let_values := List.tl !let_values)
|
|
(fun () -> binding s)
|
|
in
|
|
let more = binding_lines s ~first:target ~name_col ~one:(fun () -> binding s) in
|
|
let own = List.concat_map (fun (a, b) -> [ a; b ]) ((target, v) :: more) 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 (own @ bs) body
|
|
| _ -> make own body
|
|
in
|
|
[ 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 _ when assigns p -> expr_stmt s
|
|
| NAME (("else" | "elif") as w) when else_if_above p t ->
|
|
failk "orphan-else" t.loc
|
|
"the else above took the one-line if after it as its value, so this %s \
|
|
has no if to belong to. Write that line as elif:\n\n\
|
|
\ if a then x\n elif b then y\n else z"
|
|
w
|
|
| NAME (("else" | "elif") as w) when one_line_if_above p t ->
|
|
failk "orphan-else" t.loc
|
|
"this %s is not at the column of the one-line if above it. An else or \
|
|
elif that continues a one-line if goes at the if's column:\n\n\
|
|
\ if c then a\n else b"
|
|
w
|
|
| NAME (("else" | "elif") as w) ->
|
|
failk "orphan-else" t.loc
|
|
"%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 "=" ->
|
|
no_place e;
|
|
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 ->
|
|
no_place e;
|
|
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 (compound eq.loc o e v (span p e.loc))
|
|
| COLON ->
|
|
let before = (last p).tok in
|
|
let c = advance p in
|
|
(* [f(x):] and, with no arguments, [comment:] — a bare name — open a
|
|
block; anything else has no call to hang it on. *)
|
|
(match e.v, before with
|
|
| Form.List (_ :: _), RP -> ()
|
|
| Form.Sym _, NAME _ -> ()
|
|
| _ ->
|
|
failk "colon-block" c.loc
|
|
"a trailing colon gives a call an indented block, and %s is not a \
|
|
call. Write it as one, as in f(x): or comment:"
|
|
(text_of e));
|
|
(match (peek p).tok with
|
|
| NEWLINE -> ignore (advance p)
|
|
| _ -> stray p ~after:":");
|
|
let body = block s ~after:(text_of e ^ ":") in
|
|
(match e.v with
|
|
| Form.List items -> mk p t0.loc (Form.List (items @ body))
|
|
| _ -> mk p t0.loc (Form.List (e :: body)))
|
|
| _ ->
|
|
(* [()] alone on a line is the empty statement, spec §2 "Unit". *)
|
|
let e =
|
|
if p.i - i0 = 2 && t0.tok = LP && e.v = Form.List [] then
|
|
Form.make (Form.List [ sym t0.loc "do" ]) e.loc
|
|
else e
|
|
in
|
|
lambda_block s e ~after:(text_of e)
|
|
|
|
and header (s : st) w : Form.t =
|
|
let p = s.p in
|
|
let t = advance p in
|
|
let l0 = t.loc in
|
|
let form items = mk p l0 (Form.List (sym l0 w :: items)) in
|
|
let named head items = mk p l0 (Form.List (sym l0 head :: items)) in
|
|
match w with
|
|
| "fn" | "fn-" ->
|
|
let name = name_tok p ~what:"the function's name" in
|
|
let lp = glued_lp p ~what:"the parameters, in parentheses glued to the name" in
|
|
let ps = params p lp in
|
|
let rp = last p in
|
|
(* No arrow reads the return type off the body: the paren syntax's [_]
|
|
(spec-syntax.md §3.5). *)
|
|
let ret, ret_text =
|
|
match (peek p).tok with
|
|
| NAME "->" -> ignore (advance p); let r = ty p in (r, text_of r)
|
|
| _ -> (sym rp.loc "_", ")")
|
|
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
|
|
(* [and] is how a condition joins tests, so it is what gets written
|
|
for several predicates; the clause separates them with commas. *)
|
|
(match e.Form.v with
|
|
| Form.List ({ Form.v = Form.Sym "and"; _ } :: (_ :: _ as ps)) ->
|
|
let spell (q : Form.t) =
|
|
match q.Form.v with
|
|
| Form.List [ { Form.v = Form.Sym n; _ };
|
|
{ Form.v = Form.Sym v; _ } ] ->
|
|
Printf.sprintf "%s(%s)" n v
|
|
| _ -> Form.to_string q
|
|
in
|
|
failk "where-and" e.Form.loc
|
|
"a where clause separates its predicates with commas, not and \
|
|
— write where %s"
|
|
(String.concat ", " (List.map spell ps))
|
|
| _ -> ());
|
|
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 begin
|
|
let i0 = p.i and t0 = peek p in
|
|
let v = value_line s ~after:"=" in
|
|
let bare =
|
|
t0.tok = LP && p.toks.(i0 + 1).tok = RP && v.v = Form.List []
|
|
&& (match p.toks.(i0 + 2).tok with NEWLINE | EOF | DEDENT -> true | _ -> false)
|
|
in
|
|
[ (if bare then Form.make (Form.List [ sym t0.loc "do" ]) v.loc else v) ]
|
|
end
|
|
| NEWLINE ->
|
|
ignore (advance p);
|
|
if (peek p).tok = INDENT then block s ~after:"fn" else []
|
|
| _ -> stray p ~after:ret_text
|
|
in
|
|
named (if w = "fn" then "defn" else "defn-")
|
|
(name :: Form.make (Form.Vec ps) lp.loc :: ret :: (where_clause @ body))
|
|
| "def" | "once" | "const" -> def_form s w t l0
|
|
| "struct" | "union" ->
|
|
let name = name_tok p ~what:"the type's name" in
|
|
(* [struct Pt(x: i32, y: i32)]: the fields on the header's line, as a
|
|
data case writes them, with no block under it. *)
|
|
let inline =
|
|
match (peek p).tok with
|
|
| LP when not (peek p).sp -> let lp = advance p in Some (params p lp)
|
|
| _ -> None
|
|
in
|
|
(* [struct DiskFull :parent IoError]: a condition's parent, before the
|
|
fields as in the paren form. *)
|
|
let parent =
|
|
match (peek p).tok with
|
|
| KW "parent" when w = "struct" ->
|
|
let kt = advance p in
|
|
let pt = ty p in
|
|
Some (Form.make (Form.Kw "parent") kt.loc, pt)
|
|
| _ -> None
|
|
in
|
|
let after =
|
|
match parent, inline with
|
|
| Some (_, pt), _ -> text_of pt
|
|
| None, Some _ -> ")"
|
|
| None, None -> w ^ " " ^ text_of name
|
|
in
|
|
let fields =
|
|
match inline with
|
|
| Some fs -> expect_eol p ~after; fs
|
|
| None ->
|
|
expect_eol_block p ~after;
|
|
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
|
|
let fv = Form.make (Form.Vec fields) (span p name.loc) in
|
|
(* No field lines under a parent is the category form, which has no
|
|
field vector. *)
|
|
named (if w = "struct" then "defstruct" else "defunion")
|
|
(match parent with
|
|
| None -> [ name; fv ]
|
|
| Some (k, pt) -> name :: k :: pt :: (if fields = [] then [] else [ fv ]))
|
|
| "class" ->
|
|
let name = name_tok p ~what:"the class's name" in
|
|
let ps =
|
|
match (peek p).tok with
|
|
| LP when not (peek p).sp ->
|
|
let lp = advance p in
|
|
let ps = named_params p lp in
|
|
expect_eol p ~after:")";
|
|
ps
|
|
| _ ->
|
|
expect_eol_block p ~after:("class " ^ text_of name);
|
|
let acc = ref [] in
|
|
ignore
|
|
(lines s (fun () ->
|
|
let f = name_tok p ~what:"a slot's name" in
|
|
let t =
|
|
match (peek p).tok with
|
|
| COLON -> ignore (advance p); Some (ty p)
|
|
| _ -> None
|
|
in
|
|
expect_eol p ~after:(match t with Some t -> text_of t | None -> text_of f);
|
|
acc := (f, t) :: !acc;
|
|
[]));
|
|
List.rev !acc
|
|
in
|
|
(* Each slot's name, and its type after it when one is written: the
|
|
paren form's [(defclass c [a b n i32])], whose untyped slots are dyn. *)
|
|
let slots =
|
|
List.concat_map (fun (n, t) -> match t with Some t -> [ n; t ] | None -> [ n ]) ps
|
|
in
|
|
named "defclass" [ name; Form.make (Form.Vec slots) (span p name.loc) ]
|
|
| "generic" | "multi" | "method" ->
|
|
let name = name_tok p ~what:(Printf.sprintf "the %s's name" w) in
|
|
let lp = advance p in
|
|
let ps = named_params p lp in
|
|
(* A method's first parameter may name the class it answers for; every
|
|
other parameter of these is dyn, so it takes no type. *)
|
|
let names = String.concat ", " (List.map (fun ((n : Form.t), _) -> text_of n) ps) in
|
|
let first = match ps with (n, _) :: _ -> text_of n | [] -> "v" in
|
|
let first_class = ref None in
|
|
List.iteri
|
|
(fun k ((n : Form.t), t) ->
|
|
match t with
|
|
| Some (tf : Form.t) when k = 0 && w = "method" -> first_class := Some tf
|
|
| Some tf ->
|
|
failk "dyn-parameter" tf.loc
|
|
"every parameter of a %s is dyn, so %s takes no type: write %s %s(%s)%s"
|
|
w (text_of n) w (text_of name)
|
|
(String.concat ", "
|
|
(List.mapi
|
|
(fun k ((n : Form.t), t) ->
|
|
match t with
|
|
| Some t when k = 0 && w = "method" -> text_of n ^ ": " ^ text_of t
|
|
| _ -> text_of n)
|
|
ps))
|
|
(if w = "method" then "" else " -> dyn")
|
|
| None -> ())
|
|
ps;
|
|
let pv = Form.make (Form.Vec (List.map fst ps)) (span p lp.loc) in
|
|
let ret () =
|
|
match (peek p).tok with
|
|
| NAME "->" -> ignore (advance p); ty p
|
|
| _ ->
|
|
(* At the end of the header's line, where the arrow goes. *)
|
|
let e = (last p).loc in
|
|
failk "generic-return"
|
|
{ e with Loc.line = e.Loc.eline; col = e.Loc.ecol }
|
|
"a %s states the type every method returns: %s %s(%s) -> dyn"
|
|
w w (text_of name) names
|
|
in
|
|
let body ~after ~prev =
|
|
match (peek p).tok with
|
|
| NAME "=" ->
|
|
ignore (advance p);
|
|
[ value_line s ~after:"=" ]
|
|
| NEWLINE ->
|
|
ignore (advance p);
|
|
block s ~after
|
|
| _ -> stray p ~after:prev
|
|
in
|
|
(match w with
|
|
| "generic" ->
|
|
let r = ret () in
|
|
expect_eol p ~after:(text_of r);
|
|
named "defgeneric" [ name; pv; r ]
|
|
| "multi" ->
|
|
let r = ret () in
|
|
named "defmulti"
|
|
(name :: pv :: r :: body ~after:("multi " ^ text_of name ^ "(...)") ~prev:(text_of r))
|
|
| _ ->
|
|
let key =
|
|
match (peek p).tok, !first_class with
|
|
| NAME "when", Some tf ->
|
|
failk "method-key" (peek p).loc
|
|
"this method already answers for %s, its first parameter's type. \
|
|
Write the type or the when, not both"
|
|
(text_of tf)
|
|
| NAME "when", None ->
|
|
ignore (advance p);
|
|
fst (unary p)
|
|
| _, Some tf -> tf
|
|
| _, None ->
|
|
failk "method-key" (where_ p)
|
|
"a method says what it answers for: a class as its first \
|
|
parameter's type, method %s(%s: point), or a value after when, \
|
|
method %s(%s) when :int"
|
|
(text_of name) first (text_of name) names
|
|
in
|
|
named "defmethod"
|
|
(name :: key :: pv
|
|
:: body ~after:("method " ^ text_of name ^ "(...)")
|
|
~prev:(if !first_class = None then text_of key else ")")))
|
|
| "type" ->
|
|
let name = name_tok p ~what:"the alias's name" in
|
|
expect_name p "=" ~what:"= and the type it names";
|
|
let t = ty p in
|
|
expect_eol p ~after:(text_of t);
|
|
named "defalias" [ name; t ]
|
|
| "macro" ->
|
|
let name = name_tok p ~what:"the macro's name" in
|
|
let lp = glued_lp p ~what:"the parameters, in parentheses glued to the name" in
|
|
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 one =
|
|
match t.tok with
|
|
| NAME "&" ->
|
|
ignore (advance p);
|
|
[ name_tok p ~what:"the rest parameter's name after &"; sym t.loc "&" ]
|
|
| LB -> [ fst (primary p) ]
|
|
| _ -> [ name_tok p ~what:"a parameter's name" ]
|
|
in
|
|
(match (peek p).tok with
|
|
| COMMA -> ignore (advance p)
|
|
| RP -> ()
|
|
| _ -> stray p ~after:(text_of (List.hd one)));
|
|
go (one @ acc)
|
|
in
|
|
let ps = go [] in
|
|
let n = List.length ps in
|
|
List.iteri
|
|
(fun k (a : Form.t) ->
|
|
if a.v = Form.Sym "&" && k < n - 2 then begin
|
|
let r = List.nth ps (k + 1) in
|
|
let others = List.filteri (fun j _ -> j <> k && j <> k + 1) ps in
|
|
failk "macro-rest-last" a.loc
|
|
"& %s takes the arguments left over, so it comes last: macro %s(%s)"
|
|
(text_of r) (text_of name)
|
|
(String.concat ", " (List.map text_of others @ [ "& " ^ text_of r ]))
|
|
end)
|
|
ps;
|
|
let pv = Form.make (Form.Vec ps) (span p lp.loc) in
|
|
expect_line_end p ~after:")";
|
|
let body = block s ~after:("macro " ^ text_of name ^ "(...)") in
|
|
named "defmacro" (name :: pv :: body)
|
|
| "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" | "when" ->
|
|
let letp = if w = "if" then if_let_head p else None in
|
|
let c = match letp with Some m -> m | None -> fst (binary p 1) in
|
|
let letp, c =
|
|
match letp with
|
|
| Some _ -> (letp, c)
|
|
| None -> (match as_head p c with Some m when w = "if" -> (Some m, m) | _ -> (None, c))
|
|
in
|
|
(* The elif and else clauses at the if's column, then the whole form.
|
|
[oneline] when the if was [if c then a]: its clauses may then be
|
|
one-line too, [elif c then x] and [else y], or take blocks. *)
|
|
let clauses ~oneline body =
|
|
(match (peek p).tok with
|
|
| NAME ("else" | "elif") when w = "when" && not (assigns p) -> when_else p
|
|
| _ -> ());
|
|
(* The [elif let P = v] heads, as the [[P v]] each stands as. *)
|
|
let elif_lets = ref [] in
|
|
let rec elifs acc =
|
|
match (peek p).tok with
|
|
| NAME "elif" when not (assigns p) ->
|
|
ignore (advance p);
|
|
let c =
|
|
match if_let_head p with
|
|
| Some m -> elif_lets := m :: !elif_lets; m
|
|
| None ->
|
|
let c = fst (binary p 1) in
|
|
(match as_head p c with
|
|
| Some m -> elif_lets := m :: !elif_lets; m
|
|
| None -> c)
|
|
in
|
|
(match (peek p).tok with
|
|
| NAME "then" when oneline ->
|
|
ignore (advance p);
|
|
let x = inline_stmt p in
|
|
expect_eol p ~after:(text_of x);
|
|
elifs ((c, [ x ]) :: acc)
|
|
| NAME "then" ->
|
|
failk "elif-then" (peek p).loc
|
|
"elif takes its block on the indented lines under it, with no \
|
|
then. Put the branch on the next line, indented"
|
|
| _ ->
|
|
expect_line_end p ~after:("elif " ^ text_of c);
|
|
let b = block s ~after:"elif" in
|
|
elifs ((c, b) :: acc))
|
|
| _ -> List.rev acc
|
|
in
|
|
let els_ = elifs [] in
|
|
let else_ =
|
|
match (peek p).tok with
|
|
| NAME "else" when not (assigns p) ->
|
|
let et = advance p in
|
|
(match (peek p).tok with
|
|
| NEWLINE -> ignore (advance p); Some (et.loc, block s ~after:"else")
|
|
| NAME "if" when not oneline ->
|
|
failk "else-if" (where_ p)
|
|
"after an if with a block, another test at this level is \
|
|
written elif c, with its own block"
|
|
(* [else x] on one line, after a one-line if or a block. *)
|
|
| _ ->
|
|
let x = inline_stmt p in
|
|
expect_eol p ~after:(text_of x);
|
|
Some (et.loc, [ x ]))
|
|
| _ -> None
|
|
in
|
|
match els_, else_ with
|
|
| _ when !elif_lets <> [] ->
|
|
(* An [elif let] makes the rest of the chain the else of an if-let:
|
|
each clause nests in the one before it, [if] or [if-let] as its
|
|
head is, and a chain with no else ends in a [when]. *)
|
|
let is_let c = List.memq c !elif_lets || Some c == letp in
|
|
let rec build = function
|
|
| [] -> Option.map (fun (el, e) -> blk s el e) else_
|
|
| ((c : Form.t), b) :: rest ->
|
|
let at = c.Form.loc in
|
|
let f items = Form.make (Form.List items) at in
|
|
let r = build rest in
|
|
Some
|
|
(if is_let c then f (sym at "if-let" :: c :: blk s at b :: Option.to_list r)
|
|
else
|
|
match r with
|
|
| None -> f (sym at "when" :: c :: b)
|
|
| Some r -> f [ sym at "if"; c; blk s at b; r ])
|
|
in
|
|
Option.get (build ((c, body) :: els_))
|
|
| [], None -> named "when" (c :: body)
|
|
| [], Some (el, e) -> named "if" [ c; blk s l0 body; blk s el e ]
|
|
| _ ->
|
|
let pairs =
|
|
List.concat_map (fun (c, b) -> [ c; blk s c.Form.loc b ]) ((c, body) :: els_)
|
|
in
|
|
let tail =
|
|
match else_ with
|
|
| Some (el, e) -> [ Form.make (Form.Kw "else") el; blk s el e ]
|
|
| None -> []
|
|
in
|
|
named "cond" (pairs @ tail)
|
|
in
|
|
if_let_wrap letp @@
|
|
(match (peek p).tok with
|
|
| NAME "then" ->
|
|
ignore (advance p);
|
|
let a = inline_stmt p in
|
|
(match (peek p).tok with
|
|
| NAME ("else" | "elif") when w = "when" -> when_else p
|
|
| NAME "else" ->
|
|
ignore (advance p);
|
|
let b = inline_stmt p in
|
|
let f = named "if" [ c; a; b ] in
|
|
expect_eol p ~after:(text_of f);
|
|
f
|
|
| NAME "elif" ->
|
|
failk "one-line-elif" (peek p).loc
|
|
"a one-line if has then and else and no elif. Chain another if \
|
|
after the else — if a then x else if b then y else z — or write \
|
|
the if over several lines, where elif goes"
|
|
| _ ->
|
|
(* An else or elif indented under the one-line if: it continues
|
|
that if only at the if's own column. *)
|
|
(match (peek p).tok, (peek_at p 1).tok, (peek_at p 2).tok with
|
|
| NEWLINE, INDENT, NAME (("else" | "elif") as w) ->
|
|
failk "else-column" (peek_at p 2).loc
|
|
"this %s is indented deeper than the one-line if it continues. \
|
|
Put it at the if's column:\n\n\
|
|
\ if c then a\n %s ..."
|
|
w w
|
|
| _ -> ());
|
|
expect_eol p ~after:(text_of (named "when" [ c; a ]));
|
|
(* An else or elif on the next line, at the if's column,
|
|
continues it. *)
|
|
clauses ~oneline:true [ a ])
|
|
| _ ->
|
|
expect_line_end p ~after:("if " ^ text_of c);
|
|
let body = block s ~after:("if " ^ text_of c) in
|
|
clauses ~oneline:false body)
|
|
| "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
|
|
(match (if w = "while" then as_head p c else None) with
|
|
(* [while e? as g]: [(while true (if-let [g e] (do body) (break)))]. A
|
|
break or continue in the body is this loop's. *)
|
|
| Some m ->
|
|
expect_line_end p ~after:(w ^ " " ^ text_of c ^ " as ...");
|
|
let body = block s ~after:w in
|
|
let at = c.Form.loc in
|
|
let f items = Form.make (Form.List items) at in
|
|
form (label @ [ sym at "true";
|
|
f [ sym at "if-let"; m; f (sym at "do" :: body); f [ sym at "break" ] ] ])
|
|
| None ->
|
|
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
|
|
(* In a macro template the variable may be an unquote, [for ~i in ...]. *)
|
|
let v =
|
|
match (peek p).tok with
|
|
| UNQ -> fst (primary p)
|
|
| _ -> name_tok p ~what:"the loop variable"
|
|
in
|
|
expect_name p "in" ~what:"in, as in for i in range(n)";
|
|
let rt = peek p in
|
|
expect_name p "range" ~what:"range(n), range(a, b) or range(a, b, step)";
|
|
let lp = glued_lp p ~what:"range's bounds in parentheses" in
|
|
let bs = items p RP lp.loc ~what:"bounds" in
|
|
if bs = [] || List.length bs > 3 then
|
|
failk "range-arity" rt.loc
|
|
"range takes one, two or three bounds: range(stop), range(start, stop) \
|
|
or range(start, stop, step)";
|
|
expect_line_end p ~after:"range(...)";
|
|
let body = block s ~after:"for" in
|
|
named "dotimes"
|
|
(label @ (Form.make (Form.Vec (v :: bs)) (span_of_list v.loc bs) :: body))
|
|
| "return" ->
|
|
(match (peek p).tok with
|
|
| NEWLINE -> expect_eol p ~after:"return"; form []
|
|
| _ ->
|
|
let e, _ = expr p in
|
|
expect_eol p ~after:(text_of e);
|
|
form [ e ])
|
|
| "break" | "continue" ->
|
|
(match (peek p).tok with
|
|
| KW k ->
|
|
let kt = advance p in
|
|
expect_eol p ~after:(":" ^ k);
|
|
form [ Form.make (Form.Kw k) kt.loc ]
|
|
| _ -> expect_eol p ~after:w; form [])
|
|
| "defer" ->
|
|
(match (peek p).tok with
|
|
| NEWLINE ->
|
|
ignore (advance p);
|
|
form (block s ~after:"defer")
|
|
| _ ->
|
|
let e = inline_stmt p in
|
|
expect_eol p ~after:(text_of e);
|
|
form [ e ])
|
|
| "match" ->
|
|
let scrut, _ = expr p in
|
|
expect_eol_block p ~after:("match " ^ text_of scrut);
|
|
let arms =
|
|
lines s (fun () ->
|
|
let pat, _ = unary p in
|
|
expect_name p "->" ~what:"-> and the arm's value";
|
|
let body =
|
|
if (peek p).tok = NEWLINE && (peek_at p 1).tok = INDENT then begin
|
|
let nl = advance p in
|
|
blk s nl.loc (block s ~after:"->")
|
|
end
|
|
else begin
|
|
let e = inline_stmt p in
|
|
expect_eol p ~after:(text_of e);
|
|
e
|
|
end
|
|
in
|
|
[ pat; body ])
|
|
in
|
|
form (scrut :: arms)
|
|
| "handler-case" | "handler-bind" ->
|
|
clause_header_end p w;
|
|
let body = block s ~after:w in
|
|
let rec clauses acc =
|
|
match (peek p).tok, (peek_at p 1) with
|
|
| NAME "on", n when n.sp && not (assigns p) ->
|
|
let ot = advance p in
|
|
let head, _ = postfix p in
|
|
let ty, var =
|
|
match head.v with
|
|
| Form.List [ ty; ({ v = Form.Sym _; _ } as var) ] -> (ty, var)
|
|
| _ ->
|
|
failk "on-clause" head.loc
|
|
"a handler clause is on Type(name), naming the condition type \
|
|
and the name it is bound to, as in on FileError(c)"
|
|
in
|
|
clause_end p ("on " ^ text_of ty ^ "(" ^ text_of var ^ ")");
|
|
let b = block s ~after:"on" in
|
|
let c =
|
|
mk p ot.loc
|
|
(Form.List (ty :: Form.make (Form.Vec [ var ]) var.loc :: b))
|
|
in
|
|
clauses (c :: acc)
|
|
| _ -> List.rev acc
|
|
in
|
|
let cs = clauses [] in
|
|
let vec = Form.make (Form.Vec cs) (span p l0) in
|
|
if w = "handler-case" then form [ blk s l0 body; vec ]
|
|
else form (vec :: body)
|
|
| "restart-case" ->
|
|
clause_header_end p w;
|
|
let body = block s ~after:w in
|
|
let rec clauses acc =
|
|
match (peek p).tok, (peek_at p 1) with
|
|
| NAME "restart", n when n.sp && not (assigns p) ->
|
|
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
|
|
(* [restart name() "text"]: the report the break loop shows,
|
|
[:report "text"] in the clause. *)
|
|
let report =
|
|
match (peek p).tok with
|
|
| ATOM (Form.Str _ as v) ->
|
|
let st = advance p in
|
|
[ Form.make (Form.Kw "report") st.loc; Form.make v st.loc ]
|
|
| _ -> []
|
|
in
|
|
clause_end p ("restart " ^ text_of name ^ "(...)");
|
|
let b = block s ~after:"restart" in
|
|
let c =
|
|
mk p name.loc (Form.List (name :: Form.make (Form.Vec ps) lp.loc :: (report @ b)))
|
|
in
|
|
clauses (c :: acc)
|
|
| _ -> List.rev acc
|
|
in
|
|
let cs = clauses [] in
|
|
form (blk s l0 body :: cs)
|
|
| "quote" ->
|
|
(* One line, [quote ~x + 1], is the quasiquote of that expression. *)
|
|
(match (peek p).tok with
|
|
| NEWLINE ->
|
|
ignore (advance p);
|
|
let body = block s ~after:"quote" in
|
|
named "quasiquote" [ blk s l0 body ]
|
|
| _ ->
|
|
let e, _ = expr p in
|
|
expect_eol p ~after:(text_of e);
|
|
named "quasiquote" [ e ])
|
|
| _ -> assert false
|
|
|
|
(* [let x = v] at the top level, [once x = v] or [const x = v], from the
|
|
name on: [t] is the word, and [l0] where the form starts. A top-level let
|
|
leaves the lines indented under it to [read_all], which reads each as one
|
|
more global. *)
|
|
and def_form (s : st) w (t : token) l0 : Form.t =
|
|
let p = s.p in
|
|
let named head items = mk p l0 (Form.List (sym l0 head :: items)) in
|
|
(* A top-level [let] is read here too, as [def]: [w] is then "def" and
|
|
[t] the let. *)
|
|
let shown = match t.tok with NAME "let" -> "let" | _ -> w in
|
|
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 ~block_ok:(shown = "let") s
|
|
~after:(shown ^ " " ^ text_of name ^ " ="))
|
|
(* [let a: i32] with more globals under it. *)
|
|
| NEWLINE when shown = "let" && tyf <> None && (peek_at p 1).tok = INDENT ->
|
|
ignore (advance p); None
|
|
| _ ->
|
|
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
|
|
if shown = "def" then
|
|
failk "def-is-let" l0
|
|
"a global is written with let, at the file's top level:\n\n let %s%s%s"
|
|
(text_of name)
|
|
(match tyf, v with
|
|
| Some t, _ -> ": " ^ text_of t
|
|
| None, None -> ": i32"
|
|
| None, Some _ -> "")
|
|
(match v, tyf with
|
|
| Some v, _ -> " = " ^ text_of v
|
|
| None, None -> " = 0"
|
|
| None, Some _ -> "");
|
|
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"
|
|
shown (text_of name) shown (text_of name)
|
|
in
|
|
named head items
|
|
|
|
(* handler-case, handler-bind and restart-case take nothing on their own line. *)
|
|
and clause_header_end p w =
|
|
match (peek p).tok with
|
|
| NEWLINE -> ignore (advance p)
|
|
| _ ->
|
|
failk "clause-header" (peek p).loc
|
|
"%s takes its body on the indented lines under it, and its %s clauses \
|
|
at its own column after that, each with its block under it:\n\
|
|
%s\n body\n%s"
|
|
w (if w = "restart-case" then "restart" else "on") w
|
|
(if w = "restart-case" then "restart name()\n value" else "on Type(c)\n value")
|
|
|
|
and clause_end p head =
|
|
match (peek p).tok with
|
|
| NEWLINE -> ignore (advance p)
|
|
| _ ->
|
|
failk "clause-body" (peek p).loc
|
|
"the body of %s goes on the indented lines under it, not on its line. \
|
|
Move it to the next line, indented"
|
|
head
|
|
|
|
(* The end of a header line whose block must follow. *)
|
|
and expect_line_end p ~after =
|
|
if p.i = p.closed then () else
|
|
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
|
|
|
|
let () = block_of := fun p -> block { p; lets = [] } ~after:"=>"
|
|
|
|
(* Every [(loop ...)] and [(recur ...)] in [fs], at any depth and inside
|
|
quoted code too, in source order. The indented syntax has neither: its
|
|
loops are [while], [until], [dotimes] and [for]. The printer asks the same
|
|
question before it converts a .flan file. *)
|
|
let loop_forms (fs : Form.t list) =
|
|
let out = ref [] in
|
|
let rec walk (f : Form.t) =
|
|
match f.v with
|
|
| Form.List ({ v = Form.Sym ("loop" | "recur"); _ } :: _) ->
|
|
out := f :: !out;
|
|
(match f.v with Form.List l -> List.iter walk l | _ -> ())
|
|
| Form.List l | Form.Vec l | Form.Map l -> List.iter walk l
|
|
| _ -> ()
|
|
in
|
|
List.iter walk fs;
|
|
List.rev !out
|
|
|
|
let refuse_loops fs =
|
|
match loop_forms fs with
|
|
| [] -> ()
|
|
| (f : Form.t) :: _ ->
|
|
no_loop f.loc (match f.v with Form.List ({ v = Form.Sym w; _ } :: _) -> w | _ -> "loop")
|
|
|
|
(** 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 ?(line = 1) ?col ?indent ?(global_let = true) ~file src =
|
|
let snippet = col <> None in
|
|
let col = Option.value col ~default:1 in
|
|
let saved = !source in
|
|
let saved_n = !cmp_n and saved_o = !opt_n in
|
|
cmp_n := 0;
|
|
opt_n := 0;
|
|
(* The quoted text is indexed by the buffer's lines, so a snippet that
|
|
starts on line 40 is padded to start there. *)
|
|
source :=
|
|
(file, Array.of_list (String.split_on_char '\n'
|
|
(String.make (line - 1) '\n' ^ String.make (col - 1) ' ' ^ src)));
|
|
Fun.protect ~finally:(fun () -> source := saved; cmp_n := saved_n; opt_n := saved_o) (fun () ->
|
|
let toks = layout ~snippet ~base:col ?indent (lex ~line ~col ~file src) in
|
|
let s = { p = { toks; i = 0; closed = -1 }; lets = [] } in
|
|
(* At the top level, a [let] is a global, [(def x dyn v)]: a let there has
|
|
no block to be local to. Not in an expression the editor sends, where
|
|
a let is the statement it is in a body. *)
|
|
let rec top () =
|
|
match (peek s.p).tok with
|
|
| EOF -> []
|
|
| DEDENT -> ignore (advance s.p); []
|
|
| NAME "let" when header_follow s.p "let" ->
|
|
let t = peek s.p in
|
|
let_gap_tab t (peek_at s.p 1);
|
|
let name_col = (peek_at s.p 1).loc.Loc.col in
|
|
let f =
|
|
let_values := (name_col, text_of_tok (peek_at s.p 1), t.loc.Loc.line) :: !let_values;
|
|
Fun.protect ~finally:(fun () -> let_values := List.tl !let_values)
|
|
(fun () -> header s "def")
|
|
in
|
|
(* The lines indented under it are more globals, one each: a global
|
|
is one name, so a pattern there is refused. *)
|
|
let first = match f.v with Form.List (_ :: n :: _) -> n | _ -> f in
|
|
let more =
|
|
binding_lines ~global:true s ~first ~name_col ~one:(fun () ->
|
|
let l = peek s.p in
|
|
(match l.tok with
|
|
| LP ->
|
|
failk "global-pattern" l.loc
|
|
"a global's name is a plain name, and this line under let %s \
|
|
names an operator word in parentheses. Give the global \
|
|
another name"
|
|
(text_of first)
|
|
| LB | LC ->
|
|
failk "global-pattern" l.loc
|
|
"a global binds one name, and this line under let %s is a \
|
|
pattern. Bind the value to a name, and take it apart inside \
|
|
the function that uses it"
|
|
(text_of first)
|
|
| _ -> ());
|
|
def_form s "def" t l.loc)
|
|
in
|
|
f :: more @ top ()
|
|
| _ -> let f = stmt s in f :: top ()
|
|
in
|
|
let fs = if global_let then top () else stmts s in
|
|
(match (peek s.p).tok with
|
|
| EOF -> ()
|
|
| tk -> failk "unexpected-token" (where_ s.p) "unexpected %s" (show tk));
|
|
refuse_loops fs;
|
|
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))
|