diff options
71 files changed, 1067 insertions, 379 deletions
diff --git a/asmcomp/cmmgen.ml b/asmcomp/cmmgen.ml index 1f640b9bf..17dcb8220 100644 --- a/asmcomp/cmmgen.ml +++ b/asmcomp/cmmgen.ml @@ -641,8 +641,10 @@ let rec expr_size env = function RHS_block (List.length args) | Uprim(Pmakearray(Pfloatarray), args, _) -> RHS_floatblock (List.length args) - | Uprim (Pduprecord (Record_regular, sz), _, _) -> + | Uprim (Pduprecord ((Record_regular | Record_inlined _), sz), _, _) -> RHS_block sz + | Uprim (Pduprecord (Record_extension, sz), _, _) -> + RHS_block (sz + 1) | Uprim (Pduprecord (Record_float, sz), _, _) -> RHS_floatblock sz | Usequence(exp, exp') -> diff --git a/boot/ocamlc b/boot/ocamlc Binary files differindex 8282e0114..51c6883b2 100755 --- a/boot/ocamlc +++ b/boot/ocamlc diff --git a/boot/ocamldep b/boot/ocamldep Binary files differindex bb4b76145..90534fe30 100755 --- a/boot/ocamldep +++ b/boot/ocamldep diff --git a/boot/ocamllex b/boot/ocamllex Binary files differindex 01c4739de..4a839a9fc 100755 --- a/boot/ocamllex +++ b/boot/ocamllex diff --git a/bytecomp/bytegen.ml b/bytecomp/bytegen.ml index af5f0a3fd..be884ded5 100644 --- a/bytecomp/bytegen.ml +++ b/bytecomp/bytegen.ml @@ -144,8 +144,9 @@ let rec size_of_lambda = function | Llet (Strict, id, Lprim (Pduprecord (kind, size), _), body) when check_recordwith_updates id body -> begin match kind with - | Record_regular -> RHS_block size + | Record_regular | Record_inlined _ -> RHS_block size | Record_float -> RHS_floatblock size + | Record_extension -> RHS_block (size + 1) end | Llet(str, id, arg, body) -> size_of_lambda body | Lletrec(bindings, body) -> size_of_lambda body @@ -154,7 +155,10 @@ let rec size_of_lambda = function RHS_block (List.length args) | Lprim (Pmakearray Pfloatarray, args) -> RHS_floatblock (List.length args) | Lprim (Pmakearray Pgenarray, args) -> assert false - | Lprim (Pduprecord (Record_regular, size), args) -> RHS_block size + | Lprim (Pduprecord ((Record_regular | Record_inlined _), size), args) -> + RHS_block size + | Lprim (Pduprecord (Record_extension, size), args) -> + RHS_block (size + 1) | Lprim (Pduprecord (Record_float, size), args) -> RHS_floatblock size | Levent (lam, _) -> size_of_lambda lam | Lsequence (lam, lam') -> size_of_lambda lam' diff --git a/bytecomp/matching.ml b/bytecomp/matching.ml index 8ab6cec8b..cba32391e 100644 --- a/bytecomp/matching.ml +++ b/bytecomp/matching.ml @@ -1348,7 +1348,9 @@ let make_constr_matching p def ctx = function | ((arg, mut) :: argl) -> let cstr = pat_as_constr p in let newargs = - match cstr.cstr_tag with + if cstr.cstr_inlined <> None then + (arg, Alias) :: argl + else match cstr.cstr_tag with Cstr_constant _ | Cstr_block _ -> make_field_args Alias arg 0 (cstr.cstr_arity - 1) argl | Cstr_extension _ -> @@ -1628,8 +1630,10 @@ let make_record_matching all_labels def = function let lbl = all_labels.(pos) in let access = match lbl.lbl_repres with - Record_regular -> Pfield lbl.lbl_pos - | Record_float -> Pfloatfield lbl.lbl_pos in + Record_regular | Record_inlined _ -> Pfield lbl.lbl_pos + | Record_float -> Pfloatfield lbl.lbl_pos + | Record_extension -> Pfield (lbl.lbl_pos + 1) + in let str = match lbl.lbl_mut with Immutable -> Alias diff --git a/bytecomp/printlambda.ml b/bytecomp/printlambda.ml index d528a3574..1b9085edd 100644 --- a/bytecomp/printlambda.ml +++ b/bytecomp/printlambda.ml @@ -84,7 +84,9 @@ let print_bigarray name unsafe kind ppf layout = let record_rep ppf r = match r with | Record_regular -> fprintf ppf "regular" + | Record_inlined i -> fprintf ppf "inlined(%i)" i | Record_float -> fprintf ppf "float" + | Record_extension -> fprintf ppf "ext" ;; let string_of_loc_kind = function diff --git a/bytecomp/translcore.ml b/bytecomp/translcore.ml index 876abaa94..14f8b0659 100644 --- a/bytecomp/translcore.ml +++ b/bytecomp/translcore.ml @@ -746,7 +746,10 @@ and transl_exp0 e = end | Texp_construct(_, cstr, args) -> let ll = transl_list args in - begin match cstr.cstr_tag with + if cstr.cstr_inlined <> None then begin match ll with + | [x] -> x + | _ -> assert false + end else begin match cstr.cstr_tag with Cstr_constant n -> Lconst(Const_pointer n) | Cstr_block n -> @@ -776,20 +779,26 @@ and transl_exp0 e = [Lconst(Const_base(Const_int tag)); lam]) end | Texp_record ((_, lbl1, _) :: _ as lbl_expr_list, opt_init_expr) -> - transl_record lbl1.lbl_all lbl1.lbl_repres lbl_expr_list opt_init_expr + transl_record e.exp_env lbl1.lbl_all lbl1.lbl_repres lbl_expr_list + opt_init_expr | Texp_record ([], _) -> fatal_error "Translcore.transl_exp: bad Texp_record" | Texp_field(arg, _, lbl) -> let access = match lbl.lbl_repres with - Record_regular -> Pfield lbl.lbl_pos - | Record_float -> Pfloatfield lbl.lbl_pos in + Record_regular | Record_inlined _ -> Pfield lbl.lbl_pos + | Record_float -> Pfloatfield lbl.lbl_pos + | Record_extension -> Pfield (lbl.lbl_pos + 1) + in Lprim(access, [transl_exp arg]) | Texp_setfield(arg, _, lbl, newval) -> let access = match lbl.lbl_repres with - Record_regular -> Psetfield(lbl.lbl_pos, maybe_pointer newval) - | Record_float -> Psetfloatfield lbl.lbl_pos in + Record_regular + | Record_inlined _ -> Psetfield(lbl.lbl_pos, maybe_pointer newval) + | Record_float -> Psetfloatfield lbl.lbl_pos + | Record_extension -> Psetfield (lbl.lbl_pos + 1, maybe_pointer newval) + in Lprim(access, [transl_exp arg; transl_exp newval]) | Texp_array expr_list -> let kind = array_kind e in @@ -1071,7 +1080,7 @@ and transl_setinstvar self var expr = Lprim(Parraysetu (if maybe_pointer expr then Paddrarray else Pintarray), [self; transl_normal_path var; transl_exp expr]) -and transl_record all_labels repres lbl_expr_list opt_init_expr = +and transl_record env all_labels repres lbl_expr_list opt_init_expr = let size = Array.length all_labels in (* Determine if there are "enough" new fields *) if 3 + 2 * List.length lbl_expr_list >= size @@ -1086,7 +1095,8 @@ and transl_record all_labels repres lbl_expr_list opt_init_expr = for i = 0 to Array.length all_labels - 1 do let access = match all_labels.(i).lbl_repres with - Record_regular -> Pfield i + Record_regular | Record_inlined _ -> Pfield i + | Record_extension -> Pfield (i + 1) | Record_float -> Pfloatfield i in lv.(i) <- Lprim(access, [Lvar init_id]) done @@ -1104,13 +1114,26 @@ and transl_record all_labels repres lbl_expr_list opt_init_expr = if mut = Mutable then raise Not_constant; let cl = List.map extract_constant ll in match repres with - Record_regular -> Lconst(Const_block(0, cl)) + | Record_regular -> Lconst(Const_block(0, cl)) + | Record_inlined tag -> Lconst(Const_block(tag, cl)) | Record_float -> Lconst(Const_float_array(List.map extract_float cl)) + | Record_extension -> + raise Not_constant with Not_constant -> match repres with Record_regular -> Lprim(Pmakeblock(0, mut), ll) - | Record_float -> Lprim(Pmakearray Pfloatarray, ll) in + | Record_inlined tag -> Lprim(Pmakeblock(tag, mut), ll) + | Record_float -> Lprim(Pmakearray Pfloatarray, ll) + | Record_extension -> + let path = + match all_labels.(0).lbl_res.desc with + | Tconstr(p, _, _) -> p + | _ -> assert false + in + let slot = transl_path env path in + Lprim(Pmakeblock(0, mut), slot :: ll) + in begin match opt_init_expr with None -> lam | Some init_expr -> Llet(Strict, init_id, transl_exp init_expr, lam) @@ -1124,8 +1147,11 @@ and transl_record all_labels repres lbl_expr_list opt_init_expr = let update_field (_, lbl, expr) cont = let upd = match lbl.lbl_repres with - Record_regular -> Psetfield(lbl.lbl_pos, maybe_pointer expr) - | Record_float -> Psetfloatfield lbl.lbl_pos in + Record_regular + | Record_inlined _ -> Psetfield(lbl.lbl_pos, maybe_pointer expr) + | Record_float -> Psetfloatfield lbl.lbl_pos + | Record_extension -> Psetfield(lbl.lbl_pos + 1, maybe_pointer expr) + in Lsequence(Lprim(upd, [Lvar copy_id; transl_exp expr]), cont) in begin match opt_init_expr with None -> assert false diff --git a/bytecomp/translmod.ml b/bytecomp/translmod.ml index dc7d2d7a6..1f475565f 100644 --- a/bytecomp/translmod.ml +++ b/bytecomp/translmod.ml @@ -805,9 +805,13 @@ let transl_toplevel_item item = let idents = List.map (fun ext -> ext.ext_id) tyext.tyext_constructors in + (* we need to use unique name in case of multiple + definitions of the same extension constructor in the toplevel *) + List.iter set_toplevel_unique_name idents; transl_type_extension item.str_env None tyext (make_sequence toploop_setvalue_id idents) | Tstr_exception ext -> + set_toplevel_unique_name ext.ext_id; toploop_setvalue ext.ext_id (transl_extension_constructor item.str_env None ext) | Tstr_module {mb_id=id; mb_expr=modl} -> diff --git a/bytecomp/typeopt.ml b/bytecomp/typeopt.ml index c96e32b66..eb8c9435e 100644 --- a/bytecomp/typeopt.ml +++ b/bytecomp/typeopt.ml @@ -34,7 +34,7 @@ let maybe_pointer exp = match Env.find_type p exp.exp_env with | {type_kind = Type_variant []} -> true (* type exn *) | {type_kind = Type_variant cstrs} -> - List.exists (fun c -> c.Types.cd_args <> []) cstrs + List.exists (fun c -> c.Types.cd_args <> Cstr_tuple []) cstrs | _ -> true with Not_found -> true (* This can happen due to e.g. missing -I options, @@ -64,7 +64,8 @@ let array_element_kind env ty = {type_kind = Type_abstract} -> Pgenarray | {type_kind = Type_variant cstrs} - when List.for_all (fun c -> c.Types.cd_args = []) cstrs -> + when List.for_all (fun c -> c.Types.cd_args = Cstr_tuple []) + cstrs -> Pintarray | {type_kind = _} -> Paddrarray diff --git a/ocamldoc/odoc_ast.ml b/ocamldoc/odoc_ast.ml index 358a71a51..ce71070ef 100644 --- a/ocamldoc/odoc_ast.ml +++ b/ocamldoc/odoc_ast.ml @@ -1316,10 +1316,14 @@ module Analyser = let new_xt = match tt_ext.ext_kind with Text_decl(args, ret_type) -> + let xt_args = + match args with + | Cstr_tuple l -> Cstr_tuple (List.map (fun ctyp -> Odoc_env.subst_type new_env ctyp.ctyp_type) l) + | Cstr_record _ -> assert false + in { xt_name = complete_name; - xt_args = - List.map (fun ctyp -> Odoc_env.subst_type new_env ctyp.ctyp_type) args; + xt_args; xt_ret = may_map (fun ctyp -> Odoc_env.subst_type new_env ctyp.ctyp_type) ret_type; xt_type_extension = new_te; @@ -1330,7 +1334,7 @@ module Analyser = | Text_rebind(path, _) -> { xt_name = complete_name; - xt_args = []; + xt_args = Cstr_tuple []; xt_ret = None; xt_type_extension = new_te; xt_alias = @@ -1373,13 +1377,15 @@ module Analyser = Text_decl(tt_args, tt_ret_type) -> let loc_start = loc.Location.loc_start.Lexing.pos_cnum in let loc_end = loc.Location.loc_end.Lexing.pos_cnum in + let ex_args = + match tt_args with + | Cstr_tuple l -> Cstr_tuple (List.map (fun c -> Odoc_env.subst_type env c.ctyp_type) l) + | Cstr_record l -> assert false (* TODO *) + in { ex_name = complete_name ; ex_info = comment_opt ; - ex_args = - List.map - (fun ctyp -> Odoc_env.subst_type new_env ctyp.ctyp_type) - tt_args; + ex_args; ex_ret = Misc.may_map (fun ctyp -> Odoc_env.subst_type new_env ctyp.ctyp_type) @@ -1398,7 +1404,7 @@ module Analyser = { ex_name = complete_name ; ex_info = comment_opt ; - ex_args = [] ; + ex_args = Cstr_tuple [] ; ex_ret = None ; ex_alias = Some { ea_name = diff --git a/ocamldoc/odoc_dep.ml b/ocamldoc/odoc_dep.ml index c2949d733..b0393fe86 100644 --- a/ocamldoc/odoc_dep.ml +++ b/ocamldoc/odoc_dep.ml @@ -147,41 +147,31 @@ let type_deps t = l := s2 :: !l ; s2 in + let ty t = + let s = Odoc_print.string_of_type_expr t in + ignore (Str.global_substitute re f s) + in (match t.T.ty_kind with T.Type_abstract -> () | T.Type_variant cl -> List.iter (fun c -> - List.iter - (fun e -> - let s = Odoc_print.string_of_type_expr e in - ignore (Str.global_substitute re f s) - ) - c.T.vc_args + match c.T.vc_args with + | T.Cstr_tuple l -> List.iter ty l + | T.Cstr_record l -> List.iter (fun r -> ty r.T.rf_type) l ) cl | T.Type_record rl -> - List.iter - (fun r -> - let s = Odoc_print.string_of_type_expr r.T.rf_type in - ignore (Str.global_substitute re f s) - ) - rl + List.iter (fun r -> ty r.T.rf_type) rl | T.Type_open -> () ); (match t.T.ty_manifest with None -> () | Some (T.Object_type fields) -> - List.iter - (fun r -> - let s = Odoc_print.string_of_type_expr r.T.of_type in - ignore (Str.global_substitute re f s) - ) - fields + List.iter (fun r -> ty r.T.of_type) fields | Some (T.Other e) -> - let s = Odoc_print.string_of_type_expr e in - ignore (Str.global_substitute re f s) + ty e ); !l diff --git a/ocamldoc/odoc_exception.ml b/ocamldoc/odoc_exception.ml index b0e21196c..c65f384e5 100644 --- a/ocamldoc/odoc_exception.ml +++ b/ocamldoc/odoc_exception.ml @@ -22,7 +22,7 @@ type exception_alias = { and t_exception = { ex_name : Name.t ; mutable ex_info : Odoc_types.info option ; (** optional user information *) - ex_args : Types.type_expr list ; (** the types of the parameters *) + ex_args : Odoc_type.constructor_args ; (** the types of the parameters *) ex_ret: Types.type_expr option ; (** the optional return type *) ex_alias : exception_alias option ; mutable ex_loc : Odoc_types.location ; diff --git a/ocamldoc/odoc_extension.ml b/ocamldoc/odoc_extension.ml index 0a0841953..7b3da5f4b 100644 --- a/ocamldoc/odoc_extension.ml +++ b/ocamldoc/odoc_extension.ml @@ -25,7 +25,7 @@ type extension_alias = { and t_extension_constructor = { xt_name : Name.t ; - xt_args: Types.type_expr list ; (** the types of the parameters *) + xt_args: Odoc_type.constructor_args; xt_ret: Types.type_expr option ; (** the optional return type of the extension *) xt_type_extension: t_type_extension ; (** the type extension containing this constructor *) xt_alias: extension_alias option ; diff --git a/ocamldoc/odoc_html.ml b/ocamldoc/odoc_html.ml index 9ed06c0f0..0c5293ea1 100644 --- a/ocamldoc/odoc_html.ml +++ b/ocamldoc/odoc_html.ml @@ -1218,12 +1218,18 @@ class html = bs b "</code>" (** Print html code to display a [Types.type_expr list]. *) - method html_of_type_expr_list ?par b m_name sep l = - print_DEBUG "html#html_of_type_expr_list"; - let s = Odoc_info.string_of_type_list ?par sep l in - print_DEBUG "html#html_of_type_expr_list: 1"; + method html_of_cstr_args ?par b m_name sep l = + print_DEBUG "html#html_of_cstr_args"; + let s = + match l with + | Cstr_tuple l -> + Odoc_info.string_of_type_list ?par sep l + | Cstr_record l -> + Odoc_info.string_of_record l + in + print_DEBUG "html#html_of_cstr_args: 1"; let s2 = newline_to_indented_br s in - print_DEBUG "html#html_of_type_expr_list: 2"; + print_DEBUG "html#html_of_cstr_args: 2"; bs b "<code class=\"type\">"; bs b (self#create_fully_qualified_idents_links m_name s2); bs b "</code>" @@ -1478,16 +1484,16 @@ class html = (Name.simple x.xt_name); ( match x.xt_args, x.xt_ret with - [], None -> () + Cstr_tuple [], None -> () | l,None -> bs b (" " ^ (self#keyword "of") ^ " "); - self#html_of_type_expr_list ~par: false b father " * " l; - | [],Some r -> + self#html_of_cstr_args ~par: false b father " * " l; + | Cstr_tuple [],Some r -> bs b (" " ^ (self#keyword ":") ^ " "); self#html_of_type_expr b father r; | l,Some r -> bs b (" " ^ (self#keyword ":") ^ " "); - self#html_of_type_expr_list ~par: false b father " * " l; + self#html_of_cstr_args ~par: false b father " * " l; bs b (" " ^ (self#keyword "->") ^ " "); self#html_of_type_expr b father r; ); @@ -1539,17 +1545,17 @@ class html = bs b "</span>"; ( match e.ex_args, e.ex_ret with - [], None -> () + Cstr_tuple [], None -> () | l,None -> bs b (" "^(self#keyword "of")^" "); - self#html_of_type_expr_list + self#html_of_cstr_args ~par: false b (Name.father e.ex_name) " * " e.ex_args - | [],Some r -> + | Cstr_tuple [],Some r -> bs b (" " ^ (self#keyword ":") ^ " "); self#html_of_type_expr b (Name.father e.ex_name) r; | l,Some r -> bs b (" " ^ (self#keyword ":") ^ " "); - self#html_of_type_expr_list + self#html_of_cstr_args ~par: false b (Name.father e.ex_name) " * " l; bs b (" " ^ (self#keyword "->") ^ " "); self#html_of_type_expr b (Name.father e.ex_name) r; @@ -1659,16 +1665,16 @@ class html = (self#constructor constr.vc_name); ( match constr.vc_args, constr.vc_ret with - [], None -> () + Cstr_tuple [], None -> () | l,None -> bs b (" " ^ (self#keyword "of") ^ " "); - self#html_of_type_expr_list ~par: false b father " * " l; - | [],Some r -> + self#html_of_cstr_args ~par: false b father " * " l; + | Cstr_tuple [],Some r -> bs b (" " ^ (self#keyword ":") ^ " "); self#html_of_type_expr b father r; | l,Some r -> bs b (" " ^ (self#keyword ":") ^ " "); - self#html_of_type_expr_list ~par: false b father " * " l; + self#html_of_cstr_args ~par: false b father " * " l; bs b (" " ^ (self#keyword "->") ^ " "); self#html_of_type_expr b father r; ); diff --git a/ocamldoc/odoc_info.ml b/ocamldoc/odoc_info.ml index c576e1000..0fadbd482 100644 --- a/ocamldoc/odoc_info.ml +++ b/ocamldoc/odoc_info.ml @@ -143,6 +143,7 @@ let string_of_text t = Odoc_misc.string_of_text t let string_of_info i = Odoc_misc.string_of_info i let string_of_type t = Odoc_str.string_of_type t +let string_of_record t = Odoc_str.string_of_record t let string_of_type_extension te = Odoc_str.string_of_type_extension te diff --git a/ocamldoc/odoc_info.mli b/ocamldoc/odoc_info.mli index e9a9705c7..d1b98e224 100644 --- a/ocamldoc/odoc_info.mli +++ b/ocamldoc/odoc_info.mli @@ -187,7 +187,7 @@ module Extension : and t_extension_constructor = Odoc_extension.t_extension_constructor = { xt_name : Name.t ; - xt_args: Types.type_expr list ; (** the types of the parameters *) + xt_args: Odoc_type.constructor_args; xt_ret: Types.type_expr option ; (** the optional return type of the extension *) xt_type_extension: t_type_extension ; (** the type extension containing this constructor *) xt_alias: extension_alias option ; (** [None] when the extension is not a rebind. *) @@ -226,7 +226,7 @@ module Exception : { ex_name : Name.t ; mutable ex_info : info option ; (** Information found in the optional associated comment. *) - ex_args : Types.type_expr list ; (** The types of the parameters. *) + ex_args : Odoc_type.constructor_args; ex_ret : Types.type_expr option ; (** The the optional return type of the exception. *) ex_alias : exception_alias option ; (** [None] when the exception is not a rebind. *) mutable ex_loc : location ; @@ -240,15 +240,6 @@ module Type : type private_flag = Odoc_type.private_flag = Private | Public - (** Description of a variant type constructor. *) - type variant_constructor = Odoc_type.variant_constructor = - { - vc_name : string ; (** Name of the constructor. *) - vc_args : Types.type_expr list ; (** Arguments of the constructor. *) - vc_ret : Types.type_expr option ; - mutable vc_text : info option ; (** Optional description in the associated comment. *) - } - (** Description of a record type field. *) type record_field = Odoc_type.record_field = { @@ -258,6 +249,19 @@ module Type : mutable rf_text : info option ; (** Optional description in the associated comment.*) } + (** Description of a variant type constructor. *) + type constructor_args = Odoc_type.constructor_args = + | Cstr_record of record_field list + | Cstr_tuple of Types.type_expr list + + type variant_constructor = Odoc_type.variant_constructor = + { + vc_name : string ; (** Name of the constructor. *) + vc_args : constructor_args; + vc_ret : Types.type_expr option ; + mutable vc_text : info option ; (** Optional description in the associated comment. *) + } + (** The various kinds of a type. *) type type_kind = Odoc_type.type_kind = Type_abstract (** Type is abstract, for example [type t]. *) @@ -721,6 +725,8 @@ val string_of_info : info -> string (** @return a string to describe the given type. *) val string_of_type : Type.t_type -> string +val string_of_record : Type.record_field list -> string + (** @return a string to describe the given type extension. *) val string_of_type_extension : Extension.t_type_extension -> string diff --git a/ocamldoc/odoc_latex.ml b/ocamldoc/odoc_latex.ml index d0ef4310b..b2145d1bc 100644 --- a/ocamldoc/odoc_latex.ml +++ b/ocamldoc/odoc_latex.ml @@ -599,16 +599,16 @@ class latex = let s_cons = p fmt2 "@[<h 6> | %s" constr.vc_name ; begin match constr.vc_args, constr.vc_ret with - | [], None -> () + | Cstr_tuple [], None -> () | l, None -> p fmt2 " of@ %s" - (self#normal_type_list ~par: false mod_name " * " l) - | [], Some r -> + (self#normal_cstr_args ~par: false mod_name l) + | Cstr_tuple [], Some r -> p fmt2 " :@ %s" (self#normal_type mod_name r) | l, Some r -> p fmt2 " :@ %s@ %s@ %s" - (self#normal_type_list ~par: false mod_name " * " l) + (self#normal_cstr_args ~par: false mod_name l) "->" (self#normal_type mod_name r) end ; @@ -682,19 +682,19 @@ class latex = p fmt2 "@[<h 6> | %s" (Name.simple x.xt_name); ( match x.xt_args, x.xt_ret with - [], None -> () + Cstr_tuple [], None -> () | l, None -> p fmt2 " %s@ %s" "of" - (self#normal_type_list ~par: false father " * " l) - | [], Some r -> + (self#normal_cstr_args ~par: false father l) + | Cstr_tuple [], Some r -> p fmt2 " %s@ %s" ":" (self#normal_type father r) | l, Some r -> p fmt2 " %s@ %s@ %s@ %s" ":" - (self#normal_type_list ~par: false father " * " l) + (self#normal_cstr_args ~par: false father l) "->" (self#normal_type father r) ); diff --git a/ocamldoc/odoc_man.ml b/ocamldoc/odoc_man.ml index e97db4bc5..13733ba8e 100644 --- a/ocamldoc/odoc_man.ml +++ b/ocamldoc/odoc_man.ml @@ -383,8 +383,14 @@ class man = bs b "\n" (** Print groff string to display a [Types.type_expr list].*) - method man_of_type_expr_list ?par b m_name sep l = - let s = Odoc_str.string_of_type_list ?par sep l in + method man_of_cstr_args ?par b m_name sep l = + let s = + match l with + | Cstr_tuple l -> + Odoc_str.string_of_type_list ?par sep l + | Cstr_record l -> + Odoc_str.string_of_record l + in let s2 = Str.global_replace (Str.regexp "\n") "\n.B " s in bs b "\n.B "; bs b (self#relative_idents m_name s2); @@ -448,16 +454,16 @@ class man = bs b ("| "^(Name.simple x.xt_name)); ( match x.xt_args, x.xt_ret with - | [], None -> bs b "\n" + | Cstr_tuple [], None -> bs b "\n" | l, None -> bs b "\n.B of "; - self#man_of_type_expr_list ~par: false b father " * " l; - | [], Some r -> + self#man_of_cstr_args ~par: false b father " * " l; + | Cstr_tuple [], Some r -> bs b "\n.B : "; self#man_of_type_expr b father r; | l, Some r -> bs b "\n.B : "; - self#man_of_type_expr_list ~par: false b father " * " l; + self#man_of_cstr_args ~par: false b father " * " l; bs b ".B -> "; self#man_of_type_expr b father r; ); @@ -498,18 +504,18 @@ class man = bs b " \n"; ( match e.ex_args, e.ex_ret with - | [], None -> () + | Cstr_tuple [], None -> () | l, None -> bs b ".B of "; - self#man_of_type_expr_list + self#man_of_cstr_args ~par: false b (Name.father e.ex_name) " * " e.ex_args - | [], Some r -> + | Cstr_tuple [], Some r -> bs b ".B : "; self#man_of_type_expr b (Name.father e.ex_name) r | l, Some r -> bs b ".B : "; - self#man_of_type_expr_list + self#man_of_cstr_args ~par: false b (Name.father e.ex_name) " * " l; bs b ".B -> "; @@ -586,36 +592,36 @@ class man = bs b " *)\n " in match constr.vc_args, constr.vc_text,constr.vc_ret with - | [], None, None -> bs b "\n " - | [], (Some t), None -> + | Cstr_tuple [], None, None -> bs b "\n " + | Cstr_tuple [], (Some t), None -> print_text t | l, None, None -> bs b "\n.B of "; - self#man_of_type_expr_list ~par: false b father " * " l; + self#man_of_cstr_args ~par: false b father " * " l; bs b " " | l, (Some t), None -> bs b "\n.B of "; - self#man_of_type_expr_list ~par: false b father " * " l; + self#man_of_cstr_args ~par: false b father " * " l; bs b ".I \" \"\n"; print_text t - | [], None, Some r -> + | Cstr_tuple [], None, Some r -> bs b "\n.B : "; self#man_of_type_expr b father r; bs b " " - | [], (Some t), Some r -> + | Cstr_tuple [], (Some t), Some r -> bs b "\n.B : "; self#man_of_type_expr b father r; bs b ".I \" \"\n"; print_text t | l, None, Some r -> bs b "\n.B : "; - self#man_of_type_expr_list ~par: false b father " * " l; + self#man_of_cstr_args ~par: false b father " * " l; bs b ".B -> "; self#man_of_type_expr b father r; bs b " " | l, (Some t), Some r -> bs b "\n.B of "; - self#man_of_type_expr_list ~par: false b father " * " l; + self#man_of_cstr_args ~par: false b father " * " l; bs b ".B -> "; self#man_of_type_expr b father r; bs b ".I \" \"\n"; @@ -822,8 +828,8 @@ class man = bs b ".I "; bs b (c.vc_name^" "); (match c.vc_args with - [] -> () - | h::q -> + | Cstr_tuple [] -> () + | Cstr_tuple (h::q) -> bs b "of "; self#man_of_type_expr b modname h; List.iter @@ -831,6 +837,7 @@ class man = bs b " * "; self#man_of_type_expr b modname ty) q + | Cstr_record _ -> bs b "{ ... }" ); bs b "\n.sp\n"; self#man_of_info b c.vc_text; diff --git a/ocamldoc/odoc_sig.ml b/ocamldoc/odoc_sig.ml index e41cf2b8d..c2d365118 100644 --- a/ocamldoc/odoc_sig.ml +++ b/ocamldoc/odoc_sig.ml @@ -220,6 +220,7 @@ module Analyser = let (len, comment_opt) = My_ir.just_after_special !file_name s in (len, acc @ [ (pcd.pcd_name.txt, comment_opt) ]) | pcd :: (pcd2 :: _ as q) -> + (* TODO: support annotations on fields for inline records *) let pos_end_first = pcd.pcd_loc.Location.loc_end.Lexing.pos_cnum in let pos_start_second = pcd2.pcd_loc.Location.loc_start.Lexing.pos_cnum in let s = get_string_of_file pos_end_first pos_start_second in @@ -266,20 +267,38 @@ module Analyser = Object_type (List.map f @@ fst @@ Ctype.flatten_fields fields) | _ -> Other (Odoc_env.subst_type env type_expr) + let get_field env name_comment_list {Types.ld_id=field_name;ld_mutable=mutable_flag;ld_type=type_expr} = + let field_name = Ident.name field_name in + let comment_opt = + try List.assoc field_name name_comment_list + with Not_found -> None + in + { + rf_name = field_name ; + rf_mutable = mutable_flag = Mutable ; + rf_type = Odoc_env.subst_type env type_expr ; + rf_text = comment_opt + } + let get_type_kind env name_comment_list type_kind = match type_kind with Types.Type_abstract -> Odoc_type.Type_abstract | Types.Type_variant l -> - let f {Types.cd_id=constructor_name;cd_args=type_expr_list;cd_res=ret_type} = + let f {Types.cd_id=constructor_name;cd_args;cd_res=ret_type} = let constructor_name = Ident.name constructor_name in let comment_opt = try List.assoc constructor_name name_comment_list with Not_found -> None in + let vc_args = + match cd_args with + | Cstr_tuple l -> Cstr_tuple (List.map (Odoc_env.subst_type env) l) + | Cstr_record l -> Cstr_record (List.map (get_field env []) l) + in { vc_name = constructor_name ; - vc_args = List.map (Odoc_env.subst_type env) type_expr_list ; + vc_args; vc_ret = may_map (Odoc_env.subst_type env) ret_type; vc_text = comment_opt } @@ -287,20 +306,7 @@ module Analyser = Odoc_type.Type_variant (List.map f l) | Types.Type_record (l, _) -> - let f {Types.ld_id=field_name;ld_mutable=mutable_flag;ld_type=type_expr} = - let field_name = Ident.name field_name in - let comment_opt = - try List.assoc field_name name_comment_list - with Not_found -> None - in - { - rf_name = field_name ; - rf_mutable = mutable_flag = Mutable ; - rf_type = Odoc_env.subst_type env type_expr ; - rf_text = comment_opt - } - in - Odoc_type.Type_record (List.map f l) + Odoc_type.Type_record (List.map (get_field env name_comment_list) l) | Types.Type_open -> Odoc_type.Type_open @@ -658,10 +664,15 @@ module Analyser = [] -> (maybe_more, List.rev exts_acc) | (name, types_ext) :: q -> let ext_loc_end = types_ext.Types.ext_loc.Location.loc_end.Lexing.pos_cnum in + let xt_args = + match types_ext.ext_args with + | Cstr_tuple l -> Cstr_tuple (List.map (Odoc_env.subst_type new_env) l) + | Cstr_record l -> Cstr_record (List.map (get_field new_env []) l) + in let new_x = { xt_name = Name.concat current_module_name name ; - xt_args = List.map (Odoc_env.subst_type new_env) types_ext.ext_args ; + xt_args; xt_ret = may_map (Odoc_env.subst_type new_env) types_ext.ext_ret_type ; xt_type_extension = new_te; xt_alias = None ; @@ -696,11 +707,16 @@ module Analyser = with Not_found -> raise (Failure (Odoc_messages.exception_not_found current_module_name name.txt)) in + let ex_args = + match types_ext.ext_args with + | Cstr_tuple l -> Cstr_tuple (List.map (Odoc_env.subst_type env) l) + | Cstr_record l -> Cstr_record (List.map (get_field env []) l) + in let e = { ex_name = Name.concat current_module_name name.txt ; ex_info = comment_opt ; - ex_args = List.map (Odoc_env.subst_type env) types_ext.ext_args ; + ex_args; ex_ret = may_map (Odoc_env.subst_type env) types_ext.ext_ret_type ; ex_alias = None ; ex_loc = { loc_impl = None ; loc_inter = Some sig_item_loc } ; diff --git a/ocamldoc/odoc_str.ml b/ocamldoc/odoc_str.ml index 7d99ff107..1536640e5 100644 --- a/ocamldoc/odoc_str.ml +++ b/ocamldoc/odoc_str.ml @@ -171,13 +171,27 @@ let bool_of_private = function | Asttypes.Private -> true | _ -> false +let field_doc_str = function + | None -> "" + | Some t -> Printf.sprintf "(* %s *)" (Odoc_misc.string_of_info t) + +let string_of_record l = + let module M = Odoc_type in + let module P = Printf in + P.sprintf "{\n%s\n}" ( + String.concat "\n" ( + List.map (fun field -> + P.sprintf " %s%s : %s;%s" + (if field.M.rf_mutable then "mutable " else "") field.M.rf_name + (Odoc_print.string_of_type_expr field.M.rf_type) + (field_doc_str field.M.rf_text) + ) l + ) + ) + let string_of_type t = let module M = Odoc_type in let module P = Printf in - let field_doc_str = function - | None -> "" - | Some t -> P.sprintf "(* %s *)" (Odoc_misc.string_of_info t) - in let priv = bool_of_private t.M.ty_private in let parameters_str = String.concat " " ( @@ -215,16 +229,19 @@ let string_of_type t = | None -> "" | Some t -> P.sprintf "(* %s *)" (Odoc_misc.string_of_info t) in - let string_of_parameters lst = - String.concat " * " ( - List.map (fun t -> "("^Odoc_print.string_of_type_expr t^")") lst - ) + let string_of_parameters = function + | M.Cstr_tuple l -> + String.concat " * " ( + List.map (fun t -> "("^Odoc_print.string_of_type_expr t^")") l + ) + | M.Cstr_record l -> + string_of_record l in P.sprintf " | %s%s%s" cons.M.vc_name ( match cons.M.vc_args, cons.M.vc_ret with - | [], None -> "" + | M.Cstr_tuple [], None -> "" | li, None -> " of " ^ (string_of_parameters li) - | [], Some r -> " : " ^ Odoc_print.string_of_type_expr r + | M.Cstr_tuple [], Some r -> " : " ^ Odoc_print.string_of_type_expr r | li, Some r -> P.sprintf " : %s -> %s" (string_of_parameters li) (Odoc_print.string_of_type_expr r) @@ -237,16 +254,8 @@ let string_of_type t = "= .." (* FIXME MG: when introducing new constuctors next time, thanks to setup a minimal correct output *) | M.Type_record l -> - P.sprintf "= %s{\n%s\n}\n" (if priv then "private " else "") ( - String.concat "\n" ( - List.map (fun field -> - P.sprintf " %s%s : %s;%s" - (if field.M.rf_mutable then "mutable " else "") field.M.rf_name - (Odoc_print.string_of_type_expr field.M.rf_type) - (field_doc_str field.M.rf_text) - ) l - ) - ) + P.sprintf "= %s{\n%s\n}\n" (if priv then "private " else "") + (string_of_record l) in P.sprintf "type %s %s %s%s%s" parameters_str (Name.simple t.M.ty_name) manifest_str type_kind_str @@ -256,6 +265,7 @@ let string_of_type t = let string_of_type_extension te = let module M = Odoc_extension in + let module T = Odoc_type in "type " ^(String.concat "" (List.map @@ -272,19 +282,21 @@ let string_of_type_extension te = " | " ^(Name.simple x.M.xt_name) ^(match x.M.xt_args, x.M.xt_ret with - | [], None -> "" - | l, None -> + | T.Cstr_tuple [], None -> "" + | T.Cstr_tuple l, None -> " of " ^ (String.concat " * " (List.map (fun t -> "("^Odoc_print.string_of_type_expr t^")") l)) - | [], Some r -> " : " ^ Odoc_print.string_of_type_expr r - | l, Some r -> + | T.Cstr_tuple [], Some r -> " : " ^ Odoc_print.string_of_type_expr r + | T.Cstr_tuple l, Some r -> " : " ^ (String.concat " * " (List.map (fun t -> "("^Odoc_print.string_of_type_expr t^")") l)) ^ " -> " ^ Odoc_print.string_of_type_expr r + | T.Cstr_record _, _ -> + assert false ) ^(match x.M.xt_alias with None -> "" @@ -309,23 +321,26 @@ let string_of_type_extension te = ) let string_of_exception e = + let module T = Odoc_type in let module M = Odoc_exception in "exception "^(Name.simple e.M.ex_name)^ (match e.M.ex_args, e.M.ex_ret with - [], None -> "" - | l,None -> + T.Cstr_tuple [], None -> "" + | T.Cstr_tuple l,None -> " of "^ (String.concat " * " (List.map (fun t -> "("^(Odoc_print.string_of_type_expr t)^")") l)) - | [],Some r -> + | T.Cstr_tuple [],Some r -> " : "^ (Odoc_print.string_of_type_expr r) - | l,Some r -> + | T.Cstr_tuple l,Some r -> " : "^ (String.concat " * " (List.map (fun t -> "("^(Odoc_print.string_of_type_expr t)^")") l))^ " -> "^ (Odoc_print.string_of_type_expr r) + | T.Cstr_record _, _ -> + assert false )^ (match e.M.ex_alias with None -> "" diff --git a/ocamldoc/odoc_str.mli b/ocamldoc/odoc_str.mli index 402a82d56..925deddad 100644 --- a/ocamldoc/odoc_str.mli +++ b/ocamldoc/odoc_str.mli @@ -37,6 +37,8 @@ val string_of_class_type_param_list : Types.type_expr list -> string (** @return a string to describe the given type. *) val string_of_type : Odoc_type.t_type -> string +val string_of_record : Odoc_type.record_field list -> string + (** @return a string to display the parameters of the given class, in the same form as the compiler. *) val string_of_class_params : Odoc_class.t_class -> string diff --git a/ocamldoc/odoc_texi.ml b/ocamldoc/odoc_texi.ml index 10d45c1c8..afa4d49f7 100644 --- a/ocamldoc/odoc_texi.ml +++ b/ocamldoc/odoc_texi.ml @@ -638,12 +638,16 @@ class texi = Printf.sprintf "(%s) " (String.concat ", " (List.map f l)) - method string_of_type_args (args:Types.type_expr list) (ret:Types.type_expr option) = + method string_of_type_args (args:constructor_args) (ret:Types.type_expr option) = + let f = function + | Cstr_tuple l -> Odoc_info.string_of_type_list " * " l + | Cstr_record l -> Odoc_info.string_of_record l + in match args, ret with - | [], None -> "" - | args, None -> " of " ^ (Odoc_info.string_of_type_list " * " args) - | [], Some r -> " : " ^ (Odoc_info.string_of_type_expr r) - | args, Some r -> " : " ^ (Odoc_info.string_of_type_list " * " args) ^ + | Cstr_tuple [], None -> "" + | args, None -> " of " ^ (f args) + | Cstr_tuple [], Some r -> " : " ^ (Odoc_info.string_of_type_expr r) + | args, Some r -> " : " ^ (f args) ^ " -> " ^ (Odoc_info.string_of_type_expr r) (** Return Texinfo code for a type. *) diff --git a/ocamldoc/odoc_to_text.ml b/ocamldoc/odoc_to_text.ml index 1c7f6ba7f..ce328b0da 100644 --- a/ocamldoc/odoc_to_text.ml +++ b/ocamldoc/odoc_to_text.ml @@ -231,6 +231,10 @@ class virtual to_text = method normal_type_list ?par m_name sep t = self#relative_idents m_name (Odoc_info.string_of_type_list ?par sep t) + method normal_cstr_args ?par m_name = function + | Cstr_tuple l -> self#normal_type_list ?par m_name " * " l + | Cstr_record _ -> "{...}" (* TODO *) + (** Get a string for a list of class or class type type parameters where all idents are relative. *) method normal_class_type_param_list m_name t = @@ -339,21 +343,23 @@ class virtual to_text = let father = Name.father e.ex_name in Format.fprintf Format.str_formatter "@[<hov 2>exception %s" s_name ; (match e.ex_args, e.ex_ret with - [], None -> () - | l, None -> + Cstr_tuple [], None -> () + | Cstr_tuple l, None -> Format.fprintf Format.str_formatter " %s@ %s" "of" (self#normal_type_list ~par: false father " * " l) - | [], Some r -> + | Cstr_tuple [], Some r -> Format.fprintf Format.str_formatter " %s@ %s" ":" (self#normal_type father r) - | l, Some r -> + | Cstr_tuple l, Some r -> Format.fprintf Format.str_formatter " %s@ %s@ %s@ %s" ":" (self#normal_type_list ~par: false father " * " l) "->" (self#normal_type father r) + | Cstr_record _, _ -> + assert false ); (match e.ex_alias with None -> () diff --git a/ocamldoc/odoc_type.ml b/ocamldoc/odoc_type.ml index dadc6b1ba..f9bd9cda1 100644 --- a/ocamldoc/odoc_type.ml +++ b/ocamldoc/odoc_type.ml @@ -17,14 +17,6 @@ module Name = Odoc_name type private_flag = Asttypes.private_flag = Private | Public -(** Description of a variant type constructor. *) -type variant_constructor = { - vc_name : string ; - vc_args : Types.type_expr list ; (** arguments of the constructor *) - vc_ret : Types.type_expr option ; - mutable vc_text : Odoc_types.info option ; (** optional user description *) - } - (** Description of a record type field. *) type record_field = { rf_name : string ; @@ -33,6 +25,18 @@ type record_field = { mutable rf_text : Odoc_types.info option ; (** optional user description *) } +type constructor_args = + | Cstr_record of record_field list + | Cstr_tuple of Types.type_expr list + +(** Description of a variant type constructor. *) +type variant_constructor = { + vc_name : string ; + vc_args : constructor_args ; + vc_ret : Types.type_expr option ; + mutable vc_text : Odoc_types.info option ; (** optional user description *) + } + (** The various kinds of type. *) type type_kind = Type_abstract diff --git a/parsing/ast_helper.ml b/parsing/ast_helper.ml index 47c7bd338..f53cb2928 100644 --- a/parsing/ast_helper.ml +++ b/parsing/ast_helper.ml @@ -364,7 +364,7 @@ module Type = struct ptype_loc = loc; } - let constructor ?(loc = !default_loc) ?(attrs = []) ?(args = []) ?res name = + let constructor ?(loc = !default_loc) ?(attrs = []) ?(args = Pcstr_tuple []) ?res name = { pcd_name = name; pcd_args = args; @@ -402,7 +402,7 @@ module Te = struct pext_attributes = attrs; } - let decl ?(loc = !default_loc) ?(attrs = []) ?(args = []) ?res name = + let decl ?(loc = !default_loc) ?(attrs = []) ?(args = Pcstr_tuple []) ?res name = { pext_name = name; pext_kind = Pext_decl(args, res); diff --git a/parsing/ast_helper.mli b/parsing/ast_helper.mli index b9b04f822..847d428f6 100644 --- a/parsing/ast_helper.mli +++ b/parsing/ast_helper.mli @@ -154,7 +154,7 @@ module Type: sig val mk: ?loc:loc -> ?attrs:attrs -> ?params:(core_type * variance) list -> ?cstrs:(core_type * core_type * loc) list -> ?kind:type_kind -> ?priv:private_flag -> ?manifest:core_type -> str -> type_declaration - val constructor: ?loc:loc -> ?attrs:attrs -> ?args:core_type list -> ?res:core_type -> str -> constructor_declaration + val constructor: ?loc:loc -> ?attrs:attrs -> ?args:constructor_arguments -> ?res:core_type -> str -> constructor_declaration val field: ?loc:loc -> ?attrs:attrs -> ?mut:mutable_flag -> str -> core_type -> label_declaration end @@ -165,7 +165,7 @@ module Te: val constructor: ?loc:loc -> ?attrs:attrs -> str -> extension_constructor_kind -> extension_constructor - val decl: ?loc:loc -> ?attrs:attrs -> ?args:core_type list -> ?res:core_type -> str -> extension_constructor + val decl: ?loc:loc -> ?attrs:attrs -> ?args:constructor_arguments -> ?res:core_type -> str -> extension_constructor val rebind: ?loc:loc -> ?attrs:attrs -> str -> lid -> extension_constructor end diff --git a/parsing/ast_mapper.ml b/parsing/ast_mapper.ml index 669d01449..aa9fdbfca 100644 --- a/parsing/ast_mapper.ml +++ b/parsing/ast_mapper.ml @@ -137,6 +137,11 @@ module T = struct | Ptype_record l -> Ptype_record (List.map (sub.label_declaration sub) l) | Ptype_open -> Ptype_open + let map_constructor_arguments sub = function + | Pcstr_tuple l -> Pcstr_tuple (List.map (sub.typ sub) l) + | Pcstr_record l -> + Pcstr_record (List.map (sub.label_declaration sub) l) + let map_type_extension sub {ptyext_path; ptyext_params; ptyext_constructors; @@ -151,7 +156,7 @@ module T = struct let map_extension_constructor_kind sub = function Pext_decl(ctl, cto) -> - Pext_decl(List.map (sub.typ sub) ctl, map_opt (sub.typ sub) cto) + Pext_decl(map_constructor_arguments sub ctl, map_opt (sub.typ sub) cto) | Pext_rebind li -> Pext_rebind (map_loc sub li) @@ -573,7 +578,7 @@ let default_mapper = (fun this {pcd_name; pcd_args; pcd_res; pcd_loc; pcd_attributes} -> Type.constructor (map_loc this pcd_name) - ~args:(List.map (this.typ this) pcd_args) + ~args:(T.map_constructor_arguments this pcd_args) ?res:(map_opt (this.typ this) pcd_res) ~loc:(this.location this pcd_loc) ~attrs:(this.attributes this pcd_attributes) diff --git a/parsing/parser.mly b/parsing/parser.mly index 4e2053be3..26bbdc1e9 100644 --- a/parsing/parser.mly +++ b/parsing/parser.mly @@ -1658,16 +1658,18 @@ sig_exception_declaration: } ; generalized_constructor_arguments: - /*empty*/ { ([],None) } - | OF core_type_list { (List.rev $2,None) } - | COLON core_type_list MINUSGREATER simple_core_type - { (List.rev $2,Some $4) } + /*empty*/ { (Pcstr_tuple [],None) } + | OF constructor_arguments { ($2,None) } + | COLON constructor_arguments MINUSGREATER simple_core_type + { ($2,Some $4) } | COLON simple_core_type - { ([],Some $2) } + { (Pcstr_tuple [],Some $2) } ; - - +constructor_arguments: + | core_type_list { Pcstr_tuple (List.rev $1) } + | LBRACE label_declarations RBRACE { Pcstr_record (List.rev $2) } +; label_declarations: label_declaration { [$1] } | label_declarations SEMI label_declaration { $3 :: $1 } diff --git a/parsing/parsetree.mli b/parsing/parsetree.mli index a66317f47..d287b9eee 100644 --- a/parsing/parsetree.mli +++ b/parsing/parsetree.mli @@ -398,15 +398,23 @@ and label_declaration = and constructor_declaration = { pcd_name: string loc; - pcd_args: core_type list; + pcd_args: constructor_arguments; pcd_res: core_type option; pcd_loc: Location.t; pcd_attributes: attributes; (* C [@id1] [@id2] of ... *) } + +and constructor_arguments = + | Pcstr_tuple of core_type list + | Pcstr_record of label_declaration list + (* - | C of T1 * ... * Tn (res = None) - | C: T0 (args = [], res = Some T0) - | C: T1 * ... * Tn -> T0 (res = Some T0) + | C of T1 * ... * Tn (res = None, args = Pcstr_tuple []) + | C: T0 (res = Some T0, args = []) + | C: T1 * ... * Tn -> T0 (res = Some T0, args = Pcstr_tuple) + | C of {...} (res = None, args = Pcstr_record) + | C: {...} -> T0 (res = Some T0, args = Pcstr_record) + | C of {...} as t (res = None, args = Pcstr_record) *) and type_extension = @@ -430,7 +438,7 @@ and extension_constructor = } and extension_constructor_kind = - Pext_decl of core_type list * core_type option + Pext_decl of constructor_arguments * core_type option (* | C of T1 * ... * Tn ([T1; ...; Tn], None) | C: T0 ([], Some T0) diff --git a/parsing/pprintast.ml b/parsing/pprintast.ml index 327d67041..5f59dacac 100644 --- a/parsing/pprintast.ml +++ b/parsing/pprintast.ml @@ -1313,18 +1313,21 @@ class printer ()= object(self:'self) pp f "%s%a%a" name self#attributes attrs (fun f -> function - | [] -> () - | l -> + | Pcstr_tuple [] -> () + | Pcstr_tuple l -> pp f "@;of@;%a" (self#list self#core_type1 ~sep:"*@;") l + | Pcstr_record l -> pp f "@;of@;%a" (self#record_declaration) l ) args | Some r -> pp f "%s%a:@;%a" name self#attributes attrs (fun f -> function - | [] -> self#core_type1 f r - | l -> pp f "%a@;->@;%a" + | Pcstr_tuple [] -> self#core_type1 f r + | Pcstr_tuple l -> pp f "%a@;->@;%a" (self#list self#core_type1 ~sep:"*@;") l self#core_type1 r + | Pcstr_record l -> + pp f "%a@;->@;%a" (self#record_declaration) l self#core_type1 r ) args diff --git a/parsing/pprintast.mli b/parsing/pprintast.mli index 22e21adc6..42a340915 100644 --- a/parsing/pprintast.mli +++ b/parsing/pprintast.mli @@ -37,7 +37,7 @@ class printer : Format.formatter -> Parsetree.class_type_declaration list -> unit method constant : Format.formatter -> Asttypes.constant -> unit method constant_string : Format.formatter -> string -> unit - method constructor_declaration : Format.formatter -> (string * Parsetree.core_type list * Parsetree.core_type option * Parsetree.attributes) -> unit + method constructor_declaration : Format.formatter -> (string * Parsetree.constructor_arguments * Parsetree.core_type option * Parsetree.attributes) -> unit method core_type : Format.formatter -> Parsetree.core_type -> unit method core_type1 : Format.formatter -> Parsetree.core_type -> unit method direction_flag : diff --git a/parsing/printast.ml b/parsing/printast.ml index f0472bcdb..2bf9d8f3e 100644 --- a/parsing/printast.ml +++ b/parsing/printast.ml @@ -439,7 +439,7 @@ and extension_constructor_kind i ppf x = match x with Pext_decl(a, r) -> line i ppf "Pext_decl\n"; - list (i+1) core_type ppf a; + constructor_arguments (i+1) ppf a; option (i+1) core_type ppf r; | Pext_rebind li -> line i ppf "Pext_rebind\n"; @@ -810,9 +810,13 @@ and constructor_decl i ppf line i ppf "%a\n" fmt_location pcd_loc; line (i+1) ppf "%a\n" fmt_string_loc pcd_name; attributes i ppf pcd_attributes; - list (i+1) core_type ppf pcd_args; + constructor_arguments (i+1) ppf pcd_args; option (i+1) core_type ppf pcd_res +and constructor_arguments i ppf = function + | Pcstr_tuple l -> list i core_type ppf l + | Pcstr_record l -> list i label_decl ppf l + and label_decl i ppf {pld_name; pld_mutable; pld_type; pld_loc; pld_attributes}= line i ppf "%a\n" fmt_location pld_loc; attributes i ppf pld_attributes; diff --git a/testsuite/tests/typing-modules/Test.ml b/testsuite/tests/typing-modules/Test.ml index 97ef3f168..640655eb1 100644 --- a/testsuite/tests/typing-modules/Test.ml +++ b/testsuite/tests/typing-modules/Test.ml @@ -52,6 +52,7 @@ type u = X of bool;; module type B = A with type t = u;; (* fail *) (* PR#5815 *) +(* ---> duplicated exception name is now an error *) module type S = sig exception Foo of int exception Foo of bool end;; diff --git a/testsuite/tests/typing-modules/Test.ml.principal.reference b/testsuite/tests/typing-modules/Test.ml.principal.reference index d99e9a3cd..9646d3d0a 100644 --- a/testsuite/tests/typing-modules/Test.ml.principal.reference +++ b/testsuite/tests/typing-modules/Test.ml.principal.reference @@ -28,7 +28,11 @@ Error: Signature mismatch: ^^^^^^^^^^ Error: This variant or record definition does not match that of type u The types for field X are not equal. -# module type S = sig exception Foo of bool end +# Characters 121-124: + module type S = sig exception Foo of int exception Foo of bool end;; + ^^^ +Error: Multiple definition of the extension constructor name Foo. + Names must be unique in a given structure or signature. # module F : functor (X : sig end) -> sig val x : int end # Characters 0-3: F.x;; (* fail *) diff --git a/testsuite/tests/typing-modules/Test.ml.reference b/testsuite/tests/typing-modules/Test.ml.reference index d99e9a3cd..9646d3d0a 100644 --- a/testsuite/tests/typing-modules/Test.ml.reference +++ b/testsuite/tests/typing-modules/Test.ml.reference @@ -28,7 +28,11 @@ Error: Signature mismatch: ^^^^^^^^^^ Error: This variant or record definition does not match that of type u The types for field X are not equal. -# module type S = sig exception Foo of bool end +# Characters 121-124: + module type S = sig exception Foo of int exception Foo of bool end;; + ^^^ +Error: Multiple definition of the extension constructor name Foo. + Names must be unique in a given structure or signature. # module F : functor (X : sig end) -> sig val x : int end # Characters 0-3: F.x;; (* fail *) diff --git a/testsuite/tests/typing-recordarg/Makefile b/testsuite/tests/typing-recordarg/Makefile new file mode 100644 index 000000000..1834e83ab --- /dev/null +++ b/testsuite/tests/typing-recordarg/Makefile @@ -0,0 +1,14 @@ +######################################################################### +# # +# OCaml # +# # +# Xavier Clerc, SED, INRIA Rocquencourt # +# # +# Copyright 2010 Institut National de Recherche en Informatique et # +# en Automatique. All rights reserved. This file is distributed # +# under the terms of the Q Public License version 1.0. # +# # +######################################################################### + +include $(BASEDIR)/makefiles/Makefile.toplevel +include $(BASEDIR)/makefiles/Makefile.common diff --git a/testsuite/tests/typing-recordarg/recordarg.ml b/testsuite/tests/typing-recordarg/recordarg.ml new file mode 100644 index 000000000..82fad0783 --- /dev/null +++ b/testsuite/tests/typing-recordarg/recordarg.ml @@ -0,0 +1,86 @@ +type t = A of {x:int; mutable y:int};; +let f (A r) = r;; (* -> escape *) +let f (A r) = r.x;; (* ok *) +let f x = A {x; y = x};; (* ok *) +let f (A r) = A {r with y = r.x + 1};; (* ok *) +let f () = A {a = 1};; (* customized error message *) +let f () = A {x = 1; y = 3};; (* ok *) + +type _ t = A: {x : 'a; y : 'b} -> 'a t;; +let f (A {x; y}) = A {x; y = ()};; (* ok *) +let f (A ({x; y} as r)) = A {x = r.x; y = r.y};; (* ok *) + +module M = struct + type 'a t = + | A of {x : 'a} + | B: {u : 'b} -> unit t;; + + exception Foo of {x : int};; +end;; + +module N : sig + type 'b t = 'b M.t = + | A of {x : 'b} + | B: {u : 'bla} -> unit t + + 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;; + + +module type S = sig exception A of {x:int} end;; + +module F (X : sig val x : (module S) end) = struct + module A = (val X.x) +end;; (* -> this expression creates fresh types (not really!) *) + + +module type S = sig + exception A of {x : int} + exception A of {x : string} +end;; + +module M = struct + exception A of {x : int} + exception A of {x : string} +end;; + + +module M1 = struct + exception A of {x : int} +end;; + +module M = struct + include M1 + include M1 +end;; + + +module type S1 = sig + exception A of {x : int} +end;; + +module type S = sig + include S1 + include S1 +end;; + +module M = struct + exception A = M1.A +end;; + +module X1 = struct + type t = .. +end;; +module X2 = struct + type t = .. +end;; +module Z = struct + type X1.t += A of {x: int} + type X2.t += A of {x: int} +end;; diff --git a/testsuite/tests/typing-recordarg/recordarg.ml.reference b/testsuite/tests/typing-recordarg/recordarg.ml.reference new file mode 100644 index 000000000..12f609aca --- /dev/null +++ b/testsuite/tests/typing-recordarg/recordarg.ml.reference @@ -0,0 +1,64 @@ + +# type t = A of { x : int; mutable y : int; } +# Characters 14-15: + let f (A r) = r;; (* -> escape *) + ^ +Error: This form is not allowed as the type of the inlined record could escape. +# val f : t -> int = <fun> +# val f : int -> t = <fun> +# val f : t -> t = <fun> +# Characters 14-15: + let f () = A {a = 1};; (* customized error message *) + ^ +Error: The field a is not part of the record argument for the t.A constructor +# val f : unit -> t = <fun> +# type _ t = A : { x : 'a; y : 'b; } -> 'a t +# val f : 'a t -> 'a t = <fun> +# val f : 'a t -> 'a t = <fun> +# module M : + sig + type 'a t = A of { x : 'a; } | B : { u : 'b; } -> unit t + exception Foo of { x : int; } + end +# module N : + sig + type 'b t = 'b M.t = A of { x : 'b; } | B : { u : 'bla; } -> unit t + exception Foo of { x : int; } + end +# module type S = sig exception A of { x : int; } end +# Characters 65-74: + module A = (val X.x) + ^^^^^^^^^ +Error: This expression creates fresh types. + It is not allowed inside applicative functors. +# Characters 61-62: + exception A of {x : string} + ^ +Error: Multiple definition of the extension constructor name A. + Names must be unique in a given structure or signature. +# Characters 58-59: + exception A of {x : string} + ^ +Error: Multiple definition of the extension constructor name A. + Names must be unique in a given structure or signature. +# module M1 : sig exception A of { x : int; } end +# Characters 34-44: + include M1 + ^^^^^^^^^^ +Error: Multiple definition of the extension constructor name A. + Names must be unique in a given structure or signature. +# module type S1 = sig exception A of { x : int; } end +# Characters 36-46: + include S1 + ^^^^^^^^^^ +Error: Multiple definition of the extension constructor name A. + Names must be unique in a given structure or signature. +# module M : sig exception A of { x : int; } end +# module X1 : sig type t = .. end +# module X2 : sig type t = .. end +# Characters 62-63: + type X2.t += A of {x: int} + ^ +Error: Multiple definition of the extension constructor name A. + Names must be unique in a given structure or signature. +# diff --git a/tools/depend.ml b/tools/depend.ml index aeb121cbc..222d08d31 100644 --- a/tools/depend.ml +++ b/tools/depend.ml @@ -64,8 +64,13 @@ let add_opt add_fn bv = function None -> () | Some x -> add_fn bv x +let add_constructor_arguments bv = function + | Pcstr_tuple l -> List.iter (add_type bv) l + | Pcstr_record l -> List.iter (fun l -> add_type bv l.pld_type) l + let add_constructor_decl bv pcd = - List.iter (add_type bv) pcd.pcd_args; Misc.may (add_type bv) pcd.pcd_res + add_constructor_arguments bv pcd.pcd_args; + Misc.may (add_type bv) pcd.pcd_res let add_type_declaration bv td = List.iter @@ -83,9 +88,10 @@ let add_type_declaration bv td = let add_extension_constructor bv ext = match ext.pext_kind with - Pext_decl(args, rty) -> - List.iter (add_type bv) args; Misc.may (add_type bv) rty - | Pext_rebind lid -> add bv lid + Pext_decl(args, rty) -> + add_constructor_arguments bv args; + Misc.may (add_type bv) rty + | Pext_rebind lid -> add bv lid let add_type_extension bv te = add bv te.ptyext_path; diff --git a/tools/tast_iter.ml b/tools/tast_iter.ml index 791fb6a51..be5b85441 100644 --- a/tools/tast_iter.ml +++ b/tools/tast_iter.ml @@ -39,8 +39,12 @@ let structure_item sub x = let value_description sub x = sub # core_type x.val_desc +let constructor_args sub = function + | Cstr_tuple l -> List.iter (sub # core_type) l + | Cstr_record l -> List.iter (fun ld -> sub # core_type ld.ld_type) l + let constructor_decl sub cd = - List.iter (sub # core_type) cd.cd_args; + constructor_args sub cd.cd_args; opt (sub # core_type) cd.cd_res let label_decl sub ld = @@ -66,7 +70,7 @@ let type_extension sub te = let extension_constructor sub ext = match ext.ext_kind with Text_decl(ctl, cto) -> - List.iter (sub # core_type) ctl; + constructor_args sub ctl; opt (sub # core_type) cto | Text_rebind _ -> () diff --git a/tools/untypeast.ml b/tools/untypeast.ml index 7641c91d0..58242fc23 100644 --- a/tools/untypeast.ml +++ b/tools/untypeast.ml @@ -134,10 +134,14 @@ and untype_type_declaration decl = and untype_type_parameter (ct, v) = (untype_core_type ct, v) +and untype_constructor_arguments = function + | Cstr_tuple l -> Pcstr_tuple (List.map untype_core_type l) + | Cstr_record l -> Pcstr_record (List.map untype_label_declaration l) + and untype_constructor_declaration cd = { pcd_name = cd.cd_name; - pcd_args = List.map untype_core_type cd.cd_args; + pcd_args = untype_constructor_arguments cd.cd_args; pcd_res = option untype_core_type cd.cd_res; pcd_loc = cd.cd_loc; pcd_attributes = cd.cd_attributes; @@ -167,7 +171,7 @@ and untype_extension_constructor ext = pext_name = ext.ext_name; pext_kind = (match ext.ext_kind with Text_decl (args, ret) -> - Pext_decl (List.map untype_core_type args, + Pext_decl (untype_constructor_arguments args, option untype_core_type ret) | Text_rebind (_p, lid) -> Pext_rebind lid ); diff --git a/toplevel/genprintval.ml b/toplevel/genprintval.ml index 27f45a2d1..9af483ca9 100644 --- a/toplevel/genprintval.ml +++ b/toplevel/genprintval.ml @@ -290,40 +290,41 @@ module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct | _ -> assert false end | None -> decl.type_params in - let ty_args = - List.map - (function ty -> - try Ctype.apply env type_params ty ty_list with - Ctype.Cannot_apply -> abstract_type) - cd_args in - tree_of_constr_with_args (tree_of_constr env path) - (Ident.name cd_id) 0 depth obj ty_args + begin + match cd_args with + | Cstr_tuple l -> + let ty_args = + List.map + (function ty -> + try Ctype.apply env type_params ty ty_list with + Ctype.Cannot_apply -> abstract_type) + l + in + tree_of_constr_with_args (tree_of_constr env path) + (Ident.name cd_id) false 0 depth obj + ty_args + | Cstr_record lbls -> + let r = + tree_of_record_fields depth + env path type_params ty_list + lbls 0 obj + in + Oval_constr(tree_of_constr env path + (Ident.name cd_id), + [ r ]) + end | {type_kind = Type_record(lbl_list, rep)} -> begin match check_depth depth obj ty with Some x -> x | None -> - let rec tree_of_fields pos = function - | [] -> [] - | {ld_id; ld_type} :: remainder -> - let ty_arg = - try - Ctype.apply env decl.type_params ld_type - ty_list - with - Ctype.Cannot_apply -> abstract_type in - let name = Ident.name ld_id in - (* PR#5722: print full module path only - for first record field *) - let lid = - if pos = 0 then tree_of_label env path name - else Oide_ident name - and v = - nest tree_of_val (depth - 1) (O.field obj pos) - ty_arg - in - (lid, v) :: tree_of_fields (pos + 1) remainder + let pos = + match rep with + | Record_extension -> 1 + | _ -> 0 in - Oval_record (tree_of_fields 0 lbl_list) + tree_of_record_fields depth + env path decl.type_params ty_list + lbl_list pos obj end | {type_kind = Type_open} -> tree_of_extension path depth obj @@ -371,6 +372,31 @@ module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct Oval_stuff "<module>" end + and tree_of_record_fields depth env path type_params ty_list + lbl_list pos obj = + let rec tree_of_fields pos = function + | [] -> [] + | {ld_id; ld_type} :: remainder -> + let ty_arg = + try + Ctype.apply env type_params ld_type + ty_list + with + Ctype.Cannot_apply -> abstract_type in + let name = Ident.name ld_id in + (* PR#5722: print full module path only + for first record field *) + let lid = + if pos = 0 then tree_of_label env path name + else Oide_ident name + and v = + nest tree_of_val (depth - 1) (O.field obj pos) + ty_arg + in + (lid, v) :: tree_of_fields (pos + 1) remainder + in + Oval_record (tree_of_fields pos lbl_list) + and tree_of_val_list start depth obj ty_list = let rec tree_list i = function | [] -> [] @@ -380,9 +406,16 @@ module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct tree_list start ty_list and tree_of_constr_with_args - tree_of_cstr cstr_name start depth obj ty_args = + tree_of_cstr cstr_name inlined start depth obj ty_args = let lid = tree_of_cstr cstr_name in - let args = tree_of_val_list start depth obj ty_args in + let args = + if inlined then + match ty_args with + | [ty] -> [ tree_of_val (depth - 1) obj ty ] + | _ -> assert false + else + tree_of_val_list start depth obj ty_args + in Oval_constr (lid, args) and tree_of_extension type_path depth bucket = @@ -407,7 +440,9 @@ module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct if not (EVP.same_value slot (EVP.eval_path env path)) then raise Not_found; tree_of_constr_with_args - (fun x -> Oide_ident x) name 1 depth bucket cstr.cstr_args + (fun x -> Oide_ident x) name (cstr.cstr_inlined <> None) + 1 depth bucket + cstr.cstr_args with Not_found | EVP.Error -> match check_depth depth bucket ty with Some x -> x diff --git a/toplevel/topdirs.ml b/toplevel/topdirs.ml index 59ce633cd..1e260139e 100644 --- a/toplevel/topdirs.ml +++ b/toplevel/topdirs.ml @@ -398,7 +398,7 @@ let () = let ext = { ext_type_path = Predef.path_exn; ext_type_params = []; - ext_args = desc.cstr_args; + ext_args = Cstr_tuple desc.cstr_args; ext_ret_type = ret_type; ext_private = Asttypes.Public; Types.ext_loc = desc.cstr_loc; diff --git a/typing/btype.ml b/typing/btype.ml index ce97f654f..f23b7387b 100644 --- a/typing/btype.ml +++ b/typing/btype.ml @@ -253,12 +253,21 @@ type type_iterators = it_type_expr: type_iterators -> type_expr -> unit; it_path: Path.t -> unit; } +let iter_type_expr_cstr_args f = function + | Cstr_tuple tl -> List.iter f tl + | Cstr_record lbls -> List.iter (fun d -> f d.ld_type) lbls + +let map_type_expr_cstr_args f = function + | Cstr_tuple tl -> Cstr_tuple (List.map f tl) + | Cstr_record lbls -> + Cstr_record (List.map (fun d -> {d with ld_type=f d.ld_type}) lbls) + let iter_type_expr_kind f = function | Type_abstract -> () | Type_variant cstrs -> List.iter (fun cd -> - List.iter f cd.cd_args; + iter_type_expr_cstr_args f cd.cd_args; Misc.may f cd.cd_res ) cstrs @@ -288,7 +297,7 @@ let type_iterators = and it_extension_constructor it td = it.it_path td.ext_type_path; List.iter (it.it_type_expr it) td.ext_type_params; - List.iter (it.it_type_expr it) td.ext_args; + iter_type_expr_cstr_args (it.it_type_expr it) td.ext_args; may (it.it_type_expr it) td.ext_ret_type and it_module_declaration it md = it.it_module_type it md.md_type @@ -471,7 +480,7 @@ let unmark_type_decl decl = let unmark_extension_constructor ext = List.iter unmark_type ext.ext_type_params; - List.iter unmark_type ext.ext_args; + iter_type_expr_cstr_args unmark_type ext.ext_args; Misc.may unmark_type ext.ext_ret_type let unmark_class_signature sign = diff --git a/typing/btype.mli b/typing/btype.mli index 59f2e77b1..ec63e9ae6 100644 --- a/typing/btype.mli +++ b/typing/btype.mli @@ -205,3 +205,8 @@ val log_type: type_expr -> unit val print_raw: (Format.formatter -> type_expr -> unit) ref val iter_type_expr_kind: (type_expr -> unit) -> (type_kind -> unit) + +val iter_type_expr_cstr_args: (type_expr -> unit) -> + (constructor_arguments -> unit) +val map_type_expr_cstr_args: (type_expr -> type_expr) -> + (constructor_arguments -> constructor_arguments) diff --git a/typing/ctype.ml b/typing/ctype.ml index a7d31e7c8..aa6eabfae 100644 --- a/typing/ctype.ml +++ b/typing/ctype.ml @@ -454,7 +454,7 @@ let rec filter_row_fields erase = function (**************************************) -exception Non_closed +exception Non_closed0 let rec closed_schema_rec ty = let ty = repr ty in @@ -463,7 +463,7 @@ let rec closed_schema_rec ty = ty.level <- pivot_level - level; match ty.desc with Tvar _ when level <> generic_level -> - raise Non_closed + raise Non_closed0 | Tfield(_, kind, t1, t2) -> if field_kind_repr kind = Fpresent then closed_schema_rec t1; @@ -482,7 +482,7 @@ let closed_schema ty = closed_schema_rec ty; unmark_type ty; true - with Non_closed -> + with Non_closed0 -> unmark_type ty; false @@ -561,7 +561,11 @@ let closed_type_decl decl = (fun {cd_args; cd_res; _} -> match cd_res with | Some _ -> () - | None -> List.iter closed_type cd_args) + | 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 + ) v | Type_record(r, rep) -> List.iter (fun l -> closed_type l.ld_type) r @@ -582,7 +586,7 @@ let closed_extension_constructor ext = List.iter mark_type ext.ext_type_params; begin match ext.ext_ret_type with | Some _ -> () - | None -> List.iter closed_type ext.ext_args + | None -> iter_type_expr_cstr_args closed_type ext.ext_args end; unmark_extension_constructor ext; None @@ -594,7 +598,7 @@ type closed_class_failure = CC_Method of type_expr * bool * string * type_expr | CC_Value of type_expr * bool * string * type_expr -exception Failure of closed_class_failure +exception CCFailure of closed_class_failure let closed_class params sign = let ty = object_fields (repr sign.csig_self) in @@ -610,13 +614,13 @@ let closed_class params sign = (fun (lab, kind, ty) -> if field_kind_repr kind = Fpresent then try closed_type ty with Non_closed (ty0, real) -> - raise (Failure (CC_Method (ty0, real, lab, ty)))) + raise (CCFailure (CC_Method (ty0, real, lab, ty)))) fields; mark_type_params (repr sign.csig_self); List.iter unmark_type params; unmark_class_signature sign; None - with Failure reason -> + with CCFailure reason -> mark_type_params (repr sign.csig_self); List.iter unmark_type params; unmark_class_signature sign; @@ -1193,7 +1197,7 @@ let map_kind f = function List.map (fun c -> {c with - cd_args = List.map f c.cd_args; + cd_args = map_type_expr_cstr_args f c.cd_args; cd_res = may_map f c.cd_res }) cl) @@ -2178,7 +2182,12 @@ and mcomp_variant_description type_pairs env xs ys = match x, y with | c1 :: xs, c2 :: ys -> mcomp_type_option type_pairs env c1.cd_res c2.cd_res; - mcomp_list type_pairs env c1.cd_args c2.cd_args; + 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 -> + mcomp_record_description type_pairs env l1 l2 + | _ -> raise (Unify []) + end; if Ident.name c1.cd_id = Ident.name c2.cd_id then iter xs ys else raise (Unify []) @@ -4380,7 +4389,7 @@ let nondep_extension_constructor env mid ext = in ext.ext_type_path, type_params in - let args = List.map (nondep_type_rec env mid) ext.ext_args in + let args = map_type_expr_cstr_args (nondep_type_rec env mid) ext.ext_args in let ret_type = may_map (nondep_type_rec env mid) ext.ext_ret_type in clear_hash (); { ext_type_path = type_path; diff --git a/typing/datarepr.ml b/typing/datarepr.ml index 4922cbb0d..1c121d35a 100644 --- a/typing/datarepr.ml +++ b/typing/datarepr.ml @@ -41,8 +41,13 @@ let free_vars ty = let newgenconstr path tyl = newgenty (Tconstr (path, tyl, ref Mnil)) -let constructor_args cd_args cd_res = - let arg_vars_set = free_vars (newgenty (Ttuple cd_args)) in +let constructor_args cd_args cd_res path rep = + let tyl = + match cd_args with + | Cstr_tuple l -> l + | Cstr_record l -> List.map (fun l -> l.ld_type) l + in + let arg_vars_set = free_vars (newgenty (Ttuple tyl)) in let existentials = match cd_res with | None -> [] @@ -50,14 +55,33 @@ let constructor_args cd_args cd_res = let res_vars = free_vars type_ret in TypeSet.elements (TypeSet.diff arg_vars_set res_vars) in - existentials, cd_args + match cd_args with + | Cstr_tuple l -> existentials, l, None + | Cstr_record lbls -> + let type_params = TypeSet.elements arg_vars_set in + let tdecl = + { + type_params; + type_arity = List.length type_params; + type_kind = Type_record (lbls, rep); + type_private = Public; + type_manifest = None; + type_variance = List.map (fun _ -> Variance.full) type_params; + type_newtype_level = None; + type_loc = Location.none; + type_attributes = []; + } + in + existentials, + [ newgenconstr path type_params ], + Some tdecl let constructor_descrs ty_path 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; _} -> - if cd_args = [] then incr num_consts else incr num_nonconsts; + if cd_args = Cstr_tuple [] then incr num_consts else incr num_nonconsts; if cd_res = None then incr num_normal) cstrs; let rec describe_constructors idx_const idx_nonconst = function @@ -70,15 +94,19 @@ let constructor_descrs ty_path decl cstrs = in let (tag, descr_rem) = match cd_args with - [] -> (Cstr_constant idx_const, + Cstr_tuple [] -> (Cstr_constant idx_const, describe_constructors (idx_const+1) idx_nonconst rem) | _ -> (Cstr_block idx_nonconst, describe_constructors idx_const (idx_nonconst+1) rem) in - let existentials, cstr_args = + + let cstr_name = Ident.name cd_id in + let existentials, cstr_args, cstr_inlined = constructor_args cd_args cd_res + (Path.Pdot (ty_path, cstr_name, Path.nopos)) + (Record_inlined idx_nonconst) in let cstr = - { cstr_name = Ident.name cd_id; + { cstr_name; cstr_res = ty_res; cstr_existentials = existentials; cstr_args; @@ -91,6 +119,7 @@ let constructor_descrs ty_path decl cstrs = cstr_generalized = cd_res <> None; cstr_loc = cd_loc; cstr_attributes = cd_attributes; + cstr_inlined; } in (cd_id, cstr) :: descr_rem in describe_constructors 0 0 cstrs @@ -101,8 +130,9 @@ let extension_descr path_ext ext = Some type_ret -> type_ret | None -> newgenconstr ext.ext_type_path ext.ext_type_params in - let existentials, cstr_args = + let existentials, cstr_args, cstr_inlined = constructor_args ext.ext_args ext.ext_ret_type + path_ext Record_extension in { cstr_name = Path.last path_ext; cstr_res = ty_res; @@ -117,6 +147,7 @@ let extension_descr path_ext ext = cstr_generalized = ext.ext_ret_type <> None; cstr_loc = ext.ext_loc; cstr_attributes = ext.ext_attributes; + cstr_inlined; } let none = {desc = Ttuple []; level = -1; id = -1} @@ -155,7 +186,7 @@ exception Constr_not_found let rec find_constr tag num_const num_nonconst = function [] -> raise Constr_not_found - | {cd_args = []; _} as c :: rem -> + | {cd_args = Cstr_tuple []; _} as c :: rem -> if tag = Cstr_constant num_const then c else find_constr tag (num_const + 1) num_nonconst rem diff --git a/typing/env.ml b/typing/env.ml index 5655197a9..4e6bba0c5 100644 --- a/typing/env.ml +++ b/typing/env.ml @@ -475,6 +475,51 @@ and find_class = and find_cltype = find (fun env -> env.cltypes) (fun sc -> sc.comp_cltypes) +let type_of_cstr path = function + | {cstr_inlined = Some d; _} -> + (d, ([], List.map snd (Datarepr.labels_of_type path d))) + | _ -> + assert false + +let find_type_full path env = + match Path.constructor_typath path with + | Regular p -> find_type_full p env + | Cstr (ty_path, s) -> + let (_, (cstrs, _)) = + try find_type_full ty_path env + with Not_found -> assert false + in + let cstr = + try List.find (fun cstr -> cstr.cstr_name = s) cstrs + with Not_found -> assert false + in + type_of_cstr path cstr + | LocalExt id -> + let cstr = + try EnvTbl.find_same id env.constrs + with Not_found -> assert false + in + type_of_cstr path cstr + | Ext (mod_path, s) -> + let comps = + try find_module_descr mod_path env + with Not_found -> assert false + in + let comps = + match EnvLazy.force !components_of_module_maker' comps with + | Structure_comps c -> c + | Functor_comps _ -> assert false + in + let exts = + List.filter + (function ({cstr_tag=Cstr_extension _}, _) -> true | _ -> false) + (try Tbl.find s comps.comp_constrs + with Not_found -> assert false) + in + match exts with + | [(cstr, _)] -> type_of_cstr path cstr + | _ -> assert false + let find_type p env = fst (find_type_full p env) let find_type_descrs p env = @@ -1086,7 +1131,9 @@ let rec prefix_idents root pos sub = function (p::pl, final_sub) | Sig_typext(id, ext, _) :: rem -> let p = Pdot(root, Ident.name id, pos) in - let (pl, final_sub) = prefix_idents root (pos+1) sub rem in + (* we extend the substitution in case of an inlined record *) + let (pl, final_sub) = + prefix_idents root (pos+1) (Subst.add_type id p sub) rem in (p::pl, final_sub) | Sig_module(id, mty, _) :: rem -> let p = Pdot(root, Ident.name id, pos) in diff --git a/typing/includecore.ml b/typing/includecore.ml index ee247adad..a4da854cf 100644 --- a/typing/includecore.ml +++ b/typing/includecore.ml @@ -154,7 +154,19 @@ let report_type_mismatch first second decl ppf = if err = Manifest then () else Format.fprintf ppf "@ %a." (report_type_mismatch0 first second decl) err) -let rec compare_variants env params1 params2 n cstrs1 cstrs2 = +let rec compare_constructor_arguments env cstr params1 params2 arg1 arg2 = + match arg1, arg2 with + | Types.Cstr_tuple arg1, Types.Cstr_tuple arg2 -> + if List.length arg1 <> List.length arg2 then [Field_arity cstr] + else if Misc.for_all2 + (fun ty1 ty2 -> Ctype.equal env true (ty1::params1) (ty2::params2)) + (arg1) (arg2) + then [] else [Field_type cstr] + | Types.Cstr_record l1, Types.Cstr_record l2 -> + compare_records env params1 params2 0 l1 l2 + | _ -> [Field_type cstr] + +and compare_variants env params1 params2 n cstrs1 cstrs2 = match cstrs1, cstrs2 with [], [] -> [] | [], c::_ -> [Field_missing (true, c.Types.cd_id)] @@ -163,24 +175,21 @@ let rec compare_variants env params1 params2 n cstrs1 cstrs2 = {Types.cd_id=cstr2; cd_args=arg2; cd_res=ret2}::rem2 -> if Ident.name cstr1 <> Ident.name cstr2 then [Field_names (n, cstr1, cstr2)] - else if List.length arg1 <> List.length arg2 then - [Field_arity cstr1] else match ret1, ret2 with | Some r1, Some r2 when not (Ctype.equal env true [r1] [r2]) -> [Field_type cstr1] | Some _, None | None, Some _ -> [Field_type cstr1] | _ -> - if Misc.for_all2 - (fun ty1 ty2 -> - Ctype.equal env true (ty1::params1) (ty2::params2)) - (arg1) (arg2) - then - compare_variants env params1 params2 (n+1) rem1 rem2 - else [Field_type cstr1] + let r = + compare_constructor_arguments env cstr1 + params1 params2 arg1 arg2 + in + if r <> [] then r + else compare_variants env params1 params2 (n+1) rem1 rem2 -let rec compare_records env params1 params2 n labels1 labels2 = +and compare_records env params1 params2 n labels1 labels2 = match labels1, labels2 with [], [] -> [] | [], l::_ -> [Field_missing (true, l.ld_id)] @@ -278,17 +287,13 @@ let extension_constructors env id ext1 ext2 = (ty1 :: ext1.ext_type_params) (ty2 :: ext2.ext_type_params) then - if List.length ext1.ext_args = List.length ext2.ext_args then + if compare_constructor_arguments env (Ident.create "") + ext1.ext_type_params ext2.ext_type_params + ext1.ext_args ext2.ext_args = [] then if match ext1.ext_ret_type, ext2.ext_ret_type with Some r1, Some r2 when not (Ctype.equal env true [r1] [r2]) -> false | Some _, None | None, Some _ -> false - | _ -> - Misc.for_all2 - (fun ty1 ty2 -> - Ctype.equal env true - (ty1 :: ext1.ext_type_params) - (ty2 :: ext2.ext_type_params)) - ext1.ext_args ext2.ext_args + | _ -> true then match ext1.ext_private, ext2.ext_private with Private, Public -> false diff --git a/typing/mtype.ml b/typing/mtype.ml index 19253a10e..3c3b4b8c7 100644 --- a/typing/mtype.ml +++ b/typing/mtype.ml @@ -263,7 +263,13 @@ and contains_type_sig env = List.iter (contains_type_item env) and contains_type_item env = function Sig_type (_,({type_manifest = None} | {type_kind = Type_abstract; type_private = Private}),_) - | Sig_modtype _ -> + | Sig_modtype _ + | Sig_typext (_, {ext_args = Cstr_record _}, _) -> + (* We consider that extension constructors with an inlined + record create a type (the inlined record), even though + it would be technically safe to ignore that considering + the current constraints which guarantee that this type + is kept local to expressions. *) raise Exit | Sig_module (_, {md_type = mty}, _) -> contains_type env mty diff --git a/typing/oprint.ml b/typing/oprint.ml index 994d93275..3c2d63708 100644 --- a/typing/oprint.ml +++ b/typing/oprint.ml @@ -224,7 +224,8 @@ and print_simple_out_type ppf = pp_print_char ppf ')'; pp_close_box ppf () | Otyp_abstract | Otyp_open - | Otyp_sum _ | Otyp_record _ | Otyp_manifest (_, _) -> () + | Otyp_sum _ | Otyp_manifest (_, _) -> () + | Otyp_record lbls -> print_record_decl ppf lbls | Otyp_module (p, n, tyl) -> fprintf ppf "@[<1>(module %s" p; let first = ref true in @@ -235,6 +236,9 @@ and print_simple_out_type ppf = ) n tyl; fprintf ppf ")@]" +and print_record_decl ppf lbls = + fprintf ppf "{%a@;<1 -2>}" + (print_list_init print_out_label (fun ppf -> fprintf ppf "@ ")) lbls and print_fields rest ppf = function [] -> @@ -279,6 +283,9 @@ and print_typargs ppf = pp_print_char ppf ')'; pp_close_box ppf (); pp_print_space ppf () +and print_out_label ppf (name, mut, arg) = + fprintf ppf "@[<2>%s%s :@ %a@];" (if mut then "mutable " else "") name + print_out_type arg let out_type = ref print_out_type @@ -471,9 +478,9 @@ and print_out_type_decl kwd ppf td = let print_out_tkind ppf = function | Otyp_abstract -> () | Otyp_record lbls -> - fprintf ppf " =%a {%a@;<1 -2>}" + fprintf ppf " =%a %a" print_private td.otype_private - (print_list_init print_out_label (fun ppf -> fprintf ppf "@ ")) lbls + print_record_decl lbls | Otyp_sum constrs -> fprintf ppf " =%a@;<1 2>%a" print_private td.otype_private @@ -510,11 +517,6 @@ and print_out_constr ppf (name, tyl,ret_type_opt) = tyl print_simple_out_type ret_type end - -and print_out_label ppf (name, mut, arg) = - fprintf ppf "@[<2>%s%s :@ %a@];" (if mut then "mutable " else "") name - !out_type arg - and print_out_extension_constructor ppf ext = let print_extended_type ppf = let print_type_parameter ppf ty = diff --git a/typing/path.ml b/typing/path.ml index 260fc0731..6afa3841b 100644 --- a/typing/path.ml +++ b/typing/path.ml @@ -52,3 +52,27 @@ let rec last = function | Pident id -> Ident.name id | Pdot(_, s, _) -> s | Papply(_, p) -> last p + +let is_uident s = + assert (s <> ""); + match s.[0] with + | 'A'..'Z' -> true + | _ -> false + +type typath = + | Regular of t + | Ext of t * string + | LocalExt of Ident.t + | Cstr of t * string + +let constructor_typath = function + | Pident id when is_uident (Ident.name id) -> LocalExt id + | Pdot(ty_path, s, _) when is_uident s -> + if is_uident (last ty_path) then Ext (ty_path, s) + else Cstr (ty_path, s) + | p -> Regular p + +let is_constructor_typath p = + match constructor_typath p with + | Regular _ -> false + | _ -> true diff --git a/typing/path.mli b/typing/path.mli index c3f84130d..07de1c2c5 100644 --- a/typing/path.mli +++ b/typing/path.mli @@ -28,3 +28,12 @@ val name: ?paren:(string -> bool) -> t -> string val head: t -> Ident.t val last: t -> string + +type typath = + | Regular of t + | Ext of t * string + | LocalExt of Ident.t + | Cstr of t * string + +val constructor_typath: t -> typath +val is_constructor_typath: t -> bool diff --git a/typing/predef.ml b/typing/predef.ml index e9b9f7e5c..bcad58efd 100644 --- a/typing/predef.ml +++ b/typing/predef.ml @@ -107,7 +107,7 @@ let decl_abstr = let cstr id args = { cd_id = id; - cd_args = args; + cd_args = Cstr_tuple args; cd_res = None; cd_loc = Location.none; cd_attributes = []; @@ -163,7 +163,7 @@ let common_initial_env add_type add_extension empty_env = add_extension id { ext_type_path = path_exn; ext_type_params = []; - ext_args = l; + ext_args = Cstr_tuple l; ext_ret_type = None; ext_private = Asttypes.Public; ext_loc = Location.none; diff --git a/typing/printtyp.ml b/typing/printtyp.ml index b084935da..db856958b 100644 --- a/typing/printtyp.ml +++ b/typing/printtyp.ml @@ -739,6 +739,11 @@ let string_of_mutable = function | Immutable -> "" | Mutable -> "mutable " + +let mark_loops_constructor_arguments = function + | Cstr_tuple l -> List.iter mark_loops l + | Cstr_record l -> List.iter (fun l -> mark_loops l.ld_type) l + let rec tree_of_type_decl id decl = reset(); @@ -782,8 +787,8 @@ let rec tree_of_type_decl id decl = | Type_variant cstrs -> List.iter (fun c -> - List.iter mark_loops c.cd_args; - may mark_loops c.cd_res) + mark_loops_constructor_arguments c.cd_args; + may mark_loops c.cd_res) cstrs | Type_record(l, rep) -> List.iter (fun l -> mark_loops l.ld_type) l @@ -850,15 +855,20 @@ let rec tree_of_type_decl id decl = otype_private = priv; otype_cstrs = constraints } +and tree_of_constructor_arguments = function + | Cstr_tuple l -> tree_of_typlist false l + | Cstr_record l -> [ Otyp_record (List.map tree_of_label l) ] + and tree_of_constructor cd = let name = Ident.name cd.cd_id in + let arg () = tree_of_constructor_arguments cd.cd_args in match cd.cd_res with - | None -> (name, tree_of_typlist false cd.cd_args, None) + | None -> (name, arg (), None) | Some res -> let nm = !names in names := []; let ret = tree_of_typexp false res in - let args = tree_of_typlist false cd.cd_args in + let args = arg () in names := nm; (name, args, Some ret) @@ -871,6 +881,10 @@ let tree_of_type_declaration id decl rs = let type_declaration id ppf decl = !Oprint.out_sig_item ppf (tree_of_type_declaration id decl Trec_first) +let constructor_arguments ppf a = + let tys = tree_of_constructor_arguments a in + !Oprint.out_type ppf (Otyp_tuple tys) + (* Print an extension declaration *) let tree_of_extension_constructor id ext es = @@ -880,7 +894,7 @@ let tree_of_extension_constructor id ext es = List.iter add_alias ty_params; List.iter mark_loops ty_params; List.iter check_name_of_type (List.map proxy ty_params); - List.iter mark_loops ext.ext_args; + mark_loops_constructor_arguments ext.ext_args; may mark_loops ext.ext_ret_type; let type_param = function @@ -893,12 +907,12 @@ let tree_of_extension_constructor id ext es = let name = Ident.name id in let args, ret = match ext.ext_ret_type with - | None -> (tree_of_typlist false ext.ext_args, None) + | None -> (tree_of_constructor_arguments ext.ext_args, None) | Some res -> let nm = !names in names := []; let ret = tree_of_typexp false res in - let args = tree_of_typlist false ext.ext_args in + let args = tree_of_constructor_arguments ext.ext_args in names := nm; (args, Some ret) in diff --git a/typing/printtyp.mli b/typing/printtyp.mli index 3fa9bd484..14b67cd05 100644 --- a/typing/printtyp.mli +++ b/typing/printtyp.mli @@ -32,6 +32,7 @@ val mark_loops: type_expr -> unit val reset_and_mark_loops: type_expr -> unit val reset_and_mark_loops_list: type_expr list -> unit val type_expr: formatter -> type_expr -> unit +val constructor_arguments: formatter -> constructor_arguments -> unit val tree_of_type_scheme: type_expr -> out_type val type_sch : formatter -> type_expr -> unit val type_scheme: formatter -> type_expr -> unit @@ -82,4 +83,3 @@ val report_ambiguous_type_error: (* for toploop *) val print_items: (Env.t -> signature_item -> 'a option) -> Env.t -> signature_item list -> (out_sig_item * 'a option) list - diff --git a/typing/printtyped.ml b/typing/printtyped.ml index 0e97e586b..5184b19e5 100644 --- a/typing/printtyped.ml +++ b/typing/printtyped.ml @@ -431,7 +431,7 @@ and extension_constructor_kind i ppf x = match x with Text_decl(a, r) -> line i ppf "Pext_decl\n"; - list (i+1) core_type ppf a; + constructor_arguments (i+1) ppf a; option (i+1) core_type ppf r; | Text_rebind(p, _) -> line i ppf "Pext_rebind\n"; @@ -779,9 +779,13 @@ and constructor_decl i ppf {cd_id; cd_name = _; cd_args; cd_res; cd_loc; cd_attr line i ppf "%a\n" fmt_location cd_loc; line (i+1) ppf "%a\n" fmt_ident cd_id; attributes i ppf cd_attributes; - list (i+1) core_type ppf cd_args; + constructor_arguments (i+1) ppf cd_args; option (i+1) core_type ppf cd_res +and constructor_arguments i ppf = function + | Cstr_tuple l -> list i core_type ppf l + | Cstr_record l -> list i label_decl ppf l + and label_decl i ppf {ld_id; ld_name = _; ld_mutable; ld_type; ld_loc; ld_attributes} = line i ppf "%a\n" fmt_location ld_loc; attributes i ppf ld_attributes; diff --git a/typing/subst.ml b/typing/subst.ml index 5b1b0c67f..b6a0edbc5 100644 --- a/typing/subst.ml +++ b/typing/subst.ml @@ -76,6 +76,13 @@ let type_path s = function | Papply(p1, p2) -> fatal_error "Subst.type_path" +let type_path s p = + match Path.constructor_typath p with + | Regular p -> type_path s p + | Cstr (ty_path, cstr) -> Pdot(type_path s ty_path, cstr, nopos) + | LocalExt _ -> type_path s p + | Ext (p, cstr) -> Pdot(module_path s p, cstr, nopos) + (* Special type ids for saved signatures *) let new_id = ref (-1) @@ -193,8 +200,11 @@ let label_declaration s l = ld_attributes = attrs s l.ld_attributes; } -let constructor_arguments s args = - List.map (typexp s) args +let constructor_arguments s = function + | Cstr_tuple l -> + Cstr_tuple (List.map (typexp s) l) + | Cstr_record l -> + Cstr_record (List.map (label_declaration s) l) let constructor_declaration s c = { diff --git a/typing/typeclass.ml b/typing/typeclass.ml index 33b776bef..eb7746214 100644 --- a/typing/typeclass.ml +++ b/typing/typeclass.ml @@ -70,7 +70,7 @@ let dummy_method = Btype.dummy_method Path associated to the temporary class type of a class being typed (its constructor is not available). *) -let unbound_class = Path.Pident (Ident.create "") +let unbound_class = Path.Pident (Ident.create "*undef*") (************************************) diff --git a/typing/typecore.ml b/typing/typecore.ml index 16a310d60..9395b5295 100644 --- a/typing/typecore.ml +++ b/typing/typecore.ml @@ -67,6 +67,7 @@ type error = | Invalid_for_loop_index | No_value_clauses | Exception_pattern_below_toplevel + | Inlined_record_escape exception Error of Location.t * Env.t * error exception Error_forward of Location.error @@ -111,6 +112,17 @@ let rp node = ;; +let is_recarg d = + match (repr d.val_type).desc with + | Tconstr(p, _, _) -> Path.is_constructor_typath p + | _ -> false + +type recarg = + | Allowed + | Required + | Rejected + + let fst3 (x, _, _) = x let snd3 (_,x,_) = x @@ -592,6 +604,7 @@ module NameChoice(Name : sig val get_descrs: Env.type_descriptions -> t list val fold: (t -> 'a -> 'a) -> Longident.t option -> Env.t -> 'a -> 'a val unbound_name_error: Env.t -> Longident.t loc -> 'a + val in_env: t -> bool end) = struct open Name @@ -685,9 +698,12 @@ end) = struct with Not_found -> try let lbl = lookup_from_type env tpath lid in check_lk tpath lbl; + if in_env lbl then + begin let s = Printtyp.string_of_path tpath in warn lid.loc (Warnings.Name_out_of_scope (s, [Longident.last lid.txt], false)); + end; if not pr then warn_pr (); lbl with Not_found -> @@ -704,6 +720,7 @@ end) = struct raise (Error (lid.loc, env, Name_type_mismatch (type_kind, lid.txt, tp, tpl))) in + if in_env lbl then begin match scope with (lab1,_)::_ when lab1 == lbl -> () | _ -> @@ -725,6 +742,10 @@ module Label = NameChoice (struct let get_descrs = snd let fold = Env.fold_labels let unbound_name_error = Typetexp.unbound_label_error + let in_env lbl = + match lbl.lbl_repres with + | Record_regular | Record_float -> true + | Record_inlined _ | Record_extension -> false end) let disambiguate_label_by_ids keep env closed ids labels = @@ -877,6 +898,7 @@ module Constructor = NameChoice (struct let get_descrs = fst let fold = Env.fold_constructors let unbound_name_error = Typetexp.unbound_constructor_error + let in_env _ = true end) (* unification of a type with a tconstr with @@ -1055,6 +1077,21 @@ let rec type_pat ~constrs ~labels ~no_existentials ~mode ~env sp expected_ty = unify_pat_types_gadt loc env ty_res expected_ty else unify_pat_types loc !env ty_res expected_ty; + + let rec check_non_escaping p = + match p.ppat_desc with + | Ppat_or (p1, p2) -> + check_non_escaping p1; + check_non_escaping p2 + | Ppat_alias (p, _) -> + check_non_escaping p + | Ppat_constraint _ -> + raise (Error (p.ppat_loc, !env, Inlined_record_escape)) + | _ -> + () + in + if constr.cstr_inlined <> None then List.iter check_non_escaping sargs; + let args = List.map2 (fun p t -> type_pat p t) sargs ty_args in rp { pat_desc=Tpat_construct(lid, constr, args); @@ -1716,9 +1753,9 @@ let unify_exp env exp expected_ty = Printtyp.raw_type_expr expected_ty; *) unify_exp_types exp.exp_loc env exp.exp_type expected_ty -let rec type_exp env sexp = +let rec type_exp ?recarg env sexp = (* We now delegate everything to type_expect *) - type_expect env sexp (newvar ()) + type_expect ?recarg env sexp (newvar ()) (* Typing of an expression with an expected type. This provide better error messages, and allows controlled @@ -1726,17 +1763,17 @@ let rec type_exp env sexp = In the principal case, [type_expected'] may be at generic_level. *) -and type_expect ?in_function env sexp ty_expected = +and type_expect ?in_function ?recarg env sexp ty_expected = let previous_saved_types = Cmt_format.get_saved_types () in Typetexp.warning_enter_scope (); Typetexp.warning_attribute sexp.pexp_attributes; - let exp = type_expect_ ?in_function env sexp ty_expected in + let exp = type_expect_ ?in_function ?recarg env sexp ty_expected in Typetexp.warning_leave_scope (); Cmt_format.set_saved_types (Cmt_format.Partial_expression exp :: previous_saved_types); exp -and type_expect_ ?in_function env sexp ty_expected = +and type_expect_ ?in_function ?(recarg=Rejected) env sexp ty_expected = let loc = sexp.pexp_loc in (* Record the expression type before unifying it with the expected type *) let rue exp = @@ -1756,6 +1793,11 @@ and type_expect_ ?in_function env sexp ty_expected = let name = Path.name ~paren:Oprint.parenthesized_ident path in Stypes.record (Stypes.An_ident (loc, name, annot)) end; + begin match is_recarg desc, recarg with + | _, Allowed | true, Required | false, Rejected -> () + | true, Rejected | false, Required -> + raise (Error (loc, env, Inlined_record_escape)); + end; rue { exp_desc = begin match desc.val_kind with @@ -2012,7 +2054,7 @@ and type_expect_ ?in_function env sexp ty_expected = None -> None | Some sexp -> if !Clflags.principal then begin_def (); - let exp = type_exp env sexp in + let exp = type_exp ~recarg env sexp in if !Clflags.principal then begin end_def (); generalize_structure exp.exp_type @@ -2729,7 +2771,7 @@ and type_function ?in_function loc attrs env ty_expected l caselist = and type_label_access env loc srecord lid = if !Clflags.principal then begin_def (); - let record = type_exp env srecord in + let record = type_exp ~recarg:Allowed env srecord in if !Clflags.principal then begin end_def (); generalize_structure record.exp_type @@ -3034,7 +3076,7 @@ and type_label_exp create env loc ty_expected in (lid, label, {arg with exp_type = instance env arg.exp_type}) -and type_argument env sarg ty_expected' ty_expected = +and type_argument ?recarg env sarg ty_expected' ty_expected = (* ty_expected' may be generic *) let no_labels ty = let ls, tvar = list_labels env ty in @@ -3119,7 +3161,7 @@ and type_argument env sarg ty_expected' ty_expected = func let_var) } end | _ -> - let texp = type_expect env sarg ty_expected' in + let texp = type_expect ?recarg env sarg ty_expected' in unify_exp env texp ty_expected; texp @@ -3361,7 +3403,21 @@ and type_construct env loc lid sarg ty_expected attrs = in let texp = {texp with exp_type = ty_res} in if not separate then unify_exp env texp (instance env ty_expected); - let args = List.map2 (fun e (t,t0) -> type_argument env e t t0) sargs + let recarg = + match constr.cstr_inlined with + | None -> Rejected + | Some _ -> + begin match sargs with + | [{pexp_desc = + Pexp_ident _ | + Pexp_record (_, (Some {pexp_desc = Pexp_ident _}| None))}] -> + Required + | _ -> + raise (Error(loc, env, Inlined_record_escape)) + end + in + let args = + List.map2 (fun e (t,t0) -> type_argument ~recarg env e t t0) sargs (List.combine ty_args ty_args0) in if constr.cstr_private = Private then raise(Error(loc, env, Private_type ty_res)); @@ -3826,6 +3882,12 @@ let report_error env ppf = function fprintf ppf "The record field %a is not mutable" longident lid | Wrong_name (eorp, ty, kind, p, lid) -> reset_and_mark_loops ty; + if Path.is_constructor_typath p then begin + fprintf ppf "@[The field %a is not part of the record \ + argument for the %a constructor@]" + longident lid + path p; + end else begin fprintf ppf "@[@[<2>%s type@ %a@]@ " eorp type_expr ty; fprintf ppf "The %s %a does not belong to type %a@]" @@ -3833,6 +3895,7 @@ let report_error env ppf = function longident lid (*kind*) path p; if kind = "record" then Label.spellcheck ppf env p lid else Constructor.spellcheck ppf env p lid + end | Name_type_mismatch (kind, lid, tp, tpl) -> let name = if kind = "record" then "field" else "constructor" in report_ambiguous_type_error ppf env tp tpl @@ -3961,6 +4024,10 @@ let report_error env ppf = function | Exception_pattern_below_toplevel -> fprintf ppf "@[Exception patterns must be at the top level of a match case.@]" + | Inlined_record_escape -> + fprintf ppf + "@[This form is not allowed as the type of the inlined record could \ + escape.@]" let report_error env ppf err = wrap_printing_env env (fun () -> report_error env ppf err) @@ -3978,3 +4045,8 @@ let () = let () = Env.add_delayed_check_forward := add_delayed_check + +(* drop ?recarg argument from the external API *) +let type_expect ?in_function env e ty = type_expect ?in_function env e ty +let type_exp env e = type_exp env e +let type_argument env e t1 t2 = type_argument env e t1 t2 diff --git a/typing/typecore.mli b/typing/typecore.mli index 4ce6b1fc3..4a450e344 100644 --- a/typing/typecore.mli +++ b/typing/typecore.mli @@ -109,6 +109,7 @@ type error = | Invalid_for_loop_index | No_value_clauses | Exception_pattern_below_toplevel + | Inlined_record_escape exception Error of Location.t * Env.t * error exception Error_forward of Location.error diff --git a/typing/typedecl.ml b/typing/typedecl.ml index 2bcb8221e..90c432bc5 100644 --- a/typing/typedecl.ml +++ b/typing/typedecl.ml @@ -178,16 +178,21 @@ let transl_labels loc env closed lbls = lbls in lbls, lbls' -let transl_constructor_arguments env closed l = - let l = List.map (transl_simple_type env closed) l in - List.map (fun t -> t.ctyp_type) l, - l - -let make_constructor env type_path type_params sargs sret_type = +let transl_constructor_arguments loc env closed = function + | Pcstr_tuple l -> + let l = List.map (transl_simple_type env closed) l in + Types.Cstr_tuple (List.map (fun t -> t.ctyp_type) l), + Cstr_tuple l + | Pcstr_record l -> + let lbls, lbls' = transl_labels loc env closed l in + Types.Cstr_record lbls', + Cstr_record lbls + +let make_constructor loc env type_path type_params sargs sret_type = match sret_type with | None -> let args, targs = - transl_constructor_arguments env true sargs + transl_constructor_arguments loc env true sargs in targs, None, args, None | Some sret_type -> @@ -196,7 +201,7 @@ let make_constructor env type_path type_params sargs sret_type = let z = narrow () in reset_type_variables (); let args, targs = - transl_constructor_arguments env false sargs + transl_constructor_arguments loc env false sargs in let tret_type = transl_simple_type env false sret_type in let ret_type = tret_type.ctyp_type in @@ -237,13 +242,13 @@ let transl_declaration env sdecl id = all_constrs := StringSet.add name !all_constrs) scstrs; if List.length - (List.filter (fun cd -> cd.pcd_args <> []) scstrs) + (List.filter (fun cd -> cd.pcd_args <> Pcstr_tuple []) scstrs) > (Config.max_tag + 1) then raise(Error(sdecl.ptype_loc, Too_many_constructors)); let make_cstr scstr = let name = Ident.create scstr.pcd_name.txt in let targs, tret_type, args, ret_type = - make_constructor env (Path.Pident id) params + make_constructor scstr.pcd_loc env (Path.Pident id) params scstr.pcd_args scstr.pcd_res in let tcstr = @@ -401,10 +406,16 @@ let check_constraints env sdecl (_, decl) = let {pcd_args; pcd_res; _} = try SMap.find (Ident.name name) pl_index with Not_found -> assert false in - List.iter2 - (fun sty ty -> - check_constraints_rec env sty.ptyp_loc visited ty) - pcd_args cd_args; + begin match cd_args, pcd_args with + | Cstr_tuple tyl, Pcstr_tuple styl -> + List.iter2 + (fun sty ty -> + check_constraints_rec env sty.ptyp_loc visited ty) + styl tyl + | Cstr_record tyl, Pcstr_record styl -> + check_constraints_labels env visited tyl styl + | _ -> assert false + end; match pcd_res, cd_res with | Some sr, Some r -> check_constraints_rec env sr.ptyp_loc visited r @@ -777,12 +788,19 @@ let constrained vars ty = | Tvar _ -> List.exists (fun tl -> List.memq ty tl) vars | _ -> true +let for_constr = function + | Types.Cstr_tuple l -> add_false l + | Types.Cstr_record l -> + List.map + (fun {Types.ld_mutable; ld_type} -> (ld_mutable = Mutable, ld_type)) + l + let compute_variance_gadt env check (required, loc as rloc) decl (tl, ret_type_opt) = match ret_type_opt with | None -> compute_variance_type env check rloc {decl with type_private = Private} - (add_false tl) + (for_constr tl) | Some ret_type -> match Ctype.repr ret_type with | {desc=Tconstr (_, tyl, _)} -> @@ -802,7 +820,7 @@ let compute_variance_gadt env check (required, loc as rloc) decl in compute_variance_type env check rloc {decl with type_params = tyl; type_private = Private} - (add_false tl) + (for_constr tl) | _ -> assert false let compute_variance_extension env check decl ext rloc = @@ -829,11 +847,11 @@ let compute_variance_decl env check decl (required, _ as rloc) = | Type_variant tll -> if List.for_all (fun c -> c.Types.cd_res = None) tll then compute_variance_type env check rloc decl - (mn @ - add_false (List.flatten (List.map (fun c -> c.Types.cd_args) tll))) + (mn @ List.flatten (List.map (fun c -> for_constr c.Types.cd_args) + tll)) else begin let mn = - List.map (fun (_,ty) -> ([ty],None)) mn in + List.map (fun (_,ty) -> (Types.Cstr_tuple [ty],None)) mn in let tll = mn @ List.map (fun c -> c.Types.cd_args, c.Types.cd_res) tll in match List.map (compute_variance_gadt env check rloc decl) tll with @@ -980,6 +998,7 @@ let transl_type_decl env sdecl_list = fixed_types @ sdecl_list in + (* Create identifiers. *) let id_list = List.map (fun sdecl -> Ident.create sdecl.ptype_name.txt) sdecl_list @@ -1103,7 +1122,8 @@ let transl_extension_constructor env type_path type_params match sext.pext_kind with Pext_decl(sargs, sret_type) -> let targs, tret_type, args, ret_type = - make_constructor env type_path typext_params sargs sret_type + make_constructor sext.pext_loc env type_path typext_params + sargs sret_type in args, ret_type, Text_decl(targs, tret_type) | Pext_rebind lid -> @@ -1173,7 +1193,27 @@ let transl_extension_constructor env type_path type_params Cstr_extension(path, _) -> path | _ -> assert false in - args, ret_type, Text_rebind(path, lid) + let args = + match cdescr.cstr_inlined with + | None -> + Types.Cstr_tuple args + | Some decl -> + let tl = + match args with + | [ {desc=Tconstr(_, tl, _)} ] -> tl + | _ -> assert false + in + let decl = Ctype.instance_declaration decl in + assert (List.length decl.type_params = List.length tl); + List.iter2 (Ctype.unify env) decl.type_params tl; + let lbls = + match decl.type_kind with + | Type_record (lbls, Record_extension) -> lbls + | _ -> assert false + in + Types.Cstr_record lbls + in + args, ret_type, Text_rebind(path, lid) in let ext = { ext_type_path = type_path; @@ -1246,7 +1286,7 @@ let transl_type_extension check_open env loc styext = List.iter Ctype.generalize type_params; List.iter (fun ext -> - List.iter Ctype.generalize ext.ext_type.ext_args; + Btype.iter_type_expr_cstr_args Ctype.generalize ext.ext_type.ext_args; may Ctype.generalize ext.ext_type.ext_ret_type) constructors; (* Check that all type variable are closed *) @@ -1289,7 +1329,7 @@ let transl_exception env sext = in Ctype.end_def(); (* Generalize types *) - List.iter Ctype.generalize ext.ext_type.ext_args; + Btype.iter_type_expr_cstr_args Ctype.generalize ext.ext_type.ext_args; may Ctype.generalize ext.ext_type.ext_ret_type; (* Check that all type variable are closed *) begin match Ctype.closed_extension_constructor ext.ext_type with @@ -1461,17 +1501,21 @@ let check_recmod_typedecl env loc recmod_ids path decl = open Format -let explain_unbound ppf tv tl typ kwd lab = +let explain_unbound_gen ppf tv tl typ kwd pr = try let ti = List.find (fun ti -> Ctype.deep_occur tv (typ ti)) tl in let ty0 = (* Hack to force aliasing when needed *) Btype.newgenty (Tobject(tv, ref None)) in Printtyp.reset_and_mark_loops_list [typ ti; ty0]; fprintf ppf - ".@.@[<hov2>In %s@ %s%a@;<1 -2>the variable %a is unbound@]" - kwd (lab ti) Printtyp.type_expr (typ ti) Printtyp.type_expr tv + ".@.@[<hov2>In %s@ %a@;<1 -2>the variable %a is unbound@]" + kwd pr ti Printtyp.type_expr tv with Not_found -> () +let explain_unbound ppf tv tl typ kwd lab = + explain_unbound_gen ppf tv tl typ kwd + (fun ppf ti -> fprintf ppf "%s%a" (lab ti) Printtyp.type_expr (typ ti)) + let explain_unbound_single ppf tv ty = let trivial ty = explain_unbound ppf tv [ty] (fun t -> t) "type" (fun _ -> "") in @@ -1493,6 +1537,11 @@ let explain_unbound_single ppf tv ty = "case" (fun (lab,_) -> "`" ^ lab ^ " of ") | _ -> trivial ty + +let tys_of_constr_args = function + | Types.Cstr_tuple tl -> tl + | Types.Cstr_record lbls -> List.map (fun l -> l.Types.ld_type) lbls + let report_error ppf = function | Repeated_parameter -> fprintf ppf "A type parameter occurs several times" @@ -1551,9 +1600,14 @@ let report_error ppf = function let ty = Ctype.repr ty in begin match decl.type_kind, decl.type_manifest with | Type_variant tl, _ -> - explain_unbound ppf ty tl (fun c -> - Btype.newgenty (Ttuple c.Types.cd_args)) - "case" (fun c -> Ident.name c.Types.cd_id ^ " of ") + explain_unbound_gen ppf ty tl (fun c -> + let tl = tys_of_constr_args c.cd_args in + Btype.newgenty (Ttuple tl) + ) + "case" (fun ppf c -> + fprintf ppf + "%s of %a" (Ident.name c.Types.cd_id) + Printtyp.constructor_arguments c.cd_args) | Type_record (tl, _), _ -> explain_unbound ppf ty tl (fun l -> l.Types.ld_type) "field" (fun l -> Ident.name l.Types.ld_id ^ ": ") @@ -1563,7 +1617,8 @@ let report_error ppf = function end | Unbound_type_var_ext (ty, ext) -> fprintf ppf "A type variable is unbound in this extension constructor"; - explain_unbound ppf ty ext.ext_args (fun c -> c) "type" (fun _ -> "") + let args = tys_of_constr_args ext.ext_args in + explain_unbound ppf ty args (fun c -> c) "type" (fun _ -> "") | Not_open_type path -> fprintf ppf "@[%s@ %a@]" "Cannot extend type definition" diff --git a/typing/typedtree.ml b/typing/typedtree.ml index ecd0f132e..52067415c 100644 --- a/typing/typedtree.ml +++ b/typing/typedtree.ml @@ -409,12 +409,16 @@ and constructor_declaration = { cd_id: Ident.t; cd_name: string loc; - cd_args: core_type list; + cd_args: constructor_arguments; cd_res: core_type option; cd_loc: Location.t; cd_attributes: attribute list; } +and constructor_arguments = + | Cstr_tuple of core_type list + | Cstr_record of label_declaration list + and type_extension = { tyext_path: Path.t; @@ -436,7 +440,7 @@ and extension_constructor = } and extension_constructor_kind = - Text_decl of core_type list * core_type option + Text_decl of constructor_arguments * core_type option | Text_rebind of Path.t * Longident.t loc and class_type = diff --git a/typing/typedtree.mli b/typing/typedtree.mli index c4feae1d8..fa36dac8c 100644 --- a/typing/typedtree.mli +++ b/typing/typedtree.mli @@ -409,12 +409,16 @@ and constructor_declaration = { cd_id: Ident.t; cd_name: string loc; - cd_args: core_type list; + cd_args: constructor_arguments; cd_res: core_type option; cd_loc: Location.t; cd_attributes: attributes; } +and constructor_arguments = + | Cstr_tuple of core_type list + | Cstr_record of label_declaration list + and type_extension = { tyext_path: Path.t; @@ -436,7 +440,7 @@ and extension_constructor = } and extension_constructor_kind = - Text_decl of core_type list * core_type option + Text_decl of constructor_arguments * core_type option | Text_rebind of Path.t * Longident.t loc and class_type = diff --git a/typing/typedtreeIter.ml b/typing/typedtreeIter.ml index 3d1a19fa8..28026b598 100644 --- a/typing/typedtreeIter.ml +++ b/typing/typedtreeIter.ml @@ -160,8 +160,12 @@ module MakeIterator(Iter : IteratorArgument) : sig iter_core_type v.val_desc; Iter.leave_value_description v + and iter_constructor_arguments = function + | Cstr_tuple l -> List.iter iter_core_type l + | Cstr_record l -> List.iter (fun ld -> iter_core_type ld.ld_type) l + and iter_constructor_declaration cd = - List.iter iter_core_type cd.cd_args; + iter_constructor_arguments cd.cd_args; option iter_core_type cd.cd_res; and iter_type_parameter (ct, v) = @@ -192,7 +196,7 @@ module MakeIterator(Iter : IteratorArgument) : sig Iter.enter_extension_constructor ext; begin match ext.ext_kind with Text_decl(args, ret) -> - List.iter iter_core_type args; + iter_constructor_arguments args; option iter_core_type ret | Text_rebind _ -> () end; diff --git a/typing/typedtreeMap.ml b/typing/typedtreeMap.ml index b5ca25b17..6b28cc850 100644 --- a/typing/typedtreeMap.ml +++ b/typing/typedtreeMap.ml @@ -190,8 +190,17 @@ module MakeMap(Map : MapArgument) = struct and map_type_parameter (ct, v) = (map_core_type ct, v) + and map_constructor_arguments = function + | Cstr_tuple l -> + Cstr_tuple (List.map map_core_type l) + | Cstr_record l -> + Cstr_record + (List.map (fun ld -> {ld with ld_type = map_core_type ld.ld_type}) + l) + and map_constructor_declaration cd = - {cd with cd_args = List.map map_core_type cd.cd_args; + let cd_args = map_constructor_arguments cd.cd_args in + {cd with cd_args; cd_res = may_map map_core_type cd.cd_res } @@ -208,7 +217,7 @@ module MakeMap(Map : MapArgument) = struct let ext = Map.enter_extension_constructor ext in let ext_kind = match ext.ext_kind with Text_decl(args, ret) -> - let args = List.map map_core_type args in + let args = map_constructor_arguments args in let ret = may_map map_core_type ret in Text_decl(args, ret) | Text_rebind(p, lid) -> Text_rebind(p, lid) diff --git a/typing/typemod.ml b/typing/typemod.ml index 089135472..bf3e1bfaf 100644 --- a/typing/typemod.ml +++ b/typing/typemod.ml @@ -442,6 +442,7 @@ type names = types: StringSet.t ref; modules: StringSet.t ref; modtypes: StringSet.t ref; + typexts: StringSet.t ref; } let new_names () = @@ -449,6 +450,7 @@ let new_names () = types = ref StringSet.empty; modules = ref StringSet.empty; modtypes = ref StringSet.empty; + typexts = ref StringSet.empty; } @@ -456,11 +458,14 @@ let check_name check names name = check names name.loc name.txt let check_type names loc s = check "type" loc names.types s let check_module names loc s = check "module" loc names.modules s let check_modtype names loc s = check "module type" loc names.modtypes s +let check_typext names loc s = check "extension constructor" loc names.typexts s + let check_sig_item names loc = function | Sig_type(id, _, _) -> check_type names loc (Ident.name id) | Sig_module(id, _, _) -> check_module names loc (Ident.name id) | Sig_modtype(id, _) -> check_modtype names loc (Ident.name id) + | Sig_typext(id, _, _) -> check_typext names loc (Ident.name id) | _ -> () (* Simplify multiple specifications of a value or an extension in a signature. @@ -470,29 +475,17 @@ let check_sig_item names loc = function let simplify_signature sg = let rec aux = function - | [] -> [], StringSet.empty, StringSet.empty + | [] -> [], StringSet.empty | (Sig_value(id, descr) as component) :: sg -> - let (sg, val_names, ext_names) as k = aux sg in + let (sg, val_names) as k = aux sg in let name = Ident.name id in if StringSet.mem name val_names then k - else (component :: sg, StringSet.add name val_names, ext_names) - | (Sig_typext(id, ext, es) as component) :: sg -> - let (sg, val_names, ext_names) as k = aux sg in - let name = Ident.name id in - if StringSet.mem name ext_names then - (* #6510 *) - match es, sg with - | Text_first, Sig_typext(id2, ext2, Text_next) :: rest -> - (Sig_typext(id2, ext2, Text_first) :: rest, - val_names, ext_names) - | _ -> k - else - (component :: sg, val_names, StringSet.add name ext_names) + else (component :: sg, StringSet.add name val_names) | component :: sg -> - let (sg, val_names, ext_names) = aux sg in - (component :: sg, val_names, ext_names) + let (sg, val_names) = aux sg in + (component :: sg, val_names) in - let (sg, _, _) = aux sg in + let (sg, _) = aux sg in sg (* Check and translate a module type expression *) @@ -567,7 +560,6 @@ let rec transl_modtype env smty = | Pmty_extension ext -> raise (Error_forward (Typetexp.error_of_extension ext)) - and transl_signature env sg = let names = new_names () in let rec transl_sig env sg = @@ -595,6 +587,9 @@ and transl_signature env sg = Sig_type(td.typ_id, td.typ_type, rs)) decls rem, final_env | Psig_typext styext -> + List.iter + (fun pext -> check_name check_typext names pext.pext_name) + styext.ptyext_constructors; let (tyext, newenv) = Typedecl.transl_type_extension false env item.psig_loc styext in @@ -605,6 +600,7 @@ and transl_signature env sg = Sig_typext(ext.ext_id, ext.ext_type, es)) constructors rem, final_env | Psig_exception sext -> + check_name check_typext names sext.pext_name; let (ext, newenv) = Typedecl.transl_exception env sext in let (trem, rem, final_env) = transl_sig newenv srem in mksig (Tsig_exception ext) env loc :: trem, @@ -1220,6 +1216,9 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr scope = decls [], enrich_type_decls anchor decls env newenv | Pstr_typext styext -> + List.iter + (fun pext -> check_name check_typext names pext.pext_name) + styext.ptyext_constructors; let (tyext, newenv) = Typedecl.transl_type_extension true env loc styext in @@ -1229,6 +1228,7 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr scope = tyext.tyext_constructors [], newenv) | Pstr_exception sext -> + check_name check_typext names sext.pext_name; let (ext, newenv) = Typedecl.transl_exception env sext in Tstr_exception ext, [Sig_typext(ext.ext_id, ext.ext_type, Text_exception)], diff --git a/typing/types.ml b/typing/types.ml index f8cf46022..1aff7356f 100644 --- a/typing/types.ml +++ b/typing/types.ml @@ -156,6 +156,8 @@ and type_kind = and record_representation = Record_regular (* All fields are boxed / tagged *) | Record_float (* All fields are floats *) + | Record_inlined of int (* Inlined record *) + | Record_extension (* Inlined record under extension *) and label_declaration = { @@ -169,16 +171,20 @@ and label_declaration = and constructor_declaration = { cd_id: Ident.t; - cd_args: type_expr list; + cd_args: constructor_arguments; cd_res: type_expr option; cd_loc: Location.t; cd_attributes: Parsetree.attributes; } +and constructor_arguments = + | Cstr_tuple of type_expr list + | Cstr_record of label_declaration list + type extension_constructor = { ext_type_path: Path.t; ext_type_params: type_expr list; - ext_args: type_expr list; + ext_args: constructor_arguments; ext_ret_type: type_expr option; ext_private: private_flag; ext_loc: Location.t; @@ -285,6 +291,7 @@ type constructor_description = cstr_private: private_flag; (* Read-only constructor? *) cstr_loc: Location.t; cstr_attributes: Parsetree.attributes; + cstr_inlined: type_declaration option; } and constructor_tag = diff --git a/typing/types.mli b/typing/types.mli index acde28f99..0438f897b 100644 --- a/typing/types.mli +++ b/typing/types.mli @@ -144,6 +144,8 @@ and type_kind = and record_representation = Record_regular (* All fields are boxed / tagged *) | Record_float (* All fields are floats *) + | Record_inlined of int (* Inlined record *) + | Record_extension (* Inlined record under extension *) and label_declaration = { @@ -157,17 +159,21 @@ and label_declaration = and constructor_declaration = { cd_id: Ident.t; - cd_args: type_expr list; + cd_args: constructor_arguments; cd_res: type_expr option; cd_loc: Location.t; cd_attributes: Parsetree.attributes; } +and constructor_arguments = + | Cstr_tuple of type_expr list + | Cstr_record of label_declaration list + type extension_constructor = { ext_type_path: Path.t; ext_type_params: type_expr list; - ext_args: type_expr list; + ext_args: constructor_arguments; ext_ret_type: type_expr option; ext_private: private_flag; ext_loc: Location.t; @@ -275,6 +281,7 @@ type constructor_description = cstr_private: private_flag; (* Read-only constructor? *) cstr_loc: Location.t; cstr_attributes: Parsetree.attributes; + cstr_inlined: type_declaration option; } and constructor_tag = diff --git a/utils/config.mlp b/utils/config.mlp index db6fd20ed..ce216cc1f 100644 --- a/utils/config.mlp +++ b/utils/config.mlp @@ -49,15 +49,15 @@ let mkexe = "%%MKEXE%%" let mkmaindll = "%%MKMAINDLL%%" let exec_magic_number = "Caml1999X011" -and cmi_magic_number = "Caml1999I017" +and cmi_magic_number = "Caml1999I018" and cmo_magic_number = "Caml1999O010" and cma_magic_number = "Caml1999A011" and cmx_magic_number = "Caml1999Y014" and cmxa_magic_number = "Caml1999Z013" -and ast_impl_magic_number = "Caml1999M016" -and ast_intf_magic_number = "Caml1999N015" +and ast_impl_magic_number = "Caml1999M017" +and ast_intf_magic_number = "Caml1999N016" and cmxs_magic_number = "Caml2007D002" -and cmt_magic_number = "Caml2012T004" +and cmt_magic_number = "Caml2012T005" let load_path = ref ([] : string list) |