From be37563d0d54cd1c965aa50082d718aa18bbd448 Mon Sep 17 00:00:00 2001 From: Alfonso Garcia-Caro Date: Sun, 20 Nov 2022 15:30:14 +0900 Subject: [PATCH] Add tag argument to Erase unions --- src/Fable.Core/Fable.Core.Types.fs | 1 + src/Fable.Transforms/FSharp2Fable.Util.fs | 23 ++++++++---- src/Fable.Transforms/FSharp2Fable.fs | 45 ++++++++++++++--------- 3 files changed, 43 insertions(+), 26 deletions(-) diff --git a/src/Fable.Core/Fable.Core.Types.fs b/src/Fable.Core/Fable.Core.Types.fs index e2a478a83c..530dc9a9b1 100644 --- a/src/Fable.Core/Fable.Core.Types.fs +++ b/src/Fable.Core/Fable.Core.Types.fs @@ -29,6 +29,7 @@ type AttachMembersAttribute() = type EraseAttribute() = inherit Attribute() new (caseRules: CaseRules) = EraseAttribute() + new (tag: bool) = EraseAttribute() /// Used for "tagged" union types, which is commonly used in TypeScript. type TypeScriptTaggedUnionAttribute(tagName: string, caseRules: CaseRules) = diff --git a/src/Fable.Transforms/FSharp2Fable.Util.fs b/src/Fable.Transforms/FSharp2Fable.Util.fs index e617d91c37..a9aa8753a1 100644 --- a/src/Fable.Transforms/FSharp2Fable.Util.fs +++ b/src/Fable.Transforms/FSharp2Fable.Util.fs @@ -733,7 +733,7 @@ module Helpers = type UnionPattern = | OptionUnion of FSharpType * isStruct: bool | ListUnion of FSharpType - | ErasedUnion of FSharpEntity * IList * CaseRules + | ErasedUnion of FSharpEntity * IList * CaseRules * tag: bool | ErasedUnionCase | TypeScriptTaggedUnion of FSharpEntity * IList * tagName:string * CaseRules | StringEnum of FSharpEntity * CaseRules @@ -741,11 +741,6 @@ module Helpers = let getUnionPattern (typ: FSharpType) (unionCase: FSharpUnionCase) : UnionPattern = let typ = nonAbbreviatedType typ - let getCaseRule (att: FSharpAttribute) = - match Seq.tryHead att.ConstructorArguments with - | Some(_, (:? int as rule)) -> enum(rule) - | _ -> CaseRules.LowerFirst - unionCase.Attributes |> Seq.tryPick (fun att -> match att.AttributeType.TryFullName with | Some Atts.erase -> Some ErasedUnionCase @@ -761,8 +756,20 @@ module Helpers = | _ -> tdef.Attributes |> Seq.tryPick (fun att -> match att.AttributeType.TryFullName with - | Some Atts.erase -> Some (ErasedUnion(tdef, typ.GenericArguments, getCaseRule att)) - | Some Atts.stringEnum -> Some (StringEnum(tdef, getCaseRule att)) + | Some Atts.erase -> + let caseRule, tag = + match Seq.tryHead att.ConstructorArguments with + | Some(_, (:? int as rule)) -> enum(rule), false + | Some(_, (:? bool as tag)) -> + if tag then CaseRules.None, true else CaseRules.LowerFirst, false + | _ -> CaseRules.LowerFirst, false + Some (ErasedUnion(tdef, typ.GenericArguments, caseRule, tag)) + | Some Atts.stringEnum -> + let caseRule = + match Seq.tryHead att.ConstructorArguments with + | Some(_, (:? int as rule)) -> enum(rule) + | _ -> CaseRules.LowerFirst + Some (StringEnum(tdef, caseRule)) | Some Atts.tsTaggedUnion -> match Seq.tryItem 0 att.ConstructorArguments, Seq.tryItem 1 att.ConstructorArguments with | Some (_, (:? string as name)), None -> diff --git a/src/Fable.Transforms/FSharp2Fable.fs b/src/Fable.Transforms/FSharp2Fable.fs index 5ae298c376..4d70bfa08b 100644 --- a/src/Fable.Transforms/FSharp2Fable.fs +++ b/src/Fable.Transforms/FSharp2Fable.fs @@ -46,14 +46,19 @@ let private transformNewUnion com ctx r fsType (unionCase: FSharpUnionCase) (arg match getUnionPattern fsType unionCase with | ErasedUnionCase -> makeTuple r false argExprs - | ErasedUnion(tdef, _genArgs, rule) -> - match argExprs with - | [] -> transformStringEnum rule unionCase - | [argExpr] -> argExpr - | _ when tdef.UnionCases.Count > 1 -> - "Erased unions with multiple cases must have one single field: " + (getFsTypeFullName fsType) - |> addErrorAndReturnNull com ctx.InlinePath r - | argExprs -> makeTuple r false argExprs + // TODO: Wrap erased unions in type cast so type info is not lost + | ErasedUnion(tdef, _genArgs, rule, tag) -> + if tag then + (transformStringEnum rule unionCase)::argExprs |> makeTuple r false + else + match argExprs with + | [] -> transformStringEnum rule unionCase + | [argExpr] -> argExpr + | _ when tdef.UnionCases.Count > 1 -> + $"Erased unions with multiple fields must have one single case: {getFsTypeFullName fsType}. " + + "To allow multiple cases pass tag argument, e.g.: []" + |> addErrorAndReturnNull com ctx.InlinePath r + | argExprs -> makeTuple r false argExprs | TypeScriptTaggedUnion _ -> match argExprs with | [argExpr] -> argExpr @@ -326,10 +331,14 @@ let private transformUnionCaseTest (com: IFableCompiler) (ctx: Context) r | ErasedUnionCase -> return "Cannot test erased union cases" |> addErrorAndReturnNull com ctx.InlinePath r - | ErasedUnion(tdef, genArgs, rule) -> - match unionCase.Fields.Count with - | 0 -> return makeEqOp r unionExpr (transformStringEnum rule unionCase) BinaryEqual - | 1 -> + | ErasedUnion(tdef, genArgs, rule, tag) -> + match tag, unionCase.Fields.Count with + | true, _ -> + let tagName = transformStringEnum rule unionCase + let tagExpr = Fable.Get(unionExpr, Fable.TupleIndex 0, Fable.String, None) + return makeEqOp r tagExpr tagName BinaryEqual + | false, 0 -> return makeEqOp r unionExpr (transformStringEnum rule unionCase) BinaryEqual + | false, 1 -> let fi = unionCase.Fields[0] let typ = if fi.FieldType.IsGenericParameter then @@ -341,7 +350,7 @@ let private transformUnionCaseTest (com: IFableCompiler) (ctx: Context) r else fi.FieldType let kind = makeType ctx.GenericArgs typ |> Fable.TypeTest return Fable.Test(unionExpr, kind, r) - | _ -> + | false, _ -> return "Erased unions with multiple cases cannot have more than one field: " + (getFsTypeFullName fsType) |> addErrorAndReturnNull com ctx.InlinePath r | TypeScriptTaggedUnion (_, _, tagName, rule) -> @@ -863,16 +872,16 @@ let private transformExpr (com: IFableCompiler) (ctx: Context) fsExpr = return Fable.Get(tupleExpr, Fable.TupleIndex tupleElemIndex, typ, makeRangeFrom fsExpr) | FSharpExprPatterns.UnionCaseGet (IgnoreAddressOf unionExpr, fsType, unionCase, field) -> + let getIndex() = unionCase.Fields |> Seq.findIndex (fun x -> x.Name = field.Name) let r = makeRangeFrom fsExpr let! unionExpr = transformExpr com ctx unionExpr match getUnionPattern fsType unionCase with | ErasedUnionCase -> - let index = unionCase.Fields |> Seq.findIndex (fun x -> x.Name = field.Name) - return Fable.Get(unionExpr, Fable.TupleIndex(index), makeType ctx.GenericArgs fsType, r) - | ErasedUnion _ -> - if unionCase.Fields.Count = 1 then return unionExpr + return Fable.Get(unionExpr, Fable.TupleIndex(getIndex()), makeType ctx.GenericArgs fsType, r) + | ErasedUnion(_tdef, _genArgs, _rule, tag) -> + if not tag && unionCase.Fields.Count = 1 then return unionExpr else - let index = unionCase.Fields |> Seq.findIndex (fun x -> x.Name = field.Name) + let index = if tag then getIndex() + 1 else getIndex() return Fable.Get(unionExpr, Fable.TupleIndex index, makeType ctx.GenericArgs fsType, r) | TypeScriptTaggedUnion _ -> if unionCase.Fields.Count = 1 then return unionExpr