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