diff --git a/CHANGELOG.md b/CHANGELOG.md index 47a09757e98..8c11afde87a 100644 --- a/CHANGELOG.md +++ b/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 diff --git a/jscomp/gentype/Annotation.ml b/jscomp/gentype/Annotation.ml index ad3eca5b524..b15f1caf90d 100644 --- a/jscomp/gentype/Annotation.ml +++ b/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) -> ( diff --git a/jscomp/gentype/EmitType.ml b/jscomp/gentype/EmitType.ml index 04f1fb10d83..5f9696336de 100644 --- a/jscomp/gentype/EmitType.ml +++ b/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 diff --git a/jscomp/gentype/GenTypeCommon.ml b/jscomp/gentype/GenTypeCommon.ml index 1de02385637..14ee1bc6196 100644 --- a/jscomp/gentype/GenTypeCommon.ml +++ b/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} diff --git a/jscomp/gentype/Runtime.ml b/jscomp/gentype/Runtime.ml index 3b0d34f691f..74243493cde 100644 --- a/jscomp/gentype/Runtime.ml +++ b/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 diff --git a/jscomp/gentype/Runtime.mli b/jscomp/gentype/Runtime.mli index c5f368348bb..2fffb992465 100644 --- a/jscomp/gentype/Runtime.mli +++ b/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 diff --git a/jscomp/gentype/TranslateCoreType.ml b/jscomp/gentype/TranslateCoreType.ml index 31737445478..3d7aa8cb7c9 100644 --- a/jscomp/gentype/TranslateCoreType.ml +++ b/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 diff --git a/jscomp/gentype/TranslateTypeDeclarations.ml b/jscomp/gentype/TranslateTypeDeclarations.ml index b011e9d1cf6..31e87272270 100644 --- a/jscomp/gentype/TranslateTypeDeclarations.ml +++ b/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 = diff --git a/jscomp/gentype/TranslateTypeExprFromTypes.ml b/jscomp/gentype/TranslateTypeExprFromTypes.ml index 8e11707fc66..bdc26d78072 100644 --- a/jscomp/gentype/TranslateTypeExprFromTypes.ml +++ b/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 diff --git a/jscomp/gentype_tests/typescript-react-example/src/TestPromise.gen.tsx b/jscomp/gentype_tests/typescript-react-example/src/TestPromise.gen.tsx index af9dd20fc25..796e82a5c39 100644 --- a/jscomp/gentype_tests/typescript-react-example/src/TestPromise.gen.tsx +++ b/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 = - { 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;