From 8b99545232890e7991f4456954201cd22d728f04 Mon Sep 17 00:00:00 2001 From: Thomas Del Vecchio <127883551+tdelvecchio-jsc@users.noreply.github.com> Date: Mon, 30 Dec 2024 14:26:48 -0500 Subject: [PATCH] Fix case where parser drops attributes in packed module types. (#3262) * Demonstrate dropped attributes in test. Signed-off-by: Thomas Del Vecchio * Syntax error on misplaced attribute in packed module types. Signed-off-by: Thomas Del Vecchio --------- Signed-off-by: Thomas Del Vecchio --- parsing/parse.ml | 2 ++ parsing/parser.mly | 7 ++++++- parsing/syntaxerr.ml | 1 + parsing/syntaxerr.mli | 1 + ..._attribute_ptyp_package.compilers.reference | 10 ++++++++++ .../parsing/dropped_attribute_ptyp_package.ml | 18 ++++++++++++++++++ 6 files changed, 38 insertions(+), 1 deletion(-) create mode 100644 testsuite/tests/parsing/dropped_attribute_ptyp_package.compilers.reference create mode 100644 testsuite/tests/parsing/dropped_attribute_ptyp_package.ml diff --git a/parsing/parse.ml b/parsing/parse.ml index 1e2253b367a..1b3f6da349a 100644 --- a/parsing/parse.ml +++ b/parsing/parse.ml @@ -160,6 +160,8 @@ let prepare_error err = Format.fprintf ppf "only module type identifier and %a constraints are supported" Style.inline_code "with type" + | Misplaced_attribute -> + Format.fprintf ppf "an attribute cannot go here" in Location.errorf ~loc "invalid package type: %a" invalid ipt | Removed_string_set loc -> diff --git a/parsing/parser.mly b/parsing/parser.mly index 4c60074d276..3d2e13a7a8e 100644 --- a/parsing/parser.mly +++ b/parsing/parser.mly @@ -808,7 +808,12 @@ let package_type_of_module_type pmty = in match pmty with | {pmty_desc = Pmty_ident lid} -> (lid, [], pmty.pmty_attributes) - | {pmty_desc = Pmty_with({pmty_desc = Pmty_ident lid}, cstrs)} -> + | {pmty_desc = Pmty_with({pmty_desc = Pmty_ident lid; pmty_attributes = inner_attributes}, cstrs)} -> + begin match inner_attributes with + | [] -> () + | attr :: _ -> + err attr.attr_loc Syntaxerr.Misplaced_attribute + end; (lid, List.map map_cstr cstrs, pmty.pmty_attributes) | _ -> err pmty.pmty_loc Neither_identifier_nor_with_type diff --git a/parsing/syntaxerr.ml b/parsing/syntaxerr.ml index 76eab18b8e8..c1dbac71d7b 100644 --- a/parsing/syntaxerr.ml +++ b/parsing/syntaxerr.ml @@ -21,6 +21,7 @@ type invalid_package_type = | Private_types | Not_with_type | Neither_identifier_nor_with_type + | Misplaced_attribute type error = Unclosed of Location.t * string * Location.t * string diff --git a/parsing/syntaxerr.mli b/parsing/syntaxerr.mli index 54c619eb877..47f2910fd0e 100644 --- a/parsing/syntaxerr.mli +++ b/parsing/syntaxerr.mli @@ -26,6 +26,7 @@ type invalid_package_type = | Private_types | Not_with_type | Neither_identifier_nor_with_type + | Misplaced_attribute type error = Unclosed of Location.t * string * Location.t * string diff --git a/testsuite/tests/parsing/dropped_attribute_ptyp_package.compilers.reference b/testsuite/tests/parsing/dropped_attribute_ptyp_package.compilers.reference new file mode 100644 index 00000000000..3469a279e39 --- /dev/null +++ b/testsuite/tests/parsing/dropped_attribute_ptyp_package.compilers.reference @@ -0,0 +1,10 @@ +module type T = sig type t end +Line 3, characters 22-29: +3 | val foo : (module T [@attr] with type t = 'a) -> unit + ^^^^^^^ +Error: invalid package type: an attribute cannot go here +Line 3, characters 33-40: +3 | let foo (type a) (module M : T [@attr] with type t = a) = () + ^^^^^^^ +Error: invalid package type: an attribute cannot go here + diff --git a/testsuite/tests/parsing/dropped_attribute_ptyp_package.ml b/testsuite/tests/parsing/dropped_attribute_ptyp_package.ml new file mode 100644 index 00000000000..9fea993cc05 --- /dev/null +++ b/testsuite/tests/parsing/dropped_attribute_ptyp_package.ml @@ -0,0 +1,18 @@ +(* TEST + toplevel; +*) + +(* There is no place for the following attributes to attach to; the compiler should error + rather than silently dropping them (as it used to do). *) + +module type T = sig + type t +end;; + +module type U = sig + val foo : (module T [@attr] with type t = 'a) -> unit +end;; + +module U : U = struct + let foo (type a) (module M : T [@attr] with type t = a) = () +end;;