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

Add locations to attributes 

Changes

fix typo
master
Hugo Heuzard 2018-07-21 13:04:53 +01:00
parent 35218bf9df
commit 8043144494
26 changed files with 192 additions and 128 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
Changes
View File

@ -143,6 +143,9 @@ Working version
(Xavier Clerc, review by Gabriel Scherer, Sébastien Hinderer, and
Xavier Leroy)
- GRP#1953: Add locations to attributes in the parsetree.
(Hugo Heuzard, review by Gabriel Radanne)
- GPR#1954: Add locations to toplevel directives.
(Hugo Heuzard, review by Gabriel Radanne)

26
bytecomp/translattribute.ml
View File

@ -18,31 +18,31 @@ open Lambda
open Location
let is_inline_attribute = function
| {txt=("inline"|"ocaml.inline")}, _ -> true
| {txt=("inline"|"ocaml.inline")} -> true
| _ -> false
let is_inlined_attribute = function
| {txt=("inlined"|"ocaml.inlined")}, _ -> true
| {txt=("unrolled"|"ocaml.unrolled")}, _ when Config.flambda -> true
| {txt=("inlined"|"ocaml.inlined")} -> true
| {txt=("unrolled"|"ocaml.unrolled")} when Config.flambda -> true
| _ -> false
let is_specialise_attribute = function
| {txt=("specialise"|"ocaml.specialise")}, _ when Config.flambda -> true
| {txt=("specialise"|"ocaml.specialise")} when Config.flambda -> true
| _ -> false
let is_specialised_attribute = function
| {txt=("specialised"|"ocaml.specialised")}, _ when Config.flambda -> true
| {txt=("specialised"|"ocaml.specialised")} when Config.flambda -> true
| _ -> false
let find_attribute p attributes =
let inline_attribute, other_attributes =
List.partition p attributes
List.partition (fun a -> p a.Parsetree.attr_name) attributes
in
let attr =
match inline_attribute with
| [] -> None
| [attr] -> Some attr
| _ :: ({txt;loc}, _) :: _ ->
| _ :: {Parsetree.attr_name = {txt;loc}; _} :: _ ->
Location.prerr_warning loc (Warnings.Duplicated_attribute txt);
None
in
@ -56,7 +56,7 @@ let is_unrolled = function
let parse_inline_attribute attr =
match attr with
| None -> Default_inline
| Some ({txt;loc} as id, payload) ->
| Some {Parsetree.attr_name = {txt;loc} as id; attr_payload = payload} ->
let open Parsetree in
if is_unrolled id then begin
(* the 'unrolled' attributes must be used as [@unrolled n]. *)
@ -108,7 +108,7 @@ let parse_inline_attribute attr =
let parse_specialise_attribute attr =
match attr with
| None -> Default_specialise
| Some ({txt; loc}, payload) ->
| Some {Parsetree.attr_name = {txt; loc}; attr_payload = payload} ->
let open Parsetree in
let warning txt =
Warnings.Attribute_payload
@ -220,7 +220,7 @@ let get_and_remove_specialised_attribute e =
get_inlined_attribute *)
let get_tailcall_attribute e =
let is_tailcall_attribute = function
| {txt=("tailcall"|"ocaml.tailcall")}, _ -> true
| {Parsetree.attr_name = {txt=("tailcall"|"ocaml.tailcall")}; _} -> true
| _ -> false
in
let tailcalls, exp_attributes =
@ -231,12 +231,12 @@ let get_tailcall_attribute e =
| _ :: r ->
begin match r with
| [] -> ()
| ({txt;loc}, _) :: _ ->
| {Parsetree.attr_name = {txt;loc}; _} :: _ ->
Location.prerr_warning loc (Warnings.Duplicated_attribute txt)
end;
true, { e with exp_attributes }
let check_attribute e ({ txt; loc }, _) =
let check_attribute e {Parsetree.attr_name = { txt; loc }; _} =
match txt with
| "inline" | "ocaml.inline"
| "specialise" | "ocaml.specialise" -> begin
@ -254,7 +254,7 @@ let check_attribute e ({ txt; loc }, _) =
(Warnings.Misplaced_attribute txt)
| _ -> ()
let check_attribute_on_module e ({ txt; loc }, _) =
let check_attribute_on_module e {Parsetree.attr_name = { txt; loc }; _} =
match txt with
| "inline" | "ocaml.inline" -> begin
match e.mod_desc with

4
bytecomp/translattribute.mli
View File

@ -15,12 +15,12 @@
val check_attribute
: Typedtree.expression
-> string Location.loc * _
-> Parsetree.attribute
-> unit
val check_attribute_on_module
: Typedtree.module_expr
-> string Location.loc * _
-> Parsetree.attribute
-> unit
val add_inline_attribute

4
bytecomp/translcore.ml
View File

@ -96,14 +96,14 @@ let rec push_defaults loc bindings cases partial =
c_rhs={exp with exp_desc = Texp_function { arg_label; param; cases;
partial; }}}]
| [{c_lhs=pat; c_guard=None;
c_rhs={exp_attributes=[{txt="#default"},_];
c_rhs={exp_attributes=[{Parsetree.attr_name = {txt="#default"};_}];
exp_desc = Texp_let
(Nonrecursive, binds, ({exp_desc = Texp_function _} as e2))}}] ->
push_defaults loc (Bind_value binds :: bindings)
[{c_lhs=pat;c_guard=None;c_rhs=e2}]
partial
| [{c_lhs=pat; c_guard=None;
c_rhs={exp_attributes=[{txt="#modulepat"},_];
c_rhs={exp_attributes=[{Parsetree.attr_name = {txt="#modulepat"};_}];
exp_desc = Texp_letmodule
(id, name, mexpr, ({exp_desc = Texp_function _} as e2))}}] ->
push_defaults loc (Bind_module (id, name, mexpr) :: bindings)

7
parsing/ast_helper.ml
View File

@ -40,6 +40,13 @@ module Const = struct
let string ?quotation_delimiter s = Pconst_string (s, quotation_delimiter)
end
module Attr = struct
let mk ?(loc= !default_loc) name payload =
{ attr_name = name;
attr_payload = payload;
attr_loc = loc }
end
module Typ = struct
let mk ?(loc = !default_loc) ?(attrs = []) d =
{ptyp_desc = d; ptyp_loc = loc; ptyp_attributes = attrs}

5
parsing/ast_helper.mli
View File

@ -46,6 +46,11 @@ module Const : sig
val float : ?suffix:char -> string -> constant
end
(** {1 Attributes} *)
module Attr : sig
val mk: ?loc:loc -> str -> payload -> attribute
end
(** {1 Core language} *)
(** Type expressions *)

6
parsing/ast_iterator.ml
View File

@ -600,7 +600,11 @@ let default_iterator =
location = (fun _this _l -> ());
extension = (fun this (s, e) -> iter_loc this s; this.payload this e);
attribute = (fun this (s, e) -> iter_loc this s; this.payload this e);
attribute = (fun this a ->
iter_loc this a.attr_name;
this.payload this a.attr_payload;
this.location this a.attr_loc
);
attributes = (fun this l -> List.iter (this.attribute this) l);
payload =
(fun this -> function

37
parsing/ast_mapper.ml
View File

@ -646,7 +646,13 @@ let default_mapper =
location = (fun _this l -> l);
extension = (fun this (s, e) -> (map_loc this s, this.payload this e));
attribute = (fun this (s, e) -> (map_loc this s, this.payload this e));
attribute = (fun this a ->
{
attr_name = map_loc this a.attr_name;
attr_payload = this.payload this a.attr_payload;
attr_loc = this.location this a.attr_loc
}
);
attributes = (fun this l -> List.map (this.attribute this) l);
payload =
(fun this -> function
@ -664,8 +670,9 @@ let rec extension_of_error {loc; msg; if_highlight; sub} =
(List.map (fun ext -> Str.extension (extension_of_error ext)) sub))
let attribute_of_warning loc s =
{ loc; txt = "ocaml.ppwarning" },
PStr ([Str.eval ~loc (Exp.constant (Pconst_string (s, None)))])
Attr.mk
{loc; txt = "ocaml.ppwarning" }
(PStr ([Str.eval ~loc (Exp.constant (Pconst_string (s, None)))]))
let cookies = ref String.Map.empty
@ -716,8 +723,11 @@ module PpxContext = struct
(String.Map.bindings !cookies)
let mk fields =
{ txt = "ocaml.ppx.context"; loc = Location.none },
Parsetree.PStr [Str.eval (Exp.record fields None)]
{
attr_name = { txt = "ocaml.ppx.context"; loc = Location.none };
attr_payload = Parsetree.PStr [Str.eval (Exp.record fields None)];
attr_loc = Location.none
}
let make ~tool_name () =
let fields =
@ -849,7 +859,8 @@ let apply_lazy ~source ~target mapper =
let implem ast =
let fields, ast =
match ast with
| {pstr_desc = Pstr_attribute ({txt = "ocaml.ppx.context"}, x)} :: l ->
| {pstr_desc = Pstr_attribute ({attr_name = {txt = "ocaml.ppx.context"};
attr_payload = x})} :: l ->
PpxContext.get_fields x, l
| _ -> [], ast
in
@ -868,7 +879,9 @@ let apply_lazy ~source ~target mapper =
let iface ast =
let fields, ast =
match ast with
| {psig_desc = Psig_attribute ({txt = "ocaml.ppx.context"}, x)} :: l ->
| {psig_desc = Psig_attribute ({attr_name = {txt = "ocaml.ppx.context"};
attr_payload = x;
attr_loc = _})} :: l ->
PpxContext.get_fields x, l
| _ -> [], ast
in
@ -912,7 +925,10 @@ let apply_lazy ~source ~target mapper =
else fail ()
let drop_ppx_context_str ~restore = function
| {pstr_desc = Pstr_attribute({Location.txt = "ocaml.ppx.context"}, a)}
| {pstr_desc = Pstr_attribute
{attr_name = {Location.txt = "ocaml.ppx.context"};
attr_payload = a;
attr_loc = _}}
:: items ->
if restore then
PpxContext.restore (PpxContext.get_fields a);
@ -920,7 +936,10 @@ let drop_ppx_context_str ~restore = function
| items -> items
let drop_ppx_context_sig ~restore = function
| {psig_desc = Psig_attribute({Location.txt = "ocaml.ppx.context"}, a)}
| {psig_desc = Psig_attribute
{attr_name = {Location.txt = "ocaml.ppx.context"};
attr_payload = a;
attr_loc = _}}
:: items ->
if restore then
PpxContext.restore (PpxContext.get_fields a);

8
parsing/attr_helper.ml
View File

@ -23,12 +23,12 @@ type error =
exception Error of Location.t * error
let get_no_payload_attribute alt_names attrs =
match List.filter (fun (n, _) -> List.mem n.txt alt_names) attrs with
match List.filter (fun a -> List.mem a.attr_name.txt alt_names) attrs with
| [] -> None
| [ (name, PStr []) ] -> Some name
| [ (name, _) ] ->
| [ {attr_name = name; attr_payload = PStr []; attr_loc = _} ] -> Some name
| [ {attr_name = name; _} ] ->
raise (Error (name.loc, No_payload_expected name.txt))
| _ :: (name, _) :: _ ->
| _ :: {attr_name = name; _} :: _ ->
raise (Error (name.loc, Multiple_attributes name.txt))
let has_no_payload_attribute alt_names attrs =

65
parsing/builtin_attributes.ml
View File

@ -64,7 +64,7 @@ let cat s1 s2 =
let deprecated_attr x =
match x with
| ({txt = "ocaml.deprecated"|"deprecated"; _},_) -> Some x
| {attr_name = {txt = "ocaml.deprecated"|"deprecated"; _};_} -> Some x
| _ -> None
let rec deprecated_attrs = function
@ -77,7 +77,7 @@ let rec deprecated_attrs = function
let deprecated_of_attrs l =
match deprecated_attrs l with
| None -> None
| Some (_,p) -> Some (string_of_opt_payload p)
| Some a -> Some (string_of_opt_payload a.attr_payload)
let check_deprecated loc attrs s =
match deprecated_of_attrs attrs with
@ -91,8 +91,9 @@ let check_deprecated_inclusion ~def ~use loc attrs1 attrs2 s =
let rec deprecated_mutable_of_attrs = function
| [] -> None
| ({txt = "ocaml.deprecated_mutable"|"deprecated_mutable"; _}, p) :: _ ->
Some (string_of_opt_payload p)
| {attr_name = {txt = "ocaml.deprecated_mutable"|"deprecated_mutable"; _};
attr_payload = p} :: _ ->
Some (string_of_opt_payload p)
| _ :: tl -> deprecated_mutable_of_attrs tl
let check_deprecated_mutable loc attrs s =
@ -131,8 +132,8 @@ let rec deprecated_of_str = function
let check_no_deprecated attrs =
match deprecated_attrs attrs with
| None -> ()
| Some ({txt;loc},_) ->
Location.prerr_warning loc (Warnings.Misplaced_attribute txt)
| Some {attr_name = {txt;_};attr_loc} ->
Location.prerr_warning attr_loc (Warnings.Misplaced_attribute txt)
let warning_attribute ?(ppwarning = true) =
let process loc txt errflag payload =
@ -150,17 +151,28 @@ let warning_attribute ?(ppwarning = true) =
(txt, "A single string literal is expected"))
in
function
| ({txt = ("ocaml.warning"|"warning") as txt; loc}, payload) ->
process loc txt false payload
| ({txt = ("ocaml.warnerror"|"warnerror") as txt; loc}, payload) ->
process loc txt true payload
| {txt="ocaml.ppwarning"|"ppwarning"},
PStr[{pstr_desc=Pstr_eval({pexp_desc=Pexp_constant
(Pconst_string (s, _))},_);
pstr_loc}] when ppwarning ->
Location.prerr_warning pstr_loc (Warnings.Preprocessor s)
| {attr_name = {txt = ("ocaml.warning"|"warning") as txt; _};
attr_loc;
attr_payload;
} ->
process attr_loc txt false attr_payload
| {attr_name = {txt = ("ocaml.warnerror"|"warnerror") as txt; _};
attr_loc;
attr_payload
} ->
process attr_loc txt true attr_payload
| {attr_name = {txt="ocaml.ppwarning"|"ppwarning"; _};
attr_loc = _;
attr_payload =
PStr [
{ pstr_desc=
Pstr_eval({pexp_desc=Pexp_constant (Pconst_string (s, _))},_);
pstr_loc }
];
} when ppwarning ->
Location.prerr_warning pstr_loc (Warnings.Preprocessor s)
| _ ->
()
()
let warning_scope ?ppwarning attrs f =
let prev = Warnings.backup () in
@ -176,24 +188,23 @@ let warning_scope ?ppwarning attrs f =
let warn_on_literal_pattern =
List.exists
(function
| ({txt="ocaml.warn_on_literal_pattern"|"warn_on_literal_pattern"; _}, _)
-> true
| _ -> false
(fun a -> match a.attr_name.txt with
| "ocaml.warn_on_literal_pattern"|"warn_on_literal_pattern" -> true
| _ -> false
)
let explicit_arity =
List.exists
(function
| ({txt="ocaml.explicit_arity"|"explicit_arity"; _}, _) -> true
| _ -> false
(fun a -> match a.attr_name.txt with
| "ocaml.explicit_arity"|"explicit_arity" -> true
| _ -> false
)
let immediate =
List.exists
(function
| ({txt="ocaml.immediate"|"immediate"; _}, _) -> true
| _ -> false
(fun a -> match a.attr_name.txt with
| "ocaml.immediate"|"immediate" -> true
| _ -> false
)
(* The "ocaml.boxed (default)" and "ocaml.unboxed (default)"
@ -203,7 +214,7 @@ let immediate =
source file because the default can change between compiler
invocations. *)
let check l (x, _) = List.mem x.txt l
let check l a = List.mem a.attr_name.txt l
let has_unboxed attr =
List.exists (check ["ocaml.unboxed"; "unboxed"])

8
parsing/docstrings.ml
View File

@ -97,7 +97,9 @@ let docs_attr ds =
let item =
{ pstr_desc = Pstr_eval (exp, []); pstr_loc = exp.pexp_loc }
in
(doc_loc, PStr [item])
{ attr_name = doc_loc;
attr_payload = PStr [item];
attr_loc = Location.none }
let add_docs_attrs docs attrs =
let attrs =
@ -144,7 +146,9 @@ let text_attr ds =
let item =
{ pstr_desc = Pstr_eval (exp, []); pstr_loc = exp.pexp_loc }
in
(text_loc, PStr [item])
{ attr_name = text_loc;
attr_payload = PStr [item];
attr_loc = Location.none }
let add_text_attrs dsl attrs =
let fdsl = List.filter (function {ds_body=""} -> false| _ ->true) dsl in

9
parsing/parser.mly
View File

@ -240,7 +240,6 @@ let wrap_type_annotation newtypes core_type body =
(exp, ghtyp(Ptyp_poly(newtypes, Typ.varify_constructors newtypes core_type)))
let wrap_exp_attrs body (ext, attrs) =
(* todo: keep exact location for the entire attribute *)
let body = {body with pexp_attributes = attrs @ body.pexp_attributes} in
match ext with
| None -> body
@ -250,14 +249,12 @@ let mkexp_attrs d attrs =
wrap_exp_attrs (mkexp d) attrs
let wrap_typ_attrs typ (ext, attrs) =
(* todo: keep exact location for the entire attribute *)
let typ = {typ with ptyp_attributes = attrs @ typ.ptyp_attributes} in
match ext with
| None -> typ
| Some id -> ghtyp(Ptyp_extension (id, PTyp typ))
let wrap_pat_attrs pat (ext, attrs) =
(* todo: keep exact location for the entire attribute *)
let pat = {pat with ppat_attributes = attrs @ pat.ppat_attributes} in
match ext with
| None -> pat
@ -2654,15 +2651,15 @@ attr_id:
| single_attr_id DOT attr_id { mkloc ($1 ^ "." ^ $3.txt) (symbol_rloc())}
;
attribute:
LBRACKETAT attr_id payload RBRACKET { ($2, $3) }
LBRACKETAT attr_id payload RBRACKET { Attr.mk ~loc:(symbol_rloc ()) $2 $3 }
;
post_item_attribute:
LBRACKETATAT attr_id payload RBRACKET { ($2, $3) }
LBRACKETATAT attr_id payload RBRACKET { Attr.mk ~loc:(symbol_rloc ()) $2 $3 }
;
floating_attribute:
LBRACKETATATAT attr_id payload RBRACKET
{ mark_symbol_docs ();
($2, $3) }
Attr.mk ~loc:(symbol_rloc ()) $2 $3 }
;
post_item_attributes:
/* empty */ { [] }

6
parsing/parsetree.mli
View File

@ -39,7 +39,11 @@ type constant =
(** {1 Extension points} *)
type attribute = string loc * payload
type attribute = {
attr_name : string loc;
attr_payload : payload;
attr_loc : Location.t;
}
(* [@id ARG]
[@@id ARG]

12
parsing/pprintast.ml
View File

@ -754,14 +754,14 @@ and attributes ctxt f l =
and item_attributes ctxt f l =
List.iter (item_attribute ctxt f) l
and attribute ctxt f (s, e) =
pp f "@[<2>[@@%s@ %a]@]" s.txt (payload ctxt) e
and attribute ctxt f a =
pp f "@[<2>[@@%s@ %a]@]" a.attr_name.txt (payload ctxt) a.attr_payload
and item_attribute ctxt f (s, e) =
pp f "@[<2>[@@@@%s@ %a]@]" s.txt (payload ctxt) e
and item_attribute ctxt f a =
pp f "@[<2>[@@@@%s@ %a]@]" a.attr_name.txt (payload ctxt) a.attr_payload
and floating_attribute ctxt f (s, e) =
pp f "@[<2>[@@@@@@%s@ %a]@]" s.txt (payload ctxt) e
and floating_attribute ctxt f a =
pp f "@[<2>[@@@@@@%s@ %a]@]" a.attr_name.txt (payload ctxt) a.attr_payload
and value_description ctxt f x =
(* note: value_description has an attribute field,

34
parsing/printast.ml
View File

@ -404,14 +404,16 @@ and type_declaration i ppf x =
line i ppf "ptype_manifest =\n";
option (i+1) core_type ppf x.ptype_manifest
and attribute i ppf k a =
line i ppf "%s \"%s\"\n" k a.attr_name.txt;
payload i ppf a.attr_payload;
and attributes i ppf l =
let i = i + 1 in
List.iter
(fun (s, arg) ->
line i ppf "attribute \"%s\"\n" s.txt;
payload (i + 1) ppf arg;
)
l
List.iter (fun a ->
line i ppf "attribute \"%s\"\n" a.attr_name.txt;
payload (i + 1) ppf a.attr_payload;
) l;
and payload i ppf = function
| PStr x -> structure i ppf x
@ -523,9 +525,8 @@ and class_type_field i ppf x =
line i ppf "Pctf_constraint\n";
core_type (i+1) ppf ct1;
core_type (i+1) ppf ct2;
| Pctf_attribute (s, arg) ->
line i ppf "Pctf_attribute \"%s\"\n" s.txt;
payload i ppf arg
| Pctf_attribute a ->
attribute i ppf "Pctf_attribute" a
| Pctf_extension (s, arg) ->
line i ppf "Pctf_extension \"%s\"\n" s.txt;
payload i ppf arg
@ -618,9 +619,8 @@ and class_field i ppf x =
| Pcf_initializer (e) ->
line i ppf "Pcf_initializer\n";
expression (i+1) ppf e;
| Pcf_attribute (s, arg) ->
line i ppf "Pcf_attribute \"%s\"\n" s.txt;
payload i ppf arg
| Pcf_attribute a ->
attribute i ppf "Pcf_attribute" a
| Pcf_extension (s, arg) ->
line i ppf "Pcf_extension \"%s\"\n" s.txt;
payload i ppf arg
@ -717,9 +717,8 @@ and signature_item i ppf x =
line i ppf "Psig_extension \"%s\"\n" s.txt;
attributes i ppf attrs;
payload i ppf arg
| Psig_attribute (s, arg) ->
line i ppf "Psig_attribute \"%s\"\n" s.txt;
payload i ppf arg
| Psig_attribute a ->
attribute i ppf "Psig_attribute" a
and modtype_declaration i ppf = function
| None -> line i ppf "#abstract"
@ -824,9 +823,8 @@ and structure_item i ppf x =
line i ppf "Pstr_extension \"%s\"\n" s.txt;
attributes i ppf attrs;
payload i ppf arg
| Pstr_attribute (s, arg) ->
line i ppf "Pstr_attribute \"%s\"\n" s.txt;
payload i ppf arg
| Pstr_attribute a ->
attribute i ppf "Pstr_attribute" a
and module_declaration i ppf pmd =
string_loc i ppf pmd.pmd_name;

3
testsuite/tests/parsetree/test.ml
View File

@ -21,7 +21,8 @@ let remove_locs =
attributes =
(fun mapper attrs ->
let attrs = default_mapper.attributes mapper attrs in
List.filter (fun (s, _) -> s.Location.txt <> "#punning#")
List.filter (fun a ->
a.Parsetree.attr_name.Location.txt <> "#punning#")
attrs (* this is to accomodate a LexiFi custom extension *)
)
}

2
testsuite/tests/warnings/w03.compilers.reference
View File

@ -1,4 +1,4 @@
File "w03.ml", line 14, characters 8-9:
Warning 3: deprecated: A
File "w03.ml", line 17, characters 15-25:
File "w03.ml", line 17, characters 12-26:
Warning 53: the "deprecated" attribute cannot appear in this context

2
tools/caml_tex.ml
View File

@ -500,7 +500,7 @@ module Ellipsis = struct
(* we rely on the fact that the default iterator call first
the location subiterator, then the attribute subiterator *)
last_loc := loc in
let attribute _this (attr,_) =
let attribute _this {Parsetree.attr_name = attr;_} =
let name = attr.Location.txt in
let loc = !last_loc in
let start = loc.Location.loc_start.Lexing.pos_cnum in

8
toplevel/topdirs.ml
View File

@ -480,9 +480,13 @@ let trim_signature = function
(List.map
(function
Sig_module (id, md, rs) ->
let attribute =
Ast_helper.Attr.mk
(Location.mknoloc "...")
(Parsetree.PStr [])
in
Sig_module (id, {md with md_attributes =
(Location.mknoloc "...", Parsetree.PStr [])
:: md.md_attributes},
attribute :: md.md_attributes},
rs)
(*| Sig_modtype (id, Modtype_manifest mty) ->
Sig_modtype (id, Modtype_manifest (trim_modtype mty))*)

3
typing/parmatch.ml
View File

@ -2453,7 +2453,8 @@ let all_rhs_idents exp =
and perform "indirect check for them" *)
let is_unpack exp =
List.exists
(fun (attr, _) -> attr.txt = "#modulepat") exp.exp_attributes
(fun attr -> attr.Parsetree.attr_name.txt = "#modulepat")
exp.exp_attributes
let leave_expression exp =
if is_unpack exp then begin match exp.exp_desc with

6
typing/predef.ml
View File

@ -199,9 +199,9 @@ let common_initial_env add_type add_extension empty_env =
ext_ret_type = None;
ext_private = Asttypes.Public;
ext_loc = Location.none;
ext_attributes = [{Asttypes.txt="ocaml.warn_on_literal_pattern";
loc=Location.none},
Parsetree.PStr[]] }
ext_attributes = [Ast_helper.Attr.mk
(Location.mknoloc "ocaml.warn_on_literal_pattern")
(Parsetree.PStr [])] }
in
add_extension ident_match_failure
[newgenty (Ttuple[type_string; type_int; type_int])] (

5
typing/printtyp.ml
View File

@ -1610,8 +1610,9 @@ and trees_of_sigitem = function
[tree_of_extension_constructor id ext es]
| Sig_module(id, md, rs) ->
let ellipsis =
List.exists (function ({txt="..."}, Parsetree.PStr []) -> true
| _ -> false)
List.exists (function
| Parsetree.{attr_name = {txt="..."}; attr_payload = PStr []} -> true
| _ -> false)
md.md_attributes in
[tree_of_module id md.md_type rs ~ellipsis]
| Sig_modtype(id, decl) ->

34
typing/printtyped.ml
View File

@ -154,14 +154,16 @@ let record_representation i ppf = let open Types in function
| Record_inlined i -> line i ppf "Record_inlined %d\n" i
| Record_extension -> line i ppf "Record_extension\n"
let attribute i ppf k a =
line i ppf "%s \"%s\"\n" k a.Parsetree.attr_name.txt;
Printast.payload i ppf a.Parsetree.attr_payload
let attributes i ppf l =
let i = i + 1 in
List.iter
(fun (s, arg) ->
line i ppf "attribute \"%s\"\n" s.txt;
Printast.payload (i + 1) ppf arg;
)
l
List.iter (fun a ->
line i ppf "attribute \"%s\"\n" a.Parsetree.attr_name.txt;
Printast.payload (i + 1) ppf a.Parsetree.attr_payload
) l
let rec core_type i ppf x =
line i ppf "core_type %a\n" fmt_location x.ctyp_loc;
@ -532,9 +534,8 @@ and class_type_field i ppf x =
line i ppf "Tctf_constraint\n";
core_type (i+1) ppf ct1;
core_type (i+1) ppf ct2;
| Tctf_attribute (s, arg) ->
line i ppf "Tctf_attribute \"%s\"\n" s.txt;
Printast.payload i ppf arg
| Tctf_attribute a ->
attribute i ppf "Tctf_attribute" a
and class_description i ppf x =
line i ppf "class_description %a\n" fmt_location x.ci_loc;
@ -618,9 +619,8 @@ and class_field i ppf x =
| Tcf_initializer (e) ->
line i ppf "Tcf_initializer\n";
expression (i+1) ppf e;
| Tcf_attribute (s, arg) ->
line i ppf "Tcf_attribute \"%s\"\n" s.txt;
Printast.payload i ppf arg
| Tcf_attribute a ->
attribute i ppf "Tcf_attribute" a
and class_field_kind i ppf = function
| Tcfk_concrete (o, e) ->
@ -706,9 +706,8 @@ and signature_item i ppf x =
| Tsig_class_type (l) ->
line i ppf "Tsig_class_type\n";
list i class_type_declaration ppf l;
| Tsig_attribute (s, arg) ->
line i ppf "Tsig_attribute \"%s\"\n" s.txt;
Printast.payload i ppf arg
| Tsig_attribute a ->
attribute i ppf "Tsig_attribute" a
and module_declaration i ppf md =
line i ppf "%a" fmt_ident md.md_id;
@ -811,9 +810,8 @@ and structure_item i ppf x =
line i ppf "Tstr_include";
attributes i ppf incl.incl_attributes;
module_expr i ppf incl.incl_mod;
| Tstr_attribute (s, arg) ->
line i ppf "Tstr_attribute \"%s\"\n" s.txt;
Printast.payload i ppf arg
| Tstr_attribute a ->
attribute i ppf "Tstr_attribute" a
and longident_x_with_constraint i ppf (li, _, wc) =
line i ppf "%a\n" fmt_path li;

8
typing/subst.ml
View File

@ -66,10 +66,10 @@ let remove_loc =
{default_mapper with location = (fun _this _loc -> Location.none)}
let is_not_doc = function
| ({Location.txt = "ocaml.doc"}, _) -> false
| ({Location.txt = "ocaml.text"}, _) -> false
| ({Location.txt = "doc"}, _) -> false
| ({Location.txt = "text"}, _) -> false
| {Parsetree.attr_name = {Location.txt = "ocaml.doc"}; _} -> false
| {Parsetree.attr_name = {Location.txt = "ocaml.text"}; _} -> false
| {Parsetree.attr_name = {Location.txt = "doc"}; _} -> false
| {Parsetree.attr_name = {Location.txt = "text"}; _} -> false
| _ -> true
let attrs s x =

8
typing/typecore.ml
View File

@ -1980,7 +1980,8 @@ let create_package_type loc env (p, l) =
let open Ast_helper in
List.fold_left
(fun sexp (name, loc) ->
Exp.letmodule ~loc:sexp.pexp_loc ~attrs:[mknoloc "#modulepat",PStr []]
Exp.letmodule ~loc:sexp.pexp_loc
~attrs:[Attr.mk (mknoloc "#modulepat") (PStr [])]
name
(Mod.unpack ~loc
(Exp.ident ~loc:name.loc (mkloc (Longident.Lident name.txt)
@ -2288,7 +2289,7 @@ and type_expect_
else With_attributes in
let scp =
match sexp.pexp_attributes, rec_flag with
| [{txt="#default"},_], _ -> None
| [{attr_name = {txt="#default"}; _}], _ -> None
| _, Recursive -> Some (Annot.Idef loc)
| _, Nonrecursive -> Some (Annot.Idef sbody.pexp_loc)
in
@ -2337,7 +2338,8 @@ and type_expect_
in
let pat = Pat.var ~loc:sloc (mknoloc "*opt*") in
let body =
Exp.let_ ~loc Nonrecursive ~attrs:[mknoloc "#default",PStr []]
Exp.let_ ~loc Nonrecursive
~attrs:[Attr.mk (mknoloc "#default") (PStr [])]
[Vb.mk spat smatch] sbody
in
type_function ?in_function loc sexp.pexp_attributes env

7
typing/untypeast.ml
View File

@ -126,7 +126,12 @@ let constant = function
| Const_nativeint i -> Pconst_integer (Nativeint.to_string i, Some 'n')
| Const_float f -> Pconst_float (f,None)
let attribute sub (s, p) = (map_loc sub s, p)
let attribute sub a = {
attr_name = map_loc sub a.attr_name;
attr_payload = a.attr_payload;
attr_loc = a.attr_loc
}
let attributes sub l = List.map (sub.attribute sub) l
let structure sub str =