Commits

camlspotter committed 80384fd

vars

Comments (0)

Files changed (1)

       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 = function
+      | 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 _ -> assert false
+      | 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
+    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
+    in
+    nuv (f ctyp)
+
   module A = struct (* Dirty part *)
 
     let class_name s = "o" ^ s
 
     (* [> _Cls ] t -> ...   =>    _Cls -> ... *)
     let wrap_in pos v ty =
+
+      (* escape label *)
+      let ty, recover_label = 
+        match ty with
+        | TyLab(loc, name, ty) -> ty, fun ty -> TyLab(loc, name, ty)
+        | TyOlb(loc, name, ty) -> ty, fun ty -> TyOlb(loc, name, ty)
+        | _ -> ty, fun ty -> ty
+      in
+
       match ty with
       | <:ctyp< [ > Type.$lid:clsname$ ] Type.t >> -> 
           let tv = mk_tyvar pos in
           let oty = TyAli(_loc, <:ctyp< < $lid:clsname$ : $lid:clsname$ t ; .. > >>, tv) in
           <:expr< $v$ # $clsname$ >>,
           Some tv,
-          oty
+          recover_label oty
 
       | <:ctyp< [ > Type.$lid:clsname$ ] Type.t option >> -> 
           let tv = mk_tyvar pos in
           let oty = TyAli(_loc, <:ctyp< < $lid:clsname$ : $lid:clsname$ t ; .. > >>, tv) in
           <:expr< option_bind $v$ (fun x -> x# $clsname$) >>,
           Some tv,
-          <:ctyp< $oty$ option >>
-            
-      | _ -> v, None, ty
+          recover_label <:ctyp< $oty$ option >>
+ 
+      | _ -> 
+          v, None, ty
     ;;
 
     (* ... -> _Cls t   =>   ... -> _Cls *)