File: ppx_metaquot.ml

package info (click to toggle)
ppx-tools 5.3+4.08.0-1
  • links: PTS, VCS
  • area: main
  • in suites: bullseye, sid
  • size: 176 kB
  • sloc: ml: 1,347; makefile: 92
file content (286 lines) | stat: -rw-r--r-- 10,604 bytes parent folder | download
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
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
(*  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                      *)

(* A -ppx rewriter to be used to write Parsetree-generating code
   (including other -ppx rewriters) using concrete syntax.

   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 ...
   [%str ...] maps to code which creates the structure represented by ...
   [%stri ...] maps to code which creates the structure item represented by ...
   [%sig: ...] maps to code which creates the signature represented by ...
   [%sigi: ...] maps to code which creates the signature item represented by ...
   [%type: ...] maps to code which creates the core type represented by ...

   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
     [%%s ...] where ... is an expression of type Parsetree.structure
               or Parsetree.signature depending on the context.


   All locations generated by the meta quotation are by default set
   to [Ast_helper.default_loc].  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 ...]



   Support is also provided to use concrete syntax in pattern
   position.  The location and attribute fields are currently ignored
   by patterns generated from meta quotations.

   We support the following extensions in pattern position:

   [%expr ...]  maps to code which creates the expression 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 ...

   Quoted code can refer to expressions representing AST fragments,
   using the following extensions:

     [%e? ...] where ... is a pattern of type Parsetree.expression
     [%t? ...] where ... is a pattern of type Parsetree.core_type
     [%p? ...] where ... is a pattern of type Parsetree.pattern

*)

module Main : sig end = struct
  open Asttypes
  open Parsetree
  open Ast_helper
  open Ast_convenience

  let prefix ty s =
    let open Longident in
    match parse ty with
    | Ldot(m, _) -> String.concat "." (Longident.flatten m) ^ "." ^ s
    | _ -> s

  let append ?loc ?attrs e e' =
    let fn = Location.mknoloc (Longident.(Ldot (Lident "List", "append"))) in
    Exp.apply ?loc ?attrs (Exp.ident fn) [Nolabel, e; Nolabel, e']

  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 l = list l
      method tuple l = tuple l
      method int i = int i
      method string s = str s
      method char c = char c
      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

  class pat_builder =
    object
      method record ty x = precord ~closed:Closed (List.map (fun (l, e) -> prefix ty l, e) x)
      method constr ty (c, args) = pconstr (prefix ty c) args
      method list l = plist l
      method tuple l = ptuple l
      method int i = pint i
      method string s = pstr s
      method char c = pchar c
      method int32 x = Pat.constant (Const.int32 x)
      method int64 x = Pat.constant (Const.int64 x)
      method nativeint x = Pat.constant (Const.nativeint x)
    end


  let get_exp loc = function
    | PStr [ {pstr_desc=Pstr_eval (e, _); _} ] -> e
    | _ ->
        let report = Location.error ~loc "Expression expected." in
        Location.print_report Format.err_formatter report;
        exit 2

  let get_typ loc = function
    | PTyp t -> t
    | _ ->
        let report = Location.error ~loc "Type expected." in
        Location.print_report Format.err_formatter report;
        exit 2

  let get_pat loc = function
    | PPat (t, None) -> t
    | _ ->
        let report = Location.error ~loc "Pattern expected." in
        Location.print_report Format.err_formatter report;
        exit 2

  let exp_lifter loc map =
    let map = map.Ast_mapper.expr map in
    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); _} -> map (get_exp loc e)
        | x -> super # lift_Parsetree_expression x

      method! lift_Parsetree_pattern = function
        | {ppat_desc=Ppat_extension({txt="p";loc}, e); _} -> map (get_exp loc e)
        | x -> super # lift_Parsetree_pattern x

      method! lift_Parsetree_structure str =
        List.fold_right
          (function
           | {pstr_desc=Pstr_extension(({txt="s";loc}, e), _); _} ->
               append (get_exp loc e)
           | x ->
               cons (super # lift_Parsetree_structure_item x))
          str (nil ())

      method! lift_Parsetree_signature sign =
        List.fold_right
          (function
           | {psig_desc=Psig_extension(({txt="s";loc}, e), _); _} ->
               append (get_exp loc e)
           | x ->
               cons (super # lift_Parsetree_signature_item x))
          sign (nil ())

      method! lift_Parsetree_core_type = function
        | {ptyp_desc=Ptyp_extension({txt="t";loc}, e); _} ->map (get_exp loc e)
        | x -> super # lift_Parsetree_core_type x
    end

  let pat_lifter map =
    let map = map.Ast_mapper.pat map in
    object
      inherit [_] Ast_lifter.lifter as super
      inherit pat_builder as builder

      (* Special support for location and attributes in the generated AST *)
      method! lift_Location_t _ = Pat.any ()
      method! lift_Parsetree_attributes _ = Pat.any ()
      method! record n fields =
        let fields =
          List.map (fun (name, pat) ->
              match name with
              | "pexp_loc_stack" | "ppat_loc_stack" | "ptyp_loc_stack" ->
                 name, Pat.any ()
              | _ -> name, pat) fields
        in
        builder#record n fields

      (* Support for antiquotations *)
      method! lift_Parsetree_expression = function
        | {pexp_desc=Pexp_extension({txt="e";loc}, e); _} -> map (get_pat loc e)
        | x -> super # lift_Parsetree_expression x

      method! lift_Parsetree_pattern = function
        | {ppat_desc=Ppat_extension({txt="p";loc}, e); _} -> map (get_pat loc e)
        | x -> super # lift_Parsetree_pattern x

      method! lift_Parsetree_core_type = function
        | {ptyp_desc=Ptyp_extension({txt="t";loc}, e); _} -> map (get_pat loc e)
        | x -> super # lift_Parsetree_core_type x
    end

  let loc = ref (app (evar "Stdlib.!") [evar "Ast_helper.default_loc"])

  let handle_attr = function
    | {attr_name={txt="metaloc";loc=l}; attr_payload=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 expander _args =
    let open Ast_mapper in
    let super = default_mapper in
    let expr this e =
      with_loc ~attrs:e.pexp_attributes
        (fun () ->
           match e.pexp_desc with
           | Pexp_extension({txt="expr";loc=l}, e) ->
               (exp_lifter !loc this) # lift_Parsetree_expression (get_exp l e)
           | Pexp_extension({txt="pat";loc=l}, e) ->
               (exp_lifter !loc this) # lift_Parsetree_pattern (get_pat l e)
           | Pexp_extension({txt="str";_}, PStr e) ->
               (exp_lifter !loc this) # lift_Parsetree_structure e
           | Pexp_extension({txt="stri";_}, PStr [e]) ->
               (exp_lifter !loc this) # lift_Parsetree_structure_item e
           | Pexp_extension({txt="sig";_}, PSig e) ->
               (exp_lifter !loc this) # lift_Parsetree_signature e
           | Pexp_extension({txt="sigi";_}, PSig [e]) ->
               (exp_lifter !loc this) # lift_Parsetree_signature_item e
           | Pexp_extension({txt="type";loc=l}, e) ->
               (exp_lifter !loc this) # lift_Parsetree_core_type (get_typ l e)
           | _ ->
               super.expr this e
        )
    and pat this p =
      with_loc ~attrs:p.ppat_attributes
        (fun () ->
           match p.ppat_desc with
           | Ppat_extension({txt="expr";loc=l}, e) ->
               (pat_lifter this) # lift_Parsetree_expression (get_exp l e)
           | Ppat_extension({txt="pat";loc=l}, e) ->
               (pat_lifter this) # lift_Parsetree_pattern (get_pat l e)
           | Ppat_extension({txt="str";_}, PStr e) ->
               (pat_lifter this) # lift_Parsetree_structure e
           | Ppat_extension({txt="stri";_}, PStr [e]) ->
               (pat_lifter this) # lift_Parsetree_structure_item e
           | Ppat_extension({txt="sig";_}, PSig e) ->
               (pat_lifter this) # lift_Parsetree_signature e
           | Ppat_extension({txt="sigi";_}, PSig [e]) ->
               (pat_lifter this) # lift_Parsetree_signature_item e
           | Ppat_extension({txt="type";loc=l}, e) ->
               (pat_lifter this) # lift_Parsetree_core_type (get_typ l e)
           | _ ->
               super.pat this p
        )
    and structure this l =
      with_loc
        (fun () -> super.structure this l)

    and structure_item this x =
      begin match x.pstr_desc with
      | Pstr_attribute x -> handle_attr x
      | _ -> ()
      end;
      super.structure_item this x

    and signature this l =
      with_loc
        (fun () -> super.signature this l)

    and signature_item this x =
      begin match x.psig_desc with
      | Psig_attribute x -> handle_attr x
      | _ -> ()
      end;
      super.signature_item this x

    in
    {super with expr; pat; structure; structure_item; signature; signature_item}

  let () = Ast_mapper.run_main expander
end