Resolve untagged declaration shapes and literals once

changes/untagged-declarations.polish.md

@@ -0,0 +1 @@
+- Allow `@notUndefined` on type abbreviations, and `@typeOf` restating a builtin type's kind, as in `@typeOf("number") type count = int`; a constructor `A` and `@as("A") A` now agree across interfaces and coercions.

compiler/core/js_dump.ml

@@ -897,9 +897,7 @@ and expression_desc cxt ~(level : int) f x : cxt =
       | Tagged {tag; tag_name} ->
         ( Js_op.Lit (Option.value tag_name ~default:L.tag),
           (* TAG:xx for inline records *)
-          match tag.literal with
-          | None -> E.str p.name
-          | Some t -> E.literal_tag t )
+          E.literal_tag tag.literal )
         :: tails
     in
     expression_desc cxt ~level f (Object (E.object_entries objs))
@@ -936,9 +934,7 @@ and expression_desc cxt ~(level : int) f x : cxt =
       else
         ( Js_op.Lit tag_name,
           (* TAG:xx *)
-          match literal with
-          | None -> E.str p.name
-          | Some t -> E.literal_tag t )
+          E.literal_tag literal )
         :: tails
     in
     expression_desc cxt ~level f (J.Object (E.object_entries objs))

compiler/core/lam_compile.ml

@@ -177,14 +177,13 @@ let default_action ~saturated failaction =
   | None -> Complete
   | Some x -> if saturated then Complete else Default x
 
-let tag_of_switch_key = function
+let tag_of_switch_key : _ -> Variant_runtime.tag_type option = function
   | Lambda.Switch_int _ -> None
-  | Switch_constructor (Constant tag) ->
-    Some (Variant_runtime.to_matchable_tag tag)
-  | Switch_constructor (Block (Untagged {tag = {name}; block_type})) ->
-    Some {name; tag_type = Some (Payload_shape block_type)}
-  | Switch_constructor (Block (Tagged {tag})) ->
-    Some (Variant_runtime.to_matchable_tag tag)
+  | Switch_constructor (Constant {literal} | Block (Tagged {tag = {literal}}))
+    ->
+    Some (Literal literal)
+  | Switch_constructor (Block (Untagged {block_type})) ->
+    Some (Payload_shape block_type)
 
 let dispatch_info = function
   | Lambda.Switch_direct -> (Js_dump_lit.tag, [], [])
@@ -696,10 +695,8 @@ let compile output_prefix =
     List.fold_right
       (fun (key, lam) acc ->
         match (tag_of_switch_key key, acc) with
-        | Some {Variant_runtime.tag_type = Some t}, Some string_table ->
-          Some ((t, lam) :: string_table)
-        | Some {name; tag_type = None}, Some string_table ->
-          Some ((Literal (String name), lam) :: string_table)
+        | Some tag_type, Some string_table ->
+          Some ((tag_type, lam) :: string_table)
         | _, _ -> None)
       table (Some [])
   and compile_cases ?(untagged = false) ?(null_guard = false) ~cxt
@@ -781,19 +778,17 @@ let compile output_prefix =
               let named =
                 Ext_list.filter_map sw_consts (fun (key, _) ->
                     match tag_of_switch_key key with
-                    | Some {tag_type = Some (Literal literal)} -> Some literal
-                    | Some {name; tag_type = None} -> Some (String name)
-                    | Some {tag_type = Some (Payload_shape _)} | None -> None)
+                    | Some (Literal literal) -> Some literal
+                    | Some (Payload_shape _) | None -> None)
               in
               (* A literal reaches the same default through the payload
                  dispatch when no payload arm accepts its kind and no class
                  check runs on it *)
               let payload_arms =
                 Ext_list.filter_map sw_blocks (fun (key, _) ->
                     match tag_of_switch_key key with
-                    | Some {tag_type = Some (Payload_shape block_type)} ->
-                      Some block_type
-                    | Some {tag_type = Some (Literal _) | None} | None ->
+                    | Some (Payload_shape block_type) -> Some block_type
+                    | Some (Literal _) | None ->
                       (* The blocks of an untagged variant are all untagged *)
                       None)
               in

compiler/core/lam_compile_const.ml

@@ -45,11 +45,8 @@ and translate (x : Lambda.structured_constant) : J.expression =
   | Const_js_null -> E.nil
   | Const_js_undefined {is_unit = true} -> E.unit
   | Const_js_undefined {is_unit = false} -> E.undefined
-  | Const_constructor {name; literal = None} ->
-    (* The runtime representation of a constant constructor is its name,
-       except for the list constructor [] which is the number 0 *)
-    if name = "[]" then E.int 0l ~comment:"[]" else E.str name
-  | Const_constructor {literal = Some t} -> E.literal_tag t
+  | Const_constructor {name = "[]"} -> E.int 0l ~comment:"[]"
+  | Const_constructor {literal} -> E.literal_tag literal
   | Const_int i -> E.int i
   | Const_assertfalse -> E.int 0l ~comment:"assert_false"
   | Const_char i -> Js_of_lam_string.const_char i

compiler/gentype/translate_type_declarations.ml

@@ -40,17 +40,15 @@ let create_polyvariant_case (label, attributes) =
       | _ -> if is_number label then IntLabel label else StringLabel label);
   }
 
-let create_variant_case label = function
-  | Some (Variant_runtime.String label) ->
+let create_variant_case = function
+  | Variant_runtime.String label ->
     {label_js = StringLabel (Emit_text.escape_string_contents label)}
-  | Some (Variant_runtime.Int label) ->
-    {label_js = IntLabel (string_of_int label)}
-  | Some (Variant_runtime.Float label) -> {label_js = FloatLabel label}
-  | Some (Variant_runtime.BigInt label) -> {label_js = IntLabel label}
-  | Some (Variant_runtime.Bool label) -> {label_js = BoolLabel label}
-  | Some Variant_runtime.Null -> {label_js = NullLabel}
-  | Some Variant_runtime.Undefined -> {label_js = UndefinedLabel}
-  | None -> {label_js = StringLabel label}
+  | Variant_runtime.Int label -> {label_js = IntLabel (string_of_int label)}
+  | Variant_runtime.Float label -> {label_js = FloatLabel label}
+  | Variant_runtime.BigInt label -> {label_js = IntLabel label}
+  | Variant_runtime.Bool label -> {label_js = BoolLabel label}
+  | Variant_runtime.Null -> {label_js = NullLabel}
+  | Variant_runtime.Undefined -> {label_js = UndefinedLabel}
 
 (* The JS name of a declared record field: its runtime name (set by @as),
    escaped as string contents, or else its identifier with the \"..." of an
@@ -255,7 +253,6 @@ let traslate_declaration_kind ~config ~loc ~output_file_relative ~resolver
       constructor_declarations
       |> List.mapi (fun position constructor_declaration ->
           let constructor_args = constructor_declaration.Types.cd_args in
-          let name = constructor_declaration.cd_id |> Ident.name in
           let tag = Variant_runtime.constructor_tag layout position in
           let args_translation =
             match constructor_args with
@@ -282,25 +279,25 @@ let traslate_declaration_kind ~config ~loc ~output_file_relative ~resolver
             |> Translation.translate_dependencies ~config ~output_file_relative
                  ~resolver
           in
-          (name, tag, arg_types, import_types))
+          (tag, arg_types, import_types))
     in
     let variants_no_payload, variants_with_payload =
-      variants |> List.partition (fun (_, _, arg_types, _) -> arg_types = [])
+      variants |> List.partition (fun (_, arg_types, _) -> arg_types = [])
     in
     let no_payloads =
       variants_no_payload
-      |> List.map (fun (name, tag, _argTypes, _importTypes) ->
-          create_variant_case name tag)
+      |> List.map (fun (tag, _argTypes, _importTypes) ->
+          create_variant_case tag)
     in
     let payloads =
       variants_with_payload
-      |> List.map (fun (name, tag, arg_types, _importTypes) ->
+      |> List.map (fun (tag, arg_types, _importTypes) ->
           let type_ =
             match arg_types with
             | [type_] -> type_
             | _ -> Tuple arg_types
           in
-          {case = create_variant_case name tag; t = type_})
+          {case = create_variant_case tag; t = type_})
     in
     let variant_typ =
       let unboxed =
@@ -331,7 +328,7 @@ let traslate_declaration_kind ~config ~loc ~output_file_relative ~resolver
     in
     let import_types =
       variants
-      |> List.map (fun (_, _, _, import_types) -> import_types)
+      |> List.map (fun (_, _, import_types) -> import_types)
       |> List.concat
     in
     {Code_item.export_from_type_declaration; import_types}