Source

opycaml / oowrap / oowrap.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
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
module Id = struct
  let name = "oowrap"
  let version = "1.0"
end

open Camlp4
open PreCast

(* See P4 filter tutorial at
   http://ambassadortothecomputers.blogspot.com/2010/03/reading-camlp4-part-5-filters.html
   http://brion.inria.fr/gallium/index.php/Camlp4MapGenerator
*)

module Topo_fold(G : sig
  type t
  type node (* comparison by (=) *)
  val edges : t -> node -> node list
  val nodes : t -> node list
end) : sig

  val topo_fold : ('a -> G.node -> 'a) -> 'a -> G.t -> 'a
  (** simple topo sort, from leaves *)

end = struct 

  (* simple topo sort, from leaves *)
  let topo_fold f init graph =
    let rec visit ((visited, _) as vst) s =
      if List.mem s visited then vst
      else
        let edges = G.edges graph s in
        let visited, st = visits vst edges in
        let st' = f st s in
        (s::visited, st')
    and visits vst ss = List.fold_left (fun vst p -> visit vst p) vst ss
    in
    snd (visits ([], init) (G.nodes graph))

end

module Make (AstFilters : Sig.AstFilters) = struct
  open AstFilters
  open Ast

  (* Actually the AST is the same type, but the fact is not known to the type system.... *)
  let print_str_item (sitem : str_item) = Register.CurrentPrinter.print_implem (Obj.magic sitem)

  let _loc = Loc.ghost

  let rec iter_sig_item ~f = function
    | SgNil _ -> ()
    | SgSem (_, sig_item1, sig_item2) -> iter_sig_item ~f sig_item1; iter_sig_item ~f sig_item2
    | sig_item -> f <:sig_item< $sig_item$ >>

  let rec fold_sig_item ~f ~init = function
    | SgNil _ -> init
    | SgSem (_, sig_item1, sig_item2) ->
        let st = fold_sig_item ~f ~init sig_item1 in
        fold_sig_item ~f ~init:st sig_item2
    | sig_item -> f init <:sig_item< $sig_item$ >>

  let rec get_polyvariants = function
    | <:ctyp< $t1$ | $t2$ >> -> get_polyvariants t1 @ get_polyvariants t2
    | <:ctyp< `$v$ >> -> [v]
    | _ -> []

  (* CR jfuruse: depend *)
  let type_path_normalize = function
    | <:ident< Type.$lid:name$ >> -> <:ident< $lid:name$ >>
    | id-> id

  (* Get class type encoding *)
  let class_type =
    let extract k varpath typath =
      (* CR jfuruse: depend *)
      let normalize_path p = match type_path_normalize p with
        | <:ident< $lid:name$ >> -> Some name
        | _ -> None
      in
      match normalize_path varpath, normalize_path typath with
      | Some varpath, Some "t" -> Some (k, varpath)
      | _ -> None
    in
    function
    | <:ctyp< [> $id:varpath$ ] $id:typath$ >> -> extract `Bigger varpath typath
    | <:ctyp< $id:varpath$ $id:typath$ >> -> extract `Equal varpath typath
    | _ -> None

  (* test *)
  let _ =
    assert (class_type <:ctyp< [> _Object ] t >> = Some (`Bigger, "_Object"));
    assert (class_type <:ctyp< _Object Type.t >> = Some (`Equal, "_Object"))
    assert (class_type <:ctyp< Type._Object Type.t >> = Some (`Equal, "_Object"))
  ;;

  module DepGraph = struct
    module G = struct
      type node = string
      type t = (node, (node list * node list)) Hashtbl.t (* parents, and ancestors *)
      let edges g n = fst (Hashtbl.find g n)
      let nodes g = Hashtbl.fold (fun k _ st -> k :: st) g []
    end
    include G
    include Topo_fold(G)
  end

  (* Obtain class dependencies encoded as poly-variant type definitions in the top sig *)
  let get_class_dep_graph sig_item =
    let ancestors =
      let tbl = Hashtbl.create 107 in
      iter_sig_item sig_item ~f:(function
        | <:sig_item< type $lid:name$ = [ $tyors$ ] >> ->
              prerr_endline ("found class dependency " ^ name);
              let variants = get_polyvariants tyors in
              (* remove self to create ancestors *)
              let ancestors = List.filter (fun x -> x <> name) variants in
              Hashtbl.add tbl name ancestors
        | _ -> ());
      tbl
    in
    let is_ancestor_of a k = List.mem a (try Hashtbl.find ancestors k with Not_found -> assert false) in

    (* create direct parent relationship from [ancestors] *)
    let tbl : DepGraph.t = Hashtbl.create 107 in
    Hashtbl.iter (fun k ancs ->
      (* direct parents are ancestors which are not ancestors of other ancestors *)
      let parents = List.filter (fun anc ->
        List.for_all (fun anc' -> not (is_ancestor_of anc anc')) ancs)
        ancs
      in
      Format.eprintf "class dependency %s : %s@." k (String.concat " " parents);
      Hashtbl.add tbl k (parents, ancs)
    ) ancestors;
    tbl

  (* CR jfuruse: depend *)      
  let check_rev_path classes rev_path =
    let path = List.rev rev_path in
    match path with
    | [ "Py"; s ] when List.mem ("_" ^ s) classes -> true ,s
    | _ -> false, "NOPE!"

  let extract_vals classes sig_item =
    let vals = ref [] in
    let rec visit rev_path sig_item =
      let register, mname = check_rev_path classes rev_path in
      iter_sig_item sig_item ~f:(function
        | <:sig_item< external $name$ : $typ$ = $_$ >> when register ->
            Format.eprintf "%s : val %s (external)@." mname name;
            vals := (mname, name, typ) :: !vals
        | <:sig_item< val $name$ : $typ$ >> when register ->
            Format.eprintf "%s : val %s@." (String.concat "." (List.rev rev_path)) name;
            vals := (mname, name, typ) :: !vals
        | <:sig_item< module $name$ : $ MtSig(_, sig_item) $ >> ->
            let rev_path = name :: rev_path in
            visit rev_path sig_item
        | _ -> ())
    in
    visit [] sig_item;

    let modules = Hashtbl.create 107 in
    List.iter (fun cls ->
      let cls = String.sub cls 1 (String.length cls - 1) in (* remove the prefix '_' *)
      Hashtbl.replace modules cls []) classes;
    let hashtbl_add_in_list tbl k v =
      let vs = try Hashtbl.find tbl k with Not_found -> [] in
      Hashtbl.replace tbl k (v::vs)
    in
    List.iter (fun (mname, name, typ) ->
      hashtbl_add_in_list modules mname (name, typ)) !vals;
    modules

  (* Explicitly annotate tvars with open polymorphic types *)
  let annotate_tvars ctyp =
    let new_tvar =
      let cntr = ref 0 in
      fun () ->
        incr cntr;
        TyQuo(_loc, Printf.sprintf "x%d" !cntr) (* No ' required! *)
    in
    let rec map with_as ctyp =
      match ctyp with
      | TyNil _ -> ctyp
      | TyAny _ -> assert false
      | TyAli (loc, ct1, ct2) -> TyAli (loc, map true ct1, ct2)
      | TyApp (loc, ct1, ct2) -> TyApp (loc, map false ct1, map false ct2)
      | TyArr (loc, ct1, ct2) -> TyArr (loc, map false ct1, map false ct2)
      | TyCls (_loc, _ident) -> assert false
      | TyLab (loc, lab, ct) -> TyLab (loc, lab, map false ct)
      | TyId _ -> ctyp
      | TyMan _ -> assert false
      | TyDcl _ -> assert false
      | TyObj (loc, ctyp, RvRowVar) when not with_as ->
          TyAli (_loc, TyObj (loc, map false ctyp, RvRowVar), new_tvar ())
      | TyObj (loc, ctyp, rvf) -> TyObj (loc, map false ctyp, rvf)
      | TyOlb (loc, lab, ct) -> TyOlb (loc, lab, map false ct)
      | TyPol (loc, ct1, ct2) -> TyPol (loc, ct1, map false ct2)
      | TyQuo _ -> ctyp
      | TyQuP _ -> ctyp
      | TyQuM _ -> ctyp
      | TyVrn _ -> ctyp
      | TyRec _ -> assert false
      | TyCol (loc, l, ct) -> TyCol (loc, l, map false ct)
      | TySem (loc, ct1, ct2) -> TySem (loc, map false ct1, map false ct2)
      | TyCom (loc, ct1, ct2) -> TyCom (loc, map false ct1, map false ct2)
      | TySum _ -> assert false
      | TyOf _ -> assert false
      | TyAnd _ -> assert false
      | TyOr (loc, ct1, ct2) -> TyOr (loc, map false ct1, map false ct2)
      | TyPrv _ -> assert false
      | TyMut _ -> assert false
      | TyTup (loc, ctyp) -> TyTup (loc, map false ctyp)
      | TySta (loc, ct1, ct2) -> TySta (loc, map false ct1, map false ct2)
      | TyVrnEq (loc, ctyp) -> TyVrnEq (loc, map false ctyp)
      | TyVrnSup (loc, ctyp) when not with_as ->
          TyAli (_loc, TyVrnSup (loc, map false ctyp), new_tvar ())
      | TyVrnSup (loc, ctyp) -> TyVrnSup (loc, map false ctyp)
      | TyVrnInf (loc, ctyp) when not with_as ->
          TyAli (_loc, TyVrnInf (loc, map false ctyp), new_tvar ())
      | TyVrnInf (loc, ctyp) -> TyVrnInf (loc, map false ctyp)
      | TyVrnInfSup (loc, ct1, ct2) when not with_as ->
          TyAli (_loc, TyVrnInfSup (loc, map false ct1, map false ct2), new_tvar ())
      | TyVrnInfSup (loc, ct1, ct2) -> TyVrnInfSup (loc, map false ct1, map false ct2)

      | TyAmp (loc, ct1, ct2) -> TyAmp (loc, map false ct1, map false ct2)
      | TyOfAmp (loc, ct1, ct2) -> TyOfAmp (loc, map false ct1, map false ct2)
      | TyPkg _ -> ctyp
      | TyAnt _ -> assert false
      | _ -> assert false
    in
    map false ctyp

  (* roughly list up free tvars *)
  let free_tvars ctyp =
    let nuv xs =
      let rec nuv uniq = function
        | [] -> uniq
        | x::xs ->
            if List.mem x uniq then nuv uniq xs
            else nuv (x::uniq) xs
      in
      nuv [] xs
    in
    let rec f = function
      | TyNil _
      | TyId _
      | TyVrn _
      | TyPkg _ ->
          []
      | TyAny _ -> assert false
      | TyAli (_, ct1, ct2)
      | TyApp (_, ct1, ct2)
      | TyArr (_, ct1, ct2)
      | TySem (_, ct1, ct2)
      | TyCom (_, ct1, ct2)
      | TyOr (_, ct1, ct2)
      | TySta (_, ct1, ct2)
      | TyVrnInfSup (_, ct1, ct2)
      | TyAmp (_, ct1, ct2)
          -> f ct1 @ f ct2
      | TyCls _ -> assert false
      | TyLab (_, _, ct)
      | TyObj (_, ct, _)
      | TyOlb (_, _, ct)
      | TyCol (_, _, ct)
      | TyOf (_, _, ct)
      | TyPrv (_, ct)
      | TyMut (_, ct)
      | TyTup (_, ct)
      | TyVrnEq (_, ct)
      | TyVrnSup (_, ct)
      | TyVrnInf (_, ct)
      | TyOfAmp (_, _, ct)
        -> f ct
      | TyMan _ -> assert false
      | TyDcl _ -> assert false
      | TySum _ -> assert false
      | TyPol (_, ct1, ct2) ->
          let abs_tvars = f ct1 in
          List.filter (fun tv -> not (List.mem tv abs_tvars)) (f ct2)
      | TyQuo (_, name)
      | TyQuP (_, name)
      | TyQuM (_, name) -> [name]
      | TyRec _ -> assert false
      | TyAnd _ -> assert false
      | TyAnt _ -> assert false
      | _ -> assert false
    in
    nuv (f ctyp)

  let quantify_free_tvars cty =
    let acty = annotate_tvars cty in
    let fvars = free_tvars acty in
    if fvars = [] then acty
    else
      let rec qapp = function
        | [] -> assert false
        | [qv] -> TyQuo(_loc, qv)
        | qv::qvs -> TyApp(_loc, TyQuo(_loc, qv), qapp qvs) (* strange but it is as an app *)
      in
      TyPol (_loc, qapp fvars, acty)

  module A = struct (* Dirty part *)

    let class_name s = "o" ^ s
    let m_class_ident s : ident = <:ident< M. $lid: "o" ^ s $ >>

    let mk_id pos = Printf.sprintf "v%d" pos

    let mk_tyvar pos = TyQuo(_loc, Printf.sprintf "a%d" pos) (* No ' required! *)

    let extract_class_from_type = function
      | <:ctyp< [ > $id:clsname$ ] $id:t$ >> -> Some (`Bigger, clsname, t, None)
      | <:ctyp< [ > $id:clsname$ ] $id:t$ $id:container$ >> -> Some (`Bigger, clsname, t, Some container)
      | <:ctyp< $id:clsname$ $id:t$ >> -> Some (`Equal, clsname, t, None)
      | <:ctyp< $id:clsname$ $id:t$ $id:container$ >> -> Some (`Equal, clsname, t, Some container)
      | _ -> None

    let rec mk_mapper = function
      | <:ident< $lid:id$ >> -> <:ident< $lid: id ^ "_map"$ >>
      | <:ident< $id1$.$id2$ >> -> <:ident< $id1$.$ mk_mapper id2 $ >>
      | _ -> assert false

    (* [> _Cls ] t -> ...   =>    < _Cls : _Cls t; .. > -> ... *)
    (* ... -> [> _Cls ] t -> ...   =>    < _Cls : _Cls t; .. > -> ... 
       only when _ t occurs once
    *)
    let wrap_in v ty0 =

      (* escape label *)
      let ty, recover_label =
        match ty0 with
        | TyLab(loc, name, ty) -> ty, fun ty -> TyLab(loc, name, ty)
        | TyOlb(loc, name, ty) -> 
            <:ctyp< $ty$ option >>, 
            (fun ty -> 
              match ty with
              | <:ctyp< $ty$ option >> -> TyOlb(loc, name, ty)
              | _ -> assert false)
        | _ -> ty0, fun ty -> ty
      in

(*
      let extract_arg_type = function
        | <:ctyp< [ > $id:clsname$ ] $id:t$ >> -> Some (clsname, t, None)
        | <:ctyp< [ > $id:clsname$ ] $id:t$ $id:container$ >> -> Some (clsname, t, Some container)
        | _ -> None
      in
*)

      let normalize_arg_type ctyp = 
        match extract_class_from_type ctyp with
        | None | Some (`Equal, _, _, _) -> None
        | Some (`Bigger, clsname, t, container) ->
            let clsname = type_path_normalize clsname in
            let t = type_path_normalize t in
            match clsname, t with
            | <:ident< $lid:clsname$ >>, <:ident< t >> -> Some (clsname, container)
            | _ -> None
      in

      match normalize_arg_type ty with
      | None -> v, ty0
      | Some (clsname, None) ->
          let oty = recover_label <:ctyp< < $lid:clsname$ : $lid:clsname$ t ; .. > >> in
          <:expr< $v$ # $clsname$ >>, oty
      | Some (clsname, Some cont) ->
          let oty = recover_label <:ctyp< < $lid:clsname$ : $lid:clsname$ t ; .. > $id:cont$ >> in
          <:expr< $id:mk_mapper cont$ $v$ (fun x -> x# $clsname$) >>, oty
    ;;

    (* ... -> _Cls t   =>   ... -> _Cls *)
    let wrap_out ty =
      let normalize_arg_type ctyp =
        match extract_class_from_type ctyp with
        | None | Some (`Bigger, _, _, _) -> None
        | Some (`Equal, clsname, t, container) ->
            let clsname = type_path_normalize clsname in
            let t = type_path_normalize t in
            match clsname, t with
            | <:ident< $lid:clsname$ >>, <:ident< t >> -> Some (clsname, container)
            | _ -> None
      in
      match normalize_arg_type ty with
      | None -> (fun e -> e), ty
      | Some (clsname, None) ->
          (fun e -> <:expr< ! $lid: "new_" ^ class_name clsname$ $e$ >>),
          <:ctyp< $id: m_class_ident clsname$ >>

      | Some (clsname, Some cont) ->
          (fun e -> <:expr< $id: mk_mapper cont$ $e$ (! $lid: "new_" ^ class_name clsname$) >>),
          <:ctyp< $id: m_class_ident clsname $ $id: cont$ >>
    ;;

    let wrap_oo base ty =

      let rec args pos = function
        | <:ctyp< $argty$ -> $ty$ >> ->

            (* CR jfuruse: Should move to wrap_in *)
            let add_pat_label, add_exp_label =
              match argty with
              | TyLab (_, lab, _argty) ->
                  (fun p -> PaLab (_loc, lab, p)),
                  (fun e -> ExLab (_loc, lab, e))
              | TyOlb (_, lab, _argty) ->
                  (fun p -> PaOlb (_loc, lab, p)),
                  (fun e -> ExOlb (_loc, lab, e))
              | _ -> let id x = x in id, id
            in

            let mty, absts, args, mk_return = args (pos+1) ty in

            let v = <:expr<$lid:mk_id pos$>> in

            let pat = add_pat_label <:patt< $lid:mk_id pos$ >> in
            let e, oty = wrap_in v argty in
            let e = add_exp_label e in

            let absts = pat :: absts in
            let args = e :: args in

            let mty = <:ctyp< $oty$ -> $mty$ >> in

            mty, absts, args, mk_return

        | mty ->
            let mk_return, mty = wrap_out mty in
            mty, [], [], mk_return
      in
      let mty, absts, args, mk_return = args 0 ty in (* X *)
      let rec mk_app b = function
        | [] -> b
        | e::es -> mk_app <:expr< $b$ $e$ >> es
      in
      let rec mk_abst b = function
        | [] -> b
        | v::vs -> <:expr< fun $v$ -> $mk_abst b vs$ >>
      in
      quantify_free_tvars mty, mk_abst (mk_return (mk_app base args)) absts

  end
  (*  open A *)

  let build class_dep_graph modules =
    Hashtbl.fold (fun modname name_typ_list (clses, st) ->
      (* common names *)
      let tyname = "_" ^ modname in
      let clsname = "o" ^ tyname in

      (* Create non-methods and methods *)
      let sitems, methods =
        List.fold_left (fun (st, methods) (name, typ) ->
          match typ with
          | <:ctyp<  $arg$ -> $typ'$  >> ->
              begin match class_type arg with
              | Some (`Bigger, tyname') when tyname' = tyname -> (* Make it a method! *)
                  let polytype, exp = A.wrap_oo <:expr< Py.$uid:modname$.$lid:name$ t >> typ' in
                  st, <:class_str_item< method $name$ : $polytype$ = $exp$ >> :: methods
              | _ ->
                  let polytype, exp = A.wrap_oo <:expr< Py.$uid:modname$.$lid:name$ >> typ in
                  <:str_item<  let $lid:name$ : $polytype$ = $exp$ ;; $st$ >>, methods
              end
          | _ -> st, methods
        ) (<:str_item<>>, [])  name_typ_list
      in

      let inherits =
        let inherits = try fst (Hashtbl.find class_dep_graph tyname) with _ -> [] in
        List.fold_left (fun st x ->
          let ox = "o" ^ x in
          CrSem(_loc, <:class_str_item< inherit $lid:ox$ t >>, st))
          <:class_str_item<>>
          inherits
      in

      let unwrap = <:class_str_item< method $tyname$ = (t :> Api.$lid:tyname$ Api.t) >> in

      let method_sigs =
        let method_sigs = List.map (function
          | <:class_str_item< method $name$ : $polytype$ = $_$ >> ->
            <:class_sig_item< method $name$ : $polytype$ >>
          | _ -> assert false) methods
        in
        let init =
          (* To avoid OCaml mututal recursive module + inheritance bug,
             it includes all the ancestors.  *)
          let inherits = try snd (Hashtbl.find class_dep_graph tyname) with _ -> [] in
          List.fold_left (fun st x ->
            let ox = "o" ^ x in
            CgSem(_loc, <:class_sig_item< inherit M.$lid:ox$ >>, st))
          <:class_sig_item< method $tyname$ : Api.$lid:tyname$ Api.t >> inherits
        in
        List.fold_left (fun st x -> CgSem(_loc, st, x)) init method_sigs
      in

      let methods = List.fold_left (fun st x -> CrSem(_loc, st, x)) <:class_str_item<>> methods in
      let sitem =
        <:str_item<
           class $lid:clsname$ t : M.$lid:clsname$ = object
               $inherits$
               $unwrap$
               $methods$
           end
           let _ = $lid: "new_" ^ clsname$ := new $lid:clsname$
        >>
      in

      let cltype = CtEq(_loc,
                        CtCon(_loc, ViNil, <:ident< $lid:clsname$ >>, <:ctyp<>>),
                        <:class_type< object $method_sigs$ end >>)
      in

      (
        (tyname, sitem, cltype) :: clses,

        <:str_item<
          $st$
          module $modname$ = struct
            open Open (* To avoid name space collisions with Python's Type module *)
            $sitems$
          end
        >>
      ) ) modules ([], <:str_item<>>)

  let build class_dep_graph modules =
    let clses, st = build class_dep_graph modules in

    let news =
      List.fold_left (fun st (tyname, _, _) ->
        <:str_item<
            $st$
            let $lid: "new_o" ^ tyname$ : ( $lid:tyname$ t -> M.$lid: "o" ^ tyname$ ) ref = ref (fun _ -> assert false) >>) <:str_item<>> clses
    in

    (* create structure of classes in the order of dependency *)

    let tbl = Hashtbl.create 107 in
    List.iter (fun (tyname, sitem, cltype) -> Hashtbl.add tbl tyname (sitem, cltype)) clses;

    let mutual_class_types =
      let rec concat = function
        | [] -> raise Not_found
        | [x] -> x
        | x::xs -> CtAnd(_loc, x, concat xs)
      in
      let cltype = concat (List.map (fun (_,_,cltype) -> cltype) clses) in
      try
        <:str_item< module rec M : sig class type $cltype$ end = M >>
      with
      | Not_found -> <:str_item< module rec M : sig end = M >>
    in

    let print_class st tyname =
      let (i, _) = Hashtbl.find tbl tyname in
      <:str_item< $st$ $i$ >>
    in

    let classes = DepGraph.topo_fold print_class <:str_item<>> class_dep_graph in 

    <:str_item<
      open Type;;
      module Open = struct module Type = Type end (* To avoid name space collisions with Python's Type module *)
      module Py = Api.Py;;
      let option_map v f = match v with
        | Some v -> Some (f v)
        | None -> None
      ;;
      let list_map v f = List.map f v
      ;;
      $mutual_class_types$
      $news$
      $classes$
      $st$
    >>

  let wrap_sig_item sig_item =
    let class_dep_graph = get_class_dep_graph sig_item in
    let classes = Hashtbl.fold (fun k _ st -> k::st) class_dep_graph [] in
    let modules = extract_vals classes sig_item in
    build class_dep_graph modules

  let wrap = object
    inherit Ast.map as _super

    method !sig_item sig_item =
      let str_item = wrap_sig_item sig_item in
      (* A hack to print out implementation, in an intf filter *)
      print_str_item str_item;
      <:sig_item< >>
  end

  let _ = AstFilters.register_sig_item_filter wrap#sig_item
end

let module M = Register.AstFilter(Id)(Make) in ()