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
|
(* A -ppx rewriter to be used to write Parsetree-generating code
(including other -ppx rewriters) using concrete syntax.
See metaquot_test.ml for an example.
We support the following extensions in expression position:
[%expr ...] maps to code which creates the expression represented by ...
[%pat "..."] maps to code which creates the pattern represented by ...
[%pat "..."] maps to code which creates the pattern represented by ...
[%str ...] maps to code which creates the structure represented by ...
[type "..."] maps to code which creates the core type represented by ...
Note that except for the expr and str expander, the argument needs to be
a string literal (it can also be a quoted string, of course), which
will be re-parse by the expander (in case of a parsing error,
the location will be relative to the parsed string).
Quoted code can refer to expressions representing AST fragments,
using the following extensions:
[%e ...] where ... is an expression of type Parsetree.expression
[%t ...] where ... is an expression of type Parsetree.core_type
[%p ...] where ... is an expression of type Parsetree.pattern
All locations generated by the meta quotation are by default set
to Location.none. This can be overriden by providing a custom
expression which will be inserted whereever a location is required
in the generated AST. This expression can be specified globally
(for the current structure) as a structure item attribute:
;;[@@metaloc ...]
or locally for the scope of an expression:
e [@metaloc ...]
No support is provided for meta quotation in pattern position.
*)
module Main : sig end = struct
open Asttypes
open Parsetree
open Ast_helper
open Ast_helper.Convenience
let prefix ty s =
let open Longident in
match parse ty with
| Ldot(m, _) -> String.concat "." (Longident.flatten m) ^ "." ^ s
| _ -> s
class exp_builder =
object
method record ty x = record (List.map (fun (l, e) -> prefix ty l, e) x)
method constr ty (c, args) = constr (prefix ty c) args
method list = list
method tuple = tuple
method int = int
method string = str
method char = char
method int32 x = Exp.constant (Const_int32 x)
method int64 x = Exp.constant (Const_int64 x)
method nativeint x = Exp.constant (Const_nativeint x)
end
let get_exp loc = function
| [ {pstr_desc=Pstr_eval (e, _); _} ] -> e
| _ ->
Format.eprintf "%aExpression expected"
Location.print_error loc;
exit 2
let lifter loc =
object
inherit [_] Ast_lifter.lifter as super
inherit exp_builder
(* Special support for location in the generated AST *)
method! lift_Location_t _ = loc
(* Support for antiquotations *)
method! lift_Parsetree_expression = function
| {pexp_desc=Pexp_extension({txt="e";loc}, e); _} -> get_exp loc e
| x -> super # lift_Parsetree_expression x
method! lift_Parsetree_pattern = function
| {ppat_desc=Ppat_extension({txt="p";loc}, e); _} -> get_exp loc e
| x -> super # lift_Parsetree_pattern x
method! lift_Parsetree_core_type = function
| {ptyp_desc=Ptyp_extension({txt="t";loc}, e); _} -> get_exp loc e
| x -> super # lift_Parsetree_core_type x
end
let loc = ref (evar "Location.none")
let handle_attr = function
| {txt="metaloc";loc=l}, e -> loc := get_exp l e
| _ -> ()
let with_loc ?(attrs = []) f =
let old_loc = !loc in
List.iter handle_attr attrs;
let r = f () in
loc := old_loc;
r
let report_error ppf exn =
let report ppf = function
| Lexer.Error(err, loc) ->
Location.print_error ppf loc;
Lexer.report_error ppf err
| Syntaxerr.Error err ->
Syntaxerr.report_error ppf err
| x ->
Format.fprintf ppf "%s" (Printexc.to_string x)
in
Format.fprintf ppf "@[%a@]@." report exn
let extract_str parse kind = function
| {pexp_desc = Pexp_constant (Const_string (s, _)); pexp_loc = loc; _} ->
begin try parse (Lexing.from_string s)
with exn ->
Location.print_error Format.std_formatter loc;
Format.eprintf "Error while parsing a %s quotation:@.%a@." kind
report_error exn;
exit 2
end
| {pexp_loc = loc; _} ->
Location.print_error Format.std_formatter loc;
Format.eprintf
"The content of this quotation must be a string literal.@.";
exit 2
let expander = object
inherit Ast_mapper.mapper as super
method! expr e =
with_loc ~attrs:e.pexp_attributes
(fun () ->
match e.pexp_desc with
| Pexp_extension({txt="expr";loc=l}, e) ->
(lifter !loc) # lift_Parsetree_expression (get_exp l e)
| Pexp_extension({txt="pat";loc=l}, e) ->
let p = extract_str Parse.pattern "pattern" (get_exp l e) in
(lifter !loc) # lift_Parsetree_pattern p
| Pexp_extension({txt="str";_}, e) ->
(lifter !loc) # lift_Parsetree_structure e
| Pexp_extension({txt="type";loc=l}, e) ->
let p = extract_str Parse.core_type "type" (get_exp l e) in
(lifter !loc) # lift_Parsetree_core_type p
| _ ->
super # expr e
)
method! structure l =
with_loc
(fun () -> super # structure l)
method! structure_item x =
begin match x.pstr_desc with
| Pstr_attribute x -> handle_attr x
| _ -> ()
end;
super # structure_item x
end
let () = Ast_mapper.main expander
end
|
