Skip to content

Commit

Permalink
Add support for @tag in gentype.
Browse files Browse the repository at this point in the history
  • Loading branch information
cristianoc committed Apr 13, 2023
1 parent 1165df5 commit 781ee14
Show file tree
Hide file tree
Showing 10 changed files with 32 additions and 14 deletions.
3 changes: 3 additions & 0 deletions CHANGELOG.md
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down
7 changes: 7 additions & 0 deletions jscomp/gentype/Annotation.ml
Original file line number Diff line number Diff line change
Expand Up @@ -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"
Expand Down Expand Up @@ -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) -> (
Expand Down
5 changes: 3 additions & 2 deletions jscomp/gentype/EmitType.ml
Original file line number Diff line number Diff line change
Expand Up @@ -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_ ->
Expand All @@ -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
Expand Down
6 changes: 4 additions & 2 deletions jscomp/gentype/GenTypeCommon.ml
Original file line number Diff line number Diff line change
Expand Up @@ -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_}
Expand Down Expand Up @@ -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}
Expand Down
5 changes: 4 additions & 1 deletion jscomp/gentype/Runtime.ml
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down
2 changes: 1 addition & 1 deletion jscomp/gentype/Runtime.mli
Original file line number Diff line number Diff line change
Expand Up @@ -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
2 changes: 1 addition & 1 deletion jscomp/gentype/TranslateCoreType.ml
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down
6 changes: 4 additions & 2 deletions jscomp/gentype/TranslateTypeDeclarations.ml
Original file line number Diff line number Diff line change
Expand Up @@ -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 = []}]
Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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 =
Expand Down
6 changes: 3 additions & 3 deletions jscomp/gentype/TranslateTypeExprFromTypes.ml
Original file line number Diff line number Diff line change
Expand Up @@ -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 =
Expand Down Expand Up @@ -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 = []} ->
Expand Down Expand Up @@ -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
Expand Down
Original file line number Diff line number Diff line change
Expand Up @@ -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>;
Expand Down

0 comments on commit 781ee14

Please sign in to comment.