Add support for @tag in gentype.

Author: cristianoc

CHANGELOG.md

@@ -12,6 +12,9 @@
 
 # 11.0.0-alpha.3 (Unreleased)
 
+#### :bug: Bug Fix
+- GenType: add support for custom `@tag` in variant type declaration. https://github.com/rescript-lang/rescript-compiler/pull/6137/files
+
 # 11.0.0-alpha.2
 
 #### :rocket: Main New Feature

jscomp/gentype/Annotation.ml

@@ -22,6 +22,8 @@ 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"
@@ -125,6 +127,11 @@ let getAsString attributes =
   | Some (_, StringPayload s) -> Some s
   | _ -> None
 
+let getTag attributes =
+  match attributes |> getAttributePayload tagIsTag with
+  | Some (_, StringPayload s) -> Some s
+  | _ -> None
+
 let getAsInt attributes =
   match attributes |> getAttributePayload tagIsAs with
   | Some (_, IntPayload s) -> (

jscomp/gentype/EmitType.ml

@@ -170,7 +170,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; unboxed; customTag} ->
     let inheritsRendered =
       inherits
       |> List.map (fun type_ ->
@@ -195,7 +195,8 @@ let rec renderType ~(config : Config.t) ?(indent = None) ~typeNameIsInterface
                t |> renderType ~config ~indent ~typeNameIsInterface ~inFunType
              in
              let tagField =
-               case |> labelJSToString |> field ~name:Runtime.jsVariantTag
+               case |> labelJSToString
+               |> field ~name:(Runtime.jsVariantTag ~customTag)
              in
              match (unboxed, type_) with
              | true, type_ -> type_ |> render

jscomp/gentype/GenTypeCommon.ml

@@ -97,6 +97,7 @@ and variant = {
   payloads: payload list;
   polymorphic: bool; (* If true, this is a polymorphic variant *)
   unboxed: bool;
+  customTag: string option;
 }
 
 and payload = {case: case; inlineRecord: bool; numArgs: int; t: type_}
@@ -166,8 +167,9 @@ let rec depToResolvedName (dep : dep) =
   | Dot (p, s) -> ResolvedName.dot s (p |> depToResolvedName)
 
 let createVariant ~bsStringOrInt ~inherits ~noPayloads ~payloads ~polymorphic
-    ~unboxed =
-  Variant {bsStringOrInt; inherits; noPayloads; payloads; polymorphic; unboxed}
+    ~unboxed ~customTag =
+  Variant
+    {bsStringOrInt; inherits; noPayloads; payloads; polymorphic; unboxed; customTag}
 
 let ident ?(builtin = true) ?(typeArgs = []) name =
   Ident {builtin; name; typeArgs}

jscomp/gentype/Runtime.ml

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

jscomp/gentype/Runtime.mli

@@ -15,7 +15,7 @@ val newModuleItem : name:string -> moduleItem
 val newRecordValue : unboxed:bool -> recordGen -> recordValue
 val recordGen : unit -> recordGen
 val recordValueToString : recordValue -> string
-val jsVariantTag : string
+val jsVariantTag : customTag:string option -> string
 val jsPolymorphicVariantTag : string
 val jsVariantPayloadTag : n:int -> string
 val jsVariantValue : polymorphic:bool -> string

jscomp/gentype/TranslateCoreType.ml

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

jscomp/gentype/TranslateTypeDeclarations.ml

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

jscomp/gentype/TranslateTypeExprFromTypes.ml

@@ -146,7 +146,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 ~unboxed:false ~customTag:None
     in
     {
       dependencies =
@@ -408,7 +408,7 @@ and translateTypeExprFromTypes_ ~config ~typeVarsGen ~typeEnv
       in
       let type_ =
         createVariant ~bsStringOrInt:false ~inherits:[] ~noPayloads ~payloads:[]
-          ~polymorphic:true ~unboxed:false
+          ~polymorphic:true ~unboxed:false ~customTag:None
       in
       {dependencies = []; type_}
     | {noPayloads = []; payloads = [(_label, t)]; unknowns = []} ->
@@ -439,7 +439,7 @@ and translateTypeExprFromTypes_ ~config ~typeVarsGen ~typeEnv
       in
       let type_ =
         createVariant ~bsStringOrInt:false ~inherits:[] ~noPayloads ~payloads
-          ~polymorphic:true ~unboxed:false
+          ~polymorphic:true ~unboxed:false ~customTag:None
       in
       let dependencies =
         payloadTranslations

jscomp/gentype_tests/typescript-react-example/src/TestPromise.gen.tsx

@@ -17,8 +17,8 @@ export type toPayload = { readonly result: string };
 
 // tslint:disable-next-line:interface-over-type-literal
 export type settledResult<a> = 
-    { TAG: "fulfilled"; readonly value: a }
-  | { TAG: "rejected"; readonly reason: unknown };
+    { status: "fulfilled"; readonly value: a }
+  | { status: "rejected"; readonly reason: unknown };
 
 // tslint:disable-next-line:interface-over-type-literal
 export type settled = settledResult<string>;