Source file ppxlib_metaquot.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
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
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
open Ppxlib
open Ast_builder.Default
module E = Extension
module A = Ast_pattern
module Make (M : sig
type result
val annotate : result -> core_type -> result
val cast : extension -> result
val location : location -> result
val location_stack : (location -> result) option
val attributes : (location -> result) option
class std_lifters : location -> [result] Ppxlib_traverse_builtins.std_lifters
end) =
struct
let lift loc =
object (self)
inherit [M.result] Ast_traverse.lift as super
inherit! M.std_lifters loc
method typed ast name =
let loc = { loc with loc_ghost = true } in
M.annotate ast
(ptyp_constr ~loc
{ loc; txt = Ldot (Ldot (Lident "Ppxlib_ast", "Ast"), name) }
[])
method! attribute x =
Attribute.mark_as_handled_manually x;
super#attribute x
method! location _ = M.location loc
method! attributes x =
match M.attributes with
| None -> super#attributes x
| Some f ->
assert_no_attributes x;
f loc
method! location_stack x =
match M.location_stack with
| None -> super#location_stack x
| Some f -> f loc
method! expression e =
match e.pexp_desc with
| Pexp_extension (({ txt = "e"; _ }, _) as ext) ->
self#typed (M.cast ext) "expression"
| _ -> super#expression e
method! pattern p =
match p.ppat_desc with
| Ppat_extension (({ txt = "p"; _ }, _) as ext) ->
self#typed (M.cast ext) "pattern"
| _ -> super#pattern p
method! core_type t =
match t.ptyp_desc with
| Ptyp_extension (({ txt = "t"; _ }, _) as ext) ->
self#typed (M.cast ext) "core_type"
| _ -> super#core_type t
method! module_expr m =
match m.pmod_desc with
| Pmod_extension (({ txt = "m"; _ }, _) as ext) ->
self#typed (M.cast ext) "module_expr"
| _ -> super#module_expr m
method! module_type m =
match m.pmty_desc with
| Pmty_extension (({ txt = "m"; _ }, _) as ext) ->
self#typed (M.cast ext) "module_type"
| _ -> super#module_type m
method! structure_item i =
match i.pstr_desc with
| Pstr_extension ((({ txt = "i"; _ }, _) as ext), attrs) ->
assert_no_attributes attrs;
self#typed (M.cast ext) "structure_item"
| _ -> super#structure_item i
method! signature_item i =
match i.psig_desc with
| Psig_extension ((({ txt = "i"; _ }, _) as ext), attrs) ->
assert_no_attributes attrs;
self#typed (M.cast ext) "signature_item"
| _ -> super#signature_item i
end
end
module Expr = Make (struct
type result = expression
let location loc = evar ~loc:{ loc with loc_ghost = true } "loc"
let location_stack = None
let attributes = None
class std_lifters = Ppxlib_metaquot_lifters.expression_lifters
let annotate e core_type = pexp_constraint ~loc:core_type.ptyp_loc e core_type
let cast ext =
match snd ext with
| PStr [ { pstr_desc = Pstr_eval (e, attrs); _ } ] ->
assert_no_attributes attrs;
e
| _ ->
Location.raise_errorf ~loc:(loc_of_extension ext) "expression expected"
end)
module Patt = Make (struct
type result = pattern
let location loc = ppat_any ~loc:{ loc with loc_ghost = true }
let location_stack =
Some (fun loc -> ppat_any ~loc:{ loc with loc_ghost = true })
let attributes = Some (fun loc -> ppat_any ~loc:{ loc with loc_ghost = true })
class std_lifters = Ppxlib_metaquot_lifters.pattern_lifters
let annotate p core_type = ppat_constraint ~loc:core_type.ptyp_loc p core_type
let cast ext =
match snd ext with
| PPat (p, None) -> p
| PPat (_, Some e) ->
Location.raise_errorf ~loc:e.pexp_loc "guard not expected here"
| _ -> Location.raise_errorf ~loc:(loc_of_extension ext) "pattern expected"
end)
let () =
let extensions ctx lifter =
[
E.declare "metaquot.expr" ctx
A.(single_expr_payload __)
(fun ~loc ~path:_ e ->
let lift = lifter loc in
lift#typed (lift#expression e) "expression");
E.declare "metaquot.pat" ctx
A.(ppat __ none)
(fun ~loc ~path:_ p ->
let lift = lifter loc in
lift#typed (lift#pattern p) "pattern");
E.declare "metaquot.str" ctx
A.(pstr __)
(fun ~loc ~path:_ s ->
let lift = lifter loc in
lift#typed (lift#structure s) "structure");
E.declare "metaquot.stri" ctx
A.(pstr (__ ^:: nil))
(fun ~loc ~path:_ s ->
let lift = lifter loc in
lift#typed (lift#structure_item s) "structure_item");
E.declare "metaquot.sig" ctx
A.(psig __)
(fun ~loc ~path:_ s ->
let lift = lifter loc in
lift#typed (lift#signature s) "signature");
E.declare "metaquot.sigi" ctx
A.(psig (__ ^:: nil))
(fun ~loc ~path:_ s ->
let lift = lifter loc in
lift#typed (lift#signature_item s) "signature_item");
E.declare "metaquot.type" ctx
A.(ptyp __)
(fun ~loc ~path:_ t ->
let lift = lifter loc in
lift#typed (lift#core_type t) "core_type");
]
in
let extensions =
extensions Expression Expr.lift @ extensions Pattern Patt.lift
in
Driver.register_transformation "metaquot" ~extensions