Added support for erased unions

ncave · ncave · commit 2f55c5a0c25b · 2020-11-30T07:59:58.000-08:00
diff --git a/src/Fable.AST/Plugins.fs b/src/Fable.AST/Plugins.fs
@@ -10,6 +10,7 @@ type Verbosity =
     | Silent
 
 type CompilerOptions =
+      abstract EraseUnions: bool
       abstract TypedArrays: bool
       abstract ClampByteArrays: bool
       abstract Typescript: bool
diff --git a/src/Fable.Cli/Entry.fs b/src/Fable.Cli/Entry.fs
@@ -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,
diff --git a/src/Fable.Transforms/FSharp2Fable.Util.fs b/src/Fable.Transforms/FSharp2Fable.Util.fs
@@ -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
diff --git a/src/Fable.Transforms/FSharp2Fable.fs b/src/Fable.Transforms/FSharp2Fable.fs
@@ -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 =
@@ -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
@@ -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)
@@ -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 ->
diff --git a/src/Fable.Transforms/Global/Compiler.fs b/src/Fable.Transforms/Global/Compiler.fs
@@ -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,
@@ -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
