Commits

camlspotter committed 8ae1b97

tyloc for typetexp

  • Participants
  • Parent commits 8c5cd3f
  • Branches custom

Comments (0)

Files changed (4)

File typing/ctype.ml

 (* Re-export repr *)
 let repr = repr
 
+(* Type constructor introduction location *)
+let copy_with_loc loc ty = 
+  (* Adding a location to a type must dupe the type!
+     Otherwise one [copy_with_loc loc <int>] to <int> changes all the <int>s with [loc]!
+  *)
+  { ty with tyloc = Some loc }
+
+let set_loc loc ty = (repr ty).tyloc <- Some loc; ty
+  (* Use with great care. You should not use set_loc if copy_with_loc can solve your problem. *)
+
 (**** Type maps ****)
 
 module TypePairs =

File typing/ctype.mli

 val none: type_expr
         (* A dummy type expression *)
 
+val copy_with_loc : Location.t -> type_expr -> type_expr
+  (* Copy the type with setting tyloc *)
+val set_loc : Location.t -> type_expr -> type_expr
+  (* Modify the tyloc and return the same type. Use with care. *)
+
 val repr: type_expr -> type_expr
         (* Return the canonical representative of a type. *)
 

File typing/typecore.ml

   node
 ;;
 
-let copy_with_loc loc ty = 
-  (* Adding a location to a type must dupe the type!
-     Otherwise one [copy_with_loc loc <int>] to <int> changes all the <int>s with [loc]!
-  *)
-  { ty with tyloc = Some loc }
-
-let set_loc loc ty = (repr ty).tyloc <- Some loc; ty
-  (* Use with great care. You should not use set_loc if copy_with_loc can solve your problem. *)
-
 let snd3 (_,x,_) = x
 let thd4 (_,_, x,_) = x
 

File typing/typetexp.ml

   | Ptyp_arrow(l, st1, st2) ->
     let cty1 = transl_type env policy st1 in
     let cty2 = transl_type env policy st2 in
-    let ty = newty (Tarrow(l, cty1.ctyp_type, cty2.ctyp_type, Cok)) in
+    let ty = set_loc loc (newty (Tarrow(l, cty1.ctyp_type, cty2.ctyp_type, Cok))) in
     ctyp (Ttyp_arrow (l, cty1, cty2)) ty env loc
   | Ptyp_tuple stl ->
     let ctys = List.map (transl_type env policy) stl in
-    let ty = newty (Ttuple (List.map (fun ctyp -> ctyp.ctyp_type) ctys)) in
+    let ty = set_loc loc (newty (Ttuple (List.map (fun ctyp -> ctyp.ctyp_type) ctys))) in
     ctyp (Ttyp_tuple ctys) ty env loc
   | Ptyp_constr(lid, stl) ->
       let (path, decl) = find_type env styp.ptyp_loc lid.txt in
              raise (Error(sty.ptyp_loc, Type_mismatch (swap_list trace))))
         (List.combine stl args) params;
       let constr =
-        newconstr path (List.map (fun ctyp -> ctyp.ctyp_type) args) in
+        copy_with_loc loc (newconstr path (List.map (fun ctyp -> ctyp.ctyp_type) args)) in
       begin try
         Ctype.enforce_constraints env constr
       with Unify trace ->
 	    in
 	    { field_desc = desc; field_loc = pf.pfield_loc })
 	  fields in
-      let ty = newobj (transl_fields env policy [] fields) in
+      let ty = newobj (transl_fields env policy [] fields) in (* CR jfuruse: typloc todo *)
 	ctyp (Ttyp_object fields) ty env loc
   | Ptyp_class(lid, stl, present) ->
       let (path, decl, is_variant) =
              raise (Error(sty.ptyp_loc, Type_mismatch (swap_list trace))))
         (List.combine stl args) params;
 	let ty_args = List.map (fun ctyp -> ctyp.ctyp_type) args in
-      let ty =
+      let ty = (* CR jfuruse: typloc todo *)
         try Ctype.expand_head env (newconstr path ty_args)
         with Unify trace ->
           raise (Error(styp.ptyp_loc, Type_mismatch trace))
         else if policy <> Univars then row
         else { row with row_more = new_pre_univar () }
       in
-      let ty = newty (Tvariant row) in
+      let ty = newty (Tvariant row) in (* CR jfuruse: tyloc todo *)
       ctyp (Ttyp_variant (tfields, closed, present)) ty env loc
    | Ptyp_poly(vars, st) ->
       begin_def();
             end else tyl)
           [] new_univars
       in
+       (* CR jfuruse: tyloc todo *)
       let ty' = Btype.newgenty (Tpoly(ty, List.rev ty_list)) in
       unify_var env (newvar()) ty';
       ctyp (Ttyp_poly (vars, cty)) ty' env loc
 			     s, transl_type env policy pty
 			  ) l in
       let path = !transl_modtype_longident styp.ptyp_loc env p.txt in
-      let ty = newty (Tpackage (path,
-                       List.map (fun (s, pty) -> s.txt) l,
-                       List.map (fun (_,cty) -> cty.ctyp_type) ptys))
+      let ty = copy_with_loc loc (newty (Tpackage (path,
+                                                   List.map (fun (s, pty) -> s.txt) l,
+                                                   List.map (fun (_,cty) -> cty.ctyp_type) ptys)))
       in
 	ctyp (Ttyp_package {
 		pack_name = path;