File: ast_mapper_class.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 (652 lines) | stat: -rw-r--r-- 26,905 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
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
(*  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                      *)

(** Class-based customizable mapper *)

open Parsetree
open Asttypes
open Ast_helper

let map_fst f (x, y) = (f x, y)
let map_snd f (x, y) = (x, f y)
let map_tuple f1 f2 (x, y) = (f1 x, f2 y)
let map_tuple3 f1 f2 f3 (x, y, z) = (f1 x, f2 y, f3 z)
let map_opt f = function None -> None | Some x -> Some (f x)

let map_loc sub {loc; txt} = {loc = sub # location loc; txt}

module T = struct
  (* Type expressions for the core language *)

  let row_field_desc sub = function
    | Rtag (l, b, tl) -> Rtag (l, b, List.map (sub # typ) tl)
    | Rinherit t -> Rinherit (sub # typ t)

  let row_field sub {prf_desc = desc; prf_loc = loc; prf_attributes = attrs} =
    let desc = row_field_desc sub desc in
    let loc = sub # location loc in
    let attrs = sub # attributes attrs in
    {prf_desc = desc; prf_loc = loc; prf_attributes = attrs}

  let object_field_desc sub = function
    | Otag (s, t) -> Otag (s, sub # typ t)
    | Oinherit t -> Oinherit (sub # typ t)

  let object_field sub {pof_desc = desc; pof_loc = loc; pof_attributes = attrs} =
    let desc = object_field_desc sub desc in
    let loc = sub # location loc in
    let attrs = sub # attributes attrs in
    {pof_desc = desc; pof_loc = loc; pof_attributes = attrs}

  let map sub {ptyp_desc = desc; ptyp_loc = loc; ptyp_loc_stack = _; ptyp_attributes = attrs} =
    let open Typ in
    let loc = sub # location loc in
    let attrs = sub # attributes attrs in
    match desc with
    | Ptyp_any -> any ~loc ~attrs ()
    | Ptyp_var s -> var ~loc ~attrs s
    | Ptyp_arrow (lab, t1, t2) ->
        arrow ~loc ~attrs lab (sub # typ t1) (sub # typ t2)
    | Ptyp_tuple tyl -> tuple ~loc ~attrs (List.map (sub # typ) tyl)
    | Ptyp_constr (lid, tl) ->
        constr ~loc ~attrs (map_loc sub lid) (List.map (sub # typ) tl)
    | Ptyp_object (l, o) ->
        object_ ~loc ~attrs (List.map (object_field sub) l) o
    | Ptyp_class (lid, tl) ->
        class_ ~loc ~attrs (map_loc sub lid) (List.map (sub # typ) tl)
    | Ptyp_alias (t, s) -> alias ~loc ~attrs (sub # typ t) s
    | Ptyp_variant (rl, b, ll) ->
        variant ~loc ~attrs (List.map (row_field sub) rl) b ll
    | Ptyp_poly (sl, t) -> poly ~loc ~attrs sl (sub # typ t)
    | Ptyp_package (lid, l) ->
        package ~loc ~attrs (map_loc sub lid)
          (List.map (map_tuple (map_loc sub) (sub # typ)) l)
    | Ptyp_extension x -> extension ~loc ~attrs (sub # extension x)

  let map_type_declaration sub
      {ptype_name; ptype_params; ptype_cstrs;
       ptype_kind;
       ptype_private;
       ptype_manifest;
       ptype_attributes;
       ptype_loc} =
    Type.mk (map_loc sub ptype_name)
      ~params:(List.map (map_fst (sub # typ)) ptype_params)
      ~priv:ptype_private
      ~cstrs:(List.map (map_tuple3 (sub # typ) (sub # typ) (sub # location))
                ptype_cstrs)
      ~kind:(sub # type_kind ptype_kind)
      ?manifest:(map_opt (sub # typ) ptype_manifest)
      ~loc:(sub # location ptype_loc)
      ~attrs:(sub # attributes ptype_attributes)

  let map_type_kind sub = function
    | Ptype_abstract -> Ptype_abstract
    | Ptype_variant l ->
        Ptype_variant (List.map (sub # constructor_declaration) l)
    | Ptype_record l -> Ptype_record (List.map (sub # label_declaration) l)
    | Ptype_open -> Ptype_open

  let map_type_extension sub
      {ptyext_path; ptyext_params;
       ptyext_constructors;
       ptyext_private;
       ptyext_loc;
       ptyext_attributes} =
    Te.mk
      (map_loc sub ptyext_path)
      (List.map (sub # extension_constructor) ptyext_constructors)
      ~params:(List.map (map_fst (sub # typ)) ptyext_params)
      ~priv:ptyext_private
      ~loc:(sub # location ptyext_loc)
      ~attrs:(sub # attributes ptyext_attributes)

  let map_extension_constructor_kind sub = function
      Pext_decl(ctl, cto) ->
        Pext_decl(sub # constructor_arguments ctl, map_opt (sub # typ) cto)
    | Pext_rebind li ->
        Pext_rebind (map_loc sub li)

  let map_extension_constructor sub
      {pext_name;
       pext_kind;
       pext_loc;
       pext_attributes} =
    Te.constructor
      (map_loc sub pext_name)
      (map_extension_constructor_kind sub pext_kind)
      ~loc:(sub # location pext_loc)
      ~attrs:(sub # attributes pext_attributes)

  let map_type_exception sub {ptyexn_constructor; ptyexn_loc; ptyexn_attributes} =
    Te.mk_exception
        (map_extension_constructor sub ptyexn_constructor)
        ~loc:(sub # location ptyexn_loc)
        ~attrs:(sub # attributes ptyexn_attributes)

end

module CT = struct
  (* Type expressions for the class language *)

  let map sub {pcty_loc = loc; pcty_desc = desc; pcty_attributes = attrs} =
    let open Cty in
    let loc = sub # location loc in
    match desc with
    | Pcty_constr (lid, tys) ->
        constr ~loc ~attrs (map_loc sub lid) (List.map (sub # typ) tys)
    | Pcty_signature x -> signature ~loc ~attrs (sub # class_signature x)
    | Pcty_arrow (lab, t, ct) ->
        arrow ~loc ~attrs lab (sub # typ t) (sub # class_type ct)
    | Pcty_extension x -> extension ~loc ~attrs (sub # extension x)
    | Pcty_open (od, ct) ->
        open_ ~loc ~attrs (sub # open_description od) (sub # class_type ct)

  let map_field sub {pctf_desc = desc; pctf_loc = loc; pctf_attributes = attrs}
    =
    let open Ctf in
    let loc = sub # location loc in
    match desc with
    | Pctf_inherit ct -> inherit_ ~loc ~attrs (sub # class_type ct)
    | Pctf_val (s, m, v, t) -> val_ ~loc ~attrs s m v (sub # typ t)
    | Pctf_method (s, p, v, t) -> method_ ~loc ~attrs s p v (sub # typ t)
    | Pctf_constraint (t1, t2) ->
        constraint_ ~loc ~attrs (sub # typ t1) (sub # typ t2)
    | Pctf_attribute x -> attribute ~loc (sub # attribute x)
    | Pctf_extension x -> extension ~loc ~attrs (sub # extension x)

  let map_signature sub {pcsig_self; pcsig_fields} =
    Csig.mk
      (sub # typ pcsig_self)
      (List.map (sub # class_type_field) pcsig_fields)
end

module MT = struct
  (* Type expressions for the module language *)

  let map sub {pmty_desc = desc; pmty_loc = loc; pmty_attributes = attrs} =
    let open Mty in
    let loc = sub # location loc in
    let attrs = sub # attributes attrs in
    match desc with
    | Pmty_ident s -> ident ~loc ~attrs (map_loc sub s)
    | Pmty_alias s -> alias ~loc ~attrs (map_loc sub s)
    | Pmty_signature sg -> signature ~loc ~attrs (sub # signature sg)
    | Pmty_functor (s, mt1, mt2) ->
        functor_ ~loc ~attrs (map_loc sub s)
          (map_opt (sub # module_type) mt1)
          (sub # module_type mt2)
    | Pmty_with (mt, l) ->
        with_ ~loc ~attrs (sub # module_type mt)
          (List.map (sub # with_constraint) l)
    | Pmty_typeof me -> typeof_ ~loc ~attrs (sub # module_expr me)
    | Pmty_extension x -> extension ~loc ~attrs (sub # extension x)

  let map_with_constraint sub = function
    | Pwith_type (lid, d) ->
        Pwith_type (map_loc sub lid, sub # type_declaration d)
    | Pwith_module (lid, lid2) ->
        Pwith_module (map_loc sub lid, map_loc sub lid2)
    | Pwith_typesubst (lid, d) ->
        Pwith_typesubst (map_loc sub lid, sub # type_declaration d)
    | Pwith_modsubst (lid, lid2) ->
        Pwith_modsubst (map_loc sub lid, map_loc sub lid2)

  let map_signature_item sub {psig_desc = desc; psig_loc = loc} =
    let open Sig in
    let loc = sub # location loc in
    match desc with
    | Psig_value vd -> value ~loc (sub # value_description vd)
    | Psig_type (rf, l) -> type_ ~loc rf (List.map (sub # type_declaration) l)
    | Psig_typesubst l -> type_subst ~loc (List.map (sub # type_declaration) l)
    | Psig_typext te -> type_extension ~loc (sub # type_extension te)
    | Psig_exception texn -> exception_ ~loc (sub # type_exception texn)
    | Psig_module x -> module_ ~loc (sub # module_declaration x)
    | Psig_modsubst ms -> mod_subst ~loc (sub # module_substitution ms)
    | Psig_recmodule l ->
        rec_module ~loc (List.map (sub # module_declaration) l)
    | Psig_modtype x -> modtype ~loc (sub # module_type_declaration x)
    | Psig_open od -> open_ ~loc (sub # open_description od)
    | Psig_include x -> include_ ~loc (sub # include_description x)
    | Psig_class l -> class_ ~loc (List.map (sub # class_description) l)
    | Psig_class_type l ->
        class_type ~loc (List.map (sub # class_type_declaration) l)
    | Psig_extension (x, attrs) ->
        extension ~loc (sub # extension x) ~attrs:(sub # attributes attrs)
    | Psig_attribute x -> attribute ~loc (sub # attribute x)
end

module M = struct
  (* Value expressions for the module language *)

  let map sub {pmod_loc = loc; pmod_desc = desc; pmod_attributes = attrs} =
    let open Mod in
    let loc = sub # location loc in
    let attrs = sub # attributes attrs in
    match desc with
    | Pmod_ident x -> ident ~loc ~attrs (map_loc sub x)
    | Pmod_structure str -> structure ~loc ~attrs (sub # structure str)
    | Pmod_functor (arg, arg_ty, body) ->
        functor_ ~loc ~attrs (map_loc sub arg)
          (map_opt (sub # module_type) arg_ty)
          (sub # module_expr body)
    | Pmod_apply (m1, m2) ->
        apply ~loc ~attrs (sub # module_expr m1) (sub # module_expr m2)
    | Pmod_constraint (m, mty) ->
        constraint_ ~loc ~attrs (sub # module_expr m) (sub # module_type mty)
    | Pmod_unpack e -> unpack ~loc ~attrs (sub # expr e)
    | Pmod_extension x -> extension ~loc ~attrs (sub # extension x)

  let map_structure_item sub {pstr_loc = loc; pstr_desc = desc} =
    let open Str in
    let loc = sub # location loc in
    match desc with
    | Pstr_eval (x, attrs) ->
        eval ~loc ~attrs:(sub # attributes attrs) (sub # expr x)
    | Pstr_value (r, vbs) -> value ~loc r (List.map (sub # value_binding) vbs)
    | Pstr_primitive vd -> primitive ~loc (sub # value_description vd)
    | Pstr_type (rf, l) -> type_ ~loc rf (List.map (sub # type_declaration) l)
    | Pstr_typext te -> type_extension ~loc (sub # type_extension te)
    | Pstr_exception ed -> exception_ ~loc (sub # type_exception ed)
    | Pstr_module x -> module_ ~loc (sub # module_binding x)
    | Pstr_recmodule l -> rec_module ~loc (List.map (sub # module_binding) l)
    | Pstr_modtype x -> modtype ~loc (sub # module_type_declaration x)
    | Pstr_open od -> open_ ~loc (sub # open_declaration od)
    | Pstr_class l -> class_ ~loc (List.map (sub # class_declaration) l)
    | Pstr_class_type l ->
        class_type ~loc (List.map (sub # class_type_declaration) l)
    | Pstr_include x -> include_ ~loc (sub # include_declaration x)
    | Pstr_extension (x, attrs) ->
        extension ~loc (sub # extension x) ~attrs:(sub # attributes attrs)
    | Pstr_attribute x -> attribute ~loc (sub # attribute x)
end

module E = struct
  (* Value expressions for the core language *)

  let map_binding_op sub {pbop_op = op; pbop_pat = pat; pbop_exp = exp; pbop_loc = loc} =
    let op = map_loc sub op in
    let pat = sub # pat pat in
    let exp = sub # expr exp in
    let loc = sub # location loc in
    {pbop_op = op; pbop_pat = pat; pbop_exp = exp; pbop_loc = loc}

  let map sub {pexp_loc = loc; pexp_loc_stack = _; pexp_desc = desc; pexp_attributes = attrs} =
    let open Exp in
    let loc = sub # location loc in
    let attrs = sub # attributes attrs in
    match desc with
    | Pexp_ident x -> ident ~loc ~attrs (map_loc sub x)
    | Pexp_constant x -> constant ~loc ~attrs x
    | Pexp_let (r, vbs, e) ->
        let_ ~loc ~attrs r (List.map (sub # value_binding) vbs) (sub # expr e)
    | Pexp_fun (lab, def, p, e) ->
        fun_ ~loc ~attrs lab (map_opt (sub # expr) def) (sub # pat p)
          (sub # expr e)
    | Pexp_function pel -> function_ ~loc ~attrs (sub # cases pel)
    | Pexp_apply (e, l) ->
        apply ~loc ~attrs (sub # expr e) (List.map (map_snd (sub # expr)) l)
    | Pexp_match (e, pel) -> match_ ~loc ~attrs (sub # expr e) (sub # cases pel)
    | Pexp_try (e, pel) -> try_ ~loc ~attrs (sub # expr e) (sub # cases pel)
    | Pexp_tuple el -> tuple ~loc ~attrs (List.map (sub # expr) el)
    | Pexp_construct (lid, arg) ->
        construct ~loc ~attrs (map_loc sub lid) (map_opt (sub # expr) arg)
    | Pexp_variant (lab, eo) ->
        variant ~loc ~attrs lab (map_opt (sub # expr) eo)
    | Pexp_record (l, eo) ->
        record ~loc ~attrs (List.map (map_tuple (map_loc sub) (sub # expr)) l)
          (map_opt (sub # expr) eo)
    | Pexp_field (e, lid) -> field ~loc ~attrs (sub # expr e) (map_loc sub lid)
    | Pexp_setfield (e1, lid, e2) ->
        setfield ~loc ~attrs (sub # expr e1) (map_loc sub lid) (sub # expr e2)
    | Pexp_array el -> array ~loc ~attrs (List.map (sub # expr) el)
    | Pexp_ifthenelse (e1, e2, e3) ->
        ifthenelse ~loc ~attrs (sub # expr e1) (sub # expr e2)
          (map_opt (sub # expr) e3)
    | Pexp_sequence (e1, e2) ->
        sequence ~loc ~attrs (sub # expr e1) (sub # expr e2)
    | Pexp_while (e1, e2) -> while_ ~loc ~attrs (sub # expr e1) (sub # expr e2)
    | Pexp_for (p, e1, e2, d, e3) ->
        for_ ~loc ~attrs (sub # pat p) (sub # expr e1) (sub # expr e2) d
          (sub # expr e3)
    | Pexp_coerce (e, t1, t2) ->
        coerce ~loc ~attrs (sub # expr e) (map_opt (sub # typ) t1)
          (sub # typ t2)
    | Pexp_constraint (e, t) ->
        constraint_ ~loc ~attrs (sub # expr e) (sub # typ t)
    | Pexp_send (e, s) -> send ~loc ~attrs (sub # expr e) s
    | Pexp_new lid -> new_ ~loc ~attrs (map_loc sub lid)
    | Pexp_setinstvar (s, e) ->
        setinstvar ~loc ~attrs (map_loc sub s) (sub # expr e)
    | Pexp_override sel ->
        override ~loc ~attrs
          (List.map (map_tuple (map_loc sub) (sub # expr)) sel)
    | Pexp_letmodule (s, me, e) ->
        letmodule ~loc ~attrs (map_loc sub s) (sub # module_expr me)
          (sub # expr e)
    | Pexp_letexception (cd, e) ->
        letexception ~loc ~attrs
          (sub # extension_constructor cd)
          (sub # expr e)
    | Pexp_assert e -> assert_ ~loc ~attrs (sub # expr e)
    | Pexp_lazy e -> lazy_ ~loc ~attrs (sub # expr e)
    | Pexp_poly (e, t) ->
        poly ~loc ~attrs (sub # expr e) (map_opt (sub # typ) t)
    | Pexp_object cls -> object_ ~loc ~attrs (sub # class_structure cls)
    | Pexp_newtype (s, e) -> newtype ~loc ~attrs s (sub # expr e)
    | Pexp_pack me -> pack ~loc ~attrs (sub # module_expr me)
    | Pexp_open (od, e) ->
        open_ ~loc ~attrs (sub # open_declaration od) (sub # expr e)
    | Pexp_letop x ->
        let let_ = map_binding_op sub x.let_ in
        let ands = List.map (map_binding_op sub) x.ands in
        let body = sub # expr x.body in
        letop ~loc ~attrs let_ ands body
    | Pexp_extension x -> extension ~loc ~attrs (sub # extension x)
    | Pexp_unreachable -> unreachable ~loc ~attrs ()
end

module P = struct
  (* Patterns *)

  let map sub {ppat_desc = desc; ppat_loc = loc; ppat_loc_stack = _; ppat_attributes = attrs} =
    let open Pat in
    let loc = sub # location loc in
    let attrs = sub # attributes attrs in
    match desc with
    | Ppat_any -> any ~loc ~attrs ()
    | Ppat_var s -> var ~loc ~attrs (map_loc sub s)
    | Ppat_alias (p, s) -> alias ~loc ~attrs (sub # pat p) (map_loc sub s)
    | Ppat_constant c -> constant ~loc ~attrs c
    | Ppat_interval (c1, c2) -> interval ~loc ~attrs c1 c2
    | Ppat_tuple pl -> tuple ~loc ~attrs (List.map (sub # pat) pl)
    | Ppat_construct (l, p) ->
        construct ~loc ~attrs (map_loc sub l) (map_opt (sub # pat) p)
    | Ppat_variant (l, p) -> variant ~loc ~attrs l (map_opt (sub # pat) p)
    | Ppat_record (lpl, cf) ->
        record ~loc ~attrs (List.map (map_tuple (map_loc sub) (sub # pat)) lpl)
          cf
    | Ppat_array pl -> array ~loc ~attrs (List.map (sub # pat) pl)
    | Ppat_or (p1, p2) -> or_ ~loc ~attrs (sub # pat p1) (sub # pat p2)
    | Ppat_constraint (p, t) ->
        constraint_ ~loc ~attrs (sub # pat p) (sub # typ t)
    | Ppat_type s -> type_ ~loc ~attrs (map_loc sub s)
    | Ppat_lazy p -> lazy_ ~loc ~attrs (sub # pat p)
    | Ppat_unpack s -> unpack ~loc ~attrs (map_loc sub s)
    | Ppat_exception p -> exception_ ~loc ~attrs (sub # pat p)
    | Ppat_extension x -> extension ~loc ~attrs (sub # extension x)
    | Ppat_open (l, p) -> open_ ~loc ~attrs (map_loc sub l) (sub # pat p)
end

module CE = struct
  (* Value expressions for the class language *)

  let map sub {pcl_loc = loc; pcl_desc = desc; pcl_attributes = attrs} =
    let open Cl in
    let loc = sub # location loc in
    match desc with
    | Pcl_constr (lid, tys) ->
        constr ~loc ~attrs (map_loc sub lid) (List.map (sub # typ) tys)
    | Pcl_structure s ->
        structure ~loc ~attrs (sub # class_structure s)
    | Pcl_fun (lab, e, p, ce) ->
        fun_ ~loc ~attrs lab
          (map_opt (sub # expr) e)
          (sub # pat p)
          (sub # class_expr ce)
    | Pcl_apply (ce, l) ->
        apply ~loc ~attrs (sub # class_expr ce)
          (List.map (map_snd (sub # expr)) l)
    | Pcl_let (r, vbs, ce) ->
        let_ ~loc ~attrs r (List.map (sub # value_binding) vbs)
          (sub # class_expr ce)
    | Pcl_constraint (ce, ct) ->
        constraint_ ~loc ~attrs (sub # class_expr ce) (sub # class_type ct)
    | Pcl_extension x -> extension ~loc ~attrs (sub # extension x)
    | Pcl_open (od, ce) ->
        open_ ~loc ~attrs (sub # open_description od) (sub # class_expr ce)

  let map_kind sub = function
    | Cfk_concrete (o, e) -> Cfk_concrete (o, sub # expr e)
    | Cfk_virtual t -> Cfk_virtual (sub # typ t)

  let map_field sub {pcf_desc = desc; pcf_loc = loc; pcf_attributes = attrs} =
    let open Cf in
    let loc = sub # location loc in
    match desc with
    | Pcf_inherit (o, ce, s) -> inherit_ ~loc ~attrs o (sub # class_expr ce) s
    | Pcf_val (s, m, k) -> val_ ~loc ~attrs (map_loc sub s) m (map_kind sub k)
    | Pcf_method (s, p, k) ->
        method_ ~loc ~attrs (map_loc sub s) p (map_kind sub k)
    | Pcf_constraint (t1, t2) ->
        constraint_ ~loc ~attrs (sub # typ t1) (sub # typ t2)
    | Pcf_initializer e -> initializer_ ~loc ~attrs (sub # expr e)
    | Pcf_attribute x -> attribute ~loc (sub # attribute x)
    | Pcf_extension x -> extension ~loc ~attrs (sub # extension x)

  let map_structure sub {pcstr_self; pcstr_fields} =
    {
      pcstr_self = sub # pat pcstr_self;
      pcstr_fields = List.map (sub # class_field) pcstr_fields;
    }

  let class_infos sub f {pci_virt; pci_params = pl; pci_name; pci_expr;
                         pci_loc; pci_attributes} =
    Ci.mk
      ~virt:pci_virt
      ~params:(List.map (map_fst (sub # typ)) pl)
      (map_loc sub pci_name)
      (f pci_expr)
      ~loc:(sub # location pci_loc)
      ~attrs:(sub # attributes pci_attributes)
end

(* Now, a generic AST mapper class, to be extended to cover all kinds
   and cases of the OCaml grammar.  The default behavior of the mapper
   is the identity. *)

class mapper =
  object(this)
    method structure l = List.map (this # structure_item) l
    method structure_item si = M.map_structure_item this si
    method module_expr = M.map this

    method signature l = List.map (this # signature_item) l
    method signature_item si = MT.map_signature_item this si
    method module_type = MT.map this
    method with_constraint c = MT.map_with_constraint this c

    method class_declaration = CE.class_infos this (this # class_expr)
    method class_expr = CE.map this
    method class_field = CE.map_field this
    method class_structure = CE.map_structure this

    method class_type = CT.map this
    method class_type_field = CT.map_field this
    method class_signature = CT.map_signature this

    method class_type_declaration = CE.class_infos this (this # class_type)
    method class_description = CE.class_infos this (this # class_type)

    method binding_op = E.map_binding_op this

    method type_declaration = T.map_type_declaration this
    method type_kind = T.map_type_kind this
    method typ = T.map this

    method type_extension = T.map_type_extension this
    method type_exception = T.map_type_exception this
    method extension_constructor = T.map_extension_constructor this

    method value_description {pval_name; pval_type; pval_prim; pval_loc;
                              pval_attributes} =
      Val.mk
        (map_loc this pval_name)
        (this # typ pval_type)
        ~attrs:(this # attributes pval_attributes)
        ~loc:(this # location pval_loc)
        ~prim:pval_prim

    method pat = P.map this
    method expr = E.map this

    method module_declaration {pmd_name; pmd_type; pmd_attributes; pmd_loc} =
      Md.mk
        (map_loc this pmd_name)
        (this # module_type pmd_type)
        ~attrs:(this # attributes pmd_attributes)
        ~loc:(this # location pmd_loc)

    method module_substitution {pms_name; pms_manifest; pms_attributes; pms_loc} =
      Ms.mk
        (map_loc this pms_name)
        (map_loc this pms_manifest)
        ~attrs:(this # attributes pms_attributes)
        ~loc:(this # location pms_loc)

    method module_type_declaration {pmtd_name; pmtd_type; pmtd_attributes; pmtd_loc} =
      Mtd.mk
        (map_loc this pmtd_name)
        ?typ:(map_opt (this # module_type) pmtd_type)
        ~attrs:(this # attributes pmtd_attributes)
        ~loc:(this # location pmtd_loc)

    method module_binding {pmb_name; pmb_expr; pmb_attributes; pmb_loc} =
      Mb.mk (map_loc this pmb_name) (this # module_expr pmb_expr)
        ~attrs:(this # attributes pmb_attributes)
        ~loc:(this # location pmb_loc)

    method value_binding {pvb_pat; pvb_expr; pvb_attributes; pvb_loc} =
      Vb.mk
        (this # pat pvb_pat)
        (this # expr pvb_expr)
        ~attrs:(this # attributes pvb_attributes)
        ~loc:(this # location pvb_loc)

    method constructor_arguments = function
      | Pcstr_tuple (tys) -> Pcstr_tuple (List.map (this # typ) tys)
      | Pcstr_record (ls) -> Pcstr_record (List.map (this # label_declaration) ls)

    method constructor_declaration {pcd_name; pcd_args; pcd_res; pcd_loc;
                                    pcd_attributes} =
      Type.constructor
        (map_loc this pcd_name)
        ~args:(this # constructor_arguments pcd_args)
        ?res:(map_opt (this # typ) pcd_res)
        ~loc:(this # location pcd_loc)
        ~attrs:(this # attributes pcd_attributes)

    method label_declaration {pld_name; pld_type; pld_loc; pld_mutable;
                              pld_attributes} =
      Type.field
        (map_loc this pld_name)
        (this # typ pld_type)
        ~mut:pld_mutable
        ~loc:(this # location pld_loc)
        ~attrs:(this # attributes pld_attributes)


    method cases l = List.map (this # case) l
    method case {pc_lhs; pc_guard; pc_rhs} =
      {
        pc_lhs = this # pat pc_lhs;
        pc_guard = map_opt (this # expr) pc_guard;
        pc_rhs = this # expr pc_rhs;
      }

    method open_declaration
        {popen_expr; popen_override; popen_attributes; popen_loc} =
      Opn.mk (this # module_expr popen_expr)
        ~override:popen_override
        ~loc:(this # location popen_loc)
        ~attrs:(this # attributes popen_attributes)

    method open_description
        {popen_expr; popen_override; popen_attributes; popen_loc} =
      Opn.mk (map_loc this popen_expr)
        ~override:popen_override
        ~loc:(this # location popen_loc)
        ~attrs:(this # attributes popen_attributes)

    method include_description
        {pincl_mod; pincl_attributes; pincl_loc} =
      Incl.mk (this # module_type pincl_mod)
        ~loc:(this # location pincl_loc)
        ~attrs:(this # attributes pincl_attributes)

    method include_declaration
        {pincl_mod; pincl_attributes; pincl_loc} =
      Incl.mk (this # module_expr pincl_mod)
        ~loc:(this # location pincl_loc)
        ~attrs:(this # attributes pincl_attributes)

    method location l = l

    method extension (s, e) = (map_loc this s, this # payload e)

    method attribute a =
      {
        attr_name = map_loc this a.attr_name;
        attr_payload = this # payload a.attr_payload;
        attr_loc = this # location a.attr_loc;
      }

    method attributes l = List.map (this # attribute) l

    method payload = function
      | PStr x -> PStr (this # structure x)
      | PTyp x -> PTyp (this # typ x)
      | PPat (x, g) -> PPat (this # pat x, map_opt (this # expr) g)
      | PSig x -> PSig (this # signature x)
  end


let to_mapper this =
  let open Ast_mapper in
  {
    attribute = (fun _ -> this # attribute);
    attributes = (fun _ -> this # attributes);
    binding_op = (fun _ -> this # binding_op);
    case = (fun _ -> this # case);
    cases = (fun _ -> this # cases);
    class_declaration = (fun _ -> this # class_declaration);
    class_description = (fun _ -> this # class_description);
    class_expr = (fun _ -> this # class_expr);
    class_field = (fun _ -> this # class_field);
    class_signature = (fun _ -> this # class_signature);
    class_structure = (fun _ -> this # class_structure);
    class_type = (fun _ -> this # class_type);
    class_type_declaration = (fun _ -> this # class_type_declaration);
    class_type_field = (fun _ -> this # class_type_field);
    constructor_declaration = (fun _ -> this # constructor_declaration);
    expr = (fun _ -> this # expr);
    extension = (fun _ -> this # extension);
    extension_constructor = (fun _ -> this # extension_constructor);
    include_declaration = (fun _ -> this # include_declaration);
    include_description = (fun _ -> this # include_description);
    label_declaration = (fun _ -> this # label_declaration);
    location = (fun _ -> this # location);
    module_binding = (fun _ -> this # module_binding);
    module_declaration = (fun _ -> this # module_declaration);
    module_expr = (fun _ -> this # module_expr);
    module_substitution = (fun _ -> this # module_substitution);
    module_type = (fun _ -> this # module_type);
    module_type_declaration = (fun _ -> this # module_type_declaration);
    open_declaration = (fun _ -> this # open_declaration);
    open_description = (fun _ -> this # open_description);
    pat = (fun _ -> this # pat);
    payload = (fun _ -> this # payload);
    signature = (fun _ -> this # signature);
    signature_item = (fun _ -> this # signature_item);
    structure = (fun _ -> this # structure);
    structure_item = (fun _ -> this # structure_item);
    typ = (fun _ -> this # typ);
    type_declaration = (fun _ -> this # type_declaration);
    type_exception = (fun _ -> this # type_exception);
    type_extension = (fun _ -> this # type_extension);
    type_kind = (fun _ -> this # type_kind);
    value_binding = (fun _ -> this # value_binding);
    value_description = (fun _ -> this # value_description);
    with_constraint = (fun _ -> this # with_constraint);
  }