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
|
open Migrate_parsetree.Ast_411
(* 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 = Asttypes.arg_label
type desc = Asttypes.arg_label =
Nolabel
| Labelled of string
| Optional of string
let explode x = x
let nolabel = Nolabel
let labelled x = Labelled x
let optional x = Optional x
end
module Constant = struct
type t = Parsetree.constant =
Pconst_integer of string * char option
| Pconst_char of char
| Pconst_string of string * Location.t * string option
| Pconst_float of string * char option
let of_constant x = x
let to_constant x = x
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 =
let inner_loc =
match loc with
| None -> !default_loc
| Some loc -> loc
in
Exp.constant ?loc ?attrs (Pconst_string (s, inner_loc, None))
let int ?loc ?attrs x = Exp.constant ?loc ?attrs (Pconst_integer (string_of_int x, None))
let int32 ?loc ?attrs x = Exp.constant ?loc ?attrs (Pconst_integer (Int32.to_string x, Some 'l'))
let int64 ?loc ?attrs x = Exp.constant ?loc ?attrs (Pconst_integer (Int64.to_string x, Some 'L'))
let char ?loc ?attrs x = Exp.constant ?loc ?attrs (Pconst_char x)
let float ?loc ?attrs x = Exp.constant ?loc ?attrs (Pconst_float (string_of_float x, None))
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 =
let inner_loc =
match loc with
| None -> !default_loc
| Some loc -> loc
in
Pat.constant ?loc ?attrs (Pconst_string (s, inner_loc, None))
let pint ?loc ?attrs x = Pat.constant ?loc ?attrs (Pconst_integer (string_of_int x, None))
let pchar ?loc ?attrs x = Pat.constant ?loc ?attrs (Pconst_char x)
let pfloat ?loc ?attrs x = Pat.constant ?loc ?attrs (Pconst_float (string_of_float x, None))
let tconstr ?loc ?attrs c l = Typ.constr ?loc ?attrs (lid ?loc c) l
let get_str = function
| {pexp_desc=Pexp_constant (Pconst_string (s, _, _)); _} -> Some s
| _ -> None
let get_str_with_quotation_delimiter = function
| {pexp_desc=Pexp_constant (Pconst_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 ((List.find (fun {attr_name=x;_} -> x.txt = s) attrs).attr_payload)
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
|
