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
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
|
open Migrate_parsetree.Ast_402
(* This file is part of the ppx_tools package. It is released *)
(* under the terms of the MIT license (see LICENSE file). *)
(* Copyright 2013 Alain Frisch and LexiFi *)
open Parsetree
open Asttypes
open Location
open Ast_helper
module Label = struct
type t = string
type desc =
Nolabel
| Labelled of string
| Optional of string
let explode s =
if s = "" then Nolabel
else if s.[0] = '?' then Optional (String.sub s 1 (String.length s - 1))
else Labelled s
let nolabel = ""
let labelled s = s
let optional s = "?"^s
end
module Constant = struct
type t =
Pconst_integer of string * char option
| Pconst_char of char
| Pconst_string of string * string option
| Pconst_float of string * char option
exception Unknown_literal of string * char
(** Backport Int_literal_converter from ocaml 4.03 -
* https://github.com/ocaml/ocaml/blob/trunk/utils/misc.ml#L298 *)
module Int_literal_converter = struct
let cvt_int_aux str neg of_string =
if String.length str = 0 || str.[0] = '-'
then of_string str
else neg (of_string ("-" ^ str))
let int s = cvt_int_aux s (~-) int_of_string
let int32 s = cvt_int_aux s Int32.neg Int32.of_string
let int64 s = cvt_int_aux s Int64.neg Int64.of_string
let nativeint s = cvt_int_aux s Nativeint.neg Nativeint.of_string
end
let of_constant = function
| Asttypes.Const_int32(i) -> Pconst_integer(Int32.to_string i, Some 'l')
| Asttypes.Const_int64(i) -> Pconst_integer(Int64.to_string i, Some 'L')
| Asttypes.Const_nativeint(i) -> Pconst_integer(Nativeint.to_string i, Some 'n')
| Asttypes.Const_int(i) -> Pconst_integer(string_of_int i, None)
| Asttypes.Const_char c -> Pconst_char c
| Asttypes.Const_string(s, s_opt) -> Pconst_string(s, s_opt)
| Asttypes.Const_float f -> Pconst_float(f, None)
let to_constant = function
| Pconst_integer(i,Some 'l') -> Asttypes.Const_int32 (Int_literal_converter.int32 i)
| Pconst_integer(i,Some 'L') -> Asttypes.Const_int64 (Int_literal_converter.int64 i)
| Pconst_integer(i,Some 'n') -> Asttypes.Const_nativeint (Int_literal_converter.nativeint i)
| Pconst_integer(i,None) -> Asttypes.Const_int (Int_literal_converter.int i)
| Pconst_integer(i,Some c) -> raise (Unknown_literal (i, c))
| Pconst_char c -> Asttypes.Const_char c
| Pconst_string(s,d) -> Asttypes.Const_string(s, d)
| Pconst_float(f,None) -> Asttypes.Const_float f
| Pconst_float(f,Some c) -> raise (Unknown_literal (f, c))
end
let may_tuple ?loc tup = function
| [] -> None
| [x] -> Some x
| l -> Some (tup ?loc ?attrs:None l)
let lid ?(loc = !default_loc) s = mkloc (Longident.parse s) loc
let constr ?loc ?attrs s args = Exp.construct ?loc ?attrs (lid ?loc s) (may_tuple ?loc Exp.tuple args)
let nil ?loc ?attrs () = constr ?loc ?attrs "[]" []
let unit ?loc ?attrs () = constr ?loc ?attrs "()" []
let tuple ?loc ?attrs = function
| [] -> unit ?loc ?attrs ()
| [x] -> x
| xs -> Exp.tuple ?loc ?attrs xs
let cons ?loc ?attrs hd tl = constr ?loc ?attrs "::" [hd; tl]
let list ?loc ?attrs l = List.fold_right (cons ?loc ?attrs) l (nil ?loc ?attrs ())
let str ?loc ?attrs s = Exp.constant ?loc ?attrs (Const_string (s, None))
let int ?loc ?attrs x = Exp.constant ?loc ?attrs (Const_int x)
let char ?loc ?attrs x = Exp.constant ?loc ?attrs (Const_char x)
let float ?loc ?attrs x = Exp.constant ?loc ?attrs (Const_float (string_of_float x))
let record ?loc ?attrs ?over l =
Exp.record ?loc ?attrs (List.map (fun (s, e) -> (lid ~loc:e.pexp_loc s, e)) l) over
let func ?loc ?attrs l = Exp.function_ ?loc ?attrs (List.map (fun (p, e) -> Exp.case p e) l)
let lam ?loc ?attrs ?(label = Label.nolabel) ?default pat exp = Exp.fun_ ?loc ?attrs label default pat exp
let app ?loc ?attrs f l = if l = [] then f else Exp.apply ?loc ?attrs f (List.map (fun a -> Label.nolabel, a) l)
let evar ?loc ?attrs s = Exp.ident ?loc ?attrs (lid ?loc s)
let let_in ?loc ?attrs ?(recursive = false) b body =
Exp.let_ ?loc ?attrs (if recursive then Recursive else Nonrecursive) b body
let sequence ?loc ?attrs = function
| [] -> unit ?loc ?attrs ()
| hd :: tl -> List.fold_left (fun e1 e2 -> Exp.sequence ?loc ?attrs e1 e2) hd tl
let pvar ?(loc = !default_loc) ?attrs s = Pat.var ~loc ?attrs (mkloc s loc)
let pconstr ?loc ?attrs s args = Pat.construct ?loc ?attrs (lid ?loc s) (may_tuple ?loc Pat.tuple args)
let precord ?loc ?attrs ?(closed = Open) l =
Pat.record ?loc ?attrs (List.map (fun (s, e) -> (lid ~loc:e.ppat_loc s, e)) l) closed
let pnil ?loc ?attrs () = pconstr ?loc ?attrs "[]" []
let pcons ?loc ?attrs hd tl = pconstr ?loc ?attrs "::" [hd; tl]
let punit ?loc ?attrs () = pconstr ?loc ?attrs "()" []
let ptuple ?loc ?attrs = function
| [] -> punit ?loc ?attrs ()
| [x] -> x
| xs -> Pat.tuple ?loc ?attrs xs
let plist ?loc ?attrs l = List.fold_right (pcons ?loc ?attrs) l (pnil ?loc ?attrs ())
let pstr ?loc ?attrs s = Pat.constant ?loc ?attrs (Const_string (s, None))
let pint ?loc ?attrs x = Pat.constant ?loc ?attrs (Const_int x)
let pchar ?loc ?attrs x = Pat.constant ?loc ?attrs (Const_char x)
let pfloat ?loc ?attrs x = Pat.constant ?loc ?attrs (Const_float (string_of_float x))
let tconstr ?loc ?attrs c l = Typ.constr ?loc ?attrs (lid ?loc c) l
let get_str = function
| {pexp_desc=Pexp_constant (Const_string (s, _)); _} -> Some s
| _ -> None
let get_str_with_quotation_delimiter = function
| {pexp_desc=Pexp_constant (Const_string (s, d)); _} -> Some (s, d)
| _ -> None
let get_lid = function
| {pexp_desc=Pexp_ident{txt=id;_};_} ->
Some (String.concat "." (Longident.flatten id))
| _ -> None
let find_attr s attrs =
try Some (snd (List.find (fun (x, _) -> x.txt = s) attrs))
with Not_found -> None
let expr_of_payload = function
| PStr [{pstr_desc=Pstr_eval(e, _); _}] -> Some e
| _ -> None
let find_attr_expr s attrs =
match find_attr s attrs with
| Some e -> expr_of_payload e
| None -> None
let has_attr s attrs =
find_attr s attrs <> None
|
