diff --git a/src/Compiler/Checking/Expressions/CheckExpressions.fs b/src/Compiler/Checking/Expressions/CheckExpressions.fs index be64b075e2..585939038f 100644 --- a/src/Compiler/Checking/Expressions/CheckExpressions.fs +++ b/src/Compiler/Checking/Expressions/CheckExpressions.fs @@ -7119,12 +7119,14 @@ and CheckSuperType (cenv: cenv) ty m = and TcObjectExpr (cenv: cenv) env tpenv (objTy, realObjTy, argopt, binds, extraImpls, mObjTy, mNewExpr, mWholeExpr) = let g = cenv.g - match tryTcrefOfAppTy g objTy with | ValueNone -> error(Error(FSComp.SR.tcNewMustBeUsedWithNamedType(), mNewExpr)) | ValueSome tcref -> let isRecordTy = tcref.IsRecordTycon - if not isRecordTy && not (isInterfaceTy g objTy) && isSealedTy g objTy then errorR(Error(FSComp.SR.tcCannotCreateExtensionOfSealedType(), mNewExpr)) + let isInterfaceTy = isInterfaceTy g objTy + let isFSharpObjModelTy = isFSharpObjModelTy g objTy + let isOverallTyAbstract = HasFSharpAttribute g g.attrib_AbstractClassAttribute tcref.Attribs + if not isRecordTy && not isInterfaceTy && isSealedTy g objTy then errorR(Error(FSComp.SR.tcCannotCreateExtensionOfSealedType(), mNewExpr)) CheckSuperType cenv objTy mObjTy @@ -7135,14 +7137,14 @@ and TcObjectExpr (cenv: cenv) env tpenv (objTy, realObjTy, argopt, binds, extraI let env = EnterFamilyRegion tcref env let ad = env.AccessRights - if // record construction ? + if // record construction ? e.g { A = 1; B = 2 } isRecordTy || - // object construction? - (isFSharpObjModelTy g objTy && not (isInterfaceTy g objTy) && argopt.IsNone) then + // object construction? e.g. new A() { ... } + (isFSharpObjModelTy && not isInterfaceTy && argopt.IsNone) then if argopt.IsSome then error(Error(FSComp.SR.tcNoArgumentsForRecordValue(), mWholeExpr)) if not (isNil extraImpls) then error(Error(FSComp.SR.tcNoInterfaceImplementationForConstructionExpression(), mNewExpr)) - if isFSharpObjModelTy g objTy && GetCtorShapeCounter env <> 1 then + if isFSharpObjModelTy && GetCtorShapeCounter env <> 1 then error(Error(FSComp.SR.tcObjectConstructionCanOnlyBeUsedInClassTypes(), mNewExpr)) let fldsList = binds |> List.map (fun b -> @@ -7152,8 +7154,9 @@ and TcObjectExpr (cenv: cenv) env tpenv (objTy, realObjTy, argopt, binds, extraI TcRecordConstruction cenv objTy true env tpenv None objTy fldsList mWholeExpr else + // object expression construction e.g. { new A() with ... } or { new IA with ... } let ctorCall, baseIdOpt, tpenv = - if isInterfaceTy g objTy then + if isInterfaceTy then match argopt with | None -> BuildObjCtorCall g mWholeExpr, None, tpenv @@ -7162,7 +7165,7 @@ and TcObjectExpr (cenv: cenv) env tpenv (objTy, realObjTy, argopt, binds, extraI else let item = ForceRaise (ResolveObjectConstructor cenv.nameResolver env.DisplayEnv mObjTy ad objTy) - if isFSharpObjModelTy g objTy && GetCtorShapeCounter env = 1 then + if isFSharpObjModelTy && GetCtorShapeCounter env = 1 then error(Error(FSComp.SR.tcObjectsMustBeInitializedWithObjectExpression(), mNewExpr)) match item, argopt with @@ -7193,14 +7196,6 @@ and TcObjectExpr (cenv: cenv) env tpenv (objTy, realObjTy, argopt, binds, extraI overridesAndVirts |> List.iter (fun (m, implTy, dispatchSlots, dispatchSlotsKeyed, availPriorOverrides, overrides) -> let overrideSpecs = overrides |> List.map fst let hasStaticMembers = dispatchSlots |> List.exists (fun reqdSlot -> not reqdSlot.MethodInfo.IsInstance) - let isOverallTyAbstract = - match tryTcrefOfAppTy g objTy with - | ValueNone -> false - | ValueSome tcref -> HasFSharpAttribute g g.attrib_AbstractClassAttribute tcref.Attribs - - if overrideSpecs.IsEmpty && not (isInterfaceTy g objTy) then - errorR (Error(FSComp.SR.tcInvalidObjectExpressionSyntaxForm (), mWholeExpr)) - if hasStaticMembers then errorR(Error(FSComp.SR.chkStaticMembersOnObjectExpressions(), mObjTy)) @@ -7240,8 +7235,11 @@ and TcObjectExpr (cenv: cenv) env tpenv (objTy, realObjTy, argopt, binds, extraI let objtyR, overrides' = allTypeImpls.Head assert (typeEquiv g objTy objtyR) let extraImpls = allTypeImpls.Tail + + if not isInterfaceTy && (isOverallTyAbstract && overrides'.IsEmpty) && extraImpls.IsEmpty then + errorR (Error(FSComp.SR.tcInvalidObjectExpressionSyntaxForm (), mWholeExpr)) - // 7. Build the implementation + // 4. Build the implementation let expr = mkObjExpr(objtyR, baseValOpt, ctorCall, overrides', extraImpls, mWholeExpr) let expr = mkCoerceIfNeeded g realObjTy objtyR expr expr, tpenv diff --git a/src/Compiler/Checking/Expressions/CheckSequenceExpressions.fs b/src/Compiler/Checking/Expressions/CheckSequenceExpressions.fs index 09de598b18..31be49131a 100644 --- a/src/Compiler/Checking/Expressions/CheckSequenceExpressions.fs +++ b/src/Compiler/Checking/Expressions/CheckSequenceExpressions.fs @@ -444,20 +444,12 @@ let TcSequenceExpressionEntry (cenv: TcFileState) env (overallTy: OverallTy) tpe match RewriteRangeExpr comp with | Some replacementExpr -> TcExpr cenv overallTy env tpenv replacementExpr | None -> - let implicitYieldEnabled = cenv.g.langVersion.SupportsFeature LanguageFeature.ImplicitYield let validateObjectSequenceOrRecordExpression = not implicitYieldEnabled match comp with - | SynExpr.New _ -> - try - TcExprUndelayed cenv overallTy env tpenv comp |> ignore - with RecoverableException e -> - errorRecovery e m - - errorR (Error(FSComp.SR.tcInvalidObjectExpressionSyntaxForm (), m)) | SimpleSemicolonSequence cenv false _ when validateObjectSequenceOrRecordExpression -> errorR (Error(FSComp.SR.tcInvalidObjectSequenceOrRecordExpression (), m)) | _ -> () diff --git a/tests/FSharp.Compiler.ComponentTests/Conformance/Expressions/ObjectExpressions/ObjectExpressions.fs b/tests/FSharp.Compiler.ComponentTests/Conformance/Expressions/ObjectExpressions/ObjectExpressions.fs index 0a3eb93cf5..33fc4582f2 100644 --- a/tests/FSharp.Compiler.ComponentTests/Conformance/Expressions/ObjectExpressions/ObjectExpressions.fs +++ b/tests/FSharp.Compiler.ComponentTests/Conformance/Expressions/ObjectExpressions/ObjectExpressions.fs @@ -33,6 +33,93 @@ let implementer() ={ new IFirst } |> withLangVersion80 |> typecheck |> shouldSucceed + + [] + let ``Object expression can construct an abstract class and also implement interfaces with and without abstract members.`` () = + Fsx """ +type IFirst = interface end + +type ISecond = + abstract member M : unit -> unit + +[] +type MyClass() = class end + +{ new MyClass() with + member x.ToString() = "OK" + + interface IFirst + + interface ISecond with + member this.M() = () } |> ignore + """ + |> withLangVersion80 + |> typecheck + |> shouldSucceed + + [] + let ``Object expression can construct an abstract class(missing with...) and also implement interfaces with and without abstract members.`` () = + Fsx """ +type IFirst = interface end + +type ISecond = + abstract member M : unit -> unit + +[] +type MyClass() = class end + +{ new MyClass() interface IFirst + + interface ISecond with + member this.M() = () } |> ignore + """ + |> withLangVersion80 + |> typecheck + |> shouldSucceed + + [] + let ``Object expression can construct an abstract class(missing with... and interface in the next line) and also implement interfaces with and without abstract members.`` () = + Fsx """ +type IFirst = interface end + +type ISecond = + abstract member M : unit -> unit + +[] +type MyClass() = class end + +{ new MyClass() + interface IFirst + + interface ISecond with + member this.M() = () } |> ignore + """ + |> withLangVersion80 + |> typecheck + |> shouldSucceed + + [] + let ``Verifies that the object expression built type has the interface.`` () = + Fsx """ +type IFirst = interface end + +type ISecond = + abstract member M : unit -> unit + +[] +type MyClass() = + interface ISecond with + member this.M() = printfn "It works" + +let expr = { new MyClass() interface IFirst } +(expr:> ISecond).M() + """ + |> withLangVersion80 + |> compileExeAndRun + |> shouldSucceed + |> withStdOutContainsAllInOrder [ + "It works" + ] [] let ``Parameterized object expression implementing an interface with members`` () =