ppx_combin/lib/combin.ml

module type INPUT = sig
  type t
  type token
  val peek : t -> token option
  val advance : t -> t
  val position : t -> int
  val show_token : token -> string
end

type span = { start_pos : int; end_pos : int }

type error = {
  span : span;
  expected : string list;
}

let merge_errors e1 e2 =
  if e1.span.end_pos > e2.span.end_pos then e1
  else if e2.span.end_pos > e1.span.end_pos then e2
  else { span = { start_pos = min e1.span.start_pos e2.span.start_pos; end_pos = e1.span.end_pos }; expected = e1.expected @ e2.expected }

let pure x _input = Ok (x, _input)

let fail msg _input = Error { span = { start_pos = 0; end_pos = 0 }; expected = [msg] }

module Char_input : sig
  include INPUT with type token = char
  val of_string : string -> t
end = struct
  type token = char
  type t = { data : string; pos : int }

  let of_string s = { data = s; pos = 0 }

  let peek { data; pos } =
    if pos >= String.length data then None
    else Some (String.get data pos)

  let advance t = { t with pos = t.pos + 1 }
  let position t = t.pos
  let show_token c = Printf.sprintf "'%c'" c
end

let parse_string parser s =
  let input = Char_input.of_string s in
  parser (module Char_input : INPUT with type t = Char_input.t and type token = char) input

let format_error ?(input = "") e =
  let context =
    if String.length input > 0 && e.span.end_pos < String.length input then
      let start = max 0 (e.span.start_pos - 5) in
      let len = min 30 (String.length input - start) in
      Printf.sprintf " near '%s'" (String.sub input start len)
    else ""
  in
  let pos_str =
    if e.span.start_pos = e.span.end_pos then
      Printf.sprintf "position %d" e.span.start_pos
    else
      Printf.sprintf "positions %d-%d" e.span.start_pos e.span.end_pos
  in
  Printf.sprintf "parse error at %s%s: expected %s"
    pos_str context (String.concat " or " e.expected)

module Memo : sig
  type 'a table
  val create : unit -> 'a table
  val find : 'a table -> string -> int -> 'a option
  val add : 'a table -> string -> int -> 'a -> unit
end = struct
  type 'a table = (string * int, 'a) Hashtbl.t
  let create () = Hashtbl.create 64
  let find tbl name pos = Hashtbl.find_opt tbl (name, pos)
  let add tbl name pos v = Hashtbl.replace tbl (name, pos) v
end

type 'a memo_table = ('a * Char_input.t, error) result Memo.table

module Stream_input : sig
  include INPUT with type token = char
  val of_channel : in_channel -> t
  val of_seq : char Seq.t -> t
end = struct
  type token = char
  type t = {
    mutable buffer : char list;
    mutable source : char Seq.t;
    mutable pos : int;
  }

  let of_seq seq = { buffer = []; source = seq; pos = 0 }

  let of_channel ch =
    let rec seq () =
      match input_char ch with
      | c -> Seq.Cons (c, seq)
      | exception End_of_file -> Seq.Nil
    in
    of_seq seq

  let ensure_buffered t n =
    let rec fill needed =
      if needed <= 0 then ()
      else match t.source () with
        | Seq.Nil -> ()
        | Seq.Cons (c, rest) ->
            t.buffer <- t.buffer @ [c];
            t.source <- rest;
            fill (needed - 1)
    in
    let buffered = List.length t.buffer in
    if buffered < n then fill (n - buffered)

  let peek t =
    ensure_buffered t 1;
    match t.buffer with
    | [] -> None
    | c :: _ -> Some c

  let advance t =
    ensure_buffered t 1;
    match t.buffer with
    | [] -> t
    | _ :: rest -> { t with buffer = rest; pos = t.pos + 1 }

  let position t = t.pos
  let show_token c = Printf.sprintf "'%c'" c
end

module type TOKEN = sig
  type t
  val equal : t -> t -> bool
  val show : t -> string
end

module Make_list_input (T : TOKEN) : sig
  include INPUT with type token = T.t
  val of_list : T.t list -> t
end = struct
  type token = T.t
  type t = { data : T.t list; pos : int }

  let of_list lst = { data = lst; pos = 0 }

  let peek { data; _ } =
    match data with
    | [] -> None
    | x :: _ -> Some x

  let advance t =
    match t.data with
    | [] -> t
    | _ :: rest -> { data = rest; pos = t.pos + 1 }

  let position t = t.pos
  let show_token = T.show
end