1. camlspotter
  2. opycaml

Commits

camlspotter  committed 30d1041

topo visit

  • Participants
  • Parent commits 107228f
  • Branches dev

Comments (0)

Files changed (1)

File oowrap/oowrap.ml

View file
  • Ignore whitespace
 
   let build class_dep_graph modules =
     Hashtbl.fold (fun modname name_typ_list (clses, st) ->
-          let tyname = "_" ^ modname in
-          let clsname = "o" ^ tyname in
-          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 -> 
-                      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
-          begin 
-            let init = 
-              let inherits = try 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< method $tyname$ = (t :> $lid:tyname$ t) >> inherits
-            in
+      (* common names *)
+      let tyname = "_" ^ modname in
+      let clsname = "o" ^ tyname in
 
-            let method_sigs = List.map (function
-              | <:class_str_item< method $name$ : $polytype$ = $_$ >> ->
-                  <:class_sig_item< method $name$ : $polytype$ >>
-              | _ -> assert false) methods
-            in
-            let method_sigs = 
-              let init = 
-                let inherits = try 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$ : $lid:tyname$ t >> inherits
-              in
-              List.fold_left (fun st x -> CgSem(_loc, st, x)) init method_sigs 
-            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 -> 
+                  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 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 methods = List.fold_left (fun st x -> CrSem(_loc, st, x)) init methods in
-            let sitem = <:str_item< class $lid:clsname$ t : M.$lid:clsname$ = object $methods$ end >> in
+      let unwrap = <:class_str_item< method $tyname$ = (t :> Api.$lid:tyname$ Api.t) >> in
 
-            let cltype = CtEq(_loc, 
-                              CtCon(_loc, ViNil, <:ident< $lid:clsname$ >>, <:ctyp<>>),
-                              <:class_type< object $method_sigs$ end >>) in
-            (tyname, sitem, cltype) :: clses
-          end,
-          <:str_item< $st$ module $modname$ = struct $sitems$ end >> ) modules ([], <:str_item<>>)
+      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 = 
+          let inherits = try 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 >> 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 $sitems$ end >>
+      ) ) modules ([], <:str_item<>>)
 
   let build class_dep_graph modules =
     let clses, st = build class_dep_graph modules in
 
     let sitem = ref <:str_item<>> in
 
-    let print_class tyname =  (* CR jfuruse: we must recursively check the parents! *)
-      try
-        let (i, _) = Hashtbl.find tbl tyname in
-        sitem := <:str_item< $!sitem$ $i$ >>;
-        Hashtbl.remove tbl tyname (* done *)
-      with
-      | Not_found -> () (* already done *)
+    (* simple topo sort *)
+    let topo_fold f init graph =
+      let rec visit ((visited, _) as vst) s =
+        if List.mem s visited then vst
+        else
+          let parents = Hashtbl.find graph s in
+          let visited, st = visits vst parents 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) (Hashtbl.fold (fun k _ st -> k::st) graph []))
+    in
+
+    let print_class tyname =
+      let (i, _) = Hashtbl.find tbl tyname in
+      sitem := <:str_item< $!sitem$ $i$ >>;
     in
     
-    List.iter (fun (tyname, _sitem, _clsty) ->
-      let parents = try Hashtbl.find class_dep_graph tyname with _ -> [] in
-      List.iter print_class parents;
-      print_class tyname) clses;
+    topo_fold (fun () tyname -> print_class tyname) () class_dep_graph;
 
     <:str_item< 
       open Type;;