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.

    [`x], [~x] and [~@x] read as [(quasiquote x)], [(unquote x)] and
    [(unquote-splicing x)] by the same rule: the reader stays dumb, and what
    those names mean is settled later. Clojure's spelling rather than Common
    Lisp's, because [,] is already whitespace here (see [is_delimiter]) and
    every binding vector in the corpus relies on that.

    [#_] discards the form after it, as in Clojure: it is read and thrown away,
    so commenting out a form does not mean counting its closing parens. Repeated
    ([#_#_]) discards that many following forms, which falls out of the
    recursion rather than being counted — the discard reads *a form*, and the
    form it reads may itself begin with a discard.

    It is a property of [read_form] rather than of the sequence readers, so it
    works in every position a form can appear: at the top level, inside a list
    or a vector or a map, and after a quote. A trailing [#_] with nothing after
    it is the one error, and it is the same error an unterminated form gives.

    Not handled yet: metadata ([^:async]). It 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

(* A form's location is the span it occupies, so every reader below takes the
   location it started at and closes it where the cursor now is. Doing it here,
   in the one place that knows both ends, is why nothing above [Reader] has to
   know a span exists. *)
let spanned st loc v = Form.make v (Loc.upto loc (here st))
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.

   '`' and '~' end a symbol, so [~x] is two things and never one name. That is
   the same guard the apostrophe wants and does not have; the corpus has no
   symbol containing either character, so closing the class costs nothing. *)
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
      (* The same two places [reader/unclosed] reports, for the same reason:
         the fix goes at the quote that is still open, and how far the reader
         got before running out is the half a single caret cannot show. *)
      Loc.failk "reader/unterminated-string" loc
        ~notes:[ Loc.note (here st) "the input ends here, still inside it" ]
        "unterminated string — no closing quote"
    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.failk "reader/unknown-string-escape" loc "unknown string escape \\%c" c);
        go ()
      | c -> advance st; Buffer.add_char buf c; go ()
  in
  go ();
  spanned st loc (Form.Str (Buffer.contents buf))

(* \space \tab \newline \return \nul \backspace \formfeed, Clojure's \uXXXX
   (four hex digits), or \<any single char> *)
let read_byte st =
  let loc = here st in
  advance st;  (* backslash *)
  if at_end st then Loc.failk "reader/incomplete-character" 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
    | "backspace" -> 8
    | "formfeed"  -> 12
    | n when String.length n = 1 -> Char.code n.[0]
    | n when String.length n = 5 && n.[0] = 'u'
             && String.for_all
                  (function '0' .. '9' | 'a' .. 'f' | 'A' .. 'F' -> true | _ -> false)
                  (String.sub n 1 4) ->
      let c = int_of_string ("0x" ^ String.sub n 1 4) in
      if not (Uchar.is_valid c) then
        Loc.failk "reader/unknown-character" loc
          "\\%s is a surrogate, which is not a character" n;
      c
    (* One code point written as itself, UTF-8 in the source: \é \日. *)
    | n when (let d = String.get_utf_8_uchar n 0 in
              Uchar.utf_decode_is_valid d
              && Uchar.utf_decode_length d = String.length n) ->
      Uchar.to_int (Uchar.utf_decode_uchar (String.get_utf_8_uchar n 0))
    | n -> Loc.failk "reader/unknown-character" loc "unknown character literal \\%s" n
  in
  spanned st loc (Form.Byte code)

(* 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
    (* A top bit set is a value at or above 2^63, which only a u64 holds. *)
    | Some i when Int64.compare i 0L < 0 -> spanned st loc (Form.UInt (i, text))
    | Some i -> spanned st loc (Form.Int i)
    | None -> Loc.failk "reader/malformed-number" (Loc.upto loc (here st))
        "malformed hex literal %s" text
  else if String.contains text '.' || String.contains text 'e' then
    match float_of_string_opt text with
    | Some f -> spanned st loc (Form.Float f)
    | None -> Loc.failk "reader/malformed-number" (Loc.upto loc (here st))
        "malformed float literal %s" text
  else
    (* A decimal above the largest i64 and below 2^64 is a [UInt], as a hex
       literal with its top bit set is: only a u64 holds it. *)
    let unsigned () =
      if String.for_all (fun c -> c >= '0' && c <= '9') text then
        Int64.of_string_opt ("0u" ^ text)
      else None
    in
    match Int64.of_string_opt text with
    | Some i -> spanned st loc (Form.Int i)
    | None ->
      match unsigned () with
      | Some i -> spanned st loc (Form.UInt (i, text))
      | None -> Loc.failk "reader/malformed-number" (Loc.upto loc (here st))
          "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.failk "reader/unexpected-character" loc "unexpected character %C" (peek st);
  if text.[0] = ':' then begin
    if String.length text = 1 then
      Loc.failk "reader/empty-keyword" (Loc.upto loc (here st)) "empty keyword";
    spanned st loc (Form.Kw (String.sub text 1 (String.length text - 1)))
  end else
    spanned st loc (Form.Sym text)

(* ── 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_ignorable st;
  let loc = here st in
  match peek st with
  | '\000' -> Loc.failk "reader/unexpected-eof" loc "unexpected end of input"
  | '(' | '[' | '{' as open_c -> read_seq st open_c loc
  | ')' | ']' | '}' as c -> Loc.failk "reader/unbalanced" loc "unbalanced %C" c
  | '"' -> read_string st
  | '\\' -> read_byte st
  | '\'' -> read_sugar st loc "quote"
  | '`' -> read_sugar st loc "quasiquote"
  | '~' ->
    advance st;
    if peek st = '@' then (advance st; read_wrapped st loc "unquote-splicing")
    else read_wrapped st loc "unquote"
  (* [^^] is bit-xor's other name, and metadata on a form that starts with
     [^] would mean nothing, so the two cannot collide. *)
  | '^' when peek2 st = '^' -> read_symbol_or_keyword st
  | '^' ->
    Loc.failk "reader/metadata" 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

(* Whitespace, comments, and forms that are read only to be thrown away.
   [#_] is handled here rather than in [read_form]'s match so that it is gone
   before *anything* looks at what comes next: a discard is not a form, so a
   sequence must not count it as an element and a top-level loop must not stop
   on it.

   [#_#_ a b c] discards [a] and [b] with no counting. The outer discard reads
   one form; that read is [read_form], which sees the inner [#_], discards [a]
   and returns [b]; the outer discard then throws [b] away. What is left is
   [c]. *)
and skip_ignorable st =
  skip_trivia st;
  if peek st = '#' && peek2 st = '_' then begin
    advance st; advance st;
    ignore (read_form st : Form.t);
    skip_ignorable st
  end

(* One sigil character, then the form it applies to, wrapped in a name. The
   name's location is the sigil's, so an error inside the wrapper points at the
   character the reader saw rather than at the form after it. *)
and read_sugar st loc name = advance st; read_wrapped st loc name

and read_wrapped st loc name =
  let inner = read_form st in
  spanned st loc (Form.List [ Form.make (Form.Sym name) loc; inner ])

and read_seq st open_c loc =
  advance st;
  let want = closer open_c in
  let rec go acc =
    (* [skip_ignorable], not [skip_trivia]: a discard just before the closer —
       [(a #_b)] — has to be gone before the closer is looked for, or the
       sequence would try to read a form and find [)]. *)
    skip_ignorable st;
    if at_end st then
      (* Two places, and the second is the one that is usually news. The error
         is at the bracket that is still open, because that is where the fix
         goes; the note is where the file ran out, because that is how far the
         reader got believing the form was still being written. *)
      Loc.failk "reader/unclosed" loc
        ~notes:[ Loc.note (here st) "the input ends here, still inside it" ]
        "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
        (* The wrong closer is where the mistake reads, and the opener is what
           makes it wrong. Neither alone says which bracket to change. *)
        Loc.failk "reader/mismatched-closer" (here st)
          ~notes:[ Loc.note loc (Printf.sprintf "%C is opened here" open_c) ]
          "expected %C to close %C, found %C" want open_c c
      else go (read_form st :: acc)
  in
  let items = go [] in
  spanned st loc (wrap open_c items)

(** All top-level forms in a source string. *)
let read_all ~file src =
  let st = of_string ~file src in
  let rec go acc =
    (* Same reason as in [read_seq]: a file ending in [#_(defn …)] has read
       everything there is to read, and must not then be asked for a form. *)
    skip_ignorable 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))