Fix misplaced attribute warning when using external parser (and some cleanup) (oxcaml#101)

ccasin · web-flow · commit a9268d29b47c · 2023-01-23T09:05:11.000-05:00
* Attributes are now tracked for warning 53 even when using a ppx My previous rework of warning 53 actually made it so that, if using a serialized parsetree, NO attributes are tracked for this warning. * fix @poll and @noalloc to use the new misplaced attributes system
diff --git a/lambda/translattribute.ml b/lambda/translattribute.ml
@@ -260,12 +260,7 @@ let get_property_attribute l p =
   let attr = find_attribute (is_property_attribute p) l in
   parse_property_attribute attr p
 
-let get_check_attribute l =
-  List.filter_map (fun p ->
-    match get_property_attribute l p with
-    | Default_check -> None
-    | a -> Some a)
-    [Noalloc]
+let get_check_attribute l = get_property_attribute l Noalloc
 
 let get_poll_attribute l =
   let attr = find_attribute is_poll_attribute l in
@@ -370,9 +365,11 @@ let add_check_attribute expr loc attributes =
     | Assume p -> Printf.sprintf "%s assume" (to_string p)
     | Default_check -> assert false
   in
-  match expr, get_check_attribute attributes with
-  | expr, [] -> expr
-  | Lfunction({ attr = { stub = false } as attr } as funct), [check] ->
+  match expr with
+  | Lfunction({ attr = { stub = false } as attr } as funct) ->
+    begin match get_check_attribute attributes with
+    | Default_check -> expr
+    | (Assert _ | Assume _) as check ->
       begin match attr.check with
       | Default_check -> ()
       | Assert Noalloc | Assume Noalloc ->
@@ -381,15 +378,8 @@ let add_check_attribute expr loc attributes =
       end;
       let attr = { attr with check } in
       lfunction_with_attr ~attr funct
-  | expr, [check] ->
-      Location.prerr_warning loc
-        (Warnings.Misplaced_attribute (to_string check));
-      expr
-  | expr, a::b::_ ->
-    Location.prerr_warning loc
-      (Warnings.Duplicated_attribute
-         (Printf.sprintf "%s/%s"(to_string a) (to_string b)));
-    expr
+    end
+  | expr -> expr
 
 let add_loop_attribute expr loc attributes =
   match expr with
@@ -424,9 +414,11 @@ let add_tmc_attribute expr loc attributes =
   | _ -> expr
 
 let add_poll_attribute expr loc attributes =
-  match expr, get_poll_attribute attributes with
-  | expr, Default_poll -> expr
-  | Lfunction({ attr = { stub = false } as attr } as funct), poll ->
+  match expr with
+  | Lfunction({ attr = { stub = false } as attr } as funct) ->
+    begin match get_poll_attribute attributes with
+    | Default_poll -> expr
+    | Error_poll as poll ->
       begin match attr.poll with
       | Default_poll -> ()
       | Error_poll ->
@@ -438,10 +430,8 @@ let add_poll_attribute expr loc attributes =
       check_poll_local loc attr;
       let attr = { attr with inline = Never_inline; local = Never_local } in
       lfunction_with_attr ~attr funct
-  | expr, Error_poll ->
-      Location.prerr_warning loc
-        (Warnings.Misplaced_attribute "error_poll");
-      expr
+    end
+  | expr -> expr
 
 (* Get the [@inlined] attribute payload (or default if not present). *)
 let get_inlined_attribute e =
diff --git a/parsing/ast_invariants.ml b/parsing/ast_invariants.ml
@@ -170,6 +170,10 @@ let iterator =
           "In object types, attaching attributes to inherited \
            subtypes is not allowed."
   in
+  let attribute self attr =
+    super.attribute self attr;
+    Builtin_attributes.register_attr attr.attr_name
+  in
   { super with
     type_declaration
   ; typ
@@ -185,6 +189,7 @@ let iterator =
   ; signature_item
   ; row_field
   ; object_field
+  ; attribute
   }
 
 let structure st = iterator.structure iterator st
diff --git a/parsing/builtin_attributes.ml b/parsing/builtin_attributes.ml
@@ -92,9 +92,12 @@ let builtin_attrs =
 
 let is_builtin_attr s = Hashtbl.mem builtin_attrs s
 
-let mk_internal ?(loc= !default_loc) name payload =
+let register_attr name =
   if is_builtin_attr name.txt
-  then Attribute_table.add unused_attrs name ();
+  then Attribute_table.replace unused_attrs name ()
+
+let mk_internal ?(loc= !default_loc) name payload =
+  register_attr name;
   Attr.mk ~loc name payload
 
 
diff --git a/parsing/builtin_attributes.mli b/parsing/builtin_attributes.mli
@@ -46,6 +46,10 @@ val mk_internal:
   ?loc:Location.t -> string Location.loc -> Parsetree.payload ->
   Parsetree.attribute
 
+(** Used to record attributes that should be tracked for the purpose of
+    misplaced attribute warnings.  *)
+val register_attr: string Location.loc -> unit
+
 (** Marks alert attributes used for the purposes of misplaced attribute
     warnings.  Call this when moving things with alert attributes into the
     environment. *)
diff --git a/testsuite/tests/warnings/w53.compilers.reference b/testsuite/tests/warnings/w53.compilers.reference
@@ -6,10 +6,6 @@ File "w53.ml", line 12, characters 4-5:
 12 | let h x = x [@inline] (* rejected *)
          ^
 Warning 32 [unused-value-declaration]: unused value h.
-File "w53.ml", line 334, characters 2-33:
-334 |   let x : int64 = 42L [@@noalloc] (* rejected *)
-        ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Warning 53 [misplaced-attribute]: the "noalloc" attribute cannot appear in this context
 File "w53.ml", line 12, characters 14-20:
 12 | let h x = x [@inline] (* rejected *)
                    ^^^^^^
@@ -558,6 +554,10 @@ File "w53.ml", line 333, characters 19-26:
 333 |   type s1 = Foo1 [@noalloc] (* rejected *)
                          ^^^^^^^
 Warning 53 [misplaced-attribute]: the "noalloc" attribute cannot appear in this context
+File "w53.ml", line 334, characters 25-32:
+334 |   let x : int64 = 42L [@@noalloc] (* rejected *)
+                               ^^^^^^^
+Warning 53 [misplaced-attribute]: the "noalloc" attribute cannot appear in this context
 File "w53.ml", line 336, characters 24-31:
 336 |   external y : (int64 [@noalloc]) -> (int64 [@noalloc]) = "x" (* rejected *)
                               ^^^^^^^
@@ -590,3 +590,51 @@ File "w53.ml", line 352, characters 22-30:
 352 |   let x : int = 42 [@@untagged] (* rejected *)
                             ^^^^^^^^
 Warning 53 [misplaced-attribute]: the "untagged" attribute cannot appear in this context
+File "w53.ml", line 359, characters 21-25:
+359 |   type 'a t1 = 'a [@@poll error] (* rejected *)
+                           ^^^^
+Warning 53 [misplaced-attribute]: the "poll" attribute cannot appear in this context
+File "w53.ml", line 360, characters 19-23:
+360 |   type s1 = Foo1 [@poll error] (* rejected *)
+                         ^^^^
+Warning 53 [misplaced-attribute]: the "poll" attribute cannot appear in this context
+File "w53.ml", line 361, characters 19-23:
+361 |   val x : int64 [@@poll error] (* rejected *)
+                         ^^^^
+Warning 53 [misplaced-attribute]: the "poll" attribute cannot appear in this context
+File "w53.ml", line 363, characters 24-28:
+363 |   external y : (int64 [@poll error]) -> (int64 [@poll error]) = (* rejected *)
+                              ^^^^
+Warning 53 [misplaced-attribute]: the "poll" attribute cannot appear in this context
+File "w53.ml", line 363, characters 49-53:
+363 |   external y : (int64 [@poll error]) -> (int64 [@poll error]) = (* rejected *)
+                                                       ^^^^
+Warning 53 [misplaced-attribute]: the "poll" attribute cannot appear in this context
+File "w53.ml", line 365, characters 39-43:
+365 |   external z : int64 -> int64 = "x" [@@poll error] (* rejected *)
+                                             ^^^^
+Warning 53 [misplaced-attribute]: the "poll" attribute cannot appear in this context
+File "w53.ml", line 369, characters 21-25:
+369 |   type 'a t1 = 'a [@@poll error] (* rejected *)
+                           ^^^^
+Warning 53 [misplaced-attribute]: the "poll" attribute cannot appear in this context
+File "w53.ml", line 370, characters 19-23:
+370 |   type s1 = Foo1 [@poll error] (* rejected *)
+                         ^^^^
+Warning 53 [misplaced-attribute]: the "poll" attribute cannot appear in this context
+File "w53.ml", line 371, characters 25-29:
+371 |   let x : int64 = 42L [@@poll error] (* rejected *)
+                               ^^^^
+Warning 53 [misplaced-attribute]: the "poll" attribute cannot appear in this context
+File "w53.ml", line 374, characters 24-28:
+374 |   external y : (int64 [@poll error]) -> (int64 [@poll error]) =  (* rejected *)
+                              ^^^^
+Warning 53 [misplaced-attribute]: the "poll" attribute cannot appear in this context
+File "w53.ml", line 374, characters 49-53:
+374 |   external y : (int64 [@poll error]) -> (int64 [@poll error]) =  (* rejected *)
+                                                       ^^^^
+Warning 53 [misplaced-attribute]: the "poll" attribute cannot appear in this context
+File "w53.ml", line 376, characters 39-43:
+376 |   external z : int64 -> int64 = "x" [@@poll error] (* rejected *)
+                                             ^^^^
+Warning 53 [misplaced-attribute]: the "poll" attribute cannot appear in this context
diff --git a/testsuite/tests/warnings/w53.ml b/testsuite/tests/warnings/w53.ml
@@ -355,3 +355,23 @@ module TestUntaggedStruct = struct
   external z : int -> int = "x" "y" [@@untagged] (* accepted *)
 end
 
+module type TestPollSig = sig
+  type 'a t1 = 'a [@@poll error] (* rejected *)
+  type s1 = Foo1 [@poll error] (* rejected *)
+  val x : int64 [@@poll error] (* rejected *)
+
+  external y : (int64 [@poll error]) -> (int64 [@poll error]) = (* rejected *)
+    "x"
+  external z : int64 -> int64 = "x" [@@poll error] (* rejected *)
+end
+
+module TestPollStruct = struct
+  type 'a t1 = 'a [@@poll error] (* rejected *)
+  type s1 = Foo1 [@poll error] (* rejected *)
+  let x : int64 = 42L [@@poll error] (* rejected *)
+  let [@poll error] f x = x (* accepted *)
+
+  external y : (int64 [@poll error]) -> (int64 [@poll error]) =  (* rejected *)
+    "x"
+  external z : int64 -> int64 = "x" [@@poll error] (* rejected *)
+end
diff --git a/testsuite/tests/warnings/w53_ppx.ml b/testsuite/tests/warnings/w53_ppx.ml
@@ -0,0 +1,13 @@
+open Ast_mapper
+
+let replace_attr ({ Parsetree.attr_name; _} as attr) =
+  { attr with
+    attr_name =
+      if String.equal attr.attr_name.txt "test" then
+        { attr_name with txt = "immediate" }
+      else attr_name
+  }
+
+let () =
+  register "test" (fun _ ->
+    { default_mapper with attribute = fun _ attr -> replace_attr attr })
diff --git a/testsuite/tests/warnings/w53_with_ppx.compilers.reference b/testsuite/tests/warnings/w53_with_ppx.compilers.reference
@@ -0,0 +1,4 @@
+File "w53_with_ppx.ml", line 18, characters 13-17:
+18 | let x = 3 [@@test]
+                  ^^^^
+Warning 53 [misplaced-attribute]: the "immediate" attribute cannot appear in this context
diff --git a/testsuite/tests/warnings/w53_with_ppx.ml b/testsuite/tests/warnings/w53_with_ppx.ml
@@ -0,0 +1,20 @@
+(* TEST
+readonly_files = "w53_ppx.ml"
+include ocamlcommon
+* setup-ocamlc.byte-build-env
+** ocamlc.byte
+program = "${test_build_directory}/w53_ppx.exe"
+all_modules = "w53_ppx.ml"
+*** ocamlc.byte
+module = "w53_with_ppx.ml"
+flags = "-ppx ${program}"
+**** check-ocamlc.byte-output
+*)
+
+(* This test checks that compiler-builtin attributes inserted by a ppx still
+   trigger the misplaced attribute warning if they are unused (and not if
+   they are used). *)
+
+let x = 3 [@@test]
+
+type t = int [@@test]
