(* camlp4r *)
(****************************************************************************)
(* *)
(* OCaml *)
(* *)
(* INRIA Rocquencourt *)
(* *)
(* Copyright 2006-2007 Institut National de Recherche en Informatique et *)
(* en Automatique. All rights reserved. This file is distributed under *)
(* the terms of the GNU Library General Public License, with the special *)
(* exception on linking described in LICENSE at the top of the Camlp4 *)
(* source tree. *)
(* *)
(****************************************************************************)
(* Authors:
* - Nicolas Pouillard: initial version
*)
open Camlp4;
module Id = struct
value name = "Camlp4FoldGenerator";
value version = Sys.ocaml_version;
end;
module Make (AstFilters : Camlp4.Sig.AstFilters) = struct
open AstFilters;
module StringMap = Map.Make String;
open Ast;
value _loc = Loc.ghost;
value sf = Printf.sprintf;
value xik i k =
let i =
if i < 0 then assert False
else if i = 0 then ""
else sf "_i%d" i
in
let k =
if k < 1 then assert False
else if k = 1 then ""
else sf "_k%d" k
in
sf "_x%s%s" i k;
value exik i k = <:expr< $lid:xik i k$ >>;
value pxik i k = <:patt< $lid:xik i k$ >>;
value elidk y k = <:expr< $lid:sf "%s_%d" y k$ >>;
value plidk y k = <:patt< $lid:sf "%s_%d" y k$ >>;
value xs s = "_x_" ^ s;
value xsk = sf "_x_%s_%d";
value exsk s k = <:expr< $lid:xsk s k$>>;
value rec apply_expr accu =
fun
[ [] -> accu
| [x :: xs] ->
let _loc = Ast.loc_of_expr x
in apply_expr <:expr< $accu$ $x$ >> xs ];
value rec apply_patt accu =
fun
[ [] -> accu
| [x :: xs] ->
let _loc = Ast.loc_of_patt x
in apply_patt <:patt< $accu$ $x$ >> xs ];
value rec apply_ctyp accu =
fun
[ [] -> accu
| [x :: xs] ->
let _loc = Ast.loc_of_ctyp x
in apply_ctyp <:ctyp< $accu$ $x$ >> xs ];
value opt_map f = fun [ Some x -> Some (f x) | None -> None ];
value list_init f n =
let rec self m =
if m = n then []
else [f m :: self (succ m)]
in self 0;
value rec lid_of_ident sep =
fun
[ <:ident< $lid:s$ >> | <:ident< $uid:s$ >> -> s
| <:ident< $i1$.$i2$ >> -> lid_of_ident sep i1 ^ sep ^ lid_of_ident sep i2
| _ -> assert False ];
type type_decl = (string * Ast.ident * list Ast.ctyp * Ast.ctyp * bool);
value builtin_types =
let tyMap = StringMap.empty in
let tyMap =
let abstr = ["string"; "int"; "float"; "int32"; "int64"; "nativeint"; "char"] in
List.fold_right
(fun name -> StringMap.add name (name, <:ident< $lid:name$ >>, [], <:ctyp<>>, False))
abstr tyMap
in
let tyMap =
let concr =
[("bool", <:ident<bool>>, [], <:ctyp< [ False | True ] >>, False);
("list", <:ident<list>>, [ <:ctyp< 'a >> ], <:ctyp< [ $uid:"[]"$ | $uid:"::"$ of 'a and list 'a ] >>, False);
("option", <:ident<option>>, [ <:ctyp< 'a >> ], <:ctyp< [ None | Some of 'a ] >>, False);
("ref", <:ident<ref>>, [ <:ctyp< 'a >> ], <:ctyp< { contents : 'a } >>, False)]
in
List.fold_right (fun ((name, _, _, _, _) as decl) -> StringMap.add name decl) concr tyMap
in
tyMap;
value used_builtins = ref StringMap.empty;
value store_if_builtin_type id =
if StringMap.mem id builtin_types then
used_builtins.val := StringMap.add id (StringMap.find id builtin_types) used_builtins.val
else ();
type mode = [ Fold | Map | Fold_map ];
value string_of_mode = fun [ Fold -> "fold" | Map -> "map" | Fold_map -> "fold_map" ];
module Gen (X :
sig
value size : int;
value mode : mode;
end) =
struct
value size = X.size;
value mode = X.mode;
value tuplify_expr f =
if size <= 0 then assert False
else if size = 1 then f 1
else
let rec loop k =
if k = 2 then f 2
else <:expr< $loop (k - 1)$, $f k$ >>
in <:expr< ($f 1$, $loop size$) >>;
value tuplify_patt f =
if size <= 0 then assert False
else if size = 1 then f 1
else
let rec loop k =
if k = 2 then f 2
else <:patt< $loop (k - 1)$, $f k$ >>
in <:patt< ($f 1$, $loop size$) >>;
value xiks i = tuplify_expr (exik i);
value tuplify_type typ =
if size <= 0 then assert False
else if size = 1 then typ
else
let rec loop k =
if k = 2 then typ
else <:ctyp< $loop (k - 1)$ * $typ$ >>
in <:ctyp< ($typ$ * $loop size$) >>;
value tuplify_tycon tycon = tuplify_type <:ctyp< $lid:tycon$ >>;
value rec patt_of_expr =
fun
[ <:expr<>> -> <:patt<>>
| <:expr< $id:i$ >> -> <:patt< $id:i$ >>
| <:expr< $e1$, $e2$ >> -> <:patt< $patt_of_expr e1$, $patt_of_expr e2$ >>
| <:expr< $tup:e$ >> -> <:patt< $tup:patt_of_expr e$ >>
| _ -> assert False ];
value bind p e1 e2 =
match mode with
[ Fold_map -> <:expr< let (o, $p$) = $e1$ in $e2$ >>
| Map -> <:expr< let $p$ = $e1$ in $e2$ >>
| Fold -> <:expr< let o = $e1$ in $e2$ >> ];
value return e =
match mode with
[ Fold_map -> <:expr< (o, $e$) >>
| Map -> e
| Fold -> <:expr<o>> ];
value rec opt_bind opt_patt e1 mk_e2 =
match e1 with
[ <:expr< $id:_$ >> | <:expr< $lid:_$#$_$ >> -> mk_e2 e1
| <:expr< let $p1$ = $e1$ in $e2$ >> ->
<:expr< let $p1$ = $e1$ in $opt_bind None e2 mk_e2$ >>
| _ ->
let e2 = mk_e2 <:expr<o>> in
match opt_patt with
[ Some patt -> bind patt e1 e2
| None -> <:expr< (fun o -> $e1$) $e2$ >> ] ];
(* ts = [t1; ...; tN] *)
value chain_tuple mkp mke expr_of_ty ts =
(* exiks = [<<(x_i0_k1, ..., x_i0_kM)>>; ...; <<(x_iN_k1, ..., x_iN_kM)>>] *)
let exiks = list_init (fun i -> tuplify_expr (exik i)) (List.length ts) in
(* exi1s, pxi1s = [<<x_i0_k1>>; ...; <<x_iN_k1>>] *)
let exi1s = list_init (fun i -> exik i 1) (List.length ts) in
let pxi1s = list_init (fun i -> pxik i 1) (List.length ts) in
let ps k = mkp (list_init (fun i -> pxik i k) (List.length ts)) in
let p = tuplify_patt ps in
let e1 = mke exi1s in
let es = List.map2 (fun x -> expr_of_ty (Some x)) exiks ts in
let e =
List.fold_right2 begin fun pxi1 e acc ->
bind pxi1 e acc
end pxi1s es (return e1)
in
<:match_case< $p$ -> $e$ >>;
value mk_tuple expr_of_ty t =
let mc =
chain_tuple
(fun ps -> <:patt< ($tup:Ast.paCom_of_list ps$) >>)
(fun es -> <:expr< ($tup:Ast.exCom_of_list es$) >>)
expr_of_ty (Ast.list_of_ctyp t [])
in <:expr< fun [ $mc$ ] >>;
value default_match_case =
let mk k = if k = 1 then <:patt< x >> else <:patt< _ >> in
match mode with
[ Fold_map -> <:match_case< $tuplify_patt mk$ -> (o, x) >>
| Fold -> <:match_case< _ -> o >>
| Map -> <:match_case< $tuplify_patt mk$ -> x >> ];
value default_expr = <:expr< fun [ $default_match_case$ ] >>;
value mkfuno e =
match e with
[ <:expr< $e$ o >> -> e
| _ -> <:expr< fun o -> $e$ >> ];
value is_unknown t =
let rec loop t =
match t with
[ <:ctyp< $lid:_$ >> -> False
| <:ctyp< $id:_$ >> -> True
| <:ctyp< $t$ $_$ >> -> loop t
| _ -> False ]
in
match t with
[ <:ctyp< $uid:_$ >> -> False
| t -> loop t ];
value contains_unknown t =
try
let (_ : < .. >) =
object
inherit Ast.fold as super;
method ctyp t = if is_unknown t then raise Exit else super#ctyp t;
end#ctyp t
in False
with [ Exit -> True ];
value opt_bind' ox e1 mk_e2 =
let mk_e2 =
match ox with
[ Some x -> fun e1 -> <:expr< $mk_e2 e1$ $x$ >>
| _ -> mk_e2 ]
in
opt_bind (opt_map patt_of_expr ox) e1 mk_e2;
(* FIXME finish me
value rec is_simple =
fun
[ <:expr< $id:_$ >> -> True
| <:expr< $e$#$_$ >> | <:expr< $tup:e$ >> -> is_simple e
| <:expr< $e1$ $e2$ >> | <:expr< $e1$, $e2$ >> -> is_simple e1 && is_simple e2
| _ -> False ];
value app e1 e2 =
let is_e1_simple = is_simple e1 in
let is_e2_simple = is_simple e2 in
if is_e1_simple then
if is_e2_simple then <:expr< $e1$ $e2$ >>
else let x = fresh "y" in <:expr< let $lid:y$ = $e2$ in $e1$ $lid:y$ >>
else
if is_e2_simple then
let x = fresh "y" in <:expr< let $lid:y$ = $e1$ in $lid:y$ $e2$ >>
else ; *)
value opt_app e ox =
match ox with
[ Some x -> <:expr< $e$ $x$ >> (* call app *)
| _ -> e ];
value rec expr_of_ty x ty =
let rec self ?(arity=0) ox =
fun
[ t when is_unknown t ->
self ox <:ctyp< unknown >>
| <:ctyp< $lid:id$ >> ->
let () = store_if_builtin_type id in
opt_bind' ox <:expr<o>> (fun e1 -> <:expr< $e1$#$id$ >>)
| <:ctyp@_loc< $t1$ $t2$ >> ->
let e = opt_bind None
(self ~arity:(arity+1) None t1)
(fun e1 -> <:expr< $e1$ $mkfuno (self None t2)$ >>) in
opt_app e ox
| <:ctyp< ( $tup:t$ ) >> ->
opt_app (mk_tuple (self ~arity:0) t) ox
| <:ctyp< '$s$ >> ->
opt_app <:expr< $lid:"_f_" ^ s$ o >> ox
| _ ->
self ox <:ctyp< unknown >> ]
in self x ty
and expr_of_ty' e t = expr_of_ty (Some e) t
and out_constr_patt s =
<:patt< $uid:s$ >>
(* <:patt< `$s$ >>
<:patt< M.$uid:s$ >> *)
and out_constr_expr s =
<:expr< $uid:s$ >>
(* <:expr< `$s$ >>
<:expr< M.$uid:s$ >> *)
(* method term t =
match t with
| C(x1, ..., xn) ->
let o, x1 = o#t1 x1 in
let o, x2 = o#t2 x2 in
...
let o, xn = o#tn xn in
o, C(x1, ..., xn)
*)
(* s = C, t = t1 and ... and tN *)
and match_case_of_constructor s t =
chain_tuple
(apply_patt (out_constr_patt s))
(apply_expr (out_constr_expr s))
expr_of_ty (Ast.list_of_ctyp t [])
and match_case_of_sum_type =
fun
[ <:ctyp< $t1$ | $t2$ >> ->
<:match_case< $match_case_of_sum_type t1$ | $match_case_of_sum_type t2$ >>
| <:ctyp< $uid:s$ of $t$ >> -> match_case_of_constructor s t
| <:ctyp< $uid:s$ >> -> match_case_of_constructor s <:ctyp<>>
| _ -> assert False ]
and match_case_of_poly_constructor s ts =
chain_tuple
(fun [ [] -> <:patt< `$s$ >> | [p] -> <:patt< `$s$ $p$ >> | ps -> <:patt< `$s$ ($tup:Ast.paCom_of_list ps$) >> ])
(fun [ [] -> <:expr< `$s$ >> | [e] -> <:expr< `$s$ $e$ >> | es -> <:expr< `$s$ ($tup:Ast.exCom_of_list es$) >> ])
expr_of_ty ts
and match_case_of_poly_sum_type =
fun
[ <:ctyp< $t1$ | $t2$ >> ->
<:match_case< $match_case_of_poly_sum_type t1$ | $match_case_of_poly_sum_type t2$ >>
| <:ctyp< `$i$ of ($tup:t$) >> -> match_case_of_poly_constructor i (Ast.list_of_ctyp t [])
| <:ctyp< `$i$ of $t$ >> -> match_case_of_poly_constructor i [t]
| <:ctyp< `$i$ >> -> match_case_of_poly_constructor i []
| _ -> assert False ]
and record_patt_of_type k =
fun
[ <:ctyp< $lid:s$ : $_$ >> ->
<:patt< $lid:s$ = $lid:xsk s k$ >>
| <:ctyp< $t1$ ; $t2$ >> ->
<:patt< $record_patt_of_type k t1$; $record_patt_of_type k t2$ >>
| _ -> assert False ]
and type_list_of_record_type t ((acc1, acc2) as acc) =
match t with
[ <:ctyp<>> -> acc
| <:ctyp< $lid:s$ : mutable $t$ >> | <:ctyp< $lid:s$ : $t$ >> ->
([s :: acc1], [t :: acc2])
| <:ctyp< $t1$ ; $t2$ >> ->
type_list_of_record_type t1 (type_list_of_record_type t2 acc)
| _ -> assert False ]
and expr_of_record_type t =
let (ls, ts) = type_list_of_record_type t ([], []) in
let mkp ps = <:patt< { $list:List.map2 (fun l p -> <:patt< $lid:l$ = $p$ >>) ls ps$ } >> in
let mke es = <:expr< { $list:List.map2 (fun l e -> <:rec_binding< $lid:l$ = $e$ >>) ls es$ } >> in
chain_tuple mkp mke expr_of_ty ts
and failure_match_case =
<:match_case< $tuplify_patt (pxik 0)$ ->
o#$lid:sf "%s%d_failure" (string_of_mode mode) size$ $tuplify_expr (exik 0)$ >>
and complete_match_case mk t =
match t with
[ <:ctyp< $_$ | $_$ >> when size > 1 ->
<:match_case< $mk t$ | $failure_match_case$ >>
| _ -> mk t ]
and fun_of_ctyp tyid =
fun
[ <:ctyp< [ $t$ ] >> ->
<:expr< fun [ $complete_match_case match_case_of_sum_type t$ ] >>
| <:ctyp< { $t$ } >> ->
<:expr< fun [ $expr_of_record_type t$ ] >>
| <:ctyp< ( $tup:t$ ) >> -> mk_tuple expr_of_ty t
| <:ctyp< $lid:i$ >> when i = tyid -> default_expr
| <:ctyp< $_$ $_$ >> | <:ctyp< $_$ -> $_$ >> | <:ctyp< '$_$ >> | <:ctyp< $id:_$ >> as t ->
expr_of_ty None t
| <:ctyp<>> ->
expr_of_ty None <:ctyp< unknown >>
| <:ctyp< [ = $t$ ] >> | <:ctyp< [ < $t$ ] >> | <:ctyp< private [ < $t$ ] >> ->
<:expr< fun [ $complete_match_case match_case_of_poly_sum_type t$ ] >>
| <:ctyp< [ > $t$ ] >> | <:ctyp< private [ > $t$ ] >> ->
if size > 1 then
<:expr< fun [ $complete_match_case match_case_of_poly_sum_type t$ ] >>
else
<:expr< fun [ $match_case_of_poly_sum_type t$ | $default_match_case$ ] >>
| _ -> assert False ]
and string_of_type_param t =
match t with
[ <:ctyp< '$s$ >> | <:ctyp< +'$s$ >> | <:ctyp< -'$s$ >> -> s
| _ -> assert False ]
and method_of_type_decl _ ((id1, _, params, ctyp, priv) as type_decl) acc =
let rec lambda acc =
fun
[ [] -> acc
| [ x :: xs ] -> lambda <:expr< fun $lid:"_f_" ^ x$ -> $acc$ >> xs ] in
let params' = List.map string_of_type_param params in
let funs = lambda (fun_of_ctyp id1 ctyp) params' in
let ty = method_type_of_type_decl type_decl in
let priv = if priv then <:private_flag< private >> else <:private_flag<>> in
<:class_str_item< method $private:priv$ $lid:id1$ : $ty$ = $funs$; $acc$ >>
and ctyp_name_of_name_params name params =
apply_ctyp <:ctyp< $id:name$ >> params
and method_type_of_type_decl (_, name, params, ctyp, _) =
let t = ctyp_name_of_name_params name params in
if mode = Map && not (contains_unknown ctyp) then
let out_params = List.map (fun [ <:ctyp< '$i$ >> -> <:ctyp< '$i^"_out"$ >> | _ -> assert False ]) params in
let t_out = ctyp_name_of_name_params name out_params in
method_type_of_type t t_out params out_params
else
method_type_of_type t t params []
and method_type_of_type t_in t_out params_in params_out =
let rt t =
match mode with
[ Fold_map -> <:ctyp< ('self_type * $t$) >>
| Fold -> <:ctyp< 'self_type >>
| Map -> t ]
in
match (params_in, params_out) with
[ ([param_in], [param_out]) ->
let alphas = tuplify_type param_in in
<:ctyp< ! $param_in$ $param_out$ . ('self_type -> $alphas$ -> $rt param_out$) -> $tuplify_type t_in$ -> $rt t_out$ >>
| ([param], []) ->
let alphas = tuplify_type param in
<:ctyp< ! $param$ . ('self_type -> $alphas$ -> $rt param$) -> $tuplify_type t_in$ -> $rt t_out$ >>
| ([], []) ->
<:ctyp< $tuplify_type t_in$ -> $rt t_out$ >>
| _ ->
let i = List.length params_in in
failwith (Printf.sprintf
"Camlp4FoldGenerator: FIXME not implemented for types with %d parameters" i) ]
and class_sig_item_of_type_decl _ ((name, _, _, t, _) as type_decl) acc =
let (_ : < .. >) =
object (self)
inherit Ast.fold as super;
method ctyp =
fun
[ <:ctyp< $lid:id$ >> -> let () = store_if_builtin_type id in self
| t -> super#ctyp t ];
end#ctyp t
in
<:class_sig_item<
method $lid:name$ : $method_type_of_type_decl type_decl$;
$acc$ >>
and generate_structure tyMap =
StringMap.fold method_of_type_decl used_builtins.val
(StringMap.fold method_of_type_decl tyMap <:class_str_item<>>)
and generate_signature tyMap =
StringMap.fold class_sig_item_of_type_decl used_builtins.val
(StringMap.fold class_sig_item_of_type_decl tyMap <:class_sig_item<>>);
end;
value rec tyMap_of_type_decls t acc =
match t with
[ <:ctyp<>> -> acc
| <:ctyp< $t1$ and $t2$ >> ->
tyMap_of_type_decls t1 (tyMap_of_type_decls t2 acc)
| Ast.TyDcl _ name tl tk _ ->
StringMap.add name (name, <:ident< $lid:name$ >>, tl, tk, False) acc
| _ -> assert False ];
value generate_class_implem ?(virtual_flag=False) mode c tydcl n =
let tyMap = tyMap_of_type_decls tydcl StringMap.empty in
let module M = Gen(struct value size = n; value mode = mode; end) in
let generated = M.generate_structure tyMap in
let gen_type =
<:ctyp< ! 'a 'b . $M.method_type_of_type <:ctyp< 'a >> <:ctyp< 'b >> [] []$ >>
in
let failure =
if n > 1 then
let name = string_of_mode mode in
<:class_str_item< method $lid:sf "%s%d_failure" name n$ : $gen_type$ =
fun $M.tuplify_patt (pxik 0)$ ->
failwith $`str:sf "%s%d_failure: default implementation" name n$ >>
else <:class_str_item<>>
in
let gen_type =
<:ctyp< ! 'a . $M.method_type_of_type <:ctyp< 'a >> <:ctyp< 'a >> [] []$ >>
in
let unknown =
<:class_str_item< method unknown : $gen_type$ = $M.default_expr$ >> in
if not virtual_flag then
<:str_item< class $lid:c$ = object (o : 'self_type) $generated$; $failure$; $unknown$ end >>
else
<:str_item< class virtual $lid:c$ = object (o : 'self_type) $generated$; $failure$; $unknown$ end >>;
value generate_class_interf ?(virtual_flag=False) mode c tydcl n =
let tyMap = tyMap_of_type_decls tydcl StringMap.empty in
let module M = Gen(struct value size = n; value mode = mode; end) in
let generated = M.generate_signature tyMap in
let gen_type =
<:ctyp< ! 'a 'b . $M.method_type_of_type <:ctyp< 'a >> <:ctyp< 'b >> [] []$ >>
in
let failure =
if n > 1 then
let name = string_of_mode mode in
<:class_sig_item< method $lid:sf "%s%d_failure" name n$ : $gen_type$ >>
else <:class_sig_item<>>
in
let gen_type =
<:ctyp< ! 'a . $M.method_type_of_type <:ctyp< 'a >> <:ctyp< 'a >> [] []$ >>
in
let unknown =
<:class_sig_item< method unknown : $gen_type$ >>
in
if not virtual_flag then
<:sig_item< class $lid:c$ : object ('self_type) $generated$; $failure$; $unknown$ end >>
else
<:sig_item< class virtual $lid:c$ : object ('self_type) $generated$; $failure$; $unknown$ end >> ;
value processor =
let last = ref <:ctyp<>> in
let generate_class' generator default c s n =
match s with
[ "Fold" -> generator Fold c last.val n
| "Map" -> generator Map c last.val n
| "FoldMap" -> generator Fold_map c last.val n
| _ -> default ]
in
let generate_class_from_module_name generator c default m =
try Scanf.sscanf m "Camlp4%[^G]Generator" begin fun m' ->
try Scanf.sscanf m' "%[^0-9]%d" (generate_class' generator default c)
with [ End_of_file | Scanf.Scan_failure _ -> generate_class' generator default c m' 1 ]
end with [ End_of_file | Scanf.Scan_failure _ -> default ]
in
object (self)
inherit Ast.map as super;
method str_item st =
match st with
[ Ast.StTyp (_, _, t) -> (last.val := t; st)
(* backward compatibility *)
| <:str_item@_loc< class $lid:c$ = Camlp4Filters.GenerateFold.generated >> ->
generate_class_implem Fold c last.val 1
| <:str_item@_loc< class virtual $lid:c$ = Camlp4Filters.GenerateFold.generated >> ->
generate_class_implem ~virtual_flag:True Fold c last.val 1
| <:str_item@_loc< class $lid:c$ = Camlp4Filters.GenerateMap.generated >> ->
generate_class_implem Map c last.val 1
| <:str_item@_loc< class virtual $lid:c$ = Camlp4Filters.GenerateMap.generated >> ->
generate_class_implem ~virtual_flag:True Map c last.val 1
(* Handle Camlp4(Fold|Map|FoldMap)\d*Generator *)
| <:str_item@_loc< class $lid:c$ = $uid:m$.generated >> ->
generate_class_from_module_name (generate_class_implem ~virtual_flag:False) c st m
| <:str_item@_loc< class virtual $lid:c$ = $uid:m$.generated >> ->
generate_class_from_module_name (generate_class_implem ~virtual_flag:True) c st m
(* It's a hack to force to recurse on the left to right order *)
| <:str_item< $st1$; $st2$ >> ->
let st1 = self#str_item st1 in
<:str_item< $st1$; $self#str_item st2$ >>
| st -> super#str_item st ];
method sig_item sg =
match sg with
[ Ast.SgTyp (_, _, t) -> (last.val := t; sg)
(* backward compatibility *)
| <:sig_item@_loc< class $lid:c$ : Camlp4Filters.GenerateFold.generated >> ->
generate_class_interf Fold c last.val 1
| <:sig_item@_loc< class virtual $lid:c$ : Camlp4Filters.GenerateFold.generated >> ->
generate_class_interf ~virtual_flag:True Fold c last.val 1
| <:sig_item@_loc< class $lid:c$ : Camlp4Filters.GenerateMap.generated >> ->
generate_class_interf Map c last.val 1
| <:sig_item@_loc< class virtual $lid:c$ : Camlp4Filters.GenerateMap.generated >> ->
generate_class_interf ~virtual_flag:True Map c last.val 1
(* Handle Camlp4(Fold|Map|FoldMap)\d*Generator *)
| <:sig_item@_loc< class $lid:c$ : $uid:m$.generated >> ->
generate_class_from_module_name (generate_class_interf ~virtual_flag:False) c sg m
| <:sig_item@_loc< class virtual $lid:c$ : $uid:m$.generated >> ->
generate_class_from_module_name (generate_class_interf ~virtual_flag:True) c sg m
(* It's a hack to force to recurse on the left to right order *)
| <:sig_item< $sg1$; $sg2$ >> ->
let sg1 = self#sig_item sg1 in
<:sig_item< $sg1$; $self#sig_item sg2$ >>
| sg -> super#sig_item sg ];
end;
register_str_item_filter processor#str_item;
register_sig_item_filter processor#sig_item;
end;
let module M = Camlp4.Register.AstFilter Id Make in ();