melange-ppx: deprecated alert on bs.* attributes

Changes.md

@@ -36,6 +36,8 @@ Unreleased
 - Add `--rectypes` ([#644](https://github.com/melange-re/melange/pull/644)) to
   enable [recursive
   types](https://v2.ocaml.org/releases/5.0/htmlman/types.html#sss:typexpr-aliased-recursive)
+- [melange.ppx]: Deprecate `bs.*` attributes in favor of `mel.*`
+  ([#662](https://github.com/melange-re/melange/pull/662))
 
 1.0.0 2023-05-31
 ---------------

ppx/ast_attributes.ml

@@ -36,13 +36,21 @@ let assert_bool_lit (e : Parsetree.expression) =
       Location.raise_errorf ~loc:e.pexp_loc
         "expect `true` or `false` in this field"
 
+let warn_if_bs ~loc txt =
+  match txt with
+  | "bs" -> Bs_ast_invariant.warn ~loc Deprecated_attribute_namespace
+  | other ->
+      if String.starts_with ~prefix:"bs." other then
+        Bs_ast_invariant.warn ~loc Deprecated_attribute_namespace
+
 let process_method_attributes_rev (attrs : t) =
   let exception Local of string in
   try
     let ret =
       List.fold_left
         (fun (st, acc)
-             ({ attr_name = { txt; _ }; attr_payload = payload; _ } as attr) ->
+             ({ attr_name = { txt; loc }; attr_payload = payload; _ } as attr) ->
+          warn_if_bs ~loc txt;
           match txt with
           | "bs.get" | "get" (* @bs.get{null; undefined}*) ->
               let result =
@@ -109,6 +117,7 @@ type attr_kind =
 let process_attributes_rev (attrs : t) : attr_kind * t =
   List.fold_left
     (fun (st, acc) ({ attr_name = { txt; loc }; _ } as attr) ->
+      warn_if_bs ~loc txt;
       match (txt, st) with
       | "bs", (Nothing | Uncurry _) ->
           (Uncurry attr, acc) (* TODO: warn unused/duplicated attribute *)
@@ -122,13 +131,15 @@ let process_attributes_rev (attrs : t) : attr_kind * t =
 
 let process_pexp_fun_attributes_rev (attrs : t) =
   List.fold_left
-    (fun (st, acc) ({ attr_name = { txt; loc = _ }; _ } as attr) ->
+    (fun (st, acc) ({ attr_name = { txt; loc }; _ } as attr) ->
+      warn_if_bs ~loc txt;
       match txt with "bs.open" -> (true, acc) | _ -> (st, attr :: acc))
     (false, []) attrs
 
 let process_bs (attrs : t) =
   List.fold_left
-    (fun (st, acc) ({ attr_name = { txt; loc = _ }; _ } as attr) ->
+    (fun (st, acc) ({ attr_name = { txt; loc }; _ } as attr) ->
+      warn_if_bs ~loc txt;
       match (txt, st) with "bs", _ -> (true, acc) | _, _ -> (st, attr :: acc))
     (false, []) attrs
 
@@ -275,7 +286,8 @@ let iter_process_bs_string_int_unwrap_uncurry (attrs : t) =
     else Error.err ~loc Conflict_attributes
   in
   List.iter
-    (fun ({ attr_name = { txt; loc = _ }; attr_payload = payload; _ } as attr) ->
+    (fun ({ attr_name = { txt; loc }; attr_payload = payload; _ } as attr) ->
+      warn_if_bs ~loc txt;
       match txt with
       | "bs.string" | "string" -> assign `String attr
       | "bs.int" | "int" -> assign `Int attr
@@ -353,7 +365,7 @@ let rs_externals (attrs : t) pval_prim =
   | _, [] -> false
   (* This is  val *)
   | [], _ ->
-      (* Not any attribute found *)
+      (* No attributes found *)
       prims_to_be_encoded pval_prim
   | _, _ ->
       List.exists
@@ -367,6 +379,7 @@ let iter_process_bs_int_as (attrs : t) =
   let st = ref None in
   List.iter
     (fun ({ attr_name = { txt; loc }; attr_payload = payload; _ } as attr) ->
+      warn_if_bs ~loc txt;
       match txt with
       | "bs.as" | "as" ->
           if !st = None then (
@@ -382,7 +395,8 @@ let iter_process_bs_int_as (attrs : t) =
 
 let has_bs_optional (attrs : t) : bool =
   List.exists
-    (fun ({ attr_name = { txt; _ }; _ } as attr) ->
+    (fun ({ attr_name = { txt; loc }; _ } as attr) ->
+      warn_if_bs ~loc txt;
       match txt with
       | "bs.optional" | "optional" ->
           Bs_ast_invariant.mark_used_bs_attribute attr;
@@ -391,7 +405,9 @@ let has_bs_optional (attrs : t) : bool =
     attrs
 
 let is_inline : attr -> bool =
- fun { attr_name = { txt; _ }; _ } -> txt = "bs.inline" || txt = "inline"
+ fun { attr_name = { txt; loc }; _ } ->
+  warn_if_bs ~loc txt;
+  txt = "bs.inline" || txt = "inline"
 
 let has_inline_payload (attrs : t) = Ext_list.find_first attrs is_inline
 

ppx/ast_attributes.mli

@@ -28,6 +28,8 @@ type attr = Parsetree.attribute
 type t = attr list
 type ('a, 'b) st = { get : 'a option; set : 'b option }
 
+val warn_if_bs : loc:Location.t -> string -> unit
+
 val process_method_attributes_rev :
   t -> ((bool * bool, [ `Get | `No_get ]) st * t, string) result
 

ppx/ast_external_process.ml

@@ -255,6 +255,7 @@ let parse_external_attributes (no_arguments : bool) (prim_name_check : string)
           } )
       else
         let action () =
+          Ast_attributes.warn_if_bs ~loc txt;
           match txt with
           | "bs.val" | "val" ->
               if no_arguments then

ppx/bs_ast_invariant.ml

@@ -29,11 +29,13 @@ module Warnings = struct
     | Unused_attribute of string
     | Fragile_external of string
     | Redundant_bs_string
+    | Deprecated_attribute_namespace
 
   let kind = function
     | Unused_attribute _ -> "unused"
     | Fragile_external _ -> "fragile"
     | Redundant_bs_string -> "redundant"
+    | Deprecated_attribute_namespace -> "deprecated"
 
   let pp fmt t =
     match t with
@@ -51,19 +53,22 @@ module Warnings = struct
     | Redundant_bs_string ->
         Format.fprintf fmt
           "[@bs.string] is redundant here, you can safely remove it"
-
-  let warn ~loc msg =
-    let module Location = Ocaml_common.Location in
-    Location.prerr_alert loc
-      {
-        Ocaml_common.Warnings.kind = kind msg;
-        message = Format.asprintf "%a" pp msg;
-        def = Location.none;
-        use = loc;
-      }
+    | Deprecated_attribute_namespace ->
+        Format.fprintf fmt
+          "The `bs.*' attribute namespace is deprecated and will be removed in \
+           the next release.@\n\
+           Use `mel.*' instead."
 end
 
-let warn = Warnings.warn
+let warn ~loc msg =
+  let module Location = Ocaml_common.Location in
+  Location.prerr_alert loc
+    {
+      Ocaml_common.Warnings.kind = Warnings.kind msg;
+      message = Format.asprintf "%a" Warnings.pp msg;
+      def = Location.none;
+      use = loc;
+    }
 
 (** Warning unused bs attributes
     Note if we warn `deriving` too,

ppx/bs_ast_invariant.mli

@@ -29,6 +29,7 @@ module Warnings : sig
     | Unused_attribute of string
     | Fragile_external of string
     | Redundant_bs_string
+    | Deprecated_attribute_namespace
 end
 
 val warn : loc:Location.t -> Warnings.t -> unit

test/blackbox-tests/deriving-abstract-mutually-recursive.t

@@ -14,6 +14,6 @@ generated )
   > } [@@deriving abstract]
   > EOF
 
-  $ melc -ppx melppx -bs-no-version-header foo.ml
+  $ melc -ppx 'melppx -alert -deprecated' -bs-no-version-header foo.ml
   /* This output is empty. Its source's type definitions, externals and/or unused code got optimized away. */
 

test/blackbox-tests/dune

@@ -4,3 +4,8 @@
   (env_var MELANGE_LIB)
   setup.sh
   (package melange)))
+
+(cram
+ (applies_to mel-attributes)
+ (enabled_if
+  (<= %{ocaml_version} "5.1")))

test/blackbox-tests/ffi-error-debug.t

@@ -6,7 +6,7 @@
   >   hi_should_error:([\`a of int | \`b of string ] [@bs.string]) ->
   >   unit -> _ = "" [@@bs.obj]
   > EOF
-  $ melc -ppx melppx x.ml
+  $ melc -ppx 'melppx -alert -deprecated' x.ml
   File "x.ml", lines 2-3, characters 2-11:
   2 | ..hi_should_error:([`a of int | `b of string ] [@bs.string]) ->
   3 |   unit -> _................
@@ -18,7 +18,7 @@
   >   ?hi_should_error:([\`a of int | \`b of string ] [@bs.string]) ->
   >   unit -> _ = "" [@@bs.obj]
   > EOF
-  $ melc -ppx melppx x.ml
+  $ melc -ppx 'melppx -alert -deprecated' x.ml
   File "x.ml", lines 2-3, characters 2-11:
   2 | ..?hi_should_error:([`a of int | `b of string ] [@bs.string]) ->
   3 |   unit -> _................
@@ -30,7 +30,7 @@
   >   ?hi_should_error:([\`a of int | \`b of string ] [@bs.string]) ->
   >   unit -> unit = "err" [@@bs.val]
   > EOF
-  $ melc -ppx melppx x.ml
+  $ melc -ppx 'melppx -alert -deprecated' x.ml
   File "x.ml", lines 1-3, characters 0-33:
   1 | external err :
   2 |   ?hi_should_error:([`a of int | `b of string ] [@bs.string]) ->
@@ -46,7 +46,7 @@ Each [@bs.unwrap] variant constructor requires an argument
   >   ?hi_should_error:([\`a of int | \`b] [@bs.unwrap]) ->
   >   unit -> unit = "err" [@@bs.val]
   > EOF
-  $ melc -ppx melppx x.ml
+  $ melc -ppx 'melppx -alert -deprecated' x.ml
   File "x.ml", line 2, characters 20-36:
   2 |   ?hi_should_error:([`a of int | `b] [@bs.unwrap]) ->
                           ^^^^^^^^^^^^^^^^
@@ -60,7 +60,7 @@ Each [@bs.unwrap] variant constructor requires an argument
   > external err :
   >   ?hi_should_error:([\`a of int] [@bs.unwrap]) -> unit -> _ = "" [@@bs.obj]
   > EOF
-  $ melc -ppx melppx x.ml
+  $ melc -ppx 'melppx -alert -deprecated' x.ml
   File "x.ml", line 2, characters 2-58:
   2 |   ?hi_should_error:([`a of int] [@bs.unwrap]) -> unit -> _ = "" [@@bs.obj]
         ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^

test/blackbox-tests/legacy-ounit-cmd.t

@@ -9,7 +9,7 @@
   >   [@@bs.send.pipe:int]
   >   [@@bs.splice]
   > EOF
-  $ melc -ppx melppx x.ml
+  $ melc -ppx 'melppx -alert -deprecated' x.ml
   File "x.ml", lines 2-7, characters 0-15:
   2 | external
   3 |   f :
@@ -28,7 +28,7 @@
   >   [@@bs.send.pipe:int]
   >   [@@bs.splice]
   > EOF
-  $ melc -ppx melppx x.ml
+  $ melc -ppx 'melppx -alert -deprecated' x.ml
   File "x.ml", lines 1-6, characters 0-15:
   1 | external
   2 |   f2 :
@@ -60,7 +60,7 @@ Skip over the temporary file name printed in the error trace
   /* No side effect */
 
 
-  $ melc -ppx melppx -bs-eval 'external mk : int -> ([`a|`b [@bs.string]]) = "mk" [@@bs.val]' 2>&1 | grep -v File
+  $ melc -ppx 'melppx -alert -deprecated' -bs-eval 'external mk : int -> ([`a|`b [@bs.string]]) = "mk" [@@bs.val]' 2>&1 | grep -v File
   1 | external mk : int -> ([`a|`b [@bs.string]]) = "mk" [@@bs.val]
                                      ^^^^^^^^^
   Alert unused: Unused attribute [@bs.string]
@@ -76,7 +76,7 @@ Skip over the temporary file name printed in the error trace
   >     resp -> (_ [@bs.as "x"]) -> int -> unit =
   >     "x" [@@bs.set]
   > EOF
-  $ melc -ppx melppx x.ml
+  $ melc -ppx 'melppx -alert -deprecated' x.ml
   File "x.ml", lines 1-3, characters 0-18:
   1 | external ff :
   2 |     resp -> (_ [@bs.as "x"]) -> int -> unit =
@@ -88,7 +88,7 @@ Skip over the temporary file name printed in the error trace
   > external v3 :
   >   int -> int -> (int -> int -> int [@bs.uncurry]) = "v3"[@@bs.val]
   > EOF
-  $ melc -ppx melppx x.ml
+  $ melc -ppx 'melppx -alert -deprecated' x.ml
   File "x.ml", line 2, characters 37-47:
   2 |   int -> int -> (int -> int -> int [@bs.uncurry]) = "v3"[@@bs.val]
                                            ^^^^^^^^^^
@@ -104,7 +104,7 @@ Skip over the temporary file name printed in the error trace
   >   (int -> int -> int [@bs.uncurry]) = ""
   >   [@@bs.val]
   > EOF
-  $ melc -ppx melppx x.ml
+  $ melc -ppx 'melppx -alert -deprecated' x.ml
   File "x.ml", lines 1-3, characters 0-12:
   1 | external v4 :
   2 |   (int -> int -> int [@bs.uncurry]) = ""
@@ -117,7 +117,7 @@ Skip over the temporary file name printed in the error trace
           ^^^^^^
   Error: Offset: 3, Invalid \u escape
 
-  $ melc -ppx 'melppx -alert -fragile' -bs-eval 'external mk : int -> ([`a|`b] [@bs.string]) = "" [@@bs.val]' 2>&1 | grep -v File
+  $ melc -ppx 'melppx -alert -fragile -alert -deprecated' -bs-eval 'external mk : int -> ([`a|`b] [@bs.string]) = "" [@@bs.val]' 2>&1 | grep -v File
   1 | external mk : int -> ([`a|`b] [@bs.string]) = "" [@@bs.val]
                                       ^^^^^^^^^
   Alert unused: Unused attribute [@bs.string]
@@ -128,32 +128,32 @@ Skip over the temporary file name printed in the error trace
   /* This output is empty. Its source's type definitions, externals and/or unused code got optimized away. */
 
 
-  $ melc -ppx melppx -bs-eval 'external mk : int -> ([`a|`b] ) = "mk" [@@bs.val]' 2>&1 | grep -v File
+  $ melc -ppx 'melppx -alert -deprecated' -bs-eval 'external mk : int -> ([`a|`b] ) = "mk" [@@bs.val]' 2>&1 | grep -v File
   // Generated by Melange
   /* This output is empty. Its source's type definitions, externals and/or unused code got optimized away. */
 
   $ cat > x.ml <<EOF
   > type t
   > external mk : int -> (_ [@bs.as {json| { x : 3 } |json}]) ->  t = "mk" [@@bs.val]
   > EOF
-  $ melc -ppx melppx x.ml
+  $ melc -ppx 'melppx -alert -deprecated' x.ml
   // Generated by Melange
   /* This output is empty. Its source's type definitions, externals and/or unused code got optimized away. */
 
   $ cat > x.ml <<EOF
   > type t
   > external mk : int -> (_ [@bs.as {json| { "x" : 3 } |json}]) ->  t = "mk" [@@bs.val]
   > EOF
-  $ melc -ppx melppx x.ml
+  $ melc -ppx 'melppx -alert -deprecated' x.ml
   // Generated by Melange
   /* This output is empty. Its source's type definitions, externals and/or unused code got optimized away. */
 
-  $ melc -ppx melppx -bs-eval 'let should_fail = fun [@bs.this] (Some x) y u -> y + u' 2>&1 | grep -v File
+  $ melc -ppx 'melppx -alert -deprecated' -bs-eval 'let should_fail = fun [@bs.this] (Some x) y u -> y + u' 2>&1 | grep -v File
   1 | let should_fail = fun [@bs.this] (Some x) y u -> y + u
                                        ^^^^^^^^
   Error: @this expect its pattern variable to be simple form
 
-  $ melc -ppx melppx -bs-eval 'let should_fail = fun [@bs.this] (Some x as v) y u -> y + u' 2>&1 | grep -v File
+  $ melc -ppx 'melppx -alert -deprecated' -bs-eval 'let should_fail = fun [@bs.this] (Some x as v) y u -> y + u' 2>&1 | grep -v File
   1 | let should_fail = fun [@bs.this] (Some x as v) y u -> y + u
                                        ^^^^^^^^^^^^^
   Error: @this expect its pattern variable to be simple form
@@ -222,7 +222,7 @@ Skip over the temporary file name printed in the error trace
   >  string = "bar"
   >  [@@bs.send]
   > EOF
-  $ melc -ppx melppx x.ml
+  $ melc -ppx 'melppx -alert -deprecated' x.ml
   File "x.ml", lines 1-5, characters 0-12:
   1 | external foo_bar :
   2 |  (_ [@bs.as "foo"]) ->
@@ -232,7 +232,7 @@ Skip over the temporary file name printed in the error trace
   Error: Ill defined attribute @send(first argument can't be const)
   [2]
 
-  $ melc -ppx melppx -bs-eval 'let bla4 foo x y = foo##(method1 x y [@bs])' 2>&1 | grep -v File
+  $ melc -ppx 'melppx -alert -deprecated' -bs-eval 'let bla4 foo x y = foo##(method1 x y [@bs])' 2>&1 | grep -v File
   1 | let bla4 foo x y = foo##(method1 x y [@bs])
                                              ^^
   Alert unused: Unused attribute [@bs]
@@ -258,7 +258,7 @@ Skip over the temporary file name printed in the error trace
   >    [@bs.string]
   > ) = "mk" [@@bs.val]
   > EOF
-  $ melc -ppx melppx x.ml
+  $ melc -ppx 'melppx -alert -deprecated' x.ml
   File "x.ml", line 4, characters 5-14:
   4 |    [@bs.string]
            ^^^^^^^^^