feat(js/ts): add InlineInterface for TypeScriptTaggedUnion cases

src/Fable.AST/Fable.fs

@@ -78,6 +78,7 @@ type UnionCase =
     abstract FullName: string
     abstract CompiledName: string option
     abstract UnionCaseFields: Field list
+    abstract Attributes: Attribute seq
 
 [<RequireQualifiedAccess>]
 type Constraint =

src/Fable.Core/Fable.Core.Types.fs

@@ -85,6 +85,26 @@ type TypeScriptTaggedUnionAttribute(tagName: string, caseRules: CaseRules) =
 
     new(tagName: string) = TypeScriptTaggedUnionAttribute(tagName, CaseRules.LowerFirst)
 
+/// <summary>
+/// Compiles a case of a <c>TypeScriptTaggedUnion</c> as its interface field with the tag added,
+/// instead of as an object holding the field.
+/// On the union type, it applies to every case that has fields.
+/// </summary>
+/// <remarks>
+/// The case must have exactly one field, whose type is an interface:
+/// <code>
+/// [&lt;TypeScriptTaggedUnion("type")>]
+/// type Command =
+///     | [&lt;InlineInterface>] Take of Take
+///     | Save
+/// </code>
+/// The TypeScript type of the <c>Take</c> case is <c>Take &amp; { type: "take" }</c>.
+/// Constructing the case copies the field value with its prototype and sets the tag on the copy.
+/// Reading the field returns the union value.
+/// </remarks>
+type InlineInterfaceAttribute() =
+    inherit Attribute()
+
 /// <summary>
 /// Used in place of <c>CompiledNameAttribute</c> if the target is not a string.
 /// </summary>

src/Fable.Transforms/Babel/Fable2Babel.fs

@@ -917,16 +917,17 @@ module Annotation =
 
                 AbstractMember.abstractProperty (prop, tagType, isComputed = isComputed)
 
-            match uci.UnionCaseFields with
-            // | [ field ] when field.Name = "Item" ->
-            //     IntersectionTypeAnnotation
-            //         [|
-            //             field.FieldType |> resolveInlineType genArgs |> makeFieldAnnotation com ctx
-            //             ObjectTypeAnnotation [| tagMember |]
-            //         |]
-            | fields ->
+            match tryInlinedInterface com ent uci with
+            | Ok(Some fieldType) ->
+                IntersectionTypeAnnotation
+                    [|
+                        fieldType |> resolveInlineType genArgs |> makeFieldAnnotation com ctx
+                        ObjectTypeAnnotation [| tagMember |]
+                    |]
+            | Ok None
+            | Error _ ->
                 let names, types =
-                    fields |> List.map (fun fi -> fi.Name, fi.FieldType) |> List.unzip
+                    uci.UnionCaseFields |> List.map (fun fi -> fi.Name, fi.FieldType) |> List.unzip
 
                 makeAnonymousRecordTypeAnnotation com ctx (List.toArray names) types
                 |> function

src/Fable.Transforms/FSharp2Fable.Util.fs

@@ -138,16 +138,13 @@ type FsUnionCase(uci: FSharpUnionCase) =
             | _ -> None
         )
 
-    // static member HasNamedFields(uci: FSharpUnionCase) =
-    //     not (uci.Fields.Count = 1 && uci.Fields[0].Name = "Item")
-    //     true
-
     interface Fable.UnionCase with
         member _.Name = uci.Name
         member _.FullName = FsUnionCase.FullName uci
         member _.CompiledName = FsUnionCase.CompiledName uci
 
         member _.UnionCaseFields = uci.Fields |> Seq.mapToList (fun x -> upcast FsField(x))
+        member _.Attributes = uci.Attributes |> Seq.map (fun x -> FsAtt(x) :> Fable.Attribute)
 
 type FsAtt(att: FSharpAttribute) =
     interface Fable.Attribute with

src/Fable.Transforms/FSharp2Fable.fs

@@ -95,6 +95,14 @@ let private transformStringEnumCase (com: Compiler) (rule: Fable.Core.CaseRules)
     | Beam -> transformStringEnumAsAtom rule unionCase
     | _ -> transformStringEnum rule unionCase
 
+/// The interface type a TypeScriptTaggedUnion case compiles as; reports an error when InlineInterface cannot apply.
+let private inlinedInterface (com: IFableCompiler) (ctx: Context) r tdef (unionCase: FSharpUnionCase) =
+    match tryInlinedInterface com (FsEnt tdef) (FsUnionCase unionCase) with
+    | Ok inlined -> inlined
+    | Error msg ->
+        addError com ctx.InlinePath r msg
+        None
+
 let private transformNewUnion com ctx r fsType (unionCase: FSharpUnionCase) (argExprs: Fable.Expr list) =
     match getUnionPattern fsType unionCase with
     | ErasedUnionCase -> makeTuple r false argExprs
@@ -109,31 +117,50 @@ let private transformNewUnion com ctx r fsType (unionCase: FSharpUnionCase) (arg
             |> addErrorAndReturnNull com ctx.InlinePath r
         | argExprs -> makeTuple r false argExprs
 
-    | TypeScriptTaggedUnion(_, _, tagName, rule) ->
-        match argExprs with
-        // | [ argExpr ] when not (FsUnionCase.HasNamedFields unionCase) -> argExpr
-        | _ ->
-            let isCompiledValue, tagExpr =
-                match FsUnionCase.CompiledValue unionCase with
-                | None -> false, transformStringEnum rule unionCase
-                | Some(CompiledValue.Integer i) -> false, makeIntConst i
-                | Some(CompiledValue.Float f) -> false, makeFloatConst f
-                | Some(CompiledValue.Boolean b) -> false, makeBoolConst b
-
-            match isCompiledValue, com.Options.Language with
-            | true, TypeScript ->
-                "CompileValue attribute is not supported in TypeScript"
-                |> addErrorAndReturnNull com ctx.InlinePath r
-            | _ ->
-                let fieldNames, fieldTypes =
-                    unionCase.Fields
-                    |> Seq.map (fun fi -> fi.Name, fi.FieldType)
-                    |> Seq.toArray
-                    |> Array.unzip
+    | TypeScriptTaggedUnion(tdef, _, tagName, rule) ->
+        let inlined = inlinedInterface com ctx r tdef unionCase
 
-                let fieldTypes = makeTypeGenArgs ctx.GenericArgs fieldTypes
+        let isCompiledValue, tagExpr =
+            match FsUnionCase.CompiledValue unionCase with
+            | None -> false, transformStringEnum rule unionCase
+            | Some(CompiledValue.Integer i) -> false, makeIntConst i
+            | Some(CompiledValue.Float f) -> false, makeFloatConst f
+            | Some(CompiledValue.Boolean b) -> false, makeBoolConst b
 
-                let expr =
+        match isCompiledValue, com.Options.Language with
+        | true, TypeScript ->
+            "CompileValue attribute is not supported in TypeScript"
+            |> addErrorAndReturnNull com ctx.InlinePath r
+        | _ ->
+            let fieldNames, fieldTypes =
+                unionCase.Fields
+                |> Seq.map (fun fi -> fi.Name, fi.FieldType)
+                |> Seq.toArray
+                |> Array.unzip
+
+            let fieldTypes = makeTypeGenArgs ctx.GenericArgs fieldTypes
+
+            let expr =
+                match inlined, argExprs with
+                | Some _, [ argExpr ] ->
+                    // A copy of the interface value, with its prototype, carrying the tag
+                    let tag =
+                        Fable.NewAnonymousRecord([ tagExpr ], [| tagName |], [ tagExpr.Type ], false)
+                        |> makeValue r
+
+                    let makeCopy argExpr =
+                        emitExpr
+                            r
+                            Fable.Any
+                            [ argExpr; tag ]
+                            "Object.assign(Object.create(Object.getPrototypeOf($0)), $0, $1)"
+
+                    if canHaveSideEffects com argExpr then
+                        let ident = getIdentUniqueName com ctx "caseValue" |> makeTypedIdent argExpr.Type
+                        Fable.Let(ident, argExpr, makeCopy (Fable.IdentExpr ident))
+                    else
+                        makeCopy argExpr
+                | _ ->
                     Fable.NewAnonymousRecord(
                         tagExpr :: argExprs,
                         Array.append [| tagName |] fieldNames,
@@ -142,7 +169,7 @@ let private transformNewUnion com ctx r fsType (unionCase: FSharpUnionCase) (arg
                     )
                     |> makeValue r
 
-                Fable.TypeCast(expr, makeType ctx.GenericArgs fsType)
+            Fable.TypeCast(expr, makeType ctx.GenericArgs fsType)
 
     | StringEnum(tdef, rule) ->
         match argExprs with
@@ -1335,17 +1362,17 @@ let private transformExpr (com: IFableCompiler) (ctx: Context) appliedGenArgs fs
                     let index = unionCase.Fields |> Seq.findIndex (fun x -> x.Name = field.Name)
 
                     return Fable.Get(unionExpr, Fable.TupleIndex index, fieldType, r)
-            | TypeScriptTaggedUnion _ ->
-                // if not (FsUnionCase.HasNamedFields unionCase) then
-                //     return unionExpr
-                // else
-                let kind =
-                    Fable.FieldInfo.Create(
-                        FsField.FSharpFieldName field,
-                        fieldType = makeType Map.empty field.FieldType
-                    )
+            | TypeScriptTaggedUnion(tdef, _, _, _) ->
+                match inlinedInterface com ctx r tdef unionCase with
+                | Some _ -> return Fable.TypeCast(unionExpr, fieldType)
+                | None ->
+                    let kind =
+                        Fable.FieldInfo.Create(
+                            FsField.FSharpFieldName field,
+                            fieldType = makeType Map.empty field.FieldType
+                        )
 
-                return Fable.Get(unionExpr, kind, fieldType, r)
+                    return Fable.Get(unionExpr, kind, fieldType, r)
             | StringEnum _ ->
                 return
                     "StringEnum types cannot have fields"

src/Fable.Transforms/Transforms.Util.fs

@@ -100,6 +100,9 @@ module Atts =
     [<Literal>]
     let tsTaggedUnion = "Fable.Core.TypeScriptTaggedUnionAttribute" // typeof<Fable.Core.TypeScriptTaggedUnionAttribute>.FullName
 
+    [<Literal>]
+    let inlineInterface = "Fable.Core.InlineInterfaceAttribute" // typeof<Fable.Core.InlineInterfaceAttribute>.FullName
+
     [<Literal>]
     let stringEnum = "Fable.Core.StringEnumAttribute" // typeof<Fable.Core.StringEnumAttribute>.FullName
 
@@ -926,6 +929,27 @@ module AST =
             | _ -> ValueNone
         | _ -> ValueNone
 
+    /// The interface type a TypeScriptTaggedUnion case compiles as, when InlineInterface applies to the case.
+    /// An error carries the message for a case InlineInterface is applied to but cannot inline.
+    let tryInlinedInterface (com: Compiler) (ent: Entity) (uci: UnionCase) : Result<Type option, string> =
+        let hasAtt (atts: Attribute seq) =
+            atts |> Seq.exists (fun att -> att.Entity.FullName = Atts.inlineInterface)
+
+        let onCase = hasAtt uci.Attributes
+
+        let isInterface =
+            function
+            | DeclaredType(entRef, _) -> com.TryGetEntity(entRef) |> Option.exists (fun ent -> ent.IsInterface)
+            | _ -> false
+
+        match uci.UnionCaseFields with
+        | _ when not (onCase || hasAtt ent.Attributes) -> Ok None
+        | [] when not onCase -> Ok None
+        | [ field ] when isInterface field.FieldType -> Ok(Some field.FieldType)
+        | _ ->
+            Error
+                $"InlineInterface cannot apply to '%s{uci.Name}': the case must have exactly one field, whose type is an interface"
+
     // TODO: Improve this, see https://github.com/fable-compiler/Fable/issues/1659#issuecomment-445071965
     // This is mainly used for inlining so a computation or a reference to a mutable value are understood
     // as a side effects too (because we don't want to duplicate or change the order of execution)

tests/Integration/Compiler/CompilerMessagesTests.fs

@@ -283,4 +283,39 @@ type MyClass() =
       compile source
       |> Assert.Is.success
       |> ignore
+
+    testCase "InlineInterface on a case without an interface field emits error" <| fun _ ->
+      let source =
+        """
+open Fable.Core
+
+[<TypeScriptTaggedUnion("type")>]
+type Value =
+    | [<InlineInterface>] Count of int
+    | Empty
+
+let make () = Count 1
+"""
+      compile source
+      |> Assert.Exists.errorWith "InlineInterface cannot apply to 'Count'"
+      |> ignore
+
+    testCase "InlineInterface on a case with an interface field does not emit error" <| fun _ ->
+      let source =
+        """
+open Fable.Core
+
+type Take =
+    abstract fromIndex: int
+
+[<TypeScriptTaggedUnion("type"); InlineInterface>]
+type Command =
+    | Take of Take
+    | Save
+
+let fromIndex (c: Command) = match c with Take t -> t.fromIndex | Save -> 0
+"""
+      compile source
+      |> Assert.Is.strictSuccess
+      |> ignore
   ]

tests/Js/Main/JsInteropTests.fs

@@ -391,6 +391,30 @@ module TaggedUnion =
     type FooGeneric<'a> =
         | Bar of baz: 'a
 
+    type Take =
+        abstract fromIndex: int
+        abstract toIndex: int
+
+    type Edit =
+        abstract text: string
+
+    type TakeRange(fromIndex: int, toIndex: int) =
+        interface Take with
+            member _.fromIndex = fromIndex
+            member _.toIndex = toIndex
+
+    [<RequireQualifiedAccess; TypeScriptTaggedUnion("type")>]
+    type InlinedCase =
+        | [<InlineInterface>] Take of Take
+        | Edit of Edit
+        | Save
+
+    [<RequireQualifiedAccess; TypeScriptTaggedUnion("type"); InlineInterface>]
+    type InlinedType =
+        | Take of Take
+        | Edit of Edit
+        | Save
+
 #if FABLE_COMPILER
 module PojoDefinedByConsArgs =
     [<JS.Pojo; AllowNullLiteral>]
@@ -1090,6 +1114,59 @@ let tests =
         let fooGeneric = getFooGeneric 10
 
         equal (TaggedUnion.FooGeneric.Bar 10) fooGeneric
+
+    testCase "InlineInterface on a TS tagged union case compiles the case as its interface" <| fun () ->
+        let take = { new TaggedUnion.Take with
+                        member _.fromIndex = 1
+                        member _.toIndex = 3 }
+        let command = TaggedUnion.InlinedCase.Take take
+        command?``type`` |> equal "take"
+        command?fromIndex |> equal 1
+        jsTypeof command?Item |> equal "undefined"
+        jsTypeof take?``type`` |> equal "undefined"
+        let edit = TaggedUnion.InlinedCase.Edit { new TaggedUnion.Edit with member _.text = "hi" }
+        edit?Item?text |> equal "hi"
+        let describe = function
+            | TaggedUnion.InlinedCase.Take t -> sprintf "take: %d-%d" t.fromIndex t.toIndex
+            | TaggedUnion.InlinedCase.Edit e -> sprintf "edit: %s" e.text
+            | TaggedUnion.InlinedCase.Save -> "save"
+        command |> describe |> equal "take: 1-3"
+        edit |> describe |> equal "edit: hi"
+        TaggedUnion.InlinedCase.Save |> describe |> equal "save"
+        !!{| ``type`` = "take"; fromIndex = 2; toIndex = 5 |} |> describe |> equal "take: 2-5"
+        command.IsTake |> equal true
+        edit.IsTake |> equal false
+
+    testCase "InlineInterface on a TS tagged union type applies to every case with fields" <| fun () ->
+        let describe = function
+            | TaggedUnion.InlinedType.Take t -> sprintf "take: %d-%d" t.fromIndex t.toIndex
+            | TaggedUnion.InlinedType.Edit e -> sprintf "edit: %s" e.text
+            | TaggedUnion.InlinedType.Save -> "save"
+        let edit = TaggedUnion.InlinedType.Edit { new TaggedUnion.Edit with member _.text = "hi" }
+        edit?``type`` |> equal "edit"
+        edit?text |> equal "hi"
+        edit |> describe |> equal "edit: hi"
+        TaggedUnion.InlinedType.Save |> describe |> equal "save"
+        !!{| ``type`` = "edit"; text = "raw" |} |> describe |> equal "edit: raw"
+
+    testCase "InlineInterface keeps the prototype of a class instance" <| fun () ->
+        let range = TaggedUnion.TakeRange(1, 3)
+        let command = TaggedUnion.InlinedType.Take range
+        match command with
+        | TaggedUnion.InlinedType.Take t -> sprintf "%d-%d" t.fromIndex t.toIndex |> equal "1-3"
+        | _ -> failwith "expected Take"
+        jsTypeof range?``type`` |> equal "undefined"
+
+    testCase "InlineInterface evaluates the case value once" <| fun () ->
+        let mutable calls = 0
+        let next () =
+            calls <- calls + 1
+            { new TaggedUnion.Take with
+                member _.fromIndex = 1
+                member _.toIndex = 3 }
+        let command = TaggedUnion.InlinedCase.Take(next ())
+        command.IsTake |> equal true
+        calls |> equal 1
 #endif
 
     testCase "Pattern matching with StringEnum works" <| fun () ->