Source file `util.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
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
(** This module provides helper functions for [ppx_marshal] *)

open Ppxlib
open Ast_builder.Default

(** Generate an attribute to ignore the given warning ID *)
let ignore_warn ~loc warn =
  attribute ~loc ~name:(Loc.make ~loc "warning")
            ~payload:(PStr [pstr_eval ~loc (estring ~loc ("-" ^ Int.to_string warn)) []])

(** Generate an attribute triggering a warning *)
let warn ~loc ?(prefix="@@marshal") str =
  attribute ~loc ~name:(Loc.make ~loc "ppwarning")
            ~payload:(PStr [pstr_eval ~loc (estring ~loc ("[" ^ prefix ^ "] " ^ str)) []])

(** Generate a function with an unlabeled argument *)
let fun_' ~loc = pexp_fun ~loc Nolabel None

(** Generate a function with an unlabeled argument variable *)
let fun_ ~loc arg = pvar ~loc arg |> fun_' ~loc

(** Generate a function with an unlabeled unpacked module variable *)
let fun_m ~loc arg = Some arg |> Loc.make ~loc |> ppat_unpack ~loc |> fun_' ~loc

(** Generate a longident Loc.t from a string *)
let lident_t ~loc x = lident x |> Loc.make ~loc

(** Generate a longident Loc.t from a string Loc.t *)
let lident_t' x = lident x.txt |> Loc.make ~loc:x.loc

(** Generate a dotted expression *)
let dot ~loc l =
  let rec dot_rec = function
    | [] -> failwith "Unreachable"
    | hd::[] -> lident hd
    | hd::tl -> Ldot (dot_rec tl, hd) in
  List.rev l |> dot_rec |> Loc.make ~loc |> pexp_ident ~loc

(** Generate a function application to unlabelled args *)
let apply ~loc name args = List.map (fun arg -> (Nolabel, arg)) args |> pexp_apply ~loc name

(** Generate a function application in the form [f ~v arg] *)
let apply_v ~loc name arg arg' = pexp_apply ~loc name [(Labelled "v", arg); (Nolabel, arg')]

(** Generate a simple expression or a tuple, depending on the argument size *)
let tuple_e ~loc = function
  | [] -> failwith "tuple_e"
  | hd::[] -> hd
  | l -> pexp_tuple ~loc l

(** Generate a construct expression a bit more cleverly *)
let construct_e ~loc name =
  let f = pexp_construct ~loc (lident_t ~loc name) in
  function
    | [] -> f None
    | l -> Some (tuple_e ~loc l) |> f

(** Generate a construct pattern a bit more cleverly *)
let construct_p ~loc name =
  let f = ppat_construct ~loc (lident_t ~loc name) in
  function
    | [] -> f None
    | hd::[] -> Some hd |> f
    | l -> Some (ppat_tuple ~loc l) |> f

(** Error generators *)
let err = Location.error_extensionf "[%s] %s"
let eerr f ~loc str = f ~loc str |> pexp_extension ~loc
let err_ma = err "@@marshal"
let eerr_ma = eerr err_ma
let terr_ma ~loc str = err_ma ~loc str |> ptyp_extension ~loc
let err_me = err "%marshal"
let eerr_me = eerr err_me
let serr f ~loc str =
  let payload = f ~loc str in
  pstr_extension ~loc payload []

(** Build a list cons *)
let cons ~loc hd tl = construct_e ~loc "::" [hd; tl]

(** Capitalize a string *)
let cap = String.capitalize_ascii

(** Uncapitalize a string *)
let uncap = String.uncapitalize_ascii

(** Gendarmize a module name *)
let gendarmize m = "Gendarme_" ^ uncap m

(** Wrap a value into a unit function *)
let wrap ~loc = pexp_fun ~loc Nolabel None (construct_p ~loc "()" [])

(** Unwrap a previously wrapped function *)
let unwrap ~loc e = pexp_apply ~loc e [Nolabel, construct_e ~loc "()" []]

(** Generate a let expression *)
let let' ~loc flag pat expr = pexp_let ~loc flag [value_binding ~loc ~pat ~expr]

(** Default guard *)
let guard = None

(** Generate a raise expression *)
let raise_ ~loc name args = apply ~loc (evar ~loc "raise") [construct_e ~loc name args]