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
open Ppxlib
open Ast_builder.Default
module E = Extension
module A = Ast_pattern
module Make(M : sig
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
inherit [M.result] Ast_traverse.lift as super
inherit! M.std_lifters loc
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)-> M.cast ext
| _ -> super#expression e
method! pattern p =
match p.ppat_desc with
| Ppat_extension ({ txt = "p"; _}, _ as ext)-> M.cast ext
| _ -> super#pattern p
method! core_type t =
match t.ptyp_desc with
| Ptyp_extension ({ txt = "t"; _}, _ as ext)-> M.cast ext
| _ -> super#core_type t
method! module_expr m =
match m.pmod_desc with
| Pmod_extension ({ txt = "m"; _}, _ as ext)-> M.cast ext
| _ -> super#module_expr m
method! module_type m =
match m.pmty_desc with
| Pmty_extension ({ txt = "m"; _ }, _ as ext)-> M.cast ext
| _ -> super#module_type m
method! structure_item i =
match i.pstr_desc with
| Pstr_extension (({ txt = "i"; _}, _ as ext), attrs) ->
assert_no_attributes attrs;
M.cast ext
| _ -> super#structure_item i
method! signature_item i =
match i.psig_desc with
| Psig_extension (({ txt = "i"; _}, _ as ext), attrs) ->
assert_no_attributes attrs;
M.cast ext
| _ -> super#signature_item i
end
end
module Expr = Make(struct
type result = expression
let location loc = evar ~loc "loc"
let location_stack = None
let attributes = None
class std_lifters = Ppxlib_metaquot_lifters.expression_lifters
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
let location_stack = Some (fun loc -> ppat_any ~loc)
let attributes = Some (fun loc -> ppat_any ~loc)
class std_lifters = Ppxlib_metaquot_lifters.pattern_lifters
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 "expr" ctx A.(single_expr_payload __)
(fun ~loc ~path:_ e -> (lifter loc)#expression e)
; E.declare "pat" ctx A.(ppat __ none)
(fun ~loc ~path:_ p -> (lifter loc)#pattern p)
; E.declare "str" ctx A.(pstr __)
(fun ~loc ~path:_ s -> (lifter loc)#structure s)
; E.declare "stri" ctx A.(pstr (__ ^:: nil))
(fun ~loc ~path:_ s -> (lifter loc)#structure_item s)
; E.declare "sig" ctx A.(psig __)
(fun ~loc ~path:_ s -> (lifter loc)#signature s)
; E.declare "sigi" ctx A.(psig (__ ^:: nil))
(fun ~loc ~path:_ s -> (lifter loc)#signature_item s)
; E.declare "type" ctx A.(ptyp __)
(fun ~loc ~path:_ t -> (lifter loc)#core_type t)
]
in
let extensions =
extensions Expression Expr.lift @
extensions Pattern Patt.lift
in
Driver.register_transformation
"metaquot"
~extensions