reuse logic from ast_untagged_variants

Author: zth

jscomp/core/matching_polyfill.ml

@@ -22,6 +22,8 @@
  * along with this program; if not, write to the Free Software
  * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)
 
+let () = Ast_untagged_variants.extract_concrete_typedecl := Ctype.extract_concrete_typedecl
+
 let names_from_construct_pattern (pat : Typedtree.pattern) =
   let rec resolve_path n (path : Path.t) =
     match Env.find_type path pat.pat_env with

jscomp/ml/ast_uncurried.ml

@@ -69,12 +69,7 @@ let coreTypeIsUncurriedFun (typ : Parsetree.core_type) =
     true
   | _ -> false
 
-let typeIsUncurriedFun (typ : Types.type_expr) =
-  match typ.desc with
-  | Tconstr (Pident {name = "function$"}, [{desc = Tarrow _}; _], _) ->
-    true
-  | _ -> false
-
+let typeIsUncurriedFun = Ast_uncurried_utils.typeIsUncurriedFun
 
 let typeExtractUncurriedFun (typ : Parsetree.core_type) =
   match typ.ptyp_desc with

jscomp/ml/ast_uncurried_utils.ml

@@ -0,0 +1,5 @@
+let typeIsUncurriedFun (typ : Types.type_expr) =
+  match typ.desc with
+  | Tconstr (Pident {name = "function$"}, [{desc = Tarrow _}; _], _) ->
+    true
+  | _ -> false

jscomp/ml/ast_untagged_variants.ml

@@ -77,6 +77,10 @@ let process_untagged (attrs : Parsetree.attributes) =
       | _ -> ());
   !st
 
+let extract_concrete_typedecl: (Env.t ->
+  Types.type_expr ->
+  Path.t * Path.t * Types.type_declaration) ref = ref (Obj.magic ())
+
 let process_tag_type (attrs : Parsetree.attributes) =
   let st : tag_type option ref = ref None in
   Ext_list.iter attrs (fun ({txt; loc}, payload) ->
@@ -137,7 +141,7 @@ let get_block_type ~env (cstr : Types.constructor_declaration) :
     when Path.same path Predef.path_array ->
     Some ArrayType
   | true, Cstr_tuple [({desc = Tconstr _} as t)]
-    when Ast_uncurried.typeIsUncurriedFun t ->
+    when Ast_uncurried_utils.typeIsUncurriedFun t ->
     Some FunctionType
   | true, Cstr_tuple [{desc = Tarrow _}] -> Some FunctionType
   | true, Cstr_tuple [{desc = Tconstr (path, _, _)}]
@@ -148,7 +152,7 @@ let get_block_type ~env (cstr : Types.constructor_declaration) :
     Some ObjectType
   | true, Cstr_tuple [ty] -> (
     let default = Some UnknownType in
-    match Ctype.extract_concrete_typedecl env ty with
+    match !extract_concrete_typedecl env ty with
     | _, _, {type_kind = Type_record (_, Record_unboxed _)} -> default
     | _, _, {type_kind = Type_record (_, _)} -> Some ObjectType
     | _ -> default

jscomp/ml/variant_coercion.ml

@@ -63,57 +63,32 @@ let is_variant_typedecl
   | {type_kind = Type_variant constructors} -> Some constructors
   | _ -> None
 
-let find_attribute_payload_as_string name attrs =
-  match find_attribute_payload name attrs with
-  | None -> None
-  | Some payload -> Ast_payload.is_single_string payload
-
 let variant_representation_matches (c1_attrs : Parsetree.attributes)
     (c2_attrs : Parsetree.attributes) =
   match
-    (find_as_attribute_payload c1_attrs, find_as_attribute_payload c2_attrs)
+    (Ast_untagged_variants.process_tag_type c1_attrs, Ast_untagged_variants.process_tag_type c2_attrs)
   with
   | None, None -> true
-  | Some p1, Some p2 -> (
-    let string_matches = match
-      (Ast_payload.is_single_string p1, Ast_payload.is_single_string p2)
-    with
-    | Some (a, _), Some (b, _) when a = b -> true
-    | _ -> false in
-    if string_matches then true else
-    let float_matches = match
-      (Ast_payload.is_single_float p1, Ast_payload.is_single_float p2)
-    with
-    | Some a, Some b when a = b -> true
-    | _ -> false in
-    if float_matches then true else
-    let int_matches = match
-      (Ast_payload.is_single_int p1, Ast_payload.is_single_int p2)
-    with
-    | Some a, Some b when a = b -> true
-    | _ -> false in
-    if int_matches then true else
-    false)
+  | Some s1, Some s2 when s1 = s2 -> true
   | _ -> false
 
 let variant_configuration_can_be_coerced (a1 : Parsetree.attributes)
     (a2 : Parsetree.attributes) =
   let unboxed =
     match
-      (find_attribute_payload "unboxed" a1, find_attribute_payload "unboxed" a2)
+      (Ast_untagged_variants.process_untagged a1, Ast_untagged_variants.process_untagged a2)
     with
-    | Some (PStr []), Some (PStr []) -> true
-    | None, None -> true
+    | true, true | false, false -> true
     | _ -> false
   in
   if not unboxed then false
   else
     let tag =
       match
-        ( find_attribute_payload_as_string "tag" a1,
-          find_attribute_payload_as_string "tag" a2 )
+        (Ast_untagged_variants.process_tag_name a1,
+          Ast_untagged_variants.process_tag_name a2 )
       with
-      | Some (tag1, _), Some (tag2, _) when tag1 = tag2 -> true
+      | Some (tag1), Some (tag2) when tag1 = tag2 -> true
       | None, None -> true
       | _ -> false
     in