From c8d3ff52a2d136fba898b54b0ff35b523789fd00 Mon Sep 17 00:00:00 2001 From: Alain Frisch Date: Fri, 1 Mar 2013 12:44:04 +0000 Subject: [PATCH] Cleanup + support attributes on type declarations (syntax: type t = ... with (:a1 expr1) (:a2 expr2) ... (:an exprn)). git-svn-id: http://caml.inria.fr/svn/ocaml/branches/extension_points@13332 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02 --- camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.ml | 10 +++--- camlp4/boot/Camlp4.ml | 2 ++ ocamldoc/odoc_ast.ml | 2 +- otherlibs/labltk/browser/searchpos.ml | 2 +- parsing/ast_mapper.ml | 39 ++++++++++++---------- parsing/ast_mapper.mli | 6 ++-- parsing/parser.mly | 26 +++++++++++---- parsing/parsetree.mli | 9 ++--- parsing/pprintast.ml | 13 ++++---- parsing/printast.ml | 13 ++++++-- tools/depend.ml | 6 ++-- tools/ocamlprof.ml | 2 +- tools/untypeast.ml | 1 + typing/typecore.ml | 6 ++-- typing/typemod.ml | 2 +- typing/typetexp.ml | 3 +- 16 files changed, 87 insertions(+), 55 deletions(-) diff --git a/camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.ml b/camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.ml index 410fa2322..41ff4d642 100644 --- a/camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.ml +++ b/camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.ml @@ -322,7 +322,7 @@ module Make (Ast : Sig.Camlp4Ast) = struct let (params, variance) = List.split tl in {ptype_params = params; ptype_cstrs = cl; ptype_kind = tk; ptype_private = tp; ptype_manifest = tm; ptype_loc = mkloc loc; - ptype_variance = variance} + ptype_variance = variance; ptype_attributes = []} ; value mkprivate' m = if m then Private else Public; value mkprivate = fun @@ -445,7 +445,9 @@ module Make (Ast : Sig.Camlp4Ast) = struct ptype_kind = kind; ptype_private = priv; ptype_manifest = Some ct; - ptype_loc = mkloc loc; ptype_variance = variance}); + ptype_loc = mkloc loc; ptype_variance = variance; + ptype_attributes = []; + }); value rec mkwithc wc acc = match wc with @@ -656,8 +658,8 @@ value varify_constructors var_names = Ptyp_poly(string_lst, loop core_type) | Ptyp_package longident lst -> Ptyp_package(longident,List.map (fun (n,typ) -> (n,loop typ) ) lst) - | Ptyp_attribute (s, e, t) -> - Ptyp_attribute (s, e, loop t) + | Ptyp_attribute (t, x) -> + Ptyp_attribute (loop t, x) | Ptyp_extension x -> Ptyp_extension x ] diff --git a/camlp4/boot/Camlp4.ml b/camlp4/boot/Camlp4.ml index 9e8309b66..3aae63e23 100644 --- a/camlp4/boot/Camlp4.ml +++ b/camlp4/boot/Camlp4.ml @@ -14480,6 +14480,7 @@ module Struct = ptype_manifest = tm; ptype_loc = mkloc loc; ptype_variance = variance; + ptype_attributes = []; } let mkprivate' m = if m then Private else Public @@ -14633,6 +14634,7 @@ module Struct = ptype_manifest = Some ct; ptype_loc = mkloc loc; ptype_variance = variance; + ptype_attributes = []; })) let rec mkwithc wc acc = diff --git a/ocamldoc/odoc_ast.ml b/ocamldoc/odoc_ast.ml index 26edf6d37..38b1c5ff3 100644 --- a/ocamldoc/odoc_ast.ml +++ b/ocamldoc/odoc_ast.ml @@ -1054,7 +1054,7 @@ module Analyser = Parsetree.Pstr_eval _ -> (* don't care *) (0, env, []) - | Parsetree.Pstr_attribute (_, _, x) -> + | Parsetree.Pstr_attribute (x, _) -> analyse_structure_item env current_module_name loc pos_limit comment_opt x.Parsetree.pstr_desc typedtree table table_values | Parsetree.Pstr_extension _ -> (0, env, []) diff --git a/otherlibs/labltk/browser/searchpos.ml b/otherlibs/labltk/browser/searchpos.ml index c42f128aa..51b4778c3 100644 --- a/otherlibs/labltk/browser/searchpos.ml +++ b/otherlibs/labltk/browser/searchpos.ml @@ -130,7 +130,7 @@ let rec search_pos_type t ~pos ~env = List.iter tl ~f:(search_pos_type ~pos ~env); add_found_sig (`Type, lid.txt) ~env ~loc:t.ptyp_loc | Ptyp_alias (t, _) - | Ptyp_attribute (_, _, t) + | Ptyp_attribute (t, _) | Ptyp_poly (_, t) -> search_pos_type ~pos ~env t | Ptyp_package (_, stl) -> List.iter stl ~f:(fun (_, ty) -> search_pos_type ty ~pos ~env) diff --git a/parsing/ast_mapper.ml b/parsing/ast_mapper.ml index c7a696a1d..d62088177 100644 --- a/parsing/ast_mapper.ml +++ b/parsing/ast_mapper.ml @@ -19,7 +19,6 @@ open Asttypes (* First, some helpers to build AST fragments *) -let map_flatten f l = List.flatten (List.map f l) let map_snd f (x, y) = (x, f y) let map_tuple f1 f2 (x, y) = (f1 x, f2 y) let map_opt f = function None -> None | Some x -> Some (f x) @@ -41,8 +40,8 @@ module T = struct let variant ?loc a b c = mk ?loc (Ptyp_variant (a, b, c)) let poly ?loc a b = mk ?loc (Ptyp_poly (a, b)) let package ?loc a b = mk ?loc (Ptyp_package (a, b)) - let attribute ?loc a b c = mk ?loc (Ptyp_attribute (a, b, c)) - let extension ?loc a b = mk ?loc (Ptyp_extension (a, b)) + let attribute ?loc a b = mk ?loc (Ptyp_attribute (a, b)) + let extension ?loc a = mk ?loc (Ptyp_extension a) let field_type ?(loc = Location.none) x = {pfield_desc = x; pfield_loc = loc} let field ?loc s t = @@ -80,8 +79,8 @@ module T = struct | Ptyp_variant (rl, b, ll) -> variant ~loc (List.map (row_field sub) rl) b ll | Ptyp_poly (sl, t) -> poly ~loc sl (sub # typ t) | Ptyp_package (lid, l) -> package ~loc (map_loc sub lid) (List.map (map_tuple (map_loc sub) (sub # typ)) l) - | Ptyp_attribute (s, arg, body) -> attribute ~loc s (sub # expr arg) (sub # typ body) - | Ptyp_extension (s, arg) -> extension ~loc s (sub # expr arg) + | Ptyp_attribute (body, x) -> attribute ~loc (sub # typ body) (sub # attribute x) + | Ptyp_extension x -> extension ~loc (sub # extension x) let map_type_declaration sub td = {td with @@ -92,6 +91,7 @@ module T = struct ptype_kind = sub # type_kind td.ptype_kind; ptype_manifest = map_opt (sub # typ) td.ptype_manifest; ptype_loc = sub # location td.ptype_loc; + ptype_attributes = List.map (sub # attribute) td.ptype_attributes; } let map_type_kind sub = function @@ -235,10 +235,10 @@ module M = struct let class_ ?loc a = mk_item ?loc (Pstr_class a) let class_type ?loc a = mk_item ?loc (Pstr_class_type a) let include_ ?loc a = mk_item ?loc (Pstr_include a) - let attribute ?loc a b c = mk_item ?loc (Pstr_attribute (a, b, c)) - let extension ?loc a b = mk_item ?loc (Pstr_extension (a, b)) + let attribute ?loc a b = mk_item ?loc (Pstr_attribute (a, b)) + let extension ?loc a = mk_item ?loc (Pstr_extension a) - let rec map_structure_item sub {pstr_loc = loc; pstr_desc = desc} = + let map_structure_item sub {pstr_loc = loc; pstr_desc = desc} = let loc = sub # location loc in match desc with | Pstr_eval x -> eval ~loc (sub # expr x) @@ -254,8 +254,8 @@ module M = struct | Pstr_class l -> class_ ~loc (List.map (sub # class_declaration) l) | Pstr_class_type l -> class_type ~loc (List.map (sub # class_type_declaration) l) | Pstr_include e -> include_ ~loc (sub # module_expr e) - | Pstr_attribute (s, arg, body) -> attribute ~loc s (sub # expr arg) (map_structure_item sub body) (* not very nice, because sub # structure_item can return a list -- to be cleaned up *) - | Pstr_extension (s, arg) -> extension ~loc s (sub # expr arg) + | Pstr_attribute (body, x) -> attribute ~loc (sub # structure_item body) (sub # attribute x) + | Pstr_extension x -> extension ~loc (sub # extension x) end module E = struct @@ -296,8 +296,8 @@ module E = struct let newtype ?loc a b = mk ?loc (Pexp_newtype (a, b)) let pack ?loc a = mk ?loc (Pexp_pack a) let open_ ?loc a b = mk ?loc (Pexp_open (a, b)) - let attribute ?loc a b c = mk ?loc (Pexp_attribute (a, b, c)) - let extension ?loc a b = mk ?loc (Pexp_extension (a, b)) + let attribute ?loc a b = mk ?loc (Pexp_attribute (a, b)) + let extension ?loc a = mk ?loc (Pexp_extension a) let lid ?(loc = Location.none) lid = ident ~loc (mkloc (Longident.parse lid) loc) let apply_nolabs ?loc f el = apply ?loc f (List.map (fun e -> ("", e)) el) @@ -339,8 +339,8 @@ module E = struct | Pexp_newtype (s, e) -> newtype ~loc s (sub # expr e) | Pexp_pack me -> pack ~loc (sub # module_expr me) | Pexp_open (lid, e) -> open_ ~loc (map_loc sub lid) (sub # expr e) - | Pexp_attribute (s, arg, body) -> attribute ~loc s (sub # expr arg) (sub # expr body) - | Pexp_extension (s, arg) -> extension ~loc s (sub # expr arg) + | Pexp_attribute (body, x) -> attribute ~loc (sub # expr body) (sub # attribute x) + | Pexp_extension x -> extension ~loc (sub # extension x) end module P = struct @@ -461,12 +461,12 @@ class mapper = object(this) method implementation (input_name : string) ast = (input_name, this # structure ast) method interface (input_name: string) ast = (input_name, this # signature ast) - method structure l = map_flatten (this # structure_item) l - method structure_item si = [ M.map_structure_item this si ] + method structure l = List.map (this # structure_item) l + method structure_item si = M.map_structure_item this si method module_expr = M.map this - method signature l = map_flatten (this # signature_item) l - method signature_item si = [ MT.map_signature_item this si ] + method signature l = List.map (this # signature_item) l + method signature_item si = MT.map_signature_item this si method module_type = MT.map this method with_constraint c = MT.map_with_constraint this c @@ -498,6 +498,9 @@ class mapper = method exception_declaration tl = List.map (this # typ) tl method location l = l + + method extension (s, e) = (s, this # expr e) + method attribute (s, e) = (s, this # expr e) end class type main_entry_points = diff --git a/parsing/ast_mapper.mli b/parsing/ast_mapper.mli index 74714cdb2..d25aa0795 100644 --- a/parsing/ast_mapper.mli +++ b/parsing/ast_mapper.mli @@ -37,14 +37,16 @@ class mapper: method module_type: module_type -> module_type method pat: pattern -> pattern method signature: signature -> signature - method signature_item: signature_item -> signature_item list + method signature_item: signature_item -> signature_item method structure: structure -> structure - method structure_item: structure_item -> structure_item list + method structure_item: structure_item -> structure_item method typ: core_type -> core_type method type_declaration: type_declaration -> type_declaration method type_kind: type_kind -> type_kind method value_description: value_description -> value_description method with_constraint: with_constraint -> with_constraint + method attribute: attribute -> attribute + method extension: extension -> extension end class type main_entry_points = diff --git a/parsing/parser.mly b/parsing/parser.mly index 053544a69..8e0bb142b 100644 --- a/parsing/parser.mly +++ b/parsing/parser.mly @@ -273,8 +273,8 @@ let varify_constructors var_names t = Ptyp_poly(string_lst, loop core_type) | Ptyp_package(longident,lst) -> Ptyp_package(longident,List.map (fun (n,typ) -> (n,loop typ) ) lst) - | Ptyp_attribute (s, arg, t) -> - Ptyp_attribute (s, arg, loop t) + | Ptyp_attribute (t, x) -> + Ptyp_attribute (loop t, x) | Ptyp_extension (s, arg) -> Ptyp_extension (s, arg) in @@ -612,7 +612,7 @@ structure_item: | DOTDOT extension { mkstr (Pstr_extension $2) } | structure_item DOTDOT attribute - { mkstr(Pstr_attribute (fst $3, snd $3, $1)) } + { mkstr(Pstr_attribute ($1, $3)) } ; module_binding: EQUAL module_expr @@ -1073,7 +1073,7 @@ expr: | OBJECT class_structure error { unclosed "object" 1 "end" 3 } | simple_expr attribute - { mkexp (Pexp_attribute(fst $2, snd $2, $1)) } + { mkexp (Pexp_attribute($1, $2)) } ; opt_expr: expr { $1 } @@ -1384,7 +1384,7 @@ type_declarations: ; type_declaration: - optional_type_parameters LIDENT type_kind constraints + optional_type_parameters LIDENT type_kind constraints type_declaration_attribute { let (params, variance) = List.split $1 in let (kind, private_flag, manifest) = $3 in (mkrhs $2 2, {ptype_params = params; @@ -1393,7 +1393,13 @@ type_declaration: ptype_private = private_flag; ptype_manifest = manifest; ptype_variance = variance; - ptype_loc = symbol_rloc() }) } + ptype_attributes = $5; + ptype_loc = symbol_rloc(); + }) } +; +type_declaration_attribute: + WITH attributes { $2 } + | { [] } ; constraints: constraints CONSTRAINT constrain { $3 :: $1 } @@ -1501,6 +1507,7 @@ with_constraint: ptype_manifest = Some $5; ptype_private = $4; ptype_variance = variance; + ptype_attributes = []; ptype_loc = symbol_rloc()}) } /* used label_longident instead of type_longident to disallow functor applications in type path */ @@ -1513,6 +1520,7 @@ with_constraint: ptype_manifest = Some $5; ptype_private = Public; ptype_variance = variance; + ptype_attributes = []; ptype_loc = symbol_rloc()}) } | MODULE mod_longident EQUAL mod_ext_longident { (mkrhs $2 2, Pwith_module (mkrhs $4 4)) } @@ -1564,7 +1572,7 @@ simple_core_type: | LPAREN core_type_comma_list RPAREN %prec below_SHARP { match $2 with [sty] -> sty | _ -> raise Parse_error } | simple_core_type attribute - { mktyp (Ptyp_attribute(fst $2, snd $2, $1)) } + { mktyp (Ptyp_attribute($1, $2)) } ; simple_core_type2: QUOTE ident @@ -1616,6 +1624,10 @@ extension: attribute: | LPAREN COLON LIDENT opt_expr RPAREN { ($3, $4) } ; +attributes: + | { [] } + | attribute attributes { $1 :: $2 } +; package_type: mty_longident { (mkrhs $1 1, []) } | mty_longident WITH package_type_cstrs { (mkrhs $1 1, $3) } diff --git a/parsing/parsetree.mli b/parsing/parsetree.mli index 1223b4f84..052e6b414 100644 --- a/parsing/parsetree.mli +++ b/parsing/parsetree.mli @@ -16,7 +16,7 @@ open Asttypes (* Extension points *) -type 'a attribute = string * expression * 'a +type attribute = string * expression and extension = string * expression @@ -38,7 +38,7 @@ and core_type_desc = | Ptyp_variant of row_field list * bool * label list option | Ptyp_poly of string list * core_type | Ptyp_package of package_type - | Ptyp_attribute of core_type attribute + | Ptyp_attribute of (core_type * attribute) | Ptyp_extension of extension @@ -127,7 +127,7 @@ and expression_desc = | Pexp_newtype of string * expression | Pexp_pack of module_expr | Pexp_open of Longident.t loc * expression - | Pexp_attribute of expression attribute + | Pexp_attribute of (expression * attribute) | Pexp_extension of extension (* Value descriptions *) @@ -147,6 +147,7 @@ and type_declaration = ptype_private: private_flag; ptype_manifest: core_type option; ptype_variance: (bool * bool) list; + ptype_attributes: attribute list; ptype_loc: Location.t } and type_kind = @@ -301,7 +302,7 @@ and structure_item_desc = | Pstr_class of class_declaration list | Pstr_class_type of class_type_declaration list | Pstr_include of module_expr - | Pstr_attribute of structure_item attribute + | Pstr_attribute of structure_item * attribute | Pstr_extension of extension (* Toplevel phrases *) diff --git a/parsing/pprintast.ml b/parsing/pprintast.ml index 7f322630d..5bb4f8fc4 100644 --- a/parsing/pprintast.ml +++ b/parsing/pprintast.ml @@ -299,8 +299,8 @@ class printer ()= object(self:'self) |_ -> pp f "@[(module@ %a@ with@ %a)@]" self#longident_loc lid (self#list aux ~sep:"@ and@ ") cstrs) - | Ptyp_attribute (s, arg, body) -> - pp f "@[<2>(@@%s@ %a)@ %a@]" s self#expression arg self#core_type body + | Ptyp_attribute (body, (s, arg)) -> + pp f "@[<2>%a@ (:%s@ %a)@]" self#core_type body s self#expression arg | Ptyp_extension (s, arg) -> pp f "@[<2>(&%s@ %a)@]" s self#expression arg | _ -> self#paren true self#core_type f x @@ -621,8 +621,8 @@ class printer ()= object(self:'self) self#expression e | Pexp_variant (l,Some eo) -> pp f "@[<2>`%s@;%a@]" l self#simple_expr eo - | Pexp_attribute (s, arg, body) -> - pp f "@[<2>(@@%s@ %a)@ %a@]" s self#expression arg self#expression body + | Pexp_attribute (body, (s, arg)) -> + pp f "@[<2>%a@ (:%s@ %a)@]" self#expression body s self#expression arg | Pexp_extension (s, arg) -> pp f "@[<2>(&%s@ %a)@]" s self#expression arg | _ -> self#expression1 f x @@ -1091,8 +1091,8 @@ class printer ()= object(self:'self) (fun f l2 -> List.iter (text_x_modtype_x_module f) l2) l2 | _ -> assert false end - | Pstr_attribute (s, arg, body) -> - pp f "@[<2>%a@ ::%s@ %a@]" self#structure_item body s self#expression arg + | Pstr_attribute (body, (s, arg)) -> + pp f "@[<2>%a@ (:%s@ %a)@]" self#structure_item body s self#expression arg | Pstr_extension (s, arg) -> pp f "@[<2>&(%s@ %a)@]" s self#expression arg @@ -1157,6 +1157,7 @@ class printer ()= object(self:'self) (fun f (ct1,ct2,_) -> pp f "@[constraint@ %a@ =@ %a@]" self#core_type ct1 self#core_type ct2 )) x.ptype_cstrs ; + (* TODO: attributes *) end method case_list f (l:(pattern * expression) list) :unit= let aux f (p,e) = diff --git a/parsing/printast.ml b/parsing/printast.ml index 1912ba290..f40ef6f4d 100644 --- a/parsing/printast.ml +++ b/parsing/printast.ml @@ -163,7 +163,7 @@ let rec core_type i ppf x = | Ptyp_package (s, l) -> line i ppf "Ptyp_package %a\n" fmt_longident_loc s; list i package_with ppf l; - | Ptyp_attribute (s, arg, body) -> + | Ptyp_attribute (body, (s, arg)) -> line i ppf "Ptyp_attribute \"%s\"\n" s; expression i ppf arg; core_type i ppf body @@ -344,7 +344,7 @@ and expression i ppf x = | Pexp_open (m, e) -> line i ppf "Pexp_open \"%a\"\n" fmt_longident_loc m; expression i ppf e - | Pexp_attribute (s, arg, body) -> + | Pexp_attribute (body, (s, arg)) -> line i ppf "Pexp_attribute \"%s\"\n" s; expression i ppf arg; expression i ppf body @@ -376,6 +376,13 @@ and type_declaration i ppf x = line i ppf "ptype_private = %a\n" fmt_private_flag x.ptype_private; line i ppf "ptype_manifest =\n"; option (i+1) core_type ppf x.ptype_manifest; + line i ppf "ptype_attributes = \n"; + List.iter + (fun (s, arg) -> + line (i + 1) ppf "attribute \"%s\"\n" s; + expression (i + 1) ppf arg; + ) + x.ptype_attributes and type_kind i ppf x = match x with @@ -669,7 +676,7 @@ and structure_item i ppf x = | Pstr_include me -> line i ppf "Pstr_include"; module_expr i ppf me - | Pstr_attribute (s, arg, body) -> + | Pstr_attribute (body, (s, arg)) -> line i ppf "Pstr_attribute \"%s\"\n" s; expression i ppf arg; structure_item i ppf body diff --git a/tools/depend.ml b/tools/depend.ml index 083c7c660..0c15985b8 100644 --- a/tools/depend.ml +++ b/tools/depend.ml @@ -53,7 +53,7 @@ let rec add_type bv ty = fl | Ptyp_poly(_, t) -> add_type bv t | Ptyp_package pt -> add_package_type bv pt - | Ptyp_attribute (_, _, e) -> add_type bv e + | Ptyp_attribute (e, _) -> add_type bv e | Ptyp_extension _ -> () and add_package_type bv (lid, l) = @@ -177,7 +177,7 @@ let rec add_expr bv exp = | Pexp_newtype (_, e) -> add_expr bv e | Pexp_pack m -> add_module bv m | Pexp_open (m, e) -> addmodule bv m; add_expr bv e - | Pexp_attribute (_, _, e) -> add_expr bv e + | Pexp_attribute (e, _) -> add_expr bv e | Pexp_extension _ -> () and add_pat_expr_list bv pel = @@ -289,7 +289,7 @@ and add_struct_item bv item = List.iter (add_class_type_declaration bv) cdtl; bv | Pstr_include modl -> add_module bv modl; bv - | Pstr_attribute (_, _, e) -> add_struct_item bv e + | Pstr_attribute (e, _) -> add_struct_item bv e | Pstr_extension _ -> bv and add_use_file bv top_phrs = diff --git a/tools/ocamlprof.ml b/tools/ocamlprof.ml index dcd886cb7..83f4abc74 100644 --- a/tools/ocamlprof.ml +++ b/tools/ocamlprof.ml @@ -283,7 +283,7 @@ and rw_exp iflag sexp = | Pexp_newtype (_, sexp) -> rewrite_exp iflag sexp | Pexp_open (_, e) -> rewrite_exp iflag e | Pexp_pack (smod) -> rewrite_mod iflag smod - | Pexp_attribute (_, _, e) -> rewrite_exp iflag e + | Pexp_attribute (e, _) -> rewrite_exp iflag e | Pexp_extension _ -> () and rewrite_ifbody iflag ghost sifbody = diff --git a/tools/untypeast.ml b/tools/untypeast.ml index 1fd2766e8..72574ac95 100644 --- a/tools/untypeast.ml +++ b/tools/untypeast.ml @@ -120,6 +120,7 @@ and untype_type_declaration decl = None -> None | Some ct -> Some (untype_core_type ct)); ptype_variance = decl.typ_variance; + ptype_attributes = []; (* TODO *) ptype_loc = decl.typ_loc; } diff --git a/typing/typecore.ml b/typing/typecore.ml index 0582e5b36..9d3cfe3e2 100644 --- a/typing/typecore.ml +++ b/typing/typecore.ml @@ -140,7 +140,7 @@ let iter_expression f e = | Pexp_assert e | Pexp_setinstvar (_, e) | Pexp_send (e, _) - | Pexp_attribute (_, _, e) (* we don't iterate on the attribute argument *) + | Pexp_attribute (e, _) (* we don't iterate on the attribute argument *) | Pexp_constraint (e, _, _) | Pexp_field (e, _) -> expr e | Pexp_when (e1, e2) @@ -179,7 +179,7 @@ let iter_expression f e = | Pstr_module (_, me) -> module_expr me | Pstr_recmodule l -> List.iter (fun (_, _, me) -> module_expr me) l | Pstr_class cdl -> List.iter (fun c -> class_expr c.pci_expr) cdl - | Pstr_attribute (_, _, e) -> structure_item e + | Pstr_attribute (i, _) -> structure_item i and class_expr ce = @@ -2686,7 +2686,7 @@ and type_expect_ ?in_function env sexp ty_expected = { exp with exp_extra = (Texp_open (path, lid, newenv), loc) :: exp.exp_extra; } - | Pexp_attribute (_s, _arg, body) -> + | Pexp_attribute (body, (_s, _arg)) -> let exp = type_expect env body ty_expected in (* { exp with diff --git a/typing/typemod.ml b/typing/typemod.ml index bd03fdbc8..e8aa9d3de 100644 --- a/typing/typemod.ml +++ b/typing/typemod.ml @@ -1119,7 +1119,7 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr scope = (item :: str_rem, sg @ sig_rem, final_env) - | Pstr_attribute (_, _, st) -> + | Pstr_attribute (st, _) -> type_struct env srem (* keep attribute in the typedtree? *) | Pstr_extension (s, _arg) -> raise (Error (loc, env, Extension s)) diff --git a/typing/typetexp.ml b/typing/typetexp.ml index 2d48c04a9..69a41929b 100644 --- a/typing/typetexp.ml +++ b/typing/typetexp.ml @@ -142,6 +142,7 @@ let create_package_mty fake loc env (p, l) = ptype_private = Asttypes.Public; ptype_manifest = if fake then None else Some t; ptype_variance = []; + ptype_attributes = []; ptype_loc = loc} in {pmty_desc=Pmty_with (mty, [ { txt = s.txt; loc }, Pwith_type d ]); pmty_loc=loc} @@ -560,7 +561,7 @@ let rec transl_type env policy styp = pack_fields = ptys; pack_txt = p; }) ty env loc - | Ptyp_attribute (_, _, st) -> + | Ptyp_attribute (st, _) -> transl_type env policy st (* keep attribute in the typedtree? *) | Ptyp_extension (s, _arg) -> raise (Error (loc, env, Extension s))