Source file location_error.ml

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
open Import

type t = Astlib.Location.Error.t

let to_extension (error : Astlib.Location.Error.t) =
  let open Astlib.Location.Error in
  let open Ast_helper in
  if not (is_well_formed error) then
    raise (Invalid_argument "to_extension: expected kind Report_error");
  let sub_msgs = sub_msgs error in
  let main_msg = main_msg error in
  let err_extension_name loc = { Location.loc; txt = "ocaml.error" } in
  let mk_string_constant x = Str.eval (Exp.constant (Const.string x)) in
  let extension_of_sub_msg (sub_msg : string Location.loc) =
    Str.extension
      (err_extension_name sub_msg.loc, PStr [ mk_string_constant sub_msg.txt ])
  in
  ( err_extension_name main_msg.loc,
    Parsetree.PStr
      (mk_string_constant main_msg.txt :: List.map extension_of_sub_msg sub_msgs)
  )

let register_error_of_exn = Astlib.Location.register_error_of_exn

let message error =
  let { Astlib.Location.txt; _ } = Astlib.Location.Error.main_msg error in
  txt

let set_message = Astlib.Location.Error.set_main_msg

let make ~loc txt ~sub =
  let sub = List.map (fun (loc, txt) -> { Astlib.Location.loc; txt }) sub in
  Astlib.Location.Error.make ~sub { loc; txt }

let update_loc = Astlib.Location.Error.set_main_loc

let get_location error =
  let { Astlib.Location.loc; _ } = Astlib.Location.Error.main_msg error in
  loc

let of_exn = Astlib.Location.Error.of_exn
let raise error = raise (Astlib.Location.Error error)

let of_extension (extension : Ast.extension) =
  let open Parsetree in
  let parse_msg = function
    | {
        pstr_desc =
          Pstr_eval
            ({ pexp_desc = Pexp_constant (Pconst_string (msg, _, _)); _ }, []);
        _;
      } ->
        msg
    | _ -> "ppxlib: failed to extract message in ocaml.error"
  in
  let parse_sub_msg = function
    | {
        pstr_desc =
          Pstr_extension
            (({ txt = "error" | "ocaml.error"; loc }, PStr [ msg ]), []);
        _;
      } ->
        (loc, parse_msg msg)
    | { pstr_loc = loc; _ } ->
        (loc, "ppxlib: failed to parse ocaml.error sub messages")
  in
  match extension with
  | { txt = "error" | "ocaml.error"; loc }, PStr (main :: sub) ->
      let main = parse_msg main in
      let sub = List.map parse_sub_msg sub in
      Some (make ~loc main ~sub)
  | _ -> None