Ekdohibs
/
ocaml
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Keep the id for the synthesized sub-declaration in Cstr_record. 

git-svn-id: http://caml.inria.fr/svn/ocaml/branches/constructors_with_record3@14560 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02
master
Alain Frisch 2014-04-08 13:24:24 +00:00
parent 87c8973069
commit ca1e303b56
16 changed files with 142 additions and 51 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

37
testsuite/tests/typing-recordarg/recordarg.ml Normal file
View File

@ -0,0 +1,37 @@
module M = struct
type t = A of {x:int}
let f (A r) = r
end;;
M.f;;
module A : sig
type t = A of {x:int}
val f: t -> t.A
end = struct
type t = A of {x:int}
let f (A r) = r
end;;
module type S = sig type t = A of {x:int} val f: t -> t.A end;;
module N : S with type t = M.t = M;;
(*
module M = struct
type 'a t =
| A of {x : 'a}
| B: {u : 'b} -> unit t
exception Foo of {x : int}
end;;
module N : sig
exception Foo of {x : int}
end = struct
type 'b t = 'b M.t =
| A of {x : 'b}
| B: {u : 'z} -> unit t
exception Foo = M.Foo
end;;
*)

13
testsuite/tests/typing-recordarg/recordarg.ml.reference
View File

@ -1,8 +1,7 @@
# module M :
sig
type 'a t = A of { x : 'a; } | B : { u : 'b; } -> unit t
exception Foo of { x : int; }
end
# module N : sig exception Foo of { x : int; } end
#
# module M : sig type t = A of { x : int; } val f : t -> t.A end
# - : M.t -> M.t.A = <fun>
# module A : sig type t = A of { x : int; } val f : t -> t.A end
# module type S = sig type t = A of { x : int; } val f : t -> t.A end
# module N : sig type t = M.t = A of { x : int; } val f : t -> t.A end
# * * * * * * * * * * * * * * * * * *

2
toplevel/genprintval.ml
View File

@ -272,7 +272,7 @@ module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct
tree_of_constr_with_args (tree_of_constr env path)
(Ident.name cd_id) false 0 depth obj
ty_args
| Cstr_record lbls ->
| Cstr_record (_, lbls) ->
let r =
tree_of_record_fields depth
env path type_params ty_list

2
typing/btype.ml
View File

@ -259,7 +259,7 @@ let iter_type_expr_kind f = function
(fun cd ->
begin match cd.cd_args with
| Cstr_tuple tl -> List.iter f tl
| Cstr_record lbls -> List.iter (fun d -> f d.ld_type) lbls
| Cstr_record (_, lbls) -> List.iter (fun d -> f d.ld_type) lbls
end;
Misc.may f cd.cd_res
)

9
typing/ctype.ml
View File

@ -549,7 +549,8 @@ let closed_type_decl decl =
| None ->
match cd_args with
| Cstr_tuple l -> List.iter closed_type l
| Cstr_record l -> List.iter (fun l -> closed_type l.ld_type) l
| Cstr_record (_, l) ->
List.iter (fun l -> closed_type l.ld_type) l
)
v
| Type_record(r, rep) ->
@ -1170,9 +1171,9 @@ let map_kind f = function
cd_args =
begin match c.cd_args with
| Cstr_tuple l-> Cstr_tuple (List.map f l)
| Cstr_record l ->
| Cstr_record (id, l) ->
let field l = {l with ld_type = f l.ld_type} in
Cstr_record (List.map field l)
Cstr_record (id, List.map field l)
end;
cd_res=may_map f c.cd_res
})
@ -2142,7 +2143,7 @@ and mcomp_variant_description type_pairs env xs ys =
mcomp_type_option type_pairs env c1.cd_res c2.cd_res;
begin match c1.cd_args, c2.cd_args with
| Cstr_tuple l1, Cstr_tuple l2 -> mcomp_list type_pairs env l1 l2
| Cstr_record l1, Cstr_record l2 ->
| Cstr_record (_, l1), Cstr_record (_, l2) ->
mcomp_record_description type_pairs env l1 l2
| _ -> raise (Unify [])
end;

37
typing/datarepr.ml
View File

@ -39,8 +39,10 @@ let free_vars ty =
unmark_type ty;
!ret
let constructor_descrs resolv ty_path decl cstrs =
let ty_res = newgenty (Tconstr(ty_path, decl.type_params, ref Mnil)) in
let newgenconstr path tyl = newgenty (Tconstr (path, tyl, ref Mnil))
let constructor_descrs ty_path decl manifest_decl cstrs =
let ty_res = newgenconstr ty_path decl.type_params in
let num_consts = ref 0 and num_nonconsts = ref 0 and num_normal = ref 0 in
List.iter
(fun {cd_args; cd_res; _} ->
@ -70,7 +72,7 @@ let constructor_descrs resolv ty_path decl cstrs =
let tyl =
match cd_args with
| Cstr_tuple l -> l
| Cstr_record l -> List.map (fun l -> l.ld_type) l
| Cstr_record (_, l) -> List.map (fun l -> l.ld_type) l
in
(* TODO: handle Tpoly *)
let arg_vars = free_vars (newgenty (Ttuple tyl)) in
@ -79,9 +81,8 @@ let constructor_descrs resolv ty_path decl cstrs =
let cstr_args, cstr_inlined =
match cd_args with
| Cstr_tuple l -> l, false
| Cstr_record lbls ->
| Cstr_record (id, lbls) ->
let name = Path.last ty_path ^ "." ^ Ident.name cd_id in
let id = Ident.create name in
let path =
match ty_path with
| Path.Pdot(m, _, _) -> Path.Pdot(m, name, Path.nopos)
@ -91,12 +92,26 @@ let constructor_descrs resolv ty_path decl cstrs =
let type_manifest =
match decl.type_manifest with
| Some {desc = Tconstr(Path.Pdot (m, name, _), args, _)} ->
let p = Path.Pdot (m, name ^ "." ^ Ident.name cd_id, Path.nopos) in
Some (newgenty (Tconstr (p, args, ref Mnil)))
| Some {desc = Tconstr(Path.Pident id, args, _)} ->
begin match resolv (Ident.name id ^ "." ^ Ident.name cd_id) with
| None -> None
| Some id -> Some (newgenty (Tconstr (Path.Pident id, args, ref Mnil)))
let p =
Path.Pdot (m, name ^ "." ^ Ident.name cd_id, Path.nopos)
in
Some (newgenconstr p args)
| Some {desc = Tconstr(Path.Pident _, args, _)} ->
begin match manifest_decl with
| Some {type_kind = Type_variant cstrs} ->
let c =
try
List.find
(fun c -> Ident.name c.cd_id = Ident.name cd_id)
cstrs
with Not_found -> assert false
in
begin match c.cd_args with
| Cstr_record (id, _) ->
Some (newgenconstr (Path.Pident id) args)
| _ -> assert false
end
| _ -> None
end
| _ -> None
in

4
typing/datarepr.mli
View File

@ -17,8 +17,8 @@ open Asttypes
open Types
val constructor_descrs:
(string -> Ident.t option) ->
Path.t -> type_declaration -> constructor_declaration list ->
Path.t -> type_declaration -> type_declaration option ->
constructor_declaration list ->
(Ident.t * constructor_description) list *
(Ident.t * Path.t * type_declaration) list

23
typing/env.ml
View File

@ -1036,15 +1036,15 @@ let scrape_alias env mty = scrape_alias env mty
let constructors_of_type env ty_path decl =
match decl.type_kind with
| Type_variant cstrs ->
let resolv s =
try
let (p, _) = lookup_type (Longident.Lident s) env in
match p with
| Pident id -> Some id
| _ -> None
with Not_found -> None
let manifest_decl =
match decl.type_manifest with
| Some {desc = Tconstr((Path.Pident id) as p, _, _)} ->
begin try Some (find_type p env)
with Not_found -> None
end
| _ -> None
in
Datarepr.constructor_descrs resolv ty_path decl cstrs
Datarepr.constructor_descrs ty_path decl manifest_decl cstrs
| Type_record _ | Type_abstract -> [], []
(* Compute label descriptions *)
@ -1085,6 +1085,13 @@ let rec prefix_idents root pos sub = function
to a constructor declaration with a record argument
(the exception comes immediately after the synthesized type
declaration). *)
let sub =
List.fold_left
(fun sub id ->
Subst.add_type id (Pdot(root, Ident.name id, pos)) sub
)
sub (Subst.sub_ids decl)
in
let (pl, final_sub) =
prefix_idents root pos (Subst.add_type id p sub) rem in
(p::pl, final_sub)

8
typing/includecore.ml
View File

@ -185,11 +185,9 @@ let rec compare_variants env decl1 decl2 n cstrs1 cstrs2 =
(ty2::decl2.type_params))
(arg1) (arg2)
then [] else [Field_type cstr1]
| Cstr_record l1, Cstr_record l2 ->
let r = compare_records env decl1 decl2 0 l1 l2 in
if r <> [] then Field_type cstr1 :: r else r
| _ ->
[Field_type cstr1]
| Cstr_record (_, l1), Cstr_record (_, l2) ->
compare_records env decl1 decl2 0 l1 l2
| _ -> assert false (* TODO *)
in
if r <> [] then r
else compare_variants env decl1 decl2 (n+1) rem1 rem2

20
typing/includemod.ml
View File

@ -303,8 +303,24 @@ and signatures env cxt subst sig1 sig2 =
let (id1, item1, pos1) = Tbl.find name2 comps1 in
let new_subst =
match item2 with
Sig_type _ ->
Subst.add_type id2 (Pident id1) subst
Sig_type (id2', decl2, _) ->
let subst = Subst.add_type id2 (Pident id1) subst in
begin match item1 with
| Sig_type (id1', decl1, _) ->
let ids1 = Subst.sub_ids decl1 in
let ids2 = Subst.sub_ids decl2 in
if List.length ids1 = List.length ids2 then
List.fold_left2
(fun sub id1 id2 ->
if Ident.name id1 = Ident.name id2 then
Subst.add_type id2 (Pident id1) sub
else
sub
) subst ids1 ids2
else
subst
| _ -> assert false
end
| Sig_module _ ->
Subst.add_module id2 (Pident id1) subst
| Sig_modtype _ ->

4
typing/printtyp.ml
View File

@ -785,7 +785,7 @@ let rec tree_of_type_decl id decl =
(fun cd ->
match cd.cd_args with
| Cstr_tuple l -> List.iter mark_loops l
| Cstr_record l -> List.iter (fun l -> mark_loops l.ld_type) l
| Cstr_record (_, l) -> List.iter (fun l -> mark_loops l.ld_type) l
)
cstrs
| Type_record(l, rep) ->
@ -848,7 +848,7 @@ and tree_of_constructor cd =
let arg () =
match cd.cd_args with
| Cstr_tuple l -> tree_of_typlist false l
| Cstr_record l -> [ Otyp_record (List.map tree_of_label l) ]
| Cstr_record (_, l) -> [ Otyp_record (List.map tree_of_label l) ]
in
match cd.cd_res with
| None -> (name, arg (), None)

18
typing/subst.ml
View File

@ -208,8 +208,8 @@ let type_declaration s decl =
match c.cd_args with
| Cstr_tuple l ->
Cstr_tuple (List.map (typexp s) l)
| Cstr_record l ->
Cstr_record (List.map (label_declaration s) l)
| Cstr_record (id, l) ->
Cstr_record (id, List.map (label_declaration s) l)
in
{
cd_id = c.cd_id;
@ -346,6 +346,7 @@ let rec modtype s = function
Mty_alias(module_path s p)
and signature s sg =
(* TODO: rename the Ident.t in Cstr_record *)
(* Components of signature may be mutually recursive (e.g. type declarations
or class and type declarations), so first build global renaming
substitution... *)
@ -398,3 +399,16 @@ let compose s1 s2 =
modules = merge_tbls (module_path s2) s1.modules s2.modules;
modtypes = merge_tbls (modtype s2) s1.modtypes s2.modtypes;
for_saving = false }
let sub_ids decl =
match decl.type_kind with
| Type_variant cstrs ->
List.fold_left
(fun l c ->
match c.cd_args with
| Cstr_record (id, _) -> id :: l
| _ -> l
)
[] cstrs
| _ -> []

3
typing/subst.mli
View File

@ -55,3 +55,6 @@ val module_declaration: t -> module_declaration -> module_declaration
(* Composition of substitutions:
apply (compose s1 s2) x = apply s2 (apply s1 x) *)
val compose: t -> t -> t
val sub_ids: type_declaration -> Ident.t list

9
typing/typedecl.ml
View File

@ -239,7 +239,8 @@ let transl_declaration ?exnid env sdecl id =
Cstr_tuple l
| Pcstr_record l ->
let lbls, lbls' = transl_labels env closed l in
Types.Cstr_record lbls',
let id = Ident.create (Ident.name id ^ "." ^ lid.txt) in
Types.Cstr_record (id, lbls'),
Cstr_record lbls
in
match ret_type with
@ -416,9 +417,9 @@ let check_constraints env sdecl (_, decl) =
(fun sty ty ->
check_constraints_rec env sty.ptyp_loc visited ty)
styl tyl
| Cstr_record tyl, Pcstr_record styl ->
| Cstr_record (_, tyl), Pcstr_record styl ->
check_constraints_labels env visited tyl styl
| _ -> assert false
| _ -> assert false (* todo *)
end;
match sret_type, ret_type with
| Some sr, Some r ->
@ -759,7 +760,7 @@ let constrained env vars ty =
let for_constr = function
| Types.Cstr_tuple l -> add_false l
| Types.Cstr_record l ->
| Types.Cstr_record (_, l) ->
List.map
(fun {Types.ld_mutable; ld_type} -> (ld_mutable = Mutable, ld_type))
l

2
typing/types.ml
View File

@ -217,7 +217,7 @@ and constructor_declaration =
and constructor_arguments =
| Cstr_tuple of type_expr list
| Cstr_record of label_declaration list
| Cstr_record of Ident.t * label_declaration list
and type_transparence =
Type_public (* unrestricted expansion *)

2
typing/types.mli
View File

@ -205,7 +205,7 @@ and constructor_declaration =
and constructor_arguments =
| Cstr_tuple of type_expr list
| Cstr_record of label_declaration list
| Cstr_record of Ident.t * label_declaration list
and type_transparence =
Type_public (* unrestricted expansion *)