camlp4/Camlp4Filters/Camlp4FoldGenerator.ml

   1 (* camlp4r *)
   2 (****************************************************************************)
   3 (*                                                                          *)
   4 (*                              Objective Caml                              *)
   5 (*                                                                          *)
   6 (*                            INRIA Rocquencourt                            *)
   7 (*                                                                          *)
   8 (*  Copyright 2006,2007 Institut National de Recherche en Informatique et   *)
   9 (*  en Automatique.  All rights reserved.  This file is distributed under   *)
  10 (*  the terms of the GNU Library General Public License, with the special   *)
  11 (*  exception on linking described in LICENSE at the top of the Objective   *)
  12 (*  Caml source tree.                                                       *)
  13 (*                                                                          *)
  14 (****************************************************************************)
  15
  16 (* Authors:
  17  * - Nicolas Pouillard: initial version
  18  *)
  19
  20
  21 open Camlp4;
  22
  23 module Id = struct
  24   value name    = "Camlp4FoldGenerator";
  25   value version = "$Id$";
  26 end;
  27
  28 module Make (AstFilters : Camlp4.Sig.AstFilters) = struct
  29   open AstFilters;
  30   module StringMap = Map.Make String;
  31   open Ast;
  32
  33   value _loc = Loc.ghost;
  34
  35   value sf = Printf.sprintf;
  36
  37   value xik i k =
  38     let i =
  39       if i < 0 then assert False
  40       else if i = 0 then ""
  41       else sf "_i%d" i
  42     in
  43     let k =
  44       if k < 1 then assert False
  45       else if k = 1 then ""
  46       else sf "_k%d" k
  47     in
  48     sf "_x%s%s" i k;
  49   value exik i k = <:expr< $lid:xik i k$ >>;
  50   value pxik i k = <:patt< $lid:xik i k$ >>;
  51   value elidk y k = <:expr< $lid:sf "%s_%d" y k$ >>;
  52   value plidk y k = <:patt< $lid:sf "%s_%d" y k$ >>;
  53
  54   value xs s = "_x_" ^ s;
  55   value xsk = sf "_x_%s_%d";
  56   value exsk s k = <:expr< $lid:xsk s k$>>;
  57
  58   value rec apply_expr accu =
  59     fun
  60     [ [] -> accu
  61     | [x :: xs] ->
  62         let _loc = Ast.loc_of_expr x
  63         in apply_expr <:expr< $accu$ $x$ >> xs ];
  64
  65   value rec apply_patt accu =
  66     fun
  67     [ [] -> accu
  68     | [x :: xs] ->
  69         let _loc = Ast.loc_of_patt x
  70         in apply_patt <:patt< $accu$ $x$ >> xs ];
  71
  72   value rec apply_ctyp accu =
  73     fun
  74     [ [] -> accu
  75     | [x :: xs] ->
  76         let _loc = Ast.loc_of_ctyp x
  77         in apply_ctyp <:ctyp< $accu$ $x$ >> xs ];
  78
  79   value opt_map f = fun [ Some x -> Some (f x) | None -> None ];
  80
  81   value list_init f n =
  82     let rec self m =
  83       if m = n then []
  84       else [f m :: self (succ m)]
  85     in self 0;
  86
  87   value rec lid_of_ident sep =
  88     fun
  89     [ <:ident< $lid:s$ >> | <:ident< $uid:s$ >> -> s
  90     | <:ident< $i1$.$i2$ >> -> lid_of_ident sep i1 ^ sep ^ lid_of_ident sep i2
  91     | _ -> assert False ];
  92
  93   type type_decl = (string * Ast.ident * list Ast.ctyp * Ast.ctyp * bool);
  94
  95   value builtin_types =
  96     let tyMap = StringMap.empty in
  97     let tyMap =
  98       let abstr = ["string"; "int"; "float"; "int32"; "int64"; "nativeint"; "char"] in
  99       List.fold_right
 100         (fun name -> StringMap.add name (name, <:ident< $lid:name$ >>, [], <:ctyp<>>, False))
 101         abstr tyMap
 102     in
 103     let tyMap =
 104       let concr =
 105         [("bool", <:ident<bool>>, [], <:ctyp< [ False | True ] >>, False);
 106          ("list", <:ident<list>>, [ <:ctyp< 'a >> ], <:ctyp< [ $uid:"[]"$ | $uid:"::"$ of 'a and list 'a ] >>, False);
 107          ("option", <:ident<option>>, [ <:ctyp< 'a >> ], <:ctyp< [ None | Some of 'a ] >>, False);
 108          ("ref", <:ident<ref>>, [ <:ctyp< 'a >> ], <:ctyp< { contents : 'a } >>, False)]
 109       in
 110       List.fold_right (fun ((name, _, _, _, _) as decl) -> StringMap.add name decl) concr tyMap
 111     in
 112     tyMap;
 113
 114   value used_builtins = ref StringMap.empty;
 115
 116   value store_if_builtin_type id =
 117     if StringMap.mem id builtin_types then
 118       used_builtins.val := StringMap.add id (StringMap.find id builtin_types) used_builtins.val
 119     else ();
 120
 121   type mode = [ Fold | Map | Fold_map ];
 122
 123   value string_of_mode = fun [ Fold -> "fold" | Map -> "map" | Fold_map -> "fold_map" ];
 124
 125   module Gen (X :
 126     sig
 127       value size : int;
 128       value mode : mode;
 129     end) =
 130     struct
 131
 132       value size = X.size;
 133       value mode = X.mode;
 134
 135       value tuplify_expr f =
 136         if size <= 0 then assert False
 137         else if size = 1 then f 1
 138         else
 139           let rec loop k =
 140             if k = 2 then f 2
 141             else <:expr< $loop (k - 1)$, $f k$ >>
 142           in <:expr< ($f 1$, $loop size$) >>;
 143
 144       value tuplify_patt f =
 145         if size <= 0 then assert False
 146         else if size = 1 then f 1
 147         else
 148           let rec loop k =
 149             if k = 2 then f 2
 150             else <:patt< $loop (k - 1)$, $f k$ >>
 151           in <:patt< ($f 1$, $loop size$) >>;
 152
 153       value xiks i = tuplify_expr (exik i);
 154
 155       value tuplify_type typ =
 156         if size <= 0 then assert False
 157         else if size = 1 then typ
 158         else
 159           let rec loop k =
 160             if k = 2 then typ
 161             else <:ctyp< $loop (k - 1)$ * $typ$ >>
 162           in <:ctyp< ($typ$ * $loop size$) >>;
 163
 164       value tuplify_tycon tycon = tuplify_type <:ctyp< $lid:tycon$ >>;
 165
 166       value rec patt_of_expr =
 167         fun
 168         [ <:expr<>> -> <:patt<>>
 169         | <:expr< $id:i$ >> -> <:patt< $id:i$ >>
 170         | <:expr< $e1$, $e2$ >> -> <:patt< $patt_of_expr e1$, $patt_of_expr e2$ >>
 171         | <:expr< $tup:e$ >> -> <:patt< $tup:patt_of_expr e$ >>
 172         | _ -> assert False ];
 173
 174       value bind p e1 e2 =
 175         match mode with
 176         [ Fold_map -> <:expr< let (o, $p$) = $e1$ in $e2$ >>
 177         | Map      -> <:expr< let $p$ = $e1$ in $e2$ >>
 178         | Fold     -> <:expr< let o = $e1$ in $e2$ >> ];
 179
 180       value return e =
 181         match mode with
 182         [ Fold_map -> <:expr< (o, $e$) >>
 183         | Map      -> e
 184         | Fold     -> <:expr<o>> ];
 185
 186       value rec opt_bind opt_patt e1 mk_e2 =
 187         match e1 with
 188         [ <:expr< $id:_$ >> | <:expr< $lid:_$#$_$ >> -> mk_e2 e1
 189         | <:expr< let $p1$ = $e1$ in $e2$ >> ->
 190             <:expr< let $p1$ = $e1$ in $opt_bind None e2 mk_e2$ >>
 191         | _ ->
 192             let e2 = mk_e2 <:expr<o>> in
 193             match opt_patt with
 194             [ Some patt -> bind patt e1 e2
 195             | None -> <:expr< (fun o -> $e1$) $e2$ >> ] ];
 196
 197         (* ts = [t1; ...; tN] *)
 198       value chain_tuple mkp mke expr_of_ty ts =
 199         (* exiks = [<<(x_i0_k1, ..., x_i0_kM)>>; ...; <<(x_iN_k1, ..., x_iN_kM)>>] *)
 200         let exiks = list_init (fun i -> tuplify_expr (exik i)) (List.length ts) in
 201         (* exi1s, pxi1s = [<<x_i0_k1>>; ...; <<x_iN_k1>>] *)
 202         let exi1s = list_init (fun i -> exik i 1) (List.length ts) in
 203         let pxi1s = list_init (fun i -> pxik i 1) (List.length ts) in
 204         let ps k = mkp (list_init (fun i -> pxik i k) (List.length ts)) in
 205         let p = tuplify_patt ps in
 206         let e1 = mke exi1s in
 207         let es = List.map2 (fun x -> expr_of_ty (Some x)) exiks ts in
 208         let e =
 209           List.fold_right2 begin fun pxi1 e acc ->
 210             bind pxi1 e acc
 211           end pxi1s es (return e1)
 212         in
 213         <:match_case< $p$ -> $e$ >>;
 214
 215       value mk_tuple expr_of_ty t =
 216         let mc =
 217           chain_tuple
 218             (fun ps -> <:patt< ($tup:Ast.paCom_of_list ps$) >>)
 219             (fun es -> <:expr< ($tup:Ast.exCom_of_list es$) >>)
 220             expr_of_ty (Ast.list_of_ctyp t [])
 221         in <:expr< fun [ $mc$ ] >>;
 222
 223       value default_match_case =
 224         let mk k = if k = 1 then <:patt< x >> else <:patt< _ >> in
 225         match mode with
 226         [ Fold_map -> <:match_case< $tuplify_patt mk$ -> (o, x) >>
 227         | Fold     -> <:match_case< _ -> o >>
 228         | Map      -> <:match_case< $tuplify_patt mk$ -> x >> ];
 229
 230       value default_expr = <:expr< fun [ $default_match_case$ ] >>;
 231
 232       value mkfuno e =
 233         match e with
 234         [ <:expr< $e$ o >> -> e
 235         | _ -> <:expr< fun o -> $e$ >> ];
 236
 237       value is_unknown t =
 238         let rec loop t =
 239           match t with
 240           [ <:ctyp< $lid:_$ >> -> False
 241           | <:ctyp< $id:_$ >> -> True
 242           | <:ctyp< $t$ $_$ >> -> loop t
 243           | _ -> False ]
 244         in
 245         match t with
 246         [ <:ctyp< $uid:_$ >> -> False
 247         | t -> loop t ];
 248
 249       value contains_unknown t =
 250         try
 251           let (_ : < .. >) =
 252             object
 253               inherit Ast.fold as super;
 254               method ctyp t = if is_unknown t then raise Exit else super#ctyp t;
 255             end#ctyp t
 256           in False
 257         with [ Exit -> True ];
 258
 259       value opt_bind' ox e1 mk_e2 =
 260         let mk_e2 =
 261           match ox with
 262           [ Some x -> fun e1 -> <:expr< $mk_e2 e1$ $x$ >>
 263           | _      -> mk_e2 ]
 264         in
 265         opt_bind (opt_map patt_of_expr ox) e1 mk_e2;
 266
 267     (* FIXME finish me
 268       value rec is_simple =
 269         fun
 270         [ <:expr< $id:_$ >> -> True
 271         | <:expr< $e$#$_$ >> | <:expr< $tup:e$ >> -> is_simple e
 272         | <:expr< $e1$ $e2$ >> | <:expr< $e1$, $e2$ >> -> is_simple e1 && is_simple e2
 273         | _ -> False ];
 274
 275       value app e1 e2 =
 276         let is_e1_simple = is_simple e1 in
 277         let is_e2_simple = is_simple e2 in
 278         if is_e1_simple then
 279           if is_e2_simple then <:expr< $e1$ $e2$ >>
 280           else let x = fresh "y" in <:expr< let $lid:y$ = $e2$ in $e1$ $lid:y$ >>
 281         else
 282           if is_e2_simple then
 283             let x = fresh "y" in <:expr< let $lid:y$ = $e1$ in $lid:y$ $e2$ >>
 284           else ; *)
 285
 286       value opt_app e ox =
 287         match ox with
 288         [ Some x -> <:expr< $e$ $x$ >> (* call app *)
 289         | _ -> e ];
 290
 291       value rec expr_of_ty x ty =
 292         let rec self ?(arity=0) ox =
 293           fun
 294           [ t when is_unknown t ->
 295               self ox <:ctyp< unknown >>
 296           | <:ctyp< $lid:id$ >> ->
 297               let () = store_if_builtin_type id in
 298               opt_bind' ox <:expr<o>> (fun e1 -> <:expr< $e1$#$id$ >>)
 299           | <:ctyp@_loc< $t1$ $t2$ >> ->
 300               let e = opt_bind None
 301                                (self ~arity:(arity+1) None t1)
 302                                (fun e1 -> <:expr< $e1$ $mkfuno (self None t2)$ >>) in
 303               opt_app e ox
 304           | <:ctyp< ( $tup:t$ ) >> ->
 305               opt_app (mk_tuple (self ~arity:0) t) ox
 306           | <:ctyp< '$s$ >> ->
 307               opt_app <:expr< $lid:"_f_" ^ s$ o >> ox
 308           | _ ->
 309               self ox <:ctyp< unknown >> ]
 310         in self x ty
 311
 312       and expr_of_ty' e t = expr_of_ty (Some e) t
 313
 314       and out_constr_patt s =
 315         <:patt< $uid:s$ >>
 316         (* <:patt< `$s$ >>
 317         <:patt< M.$uid:s$ >> *)
 318       and out_constr_expr s =
 319         <:expr< $uid:s$ >>
 320         (* <:expr< `$s$ >>
 321         <:expr< M.$uid:s$ >> *)
 322
 323     (* method term t =
 324         match t with
 325         | C(x1, ..., xn) ->
 326             let o, x1 = o#t1 x1 in
 327             let o, x2 = o#t2 x2 in
 328             ...
 329             let o, xn = o#tn xn in
 330             o, C(x1, ..., xn)
 331      *)
 332
 333       (* s = C, t = t1 and ... and tN *)
 334       and match_case_of_constructor s t =
 335         chain_tuple
 336           (apply_patt (out_constr_patt s))
 337           (apply_expr (out_constr_expr s))
 338           expr_of_ty (Ast.list_of_ctyp t [])
 339
 340       and match_case_of_sum_type =
 341         fun
 342         [ <:ctyp< $t1$ | $t2$ >> ->
 343              <:match_case< $match_case_of_sum_type t1$ | $match_case_of_sum_type t2$ >>
 344         | <:ctyp< $uid:s$ of $t$ >> -> match_case_of_constructor s t
 345         | <:ctyp< $uid:s$ >> -> match_case_of_constructor s <:ctyp<>>
 346         | _ -> assert False ]
 347
 348       and match_case_of_poly_constructor s ts =
 349         chain_tuple
 350           (fun [ [] -> <:patt< `$s$ >> | [p] -> <:patt< `$s$ $p$ >> | ps -> <:patt< `$s$ ($tup:Ast.paCom_of_list ps$) >> ])
 351           (fun [ [] -> <:expr< `$s$ >> | [e] -> <:expr< `$s$ $e$ >> | es -> <:expr< `$s$ ($tup:Ast.exCom_of_list es$) >> ])
 352           expr_of_ty ts
 353
 354       and match_case_of_poly_sum_type =
 355         fun
 356         [ <:ctyp< $t1$ | $t2$ >> ->
 357              <:match_case< $match_case_of_poly_sum_type t1$ | $match_case_of_poly_sum_type t2$ >>
 358         | <:ctyp< `$i$ of ($tup:t$) >> -> match_case_of_poly_constructor i (Ast.list_of_ctyp t [])
 359         | <:ctyp< `$i$ of $t$ >> -> match_case_of_poly_constructor i [t]
 360         | <:ctyp< `$i$ >> -> match_case_of_poly_constructor i []
 361         | _ -> assert False ]
 362
 363       and record_patt_of_type k =
 364         fun
 365         [ <:ctyp< $lid:s$ : $_$ >> ->
 366             <:patt< $lid:s$ = $lid:xsk s k$ >>
 367         | <:ctyp< $t1$ ; $t2$ >> ->
 368             <:patt< $record_patt_of_type k t1$; $record_patt_of_type k t2$ >>
 369         | _ -> assert False ]
 370
 371       and type_list_of_record_type t ((acc1, acc2) as acc) =
 372         match t with
 373         [ <:ctyp<>> -> acc
 374         | <:ctyp< $lid:s$ : mutable $t$ >> | <:ctyp< $lid:s$ : $t$ >> ->
 375               ([s :: acc1], [t :: acc2])
 376         | <:ctyp< $t1$ ; $t2$ >> ->
 377              type_list_of_record_type t1 (type_list_of_record_type t2 acc)
 378         | _ -> assert False ]
 379
 380       and expr_of_record_type t =
 381         let (ls, ts) = type_list_of_record_type t ([], []) in
 382         let mkp ps = <:patt< { $list:List.map2 (fun l p -> <:patt< $lid:l$ = $p$ >>) ls ps$ } >> in
 383         let mke es = <:expr< { $list:List.map2 (fun l e -> <:rec_binding< $lid:l$ = $e$ >>) ls es$ } >> in
 384         chain_tuple mkp mke expr_of_ty ts
 385
 386       and failure_match_case =
 387         <:match_case< $tuplify_patt (pxik 0)$ ->
 388                         o#$lid:sf "%s%d_failure" (string_of_mode mode) size$ $tuplify_expr (exik 0)$ >>
 389
 390       and complete_match_case mk t =
 391         match t with
 392         [ <:ctyp< $_$ | $_$ >> when size > 1 ->
 393             <:match_case< $mk t$ | $failure_match_case$ >>
 394         | _ -> mk t ]
 395
 396       and fun_of_ctyp tyid =
 397         fun
 398         [ <:ctyp< [ $t$ ] >> ->
 399             <:expr< fun [ $complete_match_case match_case_of_sum_type t$ ] >>
 400         | <:ctyp< { $t$ } >> ->
 401             <:expr< fun [ $expr_of_record_type t$ ] >>
 402         | <:ctyp< ( $tup:t$ ) >> -> mk_tuple expr_of_ty t
 403         | <:ctyp< $lid:i$ >> when i = tyid -> default_expr
 404         | <:ctyp< $_$ $_$ >> | <:ctyp< $_$ -> $_$ >> | <:ctyp< '$_$ >> | <:ctyp< $id:_$ >> as t ->
 405             expr_of_ty None t
 406         | <:ctyp<>> ->
 407             expr_of_ty None <:ctyp< unknown >>
 408         | <:ctyp< [ = $t$ ] >> | <:ctyp< [ < $t$ ] >> | <:ctyp< private [ < $t$ ] >> ->
 409             <:expr< fun [ $complete_match_case match_case_of_poly_sum_type t$ ] >>
 410         | <:ctyp< [ > $t$ ] >> | <:ctyp< private [ > $t$ ] >> ->
 411             if size > 1 then
 412               <:expr< fun [ $complete_match_case match_case_of_poly_sum_type t$ ] >>
 413             else
 414               <:expr< fun [ $match_case_of_poly_sum_type t$ | $default_match_case$ ] >>
 415         | _ -> assert False ]
 416
 417       and string_of_type_param t =
 418         match t with
 419         [ <:ctyp< '$s$ >> | <:ctyp< +'$s$ >> | <:ctyp< -'$s$ >> -> s
 420         | _ -> assert False ]
 421
 422       and method_of_type_decl _ ((id1, _, params, ctyp, priv) as type_decl) acc =
 423         let rec lambda acc =
 424           fun
 425           [ [] -> acc
 426           | [ x :: xs ] -> lambda <:expr< fun $lid:"_f_" ^ x$ -> $acc$ >> xs ] in
 427         let params' = List.map string_of_type_param params in
 428         let funs = lambda (fun_of_ctyp id1 ctyp) params' in
 429         let ty = method_type_of_type_decl type_decl in
 430         let priv = if priv then Ast.BTrue else Ast.BFalse in
 431         <:class_str_item< method $private:priv$ $lid:id1$ : $ty$ = $funs$; $acc$ >>
 432
 433       and ctyp_name_of_name_params name params =
 434         apply_ctyp <:ctyp< $id:name$ >> params
 435
 436       and method_type_of_type_decl (_, name, params, ctyp, _) =
 437         let t = ctyp_name_of_name_params name params in
 438         if mode = Map && not (contains_unknown ctyp) then
 439           let out_params = List.map (fun [ <:ctyp< '$i$ >> -> <:ctyp< '$i^"_out"$ >> | _ -> assert False ]) params in
 440           let t_out = ctyp_name_of_name_params name out_params in
 441           method_type_of_type t t_out params out_params
 442         else
 443           method_type_of_type t t params []
 444
 445       and method_type_of_type t_in t_out params_in params_out =
 446         let rt t =
 447           match mode with
 448           [ Fold_map -> <:ctyp< ('self_type * $t$) >>
 449           | Fold     -> <:ctyp< 'self_type >>
 450           | Map      -> t ]
 451         in
 452         match (params_in, params_out) with
 453         [ ([param_in], [param_out]) ->
 454             let alphas = tuplify_type param_in in
 455             <:ctyp< ! $param_in$ $param_out$ . ('self_type -> $alphas$ -> $rt param_out$) -> $tuplify_type t_in$ -> $rt t_out$ >>
 456         | ([param], []) ->
 457             let alphas = tuplify_type param in
 458             <:ctyp< ! $param$ . ('self_type -> $alphas$ -> $rt param$) -> $tuplify_type t_in$ -> $rt t_out$ >>
 459         | ([], []) ->
 460             <:ctyp< $tuplify_type t_in$ -> $rt t_out$ >>
 461         | _ ->
 462             let i = List.length params_in in
 463             failwith (Printf.sprintf
 464                   "Camlp4FoldGenerator: FIXME not implemented for types with %d parameters" i) ]
 465
 466       and class_sig_item_of_type_decl _ ((name, _, _, t, _) as type_decl) acc =
 467         let (_ : < .. >) =
 468           object (self)
 469             inherit Ast.fold as super;
 470             method ctyp =
 471               fun
 472               [ <:ctyp< $lid:id$ >> -> let () = store_if_builtin_type id in self
 473               | t -> super#ctyp t ];
 474           end#ctyp t
 475         in
 476         <:class_sig_item<
 477            method $lid:name$ : $method_type_of_type_decl type_decl$;
 478            $acc$ >>
 479
 480       and generate_structure tyMap =
 481         StringMap.fold method_of_type_decl used_builtins.val
 482           (StringMap.fold method_of_type_decl tyMap <:class_str_item<>>)
 483
 484       and generate_signature tyMap =
 485         StringMap.fold class_sig_item_of_type_decl used_builtins.val
 486           (StringMap.fold class_sig_item_of_type_decl tyMap <:class_sig_item<>>);
 487
 488   end;
 489
 490   value rec tyMap_of_type_decls t acc =
 491     match t with
 492     [ <:ctyp<>> -> acc
 493     | <:ctyp< $t1$ and $t2$ >> ->
 494         tyMap_of_type_decls t1 (tyMap_of_type_decls t2 acc)
 495     | Ast.TyDcl _ name tl tk _ ->
 496         StringMap.add name (name, <:ident< $lid:name$ >>, tl, tk, False) acc
 497     | _ -> assert False ];
 498
 499   value generate_class_implem mode c tydcl n =
 500     let tyMap = tyMap_of_type_decls tydcl StringMap.empty in
 501     let module M = Gen(struct value size = n; value mode = mode; end) in
 502     let generated = M.generate_structure tyMap in
 503     let gen_type =
 504       <:ctyp< ! 'a 'b . $M.method_type_of_type <:ctyp< 'a >> <:ctyp< 'b >> [] []$ >>
 505     in
 506     let failure =
 507       if n > 1 then
 508         let name = string_of_mode mode in
 509         <:class_str_item< method $lid:sf "%s%d_failure" name n$ : $gen_type$ =
 510                             fun $M.tuplify_patt (pxik 0)$ ->
 511                               failwith $`str:sf "%s%d_failure: default implementation" name n$ >>
 512       else <:class_str_item<>>
 513     in
 514     let gen_type =
 515       <:ctyp< ! 'a . $M.method_type_of_type <:ctyp< 'a >> <:ctyp< 'a >> [] []$ >>
 516     in
 517     let unknown =
 518       <:class_str_item< method unknown : $gen_type$ = $M.default_expr$ >>
 519     in
 520     <:str_item< class $lid:c$ = object (o : 'self_type) $generated$; $failure$; $unknown$ end >>;
 521
 522   value generate_class_interf mode c tydcl n =
 523     let tyMap = tyMap_of_type_decls tydcl StringMap.empty in
 524     let module M = Gen(struct value size = n; value mode = mode; end) in
 525     let generated = M.generate_signature tyMap in
 526     let gen_type =
 527       <:ctyp< ! 'a 'b . $M.method_type_of_type <:ctyp< 'a >> <:ctyp< 'b >> [] []$ >>
 528     in
 529     let failure =
 530       if n > 1 then
 531         let name = string_of_mode mode in
 532         <:class_sig_item< method $lid:sf "%s%d_failure" name n$ : $gen_type$ >>
 533       else <:class_sig_item<>>
 534     in
 535     let gen_type =
 536       <:ctyp< ! 'a . $M.method_type_of_type <:ctyp< 'a >> <:ctyp< 'a >> [] []$ >>
 537     in
 538     let unknown =
 539       <:class_sig_item< method unknown : $gen_type$ >>
 540     in
 541     <:sig_item< class $lid:c$ : object ('self_type) $generated$; $failure$; $unknown$ end >>;
 542
 543   value processor =
 544     let last = ref <:ctyp<>> in
 545     let generate_class' generator default c s n =
 546       match s with
 547       [ "Fold"    -> generator Fold c last.val n
 548       | "Map"     -> generator Map c last.val n
 549       | "FoldMap" -> generator Fold_map c last.val n
 550       | _ -> default ]
 551     in
 552     let generate_class_from_module_name generator c default m =
 553       try Scanf.sscanf m "Camlp4%[^G]Generator" begin fun m' ->
 554         try Scanf.sscanf m' "%[^0-9]%d" (generate_class' generator default c)
 555         with [ End_of_file | Scanf.Scan_failure _ -> generate_class' generator default c m' 1 ]
 556       end with [ End_of_file | Scanf.Scan_failure _ -> default ]
 557     in
 558     object (self)
 559       inherit Ast.map as super;
 560
 561       method str_item st =
 562         match st with
 563         [ <:str_item< type $t$ >> -> (last.val := t; st)
 564
 565         (* backward compatibility *)
 566         | <:str_item@_loc< class $lid:c$ = Camlp4Filters.GenerateFold.generated >> ->
 567               generate_class_implem Fold c last.val 1
 568         | <:str_item@_loc< class $lid:c$ = Camlp4Filters.GenerateMap.generated >> ->
 569               generate_class_implem Map c last.val 1
 570
 571         (* Handle Camlp4(Fold|Map|FoldMap)\d*Generator *)
 572         | <:str_item@_loc< class $lid:c$ = $uid:m$.generated >> ->
 573               generate_class_from_module_name generate_class_implem c st m
 574
 575         (* It's a hack to force to recurse on the left to right order *)
 576         | <:str_item< $st1$; $st2$ >> ->
 577              let st1 = self#str_item st1 in
 578               <:str_item< $st1$; $self#str_item st2$ >>
 579
 580         | st -> super#str_item st ];
 581
 582       method sig_item sg =
 583         match sg with
 584         [ <:sig_item< type $t$ >> -> (last.val := t; sg)
 585
 586         (* backward compatibility *)
 587         | <:sig_item@_loc< class $lid:c$ : Camlp4Filters.GenerateFold.generated >> ->
 588              generate_class_interf Fold c last.val 1
 589         | <:sig_item@_loc< class $lid:c$ : Camlp4Filters.GenerateMap.generated >> ->
 590              generate_class_interf Map c last.val 1
 591
 592         (* Handle Camlp4(Fold|Map|FoldMap)\d*Generator *)
 593         | <:sig_item@_loc< class $lid:c$ : $uid:m$.generated >> ->
 594             generate_class_from_module_name generate_class_interf c sg m
 595
 596         (* It's a hack to force to recurse on the left to right order *)
 597         | <:sig_item< $sg1$; $sg2$ >> ->
 598              let sg1 = self#sig_item sg1 in
 599               <:sig_item< $sg1$; $self#sig_item sg2$ >>
 600
 601         | sg -> super#sig_item sg ];
 602     end;
 603
 604   register_str_item_filter processor#str_item;
 605   register_sig_item_filter processor#sig_item;
 606
 607 end;
 608
 609 let module M = Camlp4.Register.AstFilter Id Make in ();