pa_ovisitor / pa / pa_ovisitor.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
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
open Camlp4
open PreCast
open Pa_type_conv
open Ast

include Tctools

let _loc = Loc.ghost

(** A.x => A.visit_x *)
let rec visit_id = function
  | IdAcc (loc, a, b) -> IdAcc (loc, a, visit_id b)
  | IdLid (loc, s) -> IdLid (loc, "visit_" ^ s)
  | id -> id

let no_visit_idents = ref []

let is_no_visit_ident id = List.mem (strip_ident_loc id) !no_visit_idents

module StringSet = Set.Make(struct type t = string let compare (x : string) y = compare x y end)
module StringMap = Map.Make(struct type t = string let compare (x : string) y = compare x y end)

let group_names prefix decls =
  List.map (function 
    | TyDcl (_, name, _, _, _) -> prefix ^ name
    | _ -> assert false) decls

let make_classes ~virt params prefix decls the_clexpr =
  let names = group_names prefix decls in
  match names with
  | [] -> assert false
  | name :: names ->
      make_class
        (make_class_eq ~virt params <:ident<$lid:name$>> the_clexpr
         :: List.map (fun n ->
           make_class_eq ~virt params <:ident<$lid:n$>>
             (CeCon (_loc, ViNil, <:ident<$lid:name$>>, tyCom_of_list params))) names
        )

module Visitor = struct

  let used = ref StringMap.empty
  let defined = ref StringSet.empty
  let reset_sets () = used := StringMap.empty; defined := StringSet.empty


  let rec gen_ctyp : ctyp -> expr option = function
    | TyId (_loc, id) 
    | TyApp (_loc, TyId(_, id), _) when is_no_visit_ident id -> None
    | TyId (loc, id) -> 
        if not (StringMap.mem (label_of_path id) !used) then
          used := StringMap.add (label_of_path id) 0 !used;
        Some <:expr@loc< self # $label_of_path id$ >>
    | (TyQuo (_loc, _) as tv) -> Some (expr_of_tvar tv)
    | TyApp (loc, (TyId(_, id) as f), args) ->  (* (int, float) Hashtbl.t *)
        let args = list_of_ctyp args [] in
        used := StringMap.add (label_of_path id) (List.length args) !used;
        begin match gen_ctyp f with
        | None -> None
        | Some f -> 
            Some (Gen.apply loc f (List.map (fun x -> match gen_ctyp x with 
            | None -> <:expr<fun _ -> ()>> 
            | Some f -> f ) args))
        end
    | TyApp (loc, TyApp (_loc, f, args1), args2) -> 
        gen_ctyp (TyApp (loc, f, TyCom(_loc, args1, args2)))
    | TyTup (loc, ctyp) ->
        let ctyps = list_of_ctyp ctyp [] in
        let ids = mk_idents "__x" (List.length ctyps) in
        Some (Gen.abstract loc [ PaTup (loc, paCom_of_list (List.map patt_of_id ids)) ]
          (gen_let_seq ctyps (List.map expr_of_id ids)))
    | _ -> assert false
  
  and gen_let_seq ctyps exps = match ctyps, exps with
    | [], [] -> <:expr< () >>
    | (ctyp::ctyps), (exp::exps) ->
        begin match gen_ctyp ctyp with
        | None -> gen_let_seq ctyps exps
        | Some f -> <:expr< $f$ $exp$ ; $ gen_let_seq ctyps exps $ >>
        end
    | _ -> assert false
  
  let alias _name _loc cty = 
    match gen_ctyp cty with
    | None -> <:expr< >>
    | Some f -> <:expr< fun __value -> $f$ __value >>
  
  let is_just_unit_case = function
    | <:match_case< $_$ -> () >> -> true
    | _ -> false
  
  let sum _name _loc ctyp = 
    let constrs = list_of_ctyp ctyp [] in (* decompose TyOr *)
    let case locOf locId id ctyp =
      let ctyps = list_of_ctyp ctyp [] in (* decompose TyAnd *)
      let ids = mk_idents "__x" (List.length ctyps) in
      let patt = create_patt_app (PaId(locId, id)) (List.map patt_of_id ids) in
      let exp = match ids with
        | [] -> <:expr< () >>
        | _ -> gen_let_seq ctyps (List.map expr_of_id ids)
      in
      <:match_case@locOf< $ patt $ -> $ exp $ >>
    in
    let cases = 
      List.map (function
        | TyOf (locOf, TyId(locId, id), ctyp) -> case locOf locId id ctyp
        | TyId (locId, id) -> case locId locId id (TyNil _loc)
        | _ -> assert false
      ) constrs 
    in
    if List.for_all is_just_unit_case cases then
      <:expr< fun __value -> () >>
    else
      <:expr< fun __value -> match __value with $mcOr_of_list cases$ >>
  
  let record _name _loc ctyp = 
    let get_lab cty = match strip_field_flags cty with
      | TyId(_, id) -> id
      | _ -> assert false
    in
    let ctyps = list_of_ctyp ctyp [] in (* decomp TySems *)
    let labs, ctyps = List.split (List.map (function
      | TyCol (_, l, ctyp) -> get_lab l, strip_field_flags ctyp
      | _ -> assert false) ctyps)
    in
    let mems = List.map (fun l -> <:expr< __value.$id:l$ >> ) labs in 
    <:expr< fun __value -> $gen_let_seq ctyps mems $ >>
    
  (** for [X; Y; .. ] and BASE, build (X -> unit) -> (Y -> unit) -> ... -> BASE *)
  let dispatch_type params base = 
    List.fold_right (fun ctyp st -> <:ctyp< ($ctyp$ -> unit) -> $st$ >>) params base
  
  let method_type params name = 
    create_for_all params (dispatch_type params <:ctyp< $ create_param_type params name $ -> unit >>)
  
  
  (******************* kind of template *)
  
  let def name cty =
    let variants _ = assert false in
    let mani     _ = assert false in
    let nil      _ = assert false in
    let alias  = alias name in
    let sum    = sum name in
    let record = record name in
    Gen.switch_tp_def ~alias ~sum ~record ~variants ~mani ~nil cty
  
  
  let dcl _loc name (params : ctyp list) d =
    if is_no_visit_ident (IdLid (Loc.ghost, name)) then <:class_str_item<>>
    else begin
      defined := StringSet.add name !defined;
      <:class_str_item<
         method $name$ : $method_type params name$ = $Gen.abstract _loc (List.map patt_of_tvar params) (def name d)$
      >>
    end
  
  (* Add "of_sexp" and "sexp_of" as "sexp" to the set of generators *)
  let () = 
    Pa_type_conv.add_generator "ovisit" (fun _bool tds ->
      reset_sets ();
      let _loc = Ast.loc_of_ctyp tds in
      let decls = list_of_ctyp tds [] in (* CR jfuruse: mutual *)
      let methods = List.map (function
        | TyDcl (loc, name, params, def, _constraints) -> 
            dcl loc name params def
        | _ -> assert false) decls
      in
      let vmethods = 
        let vmethods = StringSet.fold StringMap.remove !defined !used in
        if StringMap.is_empty vmethods then [] 
        else 
          StringMap.fold (fun name nargs st ->
            let params = 
              let ns = 1--nargs in
              List.map (fun n -> TyQuo (_loc, "a" ^ string_of_int n)) ns
            in
            <:class_str_item< method virtual $name$ : $method_type params name$ >> :: st) vmethods []
      in
      let methods = concat_class_str_items (vmethods @ methods) in

      no_visit_idents := [];

      (* We use the name of the first type for the class name prefix *)
      make_classes ~virt:(vmethods <> []) []
        "ovisit_" decls 
        <:class_expr<object (self) $methods$ end>>
    )
  ;;
end


module Fold = struct

  let used = ref StringMap.empty
  let defined = ref StringSet.empty
  let reset_sets () = used := StringMap.empty; defined := StringSet.empty


  let rec gen_ctyp : ctyp -> expr option = function
    | TyId (_loc, id) 
    | TyApp (_loc, TyId(_, id), _) when is_no_visit_ident id -> None
    | TyId (loc, id) -> 
        if not (StringMap.mem (label_of_path id) !used) then
          used := StringMap.add (label_of_path id) 0 !used;
        Some <:expr@loc< self # $label_of_path id$ >>
    | (TyQuo (_loc, _) as tv) -> Some (expr_of_tvar tv)
    | TyApp (loc, (TyId(_, id) as f), args) ->  (* (int, float) Hashtbl.t *)
        let args = list_of_ctyp args [] in
        used := StringMap.add (label_of_path id) (List.length args) !used;
        begin match gen_ctyp f with
        | None -> None
        | Some f -> 
            Some (Gen.apply loc f (List.map (fun x -> match gen_ctyp x with 
            | None -> <:expr<fun __st _ -> __st>> 
            | Some f -> f ) args))
        end
    | TyApp (loc, TyApp (_loc, f, args1), args2) -> 
        gen_ctyp (TyApp (loc, f, TyCom(_loc, args1, args2)))
    | TyTup (loc, ctyp) ->
        let ctyps = list_of_ctyp ctyp [] in
        let ids = mk_idents "__tup" (List.length ctyps) in
        Some (<:expr<fun __st -> 
          $ Gen.abstract loc [ PaTup (loc, paCom_of_list (List.map patt_of_id ids)) ]
            (gen_let_seq ctyps (List.map expr_of_id ids)) $ >> )
    | _ -> assert false
  
  and gen_let_seq ctyps exps = match ctyps, exps with
    | [], [] -> <:expr< __st >>
    | (ctyp::ctyps), (exp::exps) ->
        begin match gen_ctyp ctyp with
        | None -> gen_let_seq ctyps exps
        | Some f -> <:expr< let __st = $f$ __st $exp$ in $ gen_let_seq ctyps exps $ >>
        end
    | _ -> assert false
  
  let alias _name _loc cty = 
    match gen_ctyp cty with
    | None -> assert false
    | Some f -> f
  
  let is_just_self_case = function
    | <:match_case< $_$ -> __st >> -> true
    | _ -> false
  
  let sum _name _loc ctyp = 
    let constrs = list_of_ctyp ctyp [] in (* decompose TyOr *)
    let case locOf locId id ctyp =
      let ctyps = list_of_ctyp ctyp [] in (* decompose TyAnd *)
      let ids = mk_idents "__x" (List.length ctyps) in
      let patt = create_patt_app (PaId(locId, id)) (List.map patt_of_id ids) in
      let exp = match ids with
        | [] -> <:expr< __st >>
        | _ -> gen_let_seq ctyps (List.map expr_of_id ids)
      in
      <:match_case@locOf< $ patt $ -> $ exp $ >>
    in
    let cases = 
      List.map (function
        | TyOf (locOf, TyId(locId, id), ctyp) -> case locOf locId id ctyp
        | TyId (locId, id) -> case locId locId id (TyNil _loc)
        | _ -> assert false
      ) constrs 
    in
    if List.for_all is_just_self_case cases then
      <:expr< fun __st __value -> __st >>
    else
      <:expr< fun __st __value -> match __value with $mcOr_of_list cases$ >>
  
  let record _name _loc ctyp = 
    let get_lab cty = match strip_field_flags cty with
      | TyId(_, id) -> id
      | _ -> assert false
    in
    let ctyps = list_of_ctyp ctyp [] in (* decomp TySems *)
    let labs, ctyps = List.split (List.map (function
      | TyCol (_, l, ctyp) -> get_lab l, strip_field_flags ctyp
      | _ -> assert false) ctyps)
    in
    let mems = List.map (fun l -> <:expr< __value.$id:l$ >> ) labs in 
    <:expr< fun __st __value -> $gen_let_seq ctyps mems $ >>
    
  (** for [X; Y; .. ] and BASE, build ('st -> X -> 'st) -> ('st -> Y -> 'st) -> ... -> BASE *)
  let dispatch_type params base = 
    List.fold_right (fun ctyp st -> <:ctyp< ('st -> $ctyp$ -> 'st) -> $st$ >>) params base
  
  let method_type params name = 
    create_for_all params (dispatch_type params <:ctyp< 'st -> $ create_param_type params name $ -> 'st >>)
  
  
  (******************* kind of template *)
  
  let rec def name cty =
    let variants _ = assert false in
    let mani     _loc _ctyp k = def name k in
    let nil      _ = assert false in
    let alias  = alias name in
    let sum    = sum name in
    let record = record name in
    Gen.switch_tp_def ~alias ~sum ~record ~variants ~mani ~nil cty
  
  
  let dcl _loc name (params : ctyp list) d =
    if is_no_visit_ident (IdLid (Loc.ghost, name)) then <:class_str_item<>>
    else begin
      defined := StringSet.add name !defined;
      <:class_str_item<
         method $name$ : $method_type params name$ 
           = $Gen.abstract _loc (List.map patt_of_tvar params) (def name d)$
      >>
    end
  
  (* Add "of_sexp" and "sexp_of" as "sexp" to the set of generators *)
  let () = 
    Pa_type_conv.add_generator "ofold" (fun _bool tds ->
      reset_sets ();
      let _loc = Ast.loc_of_ctyp tds in
      let decls = list_of_ctyp tds [] in (* CR jfuruse: mutual *)
      let methods = List.map (function
        | TyDcl (loc, name, params, def, _constraints) -> 
            dcl loc name params def
        | _ -> assert false) decls
      in
      let vmethods = 
        let vmethods = StringSet.fold StringMap.remove !defined !used in
        if StringMap.is_empty vmethods then [] 
        else 
          StringMap.fold (fun name nargs st ->
            let params = 
              let ns = 1--nargs in
              List.map (fun n -> TyQuo (_loc, "a" ^ string_of_int n)) ns
            in
            <:class_str_item< method virtual $name$ : $method_type params name$ >> :: st) vmethods []
      in
      let methods = concat_class_str_items (vmethods @ methods) in

      no_visit_idents := [];

      (* We use the name of the first type for the class name prefix *)
      make_classes ~virt:(vmethods <> []) [ <:ctyp<'st>> ]
        "ofold_" decls 
        <:class_expr<object (self) $methods$ end>>
    )
  ;;
end


module Map = struct

  let used = ref StringMap.empty
  let defined = ref StringSet.empty
  let reset_sets () = used := StringMap.empty; defined := StringSet.empty

  let rec gen_ctyp : ctyp -> expr option = function
    | TyId (_loc, id) 
    | TyApp (_loc, TyId(_, id), _) when is_no_visit_ident id -> None
    | TyId (loc, id) -> 
        if not (StringMap.mem (label_of_path id) !used) then
          used := StringMap.add (label_of_path id) 0 !used;
        Some <:expr@loc< self # $label_of_path id$ >>
    | (TyQuo (loc, _) as tv) -> Some <:expr@loc< $ expr_of_tvar tv $ self >>
    | TyApp (loc, (TyId(_, id) as f), args) ->  (* (int, float) Hashtbl.t *)
        let args = list_of_ctyp args [] in
        used := StringMap.add (label_of_path id) (List.length args) !used;
        begin match gen_ctyp f with
        | None -> None
        | Some f -> 
            Some (Gen.apply loc f (List.map (fun x -> match gen_ctyp x with 
            | None -> <:expr<fun __st v -> __st, v >> 
            | Some f -> f ) args))
        end
    | TyApp (loc, TyApp (_loc, f, args1), args2) -> 
        gen_ctyp (TyApp (loc, f, TyCom(_loc, args1, args2)))
    | TyTup (loc, ctyp) ->
        let ctyps = list_of_ctyp ctyp [] in
        let xs = mk_idents "__x" (List.length ctyps) in
        let ys = mk_idents "__y" (List.length ctyps) in
        let patt = <:patt< $ PaTup (loc, paCom_of_list (List.map patt_of_id xs)) $ as __value >> in
        
        let exp = 
          let final_modified = create_tuple (List.map expr_of_id ys) in 
          let modifiedp = 
            let preds = List.map2 (fun x y -> <:expr< $id:x$ == $id:y$ >>) xs ys in
            List.fold_right (fun p e -> <:expr< $p$ && $e$ >>) (List.tl preds) (List.hd preds)
          in
          let final = <:expr< if $modifiedp$ then __value else $ final_modified $ >> in
          let e, modified = gen_letx_seq ctyps (List.map expr_of_id xs) (List.map patt_of_id ys) <:expr< __st, $final$ >> in
          if modified then e else <:expr< __st, __value >>
        in
        Some (Gen.abstract loc [ patt ] exp)

    | _ -> assert false
  
  and gen_letx_seq ctyps exps pats final = match ctyps, exps, pats with
    | [], [], [] -> final, false
    | (ctyp::ctyps), (exp::exps), (pat::pats)->
        let e, modified = gen_letx_seq ctyps exps pats final in
        begin match gen_ctyp ctyp with
        | None -> 
            <:expr< let $pat$ = $exp$ in $ e $ >>, modified
        | Some f -> 
            <:expr< let __st, $pat$ = $f$ __st $exp$ in $ e $>>, true
        end
    | _ -> assert false
  
  let alias _name _loc cty = 
    match gen_ctyp cty with
    | None -> <:expr< >>
    | Some f -> f
  
  let is_just_self_case = function
    | <:match_case< $_$ -> __st, __value >> -> true
    | _ -> false
  
  let sum _name _loc ctyp = 
    let constrs = list_of_ctyp ctyp [] in (* decompose TyOr *)
    let case locOf locId id ctyp =
      let ctyps = list_of_ctyp ctyp [] in (* decompose TyAnd *)
      let xs = mk_idents "__x" (List.length ctyps) in
      let ys = mk_idents "__y" (List.length ctyps) in
      let patt = create_patt_app (PaId(locId, id)) (List.map patt_of_id xs) in
      let exp = match xs with
        | [] -> <:expr< __st, __value >>
        | _ -> 
            let final_modified = create_expr_app (ExId(locId, id)) (List.map expr_of_id ys) in
            let modifiedp = 
              let preds = List.map2 (fun x y -> <:expr< $id:x$ == $id:y$ >>) xs ys in
              List.fold_right (fun p e -> <:expr< $p$ && $e$ >>) (List.tl preds) (List.hd preds)
            in
            let final = <:expr< if $modifiedp$ then __value else $ final_modified $ >> in
            let e, modified = gen_letx_seq ctyps (List.map expr_of_id xs) (List.map patt_of_id ys) <:expr< __st, $final$ >> in
            if modified then e else <:expr< __st, __value >> 
      in
      <:match_case@locOf< $ patt $ -> $ exp $ >>
    in
    let cases = 
      List.map (function
        | TyOf (locOf, TyId(locId, id), ctyp) -> case locOf locId id ctyp
        | TyId (locId, id) -> case locId locId id (TyNil _loc)
        | _ -> assert false
      ) constrs 
    in
    if List.for_all is_just_self_case cases then
      <:expr< fun __st __value -> __st, __value >>
    else
      <:expr< fun __st __value -> match __value with $mcOr_of_list cases$ >>
  
  let record _name _loc ctyp = 
    let get_lab cty = match strip_field_flags cty with
      | TyId(_, id) -> id
      | _ -> assert false
    in
    let ctyps = list_of_ctyp ctyp [] in (* decomp TySems *)
    let labs, ctyps = List.split (List.map (function
      | TyCol (_, l, ctyp) -> get_lab l, strip_field_flags ctyp
      | _ -> assert false) ctyps)
    in
    let exp = 
      let final_modified = create_record (List.map (fun l -> l, <:expr< $id:l$ >>) labs)  in
      let modifiedp = 
        let preds = List.map (fun l -> <:expr< __value.$id:l$ == $id:l$ >>) labs in
        List.fold_right (fun p e -> <:expr< $p$ && $e$ >>) (List.tl preds) (List.hd preds)
      in
      let final = <:expr< if $modifiedp$ then __value else $ final_modified $ >> in
      <:expr< __st, $final$ >>
    in
    let e, modified = 
      gen_letx_seq ctyps (List.map (fun l -> <:expr< __value.$id:l$ >>) labs)
                          (List.map (fun l -> <:patt< $id:l$ >>) labs) exp 
    in
    <:expr< fun __st __value -> $ if modified then e else <:expr< __st, __value >> $ >>
    
  (** for [X; Y; .. ] and BASE, build ('st -> X -> 'st * X) -> ('st -> Y -> 'st * Y) -> ... -> BASE *)
  let dispatch_type params base = 
    List.fold_right (fun ctyp st -> <:ctyp< ('st -> $ctyp$ -> 'st * $ctyp$) -> $st$ >>) params base
  
  let method_type params name = 
    create_for_all params (dispatch_type params 
                      <:ctyp< 'st -> $ create_param_type params name $ 
                              -> 'st * $ create_param_type params name $ >>)
  
  
  (******************* kind of template *)
  
  let def name cty =
    let variants _ = assert false in
    let mani     _ = assert false in
    let nil      _ = assert false in
    let alias  = alias name in
    let sum    = sum name in
    let record = record name in
    Gen.switch_tp_def ~alias ~sum ~record ~variants ~mani ~nil cty
  
  
  let dcl _loc name (params : ctyp list) d =
    if is_no_visit_ident (IdLid (Loc.ghost, name)) then <:class_str_item<>>
    else begin
      defined := StringSet.add name !defined;
      <:class_str_item<
         method $name$ : $method_type params name$ = $Gen.abstract _loc (List.map patt_of_tvar params) (def name d)$
      >>
    end
  
  (* Add "of_sexp" and "sexp_of" as "sexp" to the set of generators *)
  let () = 
    Pa_type_conv.add_generator "omap" (fun _bool tds ->
      reset_sets ();
      let _loc = Ast.loc_of_ctyp tds in
      let decls = list_of_ctyp tds [] in (* CR jfuruse: mutual *)
      let methods = List.map (function
        | TyDcl (loc, name, params, def, _constraints) -> 
            dcl loc name params def
        | _ -> assert false) decls
      in
      let vmethods = 
        let vmethods = StringSet.fold StringMap.remove !defined !used in
        if StringMap.is_empty vmethods then [] 
        else 
          StringMap.fold (fun name nargs st ->
            let params = 
              let ns = 1--nargs in
              List.map (fun n -> TyQuo (_loc, "a" ^ string_of_int n)) ns
            in
            <:class_str_item< method virtual $name$ : $method_type params name$ >> :: st) vmethods []
      in
      let methods = concat_class_str_items (vmethods @ methods) in

      no_visit_idents := [];

      make_classes ~virt:(vmethods <> []) [ <:ctyp<'st>> ]
        "omap_" decls 
        <:class_expr<object (self) $methods$ end>>

    )


end



open Syntax

let comma_idents = Gram.Entry.mk "comma_idents"

EXTEND Gram
  GLOBAL: str_item sig_item comma_idents;

  str_item:
    [[
      "NO_VISIT"; "("; idents = comma_idents; ")" ->
        no_visit_idents := !no_visit_idents @ idents;
        <:str_item< >>
    ]];

  sig_item:
    [[
      "NO_VISIT"; "("; idents = comma_idents; ")"  ->
        no_visit_idents := !no_visit_idents @ idents;
        <:sig_item< >>
    ]];

  comma_idents:
    [ LEFTA
        [ ids1 = SELF; ","; ids2 = SELF -> ids1 @ ids2
        | id = ident -> [ strip_ident_loc id ]
        ]
    ];

END
Tip: Filter by directory path e.g. /media app.js to search for public/media/app.js.
Tip: Use camelCasing e.g. ProjME to search for ProjectModifiedEvent.java.
Tip: Filter by extension type e.g. /repo .js to search for all .js files in the /repo directory.
Tip: Separate your search with spaces e.g. /ssh pom.xml to search for src/ssh/pom.xml.
Tip: Use ↑ and ↓ arrow keys to navigate and return to view the file.
Tip: You can also navigate files with Ctrl+j (next) and Ctrl+k (previous) and view the file with Ctrl+o.
Tip: You can also navigate files with Alt+j (next) and Alt+k (previous) and view the file with Alt+o.