refactor: extract some @mel.as logic into Lam_variant_tag (#1212)

jscomp/core/dune

@@ -132,6 +132,19 @@
    -o
    %{targets})))
 
+(rule
+ (targets lam_variant_tag.ml)
+ (deps lam_variant_tag.cppo.ml)
+ (action
+  (run
+   cppo
+   -V
+   OCAML:%{ocaml_version}
+   %{env:CPPO_FLAGS=}
+   %{deps}
+   -o
+   %{targets})))
+
 (rule
  (targets polyvar_pattern_match.ml)
  (deps polyvar_pattern_match.cppo.ml)

jscomp/core/js_dump.ml

@@ -810,7 +810,7 @@ and expression_desc cxt ~(level : int) x : cxt =
           Lam_constant_convert.modifier ~name:p.name p.attributes
         in
         let tag_name =
-          match Record_attributes_check.process_tag_name p.attributes with
+          match Lam_variant_tag.process_tag_name p.attributes with
           | None -> L.tag
           | Some s -> s
         in
@@ -844,7 +844,7 @@ and expression_desc cxt ~(level : int) x : cxt =
             Lam_constant_convert.modifier ~name:p.name p.attributes
           in
           let tag_name =
-            match Record_attributes_check.process_tag_name p.attributes with
+            match Lam_variant_tag.process_tag_name p.attributes with
             | None -> L.tag
             | Some s -> s
           in

jscomp/core/lam_variant_tag.cppo.ml

@@ -0,0 +1,74 @@
+(* Copyright (C) 2022- Authors of Melange
+ *
+ * This program is free software: you can redistribute it and/or modify
+ * it under the terms of the GNU Lesser General Public License as published by
+ * the Free Software Foundation, either version 3 of the License, or
+ * (at your option) any later version.
+ *
+ * In addition to the permissions granted to you by the LGPL, you may combine
+ * or link a "work that uses the Library" with a publicly distributed version
+ * of this file to produce a combined library or application, then distribute
+ * that combined work under the terms of your choosing, with no requirement
+ * to comply with the obligations normally placed on you by section 4 of the
+ * LGPL version 3 (or the corresponding section of a later version of the LGPL
+ * should you choose to use a later version).
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ * GNU Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public License
+ * along with this program; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)
+
+open Import
+
+let namespace_error ~loc txt =
+  match txt with
+  | "bs.as" | "as" ->
+      Location.raise_errorf ~loc
+        "`[@bs.*]' and non-namespaced attributes have been removed in favor of \
+         `[@mel.*]' attributes. Use `[@mel.as]' instead."
+  | _ -> ()
+
+
+let process_tag_name attrs =
+  let st = ref None in
+  List.iter attrs
+    ~f:(fun { Parsetree.attr_name = { txt; loc }; attr_payload; _ } ->
+      match txt with
+      | "mel.tag" ->
+          if !st = None then (
+            (match attr_payload with
+            | PStr
+                [
+                  {
+                    pstr_desc =
+                      Pstr_eval ({ pexp_desc = Pexp_constant const; _ }, _);
+                    _;
+                  };
+                ] -> (
+                namespace_error ~loc txt;
+                match
+#if OCAML_VERSION >= (5, 3, 0)
+                  const.pconst_desc
+#else
+                  const
+#endif
+                with
+                | Pconst_string (s, _, _) -> st := Some s
+                | _ -> ())
+            | _ -> ());
+            if !st = None
+            then
+              Location.raise_errorf
+                ~loc
+                 "Variant tag annotation (`[@mel.tag \"..\"]') must be a string")
+          else
+            Location.raise_errorf
+              ~loc
+               "Duplicate `[@mel.tag \"..\"]' annotation"
+      | _ -> ());
+  !st
+

jscomp/core/matching_polyfill.cppo.ml

@@ -35,7 +35,7 @@ let names_from_construct_pattern
     in
     let get_block (cstr: Types.constructor_declaration) =
       { Lambda.cstr_name = get_cstr_name cstr
-      ; tag_name = Record_attributes_check.process_tag_name cstr.cd_attributes
+      ; tag_name = Lam_variant_tag.process_tag_name cstr.cd_attributes
       }
     in
     let consts, blocks =

jscomp/core/record_attributes_check.cppo.ml

@@ -26,55 +26,6 @@ open Import
 
 type label = Types.label_description
 
-let namespace_error ~loc txt =
-  match txt with
-  | "bs.as" | "as" ->
-      Location.raise_errorf ~loc
-        "`[@bs.*]' and non-namespaced attributes have been removed in favor of \
-         `[@mel.*]' attributes. Use `[@mel.as]' instead."
-  | _ -> ()
-
-
-let process_tag_name attrs =
-  let st = ref None in
-  List.iter attrs
-    ~f:(fun { Parsetree.attr_name = { txt; loc }; attr_payload; _ } ->
-      match txt with
-      | "mel.tag" ->
-          if !st = None then (
-            (match attr_payload with
-            | PStr
-                [
-                  {
-                    pstr_desc =
-                      Pstr_eval ({ pexp_desc = Pexp_constant const; _ }, _);
-                    _;
-                  };
-                ] -> (
-                namespace_error ~loc txt;
-                match
-#if OCAML_VERSION >= (5, 3, 0)
-                  const.pconst_desc
-#else
-                  const
-#endif
-                with
-                | Pconst_string (s, _, _) -> st := Some s
-                | _ -> ())
-            | _ -> ());
-            if !st = None
-            then
-              Location.raise_errorf
-                ~loc
-                 "Variant tag annotation (`[@mel.tag \"..\"]') must be a string")
-          else
-            Location.raise_errorf
-              ~loc
-               "Duplicate `[@mel.tag \"..\"]' annotation"
-      | _ -> ());
-  !st
-
-
 let find_mel_as_name =
   let find_mel_as_name (attr : Parsetree.attribute) =
     match attr.attr_name with
@@ -87,7 +38,7 @@ let find_mel_as_name =
                 _;
               };
             ] -> (
-            namespace_error ~loc txt;
+            Lam_variant_tag.namespace_error ~loc txt;
             match
 #if OCAML_VERSION >= (5, 3, 0)
             const.pconst_desc
@@ -138,7 +89,7 @@ let find_name_with_loc (attr : Parsetree.attribute) : string Asttypes.loc option
        ];
    _;
   } ->
-      namespace_error ~loc txt;
+      Lam_variant_tag.namespace_error ~loc txt;
       Some { txt = s; loc }
   | _ -> None
 

ppx/ast_attributes.ml

@@ -210,11 +210,6 @@ let internal_expansive =
     attr_loc = Location.none;
   }
 
-let has_internal_expansive attrs =
-  List.exists
-    ~f:(fun { attr_name = { txt; _ }; _ } -> txt = "internal.expansive")
-    attrs
-
 let mel_return_undefined =
   {
     attr_name = { txt = "mel.return"; loc = Location.none };
@@ -262,7 +257,7 @@ let iter_process_mel_string_or_int_as (attrs : attributes) =
                                 pexp_desc =
                                   Pexp_constant
                                     (Pconst_string
-                                      (s, _, ((None | Some "json") as dec)));
+                                       (s, _, ((None | Some "json") as dec)));
                                 pexp_loc;
                                 _;
                               },

ppx/ast_attributes.mli

@@ -48,7 +48,6 @@ val mel_get_index : attribute
 val mel_get_arity : attribute
 val mel_set : attribute
 val internal_expansive : attribute
-val has_internal_expansive : attribute list -> bool
 val mel_return_undefined : attribute
 
 val iter_process_mel_string_int_unwrap_uncurry :