camlspotter avatar camlspotter committed b5b508d

ocaml typing bug workaround + labels

Comments (0)

Files changed (1)

         ancs
       in
       Format.eprintf "class dependency %s : %s@." k (String.concat " " parents);
-      Hashtbl.add tbl k parents
+      Hashtbl.add tbl k (parents, ancs)
     ) ancestors;
     tbl
 
         incr cntr;
         TyQuo(_loc, Printf.sprintf "x%d" !cntr) (* No ' required! *)
     in
-    let rec map with_as = function
+    let rec map with_as ctyp =
+      match ctyp with
       | TyNil _ -> ctyp
       | TyAny _ -> assert false
       | TyAli (loc, ct1, ct2) -> TyAli (loc, map true ct1, ct2)
       | TyQuM _ -> ctyp
       | TyVrn _ -> ctyp
       | TyRec _ -> assert false
-      | TyCol _ -> 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
     in
     nuv (f ctyp)
 
+  let quantify 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 tv = mk_tyvar pos in
           (* Strange, but < $ctyp$ : $ctyp$; ..> *)
           let oty = TyAli(_loc, <:ctyp< < $lid:clsname$ : $lid:clsname$ t ; .. > >>, tv) in
-          <:expr< option_bind $v$ (fun x -> x# $clsname$) >>,
+          <:expr< option_map $v$ (fun x -> x# $clsname$) >>,
           Some tv,
           recover_label <:ctyp< $oty$ option >>
  
           (fun e -> <:expr< ! $lid: "new_" ^ class_name clsname$ $e$ >>), 
           <:ctyp@tyloc< $id: m_class_ident clsname$ >>
       | <:ctyp@tyloc< Type.$lid:clsname$ Type.t option >> ->
-          (fun e -> <:expr< option_bind $e$ (! $lid: "new_" ^ class_name clsname$) >>), 
+          (fun e -> <:expr< option_map $e$ (! $lid: "new_" ^ class_name clsname$) >>), 
           <:ctyp@tyloc< $id: m_class_ident clsname $ option >>
       | _ -> (fun e -> e), ty
     ;;
       let rec args pos = function
         | <:ctyp< $argty$ -> $ty$ >> ->
 
+            let recover_label, add_pat_label, add_exp_label, argty =
+              match argty with
+              | TyLab (_, lab, argty) -> 
+                  (fun ty -> TyLab (_loc, lab, ty)), 
+                  (fun p -> PaLab (_loc, lab, p)),
+                  (fun e -> ExLab (_loc, lab, e)),
+                  argty
+              | TyOlb (_, lab, argty) -> 
+                  (fun ty -> TyOlb (_loc, lab, ty)), 
+                  (fun p -> PaOlb (_loc, lab, p)),
+                  (fun e -> ExOlb (_loc, lab, e)),
+                  argty
+              | _ -> 
+                  let id x = x in id, id, id, argty
+            in
+
             let qvars, mty, absts, args, mk_return = args (pos+1) ty in
             
             let v = <:expr<$lid:mk_id pos$>> in
-            let pat = mk_id pos in
+
+            let pat = add_pat_label <:patt< $lid:mk_id pos$ >> in
             let e, qv_opt, oty = wrap_in pos v argty in
+            let e = add_exp_label e in
+            let oty = recover_label oty in
 
             let absts = pat :: absts in
             let args = e :: args in
       in
       let rec mk_abst b = function
         | [] -> b
-        | v::vs -> <:expr< fun $lid:v$ -> $mk_abst b vs$ >>
+        | v::vs -> <:expr< fun $v$ -> $mk_abst b vs$ >>
       in
-      q mty qvars, mk_abst (mk_return (mk_app base args)) absts
+      quantify (q mty qvars), mk_abst (mk_return (mk_app base args)) absts
 
   end
   (*  open A *)
       in
        
       let inherits = 
-        let inherits = try Hashtbl.find class_dep_graph tyname with _ -> [] in
+        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))
           | _ -> assert false) methods
         in
         let init = 
-          let inherits = try Hashtbl.find class_dep_graph tyname with _ -> [] in
+          (* 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))
     let sitem = ref <:str_item<>> in
 
     (* simple topo sort *)
+    (* CR jfuruse: generalize *)
     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 parents, _ = Hashtbl.find graph s in
           let visited, st = visits vst parents in
           let st' = f st s in
           (s::visited, st')
 
     <:str_item< 
       open Type;;
+      module Type = Type;;
       module Py = Api.Py;;
+      let option_map v f = match v with 
+        | Some v -> Some (f v)
+        | None -> None
+      ;;
       $mutual_class_types$
       $news$ 
       $!sitem$ 
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.