Gentype: support @tag (#6437)

Fixes #6436

Author: cristianoc

CHANGELOG.md

@@ -15,6 +15,7 @@
 #### :bug: Bug Fix
 
 - Fix issue with Dynamic import of module in nested expressions https://github.com/rescript-lang/rescript-compiler/pull/6431
+- Fix issue where GenType was not supporting `@tag` on ordinary variatns https://github.com/rescript-lang/rescript-compiler/pull/6437
 
 # 11.0.0-rc.4
 

jscomp/gentype/Annotation.ml

@@ -22,6 +22,9 @@ let tagIsGenTypeAs s = s = "genType.as" || s = "gentype.as"
 let tagIsAs s = s = "bs.as" || s = "as"
 let tagIsInt s = s = "bs.int" || s = "int"
 let tagIsString s = s = "bs.string" || s = "string"
+
+let tagIsTag s = s = "tag"
+
 let tagIsUnboxed s = s = "unboxed" || s = "ocaml.unboxed"
 let tagIsGenTypeImport s = s = "genType.import" || s = "gentype.import"
 let tagIsGenTypeOpaque s = s = "genType.opaque" || s = "gentype.opaque"
@@ -146,6 +149,11 @@ let getAttributeImportRenaming attributes =
     (Some importString, Some renameString)
   | _ -> (None, genTypeAsRenaming)
 
+let getTag attributes =
+  match attributes |> getAttributePayload tagIsTag with
+  | Some (_, StringPayload s) -> Some s
+  | _ -> None
+
 let getDocPayload attributes =
   let docPayload = attributes |> getAttributePayload tagIsDoc in
   match docPayload with

jscomp/gentype/EmitType.ml

@@ -156,7 +156,7 @@ let rec renderType ~(config : Config.t) ?(indent = None) ~typeNameIsInterface
       |> String.concat ", ")
     ^ "]"
   | TypeVar s -> s
-  | Variant {inherits; noPayloads; payloads; polymorphic; unboxed} ->
+  | Variant {inherits; noPayloads; payloads; polymorphic; tag; unboxed} ->
     let inheritsRendered =
       inherits
       |> List.map (fun type_ ->
@@ -183,7 +183,8 @@ let rec renderType ~(config : Config.t) ?(indent = None) ~typeNameIsInterface
              in
              let tagField =
                case |> labelJSToString
-               |> field ~name:(Runtime.jsVariantTag ~polymorphic:false)
+               |> field
+                    ~name:(Runtime.jsVariantTag ~polymorphic:false ~tag)
              in
              match (unboxed, type_) with
              | true, type_ ->
@@ -198,7 +199,7 @@ let rec renderType ~(config : Config.t) ?(indent = None) ~typeNameIsInterface
                (* poly variant *)
                [
                  case |> labelJSToString
-                 |> field ~name:(Runtime.jsVariantTag ~polymorphic);
+                 |> field ~name:(Runtime.jsVariantTag ~polymorphic ~tag);
                  type_ |> render
                  |> field ~name:(Runtime.jsVariantValue ~polymorphic);
                ]

jscomp/gentype/GenTypeCommon.ml

@@ -99,6 +99,7 @@ and variant = {
   noPayloads: case list;
   payloads: payload list;
   polymorphic: bool; (* If true, this is a polymorphic variant *)
+  tag: string option; (* The name of the tag field at runtime *)
   unboxed: bool;
 }
 
@@ -168,8 +169,8 @@ let rec depToResolvedName (dep : dep) =
   | Internal resolvedName -> resolvedName
   | Dot (p, s) -> ResolvedName.dot s (p |> depToResolvedName)
 
-let createVariant ~inherits ~noPayloads ~payloads ~polymorphic ~unboxed =
-  Variant {inherits; noPayloads; payloads; polymorphic; unboxed}
+let createVariant ~inherits ~noPayloads ~payloads ~polymorphic ~tag ~unboxed =
+  Variant {inherits; noPayloads; payloads; polymorphic; tag; unboxed}
 
 let ident ?(builtin = true) ?(typeArgs = []) name =
   Ident {builtin; name; typeArgs}

jscomp/gentype/Runtime.ml

@@ -24,10 +24,13 @@ let rec emitModuleAccessPath ~config moduleAccessPath =
   | Dot (p, moduleItem) ->
     p |> emitModuleAccessPath ~config |> EmitText.fieldAccess ~label:moduleItem
 
-let jsVariantTag ~polymorphic =
+let jsVariantTag ~polymorphic ~tag =
   match polymorphic with
   | true -> "NAME"
-  | false -> "TAG"
+  | false -> (
+    match tag with
+    | Some tag -> tag
+    | None -> "TAG")
 
 let jsVariantPayloadTag ~n = "_" ^ string_of_int n
 

jscomp/gentype/Runtime.mli

@@ -14,6 +14,6 @@ val newModuleItem : name:string -> moduleItem
 val newRecordValue : unboxed:bool -> recordGen -> recordValue
 val recordGen : unit -> recordGen
 val recordValueToString : recordValue -> string
-val jsVariantTag : polymorphic:bool -> string
+val jsVariantTag : polymorphic:bool -> tag:string option -> string
 val jsVariantPayloadTag : n:int -> string
 val jsVariantValue : polymorphic:bool -> string

jscomp/gentype/TranslateCoreType.ml

@@ -212,7 +212,7 @@ and translateCoreType_ ~config ~typeVarsGen
       let inherits = inheritsTranslations |> List.map (fun {type_} -> type_) in
       let type_ =
         createVariant ~noPayloads ~payloads ~inherits ~polymorphic:true
-          ~unboxed:false
+          ~tag:None ~unboxed:false
       in
       let dependencies =
         (inheritsTranslations

jscomp/gentype/TranslateTypeDeclarations.ml

@@ -66,6 +66,7 @@ let traslateDeclarationKind ~config ~loc ~outputFileRelative ~resolver
   let unboxedAnnotation =
     typeAttributes |> Annotation.hasAttribute Annotation.tagIsUnboxed
   in
+  let tagAnnotation = typeAttributes |> Annotation.getTag in
   let returnTypeDeclaration (typeDeclaration : CodeItem.typeDeclaration) =
     match opaque = Some true with
     | true -> [{typeDeclaration with importTypes = []}]
@@ -203,7 +204,7 @@ let traslateDeclarationKind ~config ~loc ~outputFileRelative ~resolver
           else variant.payloads
         in
         createVariant ~inherits:variant.inherits ~noPayloads ~payloads
-          ~polymorphic:true ~unboxed:false
+          ~polymorphic:true ~tag:None ~unboxed:false
       | _ -> translation.type_
     in
     {translation with type_} |> handleGeneralDeclaration
@@ -295,7 +296,7 @@ let traslateDeclarationKind ~config ~loc ~outputFileRelative ~resolver
     in
     let variantTyp =
       createVariant ~inherits:[] ~noPayloads ~payloads ~polymorphic:false
-        ~unboxed:unboxedAnnotation
+        ~tag:tagAnnotation ~unboxed:unboxedAnnotation
     in
     let resolvedTypeName = typeName |> TypeEnv.addModulePath ~typeEnv in
     let exportFromTypeDeclaration =

jscomp/gentype/TranslateTypeExprFromTypes.ml

@@ -147,7 +147,7 @@ let translateConstr ~config ~paramsTranslation ~(path : Path.t) ~typeEnv =
             case 0 "Ok" paramTranslation1.type_;
             case 1 "Error" paramTranslation2.type_;
           ]
-        ~polymorphic:false ~unboxed:false
+        ~polymorphic:false ~tag:None ~unboxed:false
     in
     {
       dependencies =
@@ -386,7 +386,7 @@ and translateTypeExprFromTypes_ ~config ~typeVarsGen ~typeEnv
       in
       let type_ =
         createVariant ~inherits:[] ~noPayloads ~payloads:[] ~polymorphic:true
-          ~unboxed:false
+          ~tag:None ~unboxed:false
       in
       {dependencies = []; type_}
     | {noPayloads = []; payloads = [(_label, t)]; unknowns = []} ->
@@ -415,7 +415,7 @@ and translateTypeExprFromTypes_ ~config ~typeVarsGen ~typeEnv
       in
       let type_ =
         createVariant ~inherits:[] ~noPayloads ~payloads ~polymorphic:true
-          ~unboxed:false
+          ~tag:None ~unboxed:false
       in
       let dependencies =
         payloadTranslations