flan/lib/reader.ml

(** S-expression reader.

    Hand-written rather than ocamllex/menhir: a Lisp needs no parser generator,
    locations come out cleaner, and it keeps the compiler dependency-free.

    ['x] reads as [(quote x)]. That is not macro support — it is here because
    restart names are quoted symbols ([(invoke-restart 'skip-form)]) and without
    it the apostrophe would silently become part of the symbol's name.

    Not handled yet: quasiquote/unquote (milestone 5, with macros) and metadata
    ([^:async]). Metadata is rejected rather than read as a symbol, so it cannot
    rot into a silently-wrong name the way quote would have. *)

type state = {
  src   : string;
  file  : string;
  mutable pos  : int;
  mutable line : int;
  mutable col  : int;
}

let of_string ~file src = { src; file; pos = 0; line = 1; col = 1 }

let here st = Loc.make st.file st.line st.col
let at_end st = st.pos >= String.length st.src
let peek st = if at_end st then '\000' else st.src.[st.pos]
let peek2 st =
  if st.pos + 1 >= String.length st.src then '\000' else st.src.[st.pos + 1]

let advance st =
  if not (at_end st) then begin
    if st.src.[st.pos] = '\n' then (st.line <- st.line + 1; st.col <- 1)
    else st.col <- st.col + 1;
    st.pos <- st.pos + 1
  end

(* Symbol constituents. Note '-' and '?' and '!' and '/' and '.' are all
   ordinary: `empty-at?`, `rl/draw-fps`, `.pos`, `->>` are single symbols. *)
let is_delimiter = function
  | '(' | ')' | '[' | ']' | '{' | '}' | '"' | ';' | '\000' -> true
  | c -> c = ' ' || c = '\t' || c = '\n' || c = '\r' || c = ','

let is_digit c = c >= '0' && c <= '9'

let rec skip_trivia st =
  match peek st with
  | ' ' | '\t' | '\n' | '\r' | ',' -> advance st; skip_trivia st
  | ';' ->
    while (not (at_end st)) && peek st <> '\n' do advance st done;
    skip_trivia st
  | _ -> ()

let take_while st pred =
  let start = st.pos in
  while (not (at_end st)) && pred (peek st) do advance st done;
  String.sub st.src start (st.pos - start)

(* ── Atoms ─────────────────────────────────────────────────────────── *)

let read_string st =
  let loc = here st in
  advance st;  (* opening quote *)
  let buf = Buffer.create 16 in
  let rec go () =
    if at_end st then Loc.fail loc "unterminated string"
    else match peek st with
      | '"'  -> advance st
      | '\\' ->
        advance st;
        let c = peek st in
        advance st;
        Buffer.add_char buf
          (match c with
           | 'n' -> '\n' | 't' -> '\t' | 'r' -> '\r'
           | '\\' -> '\\' | '"' -> '"' | '0' -> '\000'
           | c -> Loc.fail loc "unknown string escape \\%c" c);
        go ()
      | c -> advance st; Buffer.add_char buf c; go ()
  in
  go ();
  Form.make (Form.Str (Buffer.contents buf)) loc

(* \space \tab \newline \return \nul, or \<any single char> *)
let read_byte st =
  let loc = here st in
  advance st;  (* backslash *)
  if at_end st then Loc.fail loc "expected a character after \\";
  let first = peek st in
  advance st;
  let rest = take_while st (fun c -> not (is_delimiter c)) in
  let name = String.make 1 first ^ rest in
  let code = match name with
    | "space"   -> 32
    | "tab"     -> 9
    | "newline" -> 10
    | "return"  -> 13
    | "nul"     -> 0
    | n when String.length n = 1 -> Char.code n.[0]
    | n -> Loc.fail loc "unknown character literal \\%s" n
  in
  Form.make (Form.Byte code) loc

(* A token that started with a digit, or with '-'/'+' followed by a digit. *)
let read_number st =
  let loc = here st in
  let text = take_while st (fun c -> not (is_delimiter c)) in
  let is_hex =
    String.length text > 2
    && text.[0] = '0'
    && (text.[1] = 'x' || text.[1] = 'X')
  in
  if is_hex then
    match Int64.of_string_opt text with
    | Some i -> Form.make (Form.Int i) loc
    | None -> Loc.fail loc "malformed hex literal %s" text
  else if String.contains text '.' || String.contains text 'e' then
    match float_of_string_opt text with
    | Some f -> Form.make (Form.Float f) loc
    | None -> Loc.fail loc "malformed float literal %s" text
  else
    match Int64.of_string_opt text with
    | Some i -> Form.make (Form.Int i) loc
    | None -> Loc.fail loc "malformed integer literal %s" text

let read_symbol_or_keyword st =
  let loc = here st in
  let text = take_while st (fun c -> not (is_delimiter c)) in
  if text = "" then Loc.fail loc "unexpected character %C" (peek st);
  if text.[0] = ':' then begin
    if String.length text = 1 then Loc.fail loc "empty keyword";
    Form.make (Form.Kw (String.sub text 1 (String.length text - 1))) loc
  end else
    Form.make (Form.Sym text) loc

(* ── Forms ─────────────────────────────────────────────────────────── *)

let closer = function
  | '(' -> ')' | '[' -> ']' | '{' -> '}'
  | _ -> assert false

let wrap open_c items =
  match open_c with
  | '(' -> Form.List items
  | '[' -> Form.Vec items
  | '{' -> Form.Map items
  | _ -> assert false

let rec read_form st =
  skip_trivia st;
  let loc = here st in
  match peek st with
  | '\000' -> Loc.fail loc "unexpected end of input"
  | '(' | '[' | '{' as open_c -> read_seq st open_c loc
  | ')' | ']' | '}' as c -> Loc.fail loc "unbalanced %C" c
  | '"' -> read_string st
  | '\\' -> read_byte st
  | '\'' ->
    advance st;
    let quoted = read_form st in
    Form.make (Form.List [ Form.make (Form.Sym "quote") loc; quoted ]) loc
  | '^' ->
    Loc.fail loc "metadata (^) is not supported yet"

  | c when is_digit c -> read_number st
  | ('-' | '+') when is_digit (peek2 st) -> read_number st
  | _ -> read_symbol_or_keyword st

and read_seq st open_c loc =
  advance st;
  let want = closer open_c in
  let rec go acc =
    skip_trivia st;
    if at_end st then
      Loc.fail loc "unclosed %C, expected %C" open_c want
    else
      let c = peek st in
      if c = want then (advance st; List.rev acc)
      else if c = ')' || c = ']' || c = '}' then
        Loc.fail (here st) "expected %C to close %C, found %C" want open_c c
      else go (read_form st :: acc)
  in
  Form.make (wrap open_c (go [])) loc

(** All top-level forms in a source string. *)
let read_all ~file src =
  let st = of_string ~file src in
  let rec go acc =
    skip_trivia st;
    if at_end st then List.rev acc else go (read_form st :: acc)
  in
  go []

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))