Source file lex_buffer.ml

(* Based on
 * https://github.com/smolkaj/ocaml-parsing/blob/master/src/LexBuffer.ml *)

(** A custom lexbuffer that automatically keeps track of the source location.
    This module is a thin wrapper arounds sedlexing's default buffer, which does
    not provide this functionality. *)

(** the lex buffer type *)
type t =
  { buf : Sedlexing.lexbuf
  ; mutable pos : Lexing.position
  ; mutable pos_mark : Lexing.position
  ; mutable last_char : int option
  ; mutable last_char_mark : int option
  }

let of_sedlex ?(file = "<n/a>") ?pos buf =
  let pos =
    match pos with
    | None ->
      { Lexing.pos_fname = file
      ; pos_lnum = 1
      ; (* line number *)
        pos_bol = 0
      ; (* offset of beginning of current line *)
        pos_cnum = 0 (* total offset *)
      }
    | Some p -> p
  in
  { buf; pos; pos_mark = pos; last_char = None; last_char_mark = None }
;;

let of_ascii_string ?pos s = of_sedlex ?pos (Sedlexing.Latin1.from_string s)

let of_ascii_file file =
  let chan = open_in file in
  of_sedlex ~file (Sedlexing.Latin1.from_channel chan)
;;

(** The next four functions are used by sedlex internally.
    See https://www.lexifi.com/sedlex/libdoc/Sedlexing.html.  *)
let mark lexbuf p =
  lexbuf.pos_mark <- lexbuf.pos;
  lexbuf.last_char_mark <- lexbuf.last_char;
  Sedlexing.mark lexbuf.buf p
;;

let backtrack lexbuf =
  lexbuf.pos <- lexbuf.pos_mark;
  lexbuf.last_char <- lexbuf.last_char_mark;
  Sedlexing.backtrack lexbuf.buf
;;

let start lexbuf =
  lexbuf.pos_mark <- lexbuf.pos;
  lexbuf.last_char_mark <- lexbuf.last_char;
  Sedlexing.start lexbuf.buf
;;

(** location of next character *)
let next_loc lexbuf = { lexbuf.pos with pos_cnum = lexbuf.pos.pos_cnum + 1 }

let cr = Char.code '\r'

(** next character *)
let next lexbuf =
  let c = Sedlexing.next lexbuf.buf in
  let pos = next_loc lexbuf in
  let ch =
    match c with
    | None -> None
    | Some c ->
      (try Some (Uchar.to_char c) with
       | Invalid_argument _ -> None)
  in
  (match ch with
   | Some '\r' ->
     lexbuf.pos <- { pos with pos_bol = pos.pos_cnum - 1; pos_lnum = pos.pos_lnum + 1 }
   | Some '\n' when not (lexbuf.last_char = Some cr) ->
     lexbuf.pos <- { pos with pos_bol = pos.pos_cnum - 1; pos_lnum = pos.pos_lnum + 1 }
   | Some '\n' -> ()
   | _ -> lexbuf.pos <- pos);
  (match c with
   | None -> lexbuf.last_char <- None
   | Some c -> lexbuf.last_char <- Some (Uchar.to_int c));
  c
;;

let __private__next_int lexbuf =
  match next lexbuf with
  | None -> -1
  | Some x -> Uchar.to_int x
;;

let raw lexbuf = Sedlexing.lexeme lexbuf.buf

let latin1 ?(skip = 0) ?(drop = 0) lexbuf =
  let len = Sedlexing.lexeme_length lexbuf.buf - skip - drop in
  Sedlexing.Latin1.sub_lexeme lexbuf.buf skip len
;;

let utf8 ?(skip = 0) ?(drop = 0) lexbuf =
  let len = Sedlexing.lexeme_length lexbuf.buf - skip - drop in
  Sedlexing.Utf8.sub_lexeme lexbuf.buf skip len
;;

let container_lnum_ref = ref 0

let fix_loc loc =
  let fix_pos pos =
    (* It looks like lex_buffer.ml returns a position with 2 extra
     * chars for parsed lines after the first one. Bug? *)
    let pos_cnum =
      if pos.Lexing.pos_lnum > !container_lnum_ref
      then pos.Lexing.pos_cnum - 2
      else pos.Lexing.pos_cnum
    in
    { pos with Lexing.pos_cnum }
  in
  let loc_start = fix_pos loc.Location.loc_start in
  let loc_end = fix_pos loc.Location.loc_end in
  { loc with Location.loc_start; loc_end }
;;

let make_loc ?(loc_ghost = false) start_pos end_pos : Location.t =
  { Location.loc_start = start_pos; loc_end = end_pos; loc_ghost }
;;

let make_loc_and_fix ?(loc_ghost = false) start_pos end_pos : Location.t =
  make_loc ~loc_ghost start_pos end_pos |> fix_loc
;;