Skip to content

Commit

Permalink
Add tag argument to Erase unions
Browse files Browse the repository at this point in the history
  • Loading branch information
@alfonsogarciacaro
alfonsogarciacaro committed Nov 20, 2022
1 parent 07d0311 commit be37563
Show file tree
Hide file tree
Showing 3 changed files with 43 additions and 26 deletions.
1 change: 1 addition & 0 deletions src/Fable.Core/Fable.Core.Types.fs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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) =
Expand Down
23 changes: 15 additions & 8 deletions src/Fable.Transforms/FSharp2Fable.Util.fs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -733,19 +733,14 @@ module Helpers =
type UnionPattern =
| OptionUnion of FSharpType * isStruct: bool
| ListUnion of FSharpType
| ErasedUnion of FSharpEntity * IList<FSharpType> * CaseRules
| ErasedUnion of FSharpEntity * IList<FSharpType> * CaseRules * tag: bool
| ErasedUnionCase
| TypeScriptTaggedUnion of FSharpEntity * IList<FSharpType> * tagName:string * CaseRules
| StringEnum of FSharpEntity * CaseRules
| DiscriminatedUnion of FSharpEntity * IList<FSharpType>

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<CaseRules>(rule)
| _ -> CaseRules.LowerFirst

unionCase.Attributes |> Seq.tryPick (fun att ->
match att.AttributeType.TryFullName with
| Some Atts.erase -> Some ErasedUnionCase
Expand All @@ -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<CaseRules>(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<CaseRules>(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 ->
Expand Down
45 changes: 27 additions & 18 deletions src/Fable.Transforms/FSharp2Fable.fs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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.: [<Erase(tag=true)>]"
|> addErrorAndReturnNull com ctx.InlinePath r
| argExprs -> makeTuple r false argExprs
| TypeScriptTaggedUnion _ ->
match argExprs with
| [argExpr] -> argExpr
Expand Down Expand Up @@ -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
Expand All @@ -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) ->
Expand Down Expand Up @@ -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
Expand Down

0 comments on commit be37563

Please sign in to comment.