Source file error.ml

type pos = Lexing.position * Lexing.position
let dummy_pos = (Lexing.dummy_pos, Lexing.dummy_pos)

exception AcgtkError of string * (Format.formatter -> unit) * (pos option)

let base_prompt = "ACGtk> "
let cont_prompt = "... "

module type ERROR_MANAGER =
  sig
    type t
    val kind : string
    val pp : Format.formatter -> t -> unit
  end

module type ERROR_HANDLER =
sig
  type manager
  val emit : ?loc:pos -> manager -> 'a
end


module ErrorManager (E : ERROR_MANAGER) =
struct
  type manager = E.t
    let emit ?loc e = raise (AcgtkError (E.kind, (fun fmt -> E.pp fmt e), loc))
  end

let set_position lexbuf loc =
  let () = Sedlexing.set_position lexbuf loc in
  let () = Sedlexing.set_filename lexbuf loc.Lexing.pos_fname in ()

let quote_position (p1, p2) =
  ({ p1 with Lexing.pos_cnum = p1.Lexing.pos_cnum + 1 }, { p2 with Lexing.pos_cnum = p2.Lexing.pos_cnum - 1 })

let underlined_red_pp s = Fmt.(styled `Red (styled `Underline string)) s

let unicode_sub_str str s_byte uni_chars =
  let buff = Buffer.create 128 in
  let rec unicode_sub_str_rec s_byte uni_chars =
    if uni_chars = 0
      then (Buffer.contents buff, s_byte)
      else
        let u = (Uchar.utf_decode_uchar ((String.get_utf_8_uchar str s_byte))) in
        let () = Buffer.add_utf_8_uchar buff u in
        let (str, k) =
          (unicode_sub_str_rec (s_byte + (Uchar.utf_8_byte_length u)) (uni_chars - 1)) in
        (str, k) in
   unicode_sub_str_rec s_byte uni_chars

let color_error_pp start_c end_c fmt str =
  let (s1, s2_start_byte) = unicode_sub_str str 0 start_c in
  let (s2, s3_start_byte) = unicode_sub_str str s2_start_byte (end_c - start_c) in
  let s3 = String.sub str s3_start_byte (String.length str - s3_start_byte) in
  Format.fprintf fmt "%s%s%a%s" base_prompt s1 underlined_red_pp s2 s3

let underline_error str (l1, l2) =
  let line_num = String.fold_left (fun i c -> if c = '\n' then i + 1 else i) 1 str in
  let () = ANSITerminal.move_cursor 0 (-line_num) in
  Logs.app (fun m -> m "%a" (color_error_pp l1.Lexing.pos_cnum l2.Lexing.pos_cnum) str)

let compute_comment_for_location (pos1, pos2) =
  let line2 = pos2.Lexing.pos_lnum in
  let col2 = pos2.Lexing.pos_cnum - pos2.Lexing.pos_bol in
  let pos1 = pos1 in
  let line1 = pos1.Lexing.pos_lnum in
  let col1 = pos1.Lexing.pos_cnum - pos1.Lexing.pos_bol in
  let msg =
    if line1 = line2 then
      if col1 = col2 then
        Printf.sprintf "line %d, character %d" line2 col2
      else
        Printf.sprintf "line %d, characters %d-%d" line2 col1 col2
    else
      Printf.sprintf "line %d, character %d to line %d, character %d" line1 col1
        line2 col2 in
  match pos1.Lexing.pos_fname with
  | "" -> msg
  | "<stdin>" -> Printf.sprintf "file <stdin>, %s" msg
  | fname -> Printf.sprintf "file \"%s\", %s" fname msg

let pp_text fmt text =
  let words = String.split_on_char ' ' text in
  match words with
  | w :: words ->
      let () = Format.fprintf fmt "%s" w in
      List.iter (fun w -> Format.fprintf fmt "@ %s" w) words
  | _ -> ()

let print_error e str =
  match e with
  | AcgtkError (kind, ppf, Some (l1, l2)) ->
    let () = match str with
      | Some str -> if l1.Lexing.pos_fname = "" && l2.Lexing.pos_fname = "" then underline_error str (l1, l2)
      | None -> () in
    let loc_string = compute_comment_for_location (l1, l2) in
    Logs.err (fun m -> m "@[@[<h>%s error:@;@[%a:@]@]@;@[%t.@]@]" kind pp_text loc_string ppf)
  | AcgtkError (kind, ppf, None) ->
      Logs.err (fun m -> m "%s error:@;@[<4>@[%t.@]@]" kind ppf)
  | Failure s -> Logs.err (fun m -> m "Bug,@ please@ report:@ failure:@ %a" pp_text s)
  | Assert_failure (file, line, col) -> Logs.err (fun m -> m "Bug,@ please@ report:@ assertion@ failed@ at@ %s:%i:%i" file line col)
  | e ->
    let bt = (Printexc.get_backtrace ()) in
      if bt = "" then
        Logs.err (fun m -> m "Bug,@ please@ report:@ uncaught@ exception@ \"%s\"@ (run@ with@ \"-d\"@ to@ see@ backtrace)" (Printexc.to_string e))
      else
        Logs.err (fun m -> m "Bug,@ please@ report:@ uncaught@ exception@ \"%s\"\nBACKTRACE:\n%a" (Printexc.to_string e) pp_text bt)

let print_error_fatal e str =
  let () = print_error e str in exit 1

let rec list_to_string l =
  match l with
  | [] -> "nothing"
  | [ s ] -> Printf.sprintf "\"%s\"" s
  | [ s1 ; s2 ] -> Printf.sprintf "\"%s\" or \"%s\"" s1 s2
  | s :: l -> Printf.sprintf "\"%s\", %s" s (list_to_string l)