Skip to content

Commit

Permalink
Added support for erased unions
Browse files Browse the repository at this point in the history
  • Loading branch information
@ncave
ncave committed Nov 30, 2020
1 parent a377994 commit 2f55c5a
Show file tree
Hide file tree
Showing 5 changed files with 77 additions and 61 deletions.
1 change: 1 addition & 0 deletions src/Fable.AST/Plugins.fs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -10,6 +10,7 @@ type Verbosity =
| Silent

type CompilerOptions =
abstract EraseUnions: bool
abstract TypedArrays: bool
abstract ClampByteArrays: bool
abstract Typescript: bool
Expand Down
3 changes: 2 additions & 1 deletion src/Fable.Cli/Entry.fs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -138,7 +138,8 @@ type Runner =
argValue "--extension" args |> Option.defaultValue (defaultFileExt typescript args)

let compilerOptions =
CompilerOptionsHelper.Make(typescript = typescript,
CompilerOptionsHelper.Make(eraseUnions = flagEnabled "--eraseUnions" args,
typescript = typescript,
typedArrays = typedArrays,
fileExtension = fileExt,
define = define,
Expand Down
59 changes: 39 additions & 20 deletions src/Fable.Transforms/FSharp2Fable.Util.fs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -675,33 +675,52 @@ module Patterns =
| _ -> None
else None

let (|OptionUnion|ListUnion|ErasedUnion|ErasedUnionCase|StringEnum|DiscriminatedUnion|)
(NonAbbreviatedType typ: FSharpType, unionCase: FSharpUnionCase) =
[<RequireQualifiedAccess>]
type EraseKind =
| AsValue
| AsTuple
| AsNamedTuple of CaseRules

let (|OptionUnion|ListUnion|ErasedUnion|DiscriminatedUnion|)
(com: Compiler, NonAbbreviatedType typ: FSharpType, unionCase: FSharpUnionCase) =

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
| _ -> None)
|> Option.defaultWith (fun () ->
match tryDefinition typ with
| None -> failwith "Union without definition"
| Some(tdef, fullName) ->
match defaultArg fullName tdef.CompiledName with
| Types.valueOption
| Types.option -> OptionUnion typ.GenericArguments.[0]
| Types.list -> ListUnion typ.GenericArguments.[0]
| _ ->
let getEraseKind (tdef: FSharpEntity) caseRule =
if tdef.UnionCases.Count = 1 && tdef.UnionCases.[0].UnionCaseFields.Count = 1
then EraseKind.AsValue
else EraseKind.AsNamedTuple(caseRule)

match tryDefinition typ with
| None -> failwith "Union without definition"
| Some(tdef, fullName) ->
let fullName = defaultArg fullName tdef.CompiledName
match fullName with
| Types.valueOption
| Types.option -> OptionUnion typ.GenericArguments.[0]
| Types.list -> ListUnion typ.GenericArguments.[0]
| _ ->
unionCase.Attributes |> Seq.tryPick (fun att ->
match att.AttributeType.TryFullName with
| Some Atts.erase ->
Some (ErasedUnion(EraseKind.AsTuple, tdef, typ.GenericArguments))
| _ -> None)
|> Option.orElseWith (fun () ->
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))
| _ -> None)
|> Option.defaultValue (DiscriminatedUnion(tdef, typ.GenericArguments))
)
| Some Atts.erase
| Some Atts.stringEnum ->
let kind = getEraseKind tdef (getCaseRule att)
Some (ErasedUnion(kind, tdef, typ.GenericArguments))
| _ -> None))
|> Option.defaultWith (fun () ->
if com.Options.EraseUnions then
let kind = getEraseKind tdef CaseRules.None
ErasedUnion(kind, tdef, typ.GenericArguments)
else DiscriminatedUnion(tdef, typ.GenericArguments))

let (|ContainsAtt|_|) (fullName: string) (ent: FSharpEntity) =
tryFindAtt fullName ent.Attributes
Expand Down
71 changes: 32 additions & 39 deletions src/Fable.Transforms/FSharp2Fable.fs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -50,22 +50,14 @@ let private transformBaseConsCall com ctx r (baseEnt: FSharpEntity) (baseCons: F
| e -> e

let private transformNewUnion com ctx r fsType (unionCase: FSharpUnionCase) (argExprs: Fable.Expr list) =
match fsType, unionCase with
| ErasedUnionCase ->
Fable.NewTuple argExprs |> makeValue r
| 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 -> Fable.NewTuple argExprs |> makeValue r
| StringEnum(tdef, rule) ->
match argExprs with
| [] -> transformStringEnum rule unionCase
| _ -> sprintf "StringEnum types cannot have fields: %O" tdef.TryFullName
|> addErrorAndReturnNull com ctx.InlinePath r
match com, fsType, unionCase with
| ErasedUnion(kind, tdef, _genArgs) ->
match kind, argExprs with
| EraseKind.AsNamedTuple caseRule, [] -> transformStringEnum caseRule unionCase
| EraseKind.AsNamedTuple _, _ -> (makeStrConst unionCase.Name)::argExprs |> Fable.NewTuple |> makeValue r
| EraseKind.AsValue, [arg] -> arg
| EraseKind.AsValue, _ -> failwith "Shouldn't happen, error?"
| EraseKind.AsTuple, _ -> Fable.NewTuple argExprs |> makeValue r
| OptionUnion typ ->
let typ = makeType ctx.GenericArgs typ
let expr =
Expand Down Expand Up @@ -228,14 +220,16 @@ let private transformUnionCaseTest (com: IFableCompiler) (ctx: Context) r
unionExpr fsType (unionCase: FSharpUnionCase) =
trampoline {
let! unionExpr = transformExpr com ctx unionExpr
match fsType, unionCase with
| ErasedUnionCase ->
return "Cannot test erased union cases"
|> addErrorAndReturnNull com ctx.InlinePath r
| ErasedUnion(tdef, genArgs, rule) ->
match unionCase.UnionCaseFields.Count with
| 0 -> return makeEqOp r unionExpr (transformStringEnum rule unionCase) BinaryEqualStrict
| 1 ->
match com, fsType, unionCase with
| ErasedUnion(kind, tdef, genArgs) ->
match kind with
| EraseKind.AsNamedTuple caseRule ->
if unionCase.UnionCaseFields.Count = 0 then
return makeEqOp r unionExpr (transformStringEnum caseRule unionCase) BinaryEqualStrict
else
let name = Fable.Get(unionExpr, Fable.TupleIndex(0), Fable.String, None)
return makeEqOp r name (makeStrConst unionCase.Name) BinaryEqualStrict
| EraseKind.AsValue ->
let fi = unionCase.UnionCaseFields.[0]
let typ =
if fi.FieldType.IsGenericParameter then
Expand All @@ -247,17 +241,15 @@ 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)
| _ ->
return "Erased unions with multiple cases cannot have more than one field: " + (getFsTypeFullName fsType)
| EraseKind.AsTuple ->
return "Cannot test erased union cases"
|> addErrorAndReturnNull com ctx.InlinePath r
| OptionUnion _ ->
let kind = Fable.OptionTest(unionCase.Name <> "None" && unionCase.Name <> "ValueNone")
return Fable.Test(unionExpr, kind, r)
| ListUnion _ ->
let kind = Fable.ListTest(unionCase.CompiledName <> "Empty")
return Fable.Test(unionExpr, kind, r)
| StringEnum(_, rule) ->
return makeEqOp r unionExpr (transformStringEnum rule unionCase) BinaryEqualStrict
| DiscriminatedUnion(tdef,_) ->
let tag = unionCaseTag tdef unionCase
return Fable.Test(unionExpr, Fable.UnionCaseTest(tag), r)
Expand Down Expand Up @@ -678,18 +670,19 @@ let private transformExpr (com: IFableCompiler) (ctx: Context) fsExpr =
| BasicPatterns.UnionCaseGet (unionExpr, fsType, unionCase, field) ->
let r = makeRangeFrom fsExpr
let! unionExpr = transformExpr com ctx unionExpr
match fsType, unionCase with
| ErasedUnionCase ->
let index = unionCase.UnionCaseFields |> Seq.findIndex (fun x -> x.Name = field.Name)
return Fable.Get(unionExpr, Fable.TupleIndex(index), makeType ctx.GenericArgs fsType, r)
| ErasedUnion _ ->
if unionCase.UnionCaseFields.Count = 1 then return unionExpr
else
match com, fsType, unionCase with
| ErasedUnion(kind, _, _) ->
let getByIndex offset =
let index = unionCase.UnionCaseFields |> Seq.findIndex (fun x -> x.Name = field.Name)
return Fable.Get(unionExpr, Fable.TupleIndex index, makeType ctx.GenericArgs fsType, r)
| StringEnum _ ->
return "StringEnum types cannot have fields"
|> addErrorAndReturnNull com ctx.InlinePath r
Fable.Get(unionExpr, Fable.TupleIndex(index + offset), makeType ctx.GenericArgs fsType, r)
match kind with
| EraseKind.AsValue -> return unionExpr
| EraseKind.AsTuple -> return getByIndex 0
| EraseKind.AsNamedTuple _ ->
if unionCase.UnionCaseFields.Count = 0 then
return "StringEnum types cannot have fields" |> addErrorAndReturnNull com ctx.InlinePath r
else
return getByIndex 1
| OptionUnion t ->
return Fable.Get(unionExpr, Fable.OptionValue, makeType ctx.GenericArgs t, r)
| ListUnion t ->
Expand Down
4 changes: 3 additions & 1 deletion src/Fable.Transforms/Global/Compiler.fs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -5,7 +5,8 @@ module Literals =

type CompilerOptionsHelper =
static member DefaultExtension = ".fs.js"
static member Make(?typedArrays,
static member Make(?eraseUnions,
?typedArrays,
?typescript,
?define,
?optimizeFSharpAst,
Expand All @@ -17,6 +18,7 @@ type CompilerOptionsHelper =
{ new CompilerOptions with
member _.Define = define
member _.DebugMode = isDebug
member _.EraseUnions = defaultArg eraseUnions false
member _.Typescript = defaultArg typescript false
member _.TypedArrays = defaultArg typedArrays true
member _.OptimizeFSharpAst = defaultArg optimizeFSharpAst false
Expand Down

0 comments on commit 2f55c5a

Please sign in to comment.