diff --git a/src/Fable.AST/Fable.fs b/src/Fable.AST/Fable.fs index 9a6647954c..eb8df5206c 100644 --- a/src/Fable.AST/Fable.fs +++ b/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 [] type Constraint = diff --git a/src/Fable.Core/Fable.Core.Types.fs b/src/Fable.Core/Fable.Core.Types.fs index 6d6e2ca30a..85a15395d9 100644 --- a/src/Fable.Core/Fable.Core.Types.fs +++ b/src/Fable.Core/Fable.Core.Types.fs @@ -85,6 +85,26 @@ type TypeScriptTaggedUnionAttribute(tagName: string, caseRules: CaseRules) = new(tagName: string) = TypeScriptTaggedUnionAttribute(tagName, CaseRules.LowerFirst) +/// +/// Compiles a case of a TypeScriptTaggedUnion 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. +/// +/// +/// The case must have exactly one field, whose type is an interface: +/// +/// [<TypeScriptTaggedUnion("type")>] +/// type Command = +/// | [<InlineInterface>] Take of Take +/// | Save +/// +/// The TypeScript type of the Take case is Take & { type: "take" }. +/// Constructing the case copies the field value with its prototype and sets the tag on the copy. +/// Reading the field returns the union value. +/// +type InlineInterfaceAttribute() = + inherit Attribute() + /// /// Used in place of CompiledNameAttribute if the target is not a string. /// diff --git a/src/Fable.Transforms/Babel/Fable2Babel.fs b/src/Fable.Transforms/Babel/Fable2Babel.fs index f3a630f375..672d5fd65a 100644 --- a/src/Fable.Transforms/Babel/Fable2Babel.fs +++ b/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 diff --git a/src/Fable.Transforms/FSharp2Fable.Util.fs b/src/Fable.Transforms/FSharp2Fable.Util.fs index c4de960e19..e112801a8d 100644 --- a/src/Fable.Transforms/FSharp2Fable.Util.fs +++ b/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 diff --git a/src/Fable.Transforms/FSharp2Fable.fs b/src/Fable.Transforms/FSharp2Fable.fs index b31c8b1a95..f6c1232f15 100644 --- a/src/Fable.Transforms/FSharp2Fable.fs +++ b/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" diff --git a/src/Fable.Transforms/Transforms.Util.fs b/src/Fable.Transforms/Transforms.Util.fs index 5f0d7ae2b4..1a6c3be83b 100644 --- a/src/Fable.Transforms/Transforms.Util.fs +++ b/src/Fable.Transforms/Transforms.Util.fs @@ -100,6 +100,9 @@ module Atts = [] let tsTaggedUnion = "Fable.Core.TypeScriptTaggedUnionAttribute" // typeof.FullName + [] + let inlineInterface = "Fable.Core.InlineInterfaceAttribute" // typeof.FullName + [] let stringEnum = "Fable.Core.StringEnumAttribute" // typeof.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 = + 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) diff --git a/src/fable-metadata/lib/Fable.Core.dll b/src/fable-metadata/lib/Fable.Core.dll index ad480fca01..6c465859ec 100644 Binary files a/src/fable-metadata/lib/Fable.Core.dll and b/src/fable-metadata/lib/Fable.Core.dll differ diff --git a/tests/Integration/Compiler/CompilerMessagesTests.fs b/tests/Integration/Compiler/CompilerMessagesTests.fs index 88dae4532f..b9bd2abfb4 100644 --- a/tests/Integration/Compiler/CompilerMessagesTests.fs +++ b/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 + +[] +type Value = + | [] 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 + +[] +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 ] diff --git a/tests/Js/Main/JsInteropTests.fs b/tests/Js/Main/JsInteropTests.fs index 35c01030c1..5fad2525b8 100644 --- a/tests/Js/Main/JsInteropTests.fs +++ b/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 + + [] + type InlinedCase = + | [] Take of Take + | Edit of Edit + | Save + + [] + type InlinedType = + | Take of Take + | Edit of Edit + | Save + #if FABLE_COMPILER module PojoDefinedByConsArgs = [] @@ -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 () ->