Source file location.ml

open Import
module L = Astlib.Location

type t = location = {
  loc_start : Lexing.position;
  loc_end : Lexing.position;
  loc_ghost : bool;
}

let in_file name =
  let loc = { pos_fname = name; pos_lnum = 0; pos_bol = 0; pos_cnum = -1 } in
  { loc_start = loc; loc_end = loc; loc_ghost = true }

let set_filename loc fn =
  let loc_start = { loc.loc_start with pos_fname = fn } in
  let loc_end = { loc.loc_end with pos_fname = fn } in
  { loc with loc_start; loc_end }

let none = in_file "_none_"
let is_none v = Poly.( = ) v none

let init lexbuf fname =
  let open Lexing in
  lexbuf.lex_curr_p <-
    { pos_fname = fname; pos_lnum = 1; pos_bol = 0; pos_cnum = 0 }

let raise_errorf ?loc fmt = L.raise_errorf ?loc fmt
let report_exception = L.report_exception

let of_lexbuf (lexbuf : Lexing.lexbuf) =
  {
    loc_start = lexbuf.lex_start_p;
    loc_end = lexbuf.lex_curr_p;
    loc_ghost = false;
  }

let print ppf t =
  Stdlib.Format.fprintf ppf "File \"%s\", line %d, characters %d-%d:"
    t.loc_start.pos_fname t.loc_start.pos_lnum
    (t.loc_start.pos_cnum - t.loc_start.pos_bol)
    (t.loc_end.pos_cnum - t.loc_start.pos_bol)

type nonrec 'a loc = 'a loc = { txt : 'a; loc : t }

let compare_pos p1 p2 =
  let open Lexing in
  let column p =
    (* Manual extract:
       The difference between pos_cnum and pos_bol is the character offset
       within the line (i.e. the column number, assuming each character is
       one column wide). *)
    p.pos_cnum - p.pos_bol
  in
  match Int.compare p1.pos_lnum p2.pos_lnum with
  | 0 -> Int.compare (column p1) (column p2)
  | n -> n

let min_pos p1 p2 = if compare_pos p1 p2 <= 0 then p1 else p2
let max_pos p1 p2 = if compare_pos p1 p2 >= 0 then p1 else p2

let compare loc1 loc2 =
  match compare_pos loc1.loc_start loc2.loc_start with
  | 0 -> compare_pos loc1.loc_end loc2.loc_end
  | n -> n

module Error = struct
  include Ppxlib_ast.Location_error

  let createf ~loc fmt = Format.kasprintf (fun str -> make ~loc ~sub:[] str) fmt
end

let error_extensionf ~loc fmt =
  Format.kasprintf
    (fun str -> Error.to_extension @@ Error.make ~loc ~sub:[] str)
    fmt

exception Error = L.Error

let () =
  Stdlib.Printexc.register_printer (function
    | Error e -> Some (Error.message e)
    | _ -> None)