diff --git a/src/ProvidedTypes.fs b/src/ProvidedTypes.fs index d755119..1e2ba27 100644 --- a/src/ProvidedTypes.fs +++ b/src/ProvidedTypes.fs @@ -1657,9 +1657,15 @@ and ProvidedTypeDefinition(isTgt: bool, container:TypeContainer, className: stri let xs = this.GetNestedTypes bindingFlags |> Array.filter (fun m -> m.Name = name) if xs.Length > 0 then xs.[0] else null) - override __.GetInterface(_name, _ignoreCase) = notRequired this "GetInterface" this.Name + override __.GetInterface(name, ignoreCase) = + let sc = if ignoreCase then StringComparison.OrdinalIgnoreCase else StringComparison.Ordinal + this.GetInterfaces() + |> Array.tryFind (fun t -> + if name.Contains(".") then String.Equals(t.FullName, name, sc) + else String.Equals(t.Name, name, sc)) + |> Option.toObj - override __.GetInterfaces() = getInterfaces() + override __.GetInterfaces() = getInterfaces() override __.MakeArrayType() = ProvidedTypeSymbol(ProvidedTypeSymbolKind.SDArray, [this], typeBuilder) :> Type @@ -8148,7 +8154,13 @@ namespace ProviderImplementation.ProvidedTypes override this.GetCustomAttributes(_inherited) = notRequired this "GetCustomAttributes" inp.Name override this.GetCustomAttributes(_attributeType, _inherited) = notRequired this "GetCustomAttributes" inp.Name override this.IsDefined(_attributeType, _inherited) = notRequired this "IsDefined" inp.Name - override this.GetInterface(_name, _ignoreCase) = notRequired this "GetInterface" inp.Name + override this.GetInterface(name, ignoreCase) = + let sc = if ignoreCase then StringComparison.OrdinalIgnoreCase else StringComparison.Ordinal + this.GetInterfaces() + |> Array.tryFind (fun t -> + if name.Contains(".") then String.Equals(t.FullName, name, sc) + else String.Equals(t.Name, name, sc)) + |> Option.toObj override this.GetElementType() = notRequired this "GetElementType" inp.Name override this.InvokeMember(_name, _invokeAttr, _binder, _target, _args, _modifiers, _culture, _namedParameters) = notRequired this "InvokeMember" inp.Name @@ -13971,6 +13983,7 @@ namespace ProviderImplementation.ProvidedTypes member __.DefineGenericParameter(name, attrs) = let eb = ILGenericParameterBuilder(name, attrs) in gparams.Add eb; eb member __.DefineParameter(i, attrs, parameterName) = ilParams.[i].SetData(attrs, parameterName) ; ilParams.[i] member __.SetCustomAttribute(ca) = cattrs.Add(ca) + member __.SetImplementationFlags(f: MethodImplAttributes) = implflags <- f member __.GetILGenerator() = let ilg = ILGenerator(methodName) in body <- Some ilg; ilg member __.FormalMethodRef = let cc = (if ILMethodDef.ComputeIsStatic attrs then ILCallingConv.Static else ILCallingConv.Instance) @@ -15767,6 +15780,7 @@ namespace ProviderImplementation.ProvidedTypes match ptdT with | None -> () | Some ptdT -> + let isDelegateType = ptdT.BaseType <> null && ptdT.BaseType.FullName = "System.MulticastDelegate" for cinfo in ptdT.GetConstructors(bindAll) do match cinfo with | :? ProvidedConstructor as pcinfo when not (ctorMap.ContainsKey pcinfo) -> @@ -15779,6 +15793,9 @@ namespace ProviderImplementation.ProvidedTypes for (i, p) in cinfo.GetParameters() |> Seq.mapi (fun i x -> (i, x)) do cb.DefineParameter(i+1, ParameterAttributes.None, p.Name) |> ignore cb + // Delegate constructors use Runtime implementation; they have no IL body + if isDelegateType then + cb.SetImplementationFlags(MethodImplAttributes.Runtime ||| MethodImplAttributes.Managed) ctorMap.[pcinfo] <- cb | _ -> () @@ -15826,6 +15843,9 @@ namespace ProviderImplementation.ProvidedTypes pb.SetConstant p.RawDefaultValue + // Delegate methods use Runtime implementation; they have no IL body + if isDelegateType then + mb.SetImplementationFlags(MethodImplAttributes.Runtime ||| MethodImplAttributes.Managed) methMap.[pminfo] <- mb | _ -> () @@ -15841,6 +15861,10 @@ namespace ProviderImplementation.ProvidedTypes defineCustomAttrs tb.SetCustomAttribute (ptdT.GetCustomAttributesData()) + // Delegate types (base = System.MulticastDelegate) use Runtime implementation; their + // constructor and Invoke/BeginInvoke/EndInvoke bodies are synthesised by the CLR. + let isDelegateType = ptdT.BaseType <> null && ptdT.BaseType.FullName = "System.MulticastDelegate" + // Allow at most one constructor, and use its arguments as the fields of the type let ctors = ptdT.GetConstructors(bindAll) // exclude type initializer @@ -15866,6 +15890,9 @@ namespace ProviderImplementation.ProvidedTypes defineCustomAttrs cb.SetCustomAttribute (pcinfo.GetCustomAttributesData()) + // Delegate constructors have Runtime implementation; the CLR synthesises the body + if isDelegateType then () else + let ilg = cb.GetILGenerator() let ctorLocals = Dictionary() let parameterVars = @@ -15932,6 +15959,10 @@ namespace ProviderImplementation.ProvidedTypes [ for v in parameterVars -> Expr.Var v ] match pminfo.GetInvokeCode with + | _ when isDelegateType -> + // Delegate methods (Invoke, BeginInvoke, EndInvoke) have Runtime implementation; + // the CLR synthesises their bodies. No IL is emitted. + () | Some _ when ptdT.IsInterface -> failwith "The provided type definition is an interface; therefore, it should not define an implementation for its members." | Some _ when pminfo.IsAbstract -> diff --git a/tests/FSharp.TypeProviders.SDK.Tests.fsproj b/tests/FSharp.TypeProviders.SDK.Tests.fsproj index dcd5b96..1af107e 100644 --- a/tests/FSharp.TypeProviders.SDK.Tests.fsproj +++ b/tests/FSharp.TypeProviders.SDK.Tests.fsproj @@ -21,6 +21,7 @@ + diff --git a/tests/GenerativeDelegateTests.fs b/tests/GenerativeDelegateTests.fs new file mode 100644 index 0000000..a93edec --- /dev/null +++ b/tests/GenerativeDelegateTests.fs @@ -0,0 +1,128 @@ +module TPSDK.GenerativeDelegateTests + +#nowarn "760" // IDisposable needs new + +open System +open System.Reflection +open Microsoft.FSharp.Core.CompilerServices +open Xunit +open ProviderImplementation.ProvidedTypes +open ProviderImplementation.ProvidedTypesTesting + +/// Type provider that creates a container type with two custom delegate types: +/// - SimpleHandler : delegate void SimpleHandler(object sender, EventArgs e) +/// - ValueHandler : delegate int ValueHandler(int x, int y) +[] +type GenerativeDelegatesProvider (config: TypeProviderConfig) as this = + inherit TypeProviderForNamespaces (config) + + let ns = "Delegates.Provided" + let tempAssembly = ProvidedAssembly() + let container = ProvidedTypeDefinition(tempAssembly, ns, "Container", Some typeof, isErased = false) + + do + // --- SimpleHandler: void(object, EventArgs) --- + let simpleHandler = ProvidedTypeDefinition("SimpleHandler", Some typeof, isErased = false) + simpleHandler.AddMember( + ProvidedConstructor( + [ ProvidedParameter("object", typeof) + ProvidedParameter("method", typeof) ], + invokeCode = fun _ -> <@@ () @@>)) + let invokeSimple = ProvidedMethod("Invoke", + [ ProvidedParameter("sender", typeof) + ProvidedParameter("e", typeof) ], + typeof) + simpleHandler.AddMember invokeSimple + container.AddMember simpleHandler + + // --- ValueHandler: int(int, int) --- + let valueHandler = ProvidedTypeDefinition("ValueHandler", Some typeof, isErased = false) + valueHandler.AddMember( + ProvidedConstructor( + [ ProvidedParameter("object", typeof) + ProvidedParameter("method", typeof) ], + invokeCode = fun _ -> <@@ () @@>)) + let invokeValue = ProvidedMethod("Invoke", + [ ProvidedParameter("x", typeof) + ProvidedParameter("y", typeof) ], + typeof) + valueHandler.AddMember invokeValue + container.AddMember valueHandler + + tempAssembly.AddTypes [container] + this.AddNamespace(ns, [container]) + +let loadTestAssembly () = + let runtimeAssemblyRefs = Targets.DotNetStandard20FSharpRefs() + let runtimeAssembly = runtimeAssemblyRefs.[0] + let cfg = Testing.MakeSimulatedTypeProviderConfig (__SOURCE_DIRECTORY__, runtimeAssembly, runtimeAssemblyRefs) + let tp = GenerativeDelegatesProvider(cfg) :> TypeProviderForNamespaces + let providedNamespace = tp.Namespaces.[0] + let providedType = providedNamespace.GetTypes().[0] :?> ProvidedTypeDefinition + Assert.Equal("Container", providedType.Name) + let bytes = (tp :> ITypeProvider).GetGeneratedAssemblyContents(providedType.Assembly) + Assembly.Load bytes + +[] +let ``Generative delegate type is present in generated assembly``() = + let assembly = loadTestAssembly () + let containerType = assembly.ExportedTypes |> Seq.find (fun t -> t.Name = "Container") + let delegateType = containerType.GetNestedType("SimpleHandler") + Assert.NotNull(delegateType) + Assert.True(delegateType.IsClass, "SimpleHandler should be a class") + Assert.Equal("System.MulticastDelegate", delegateType.BaseType.FullName) + +[] +let ``Generative delegate type has correct constructor``() = + let assembly = loadTestAssembly () + let containerType = assembly.ExportedTypes |> Seq.find (fun t -> t.Name = "Container") + let delegateType = containerType.GetNestedType("SimpleHandler") + Assert.NotNull(delegateType) + let ctor = delegateType.GetConstructor([| typeof; typeof |]) + Assert.NotNull(ctor) + let ps = ctor.GetParameters() + Assert.Equal(2, ps.Length) + Assert.Equal(typeof, ps.[0].ParameterType) + Assert.Equal(typeof, ps.[1].ParameterType) + +[] +let ``Generative delegate Invoke method has correct signature``() = + let assembly = loadTestAssembly () + let containerType = assembly.ExportedTypes |> Seq.find (fun t -> t.Name = "Container") + let delegateType = containerType.GetNestedType("SimpleHandler") + Assert.NotNull(delegateType) + let invoke = delegateType.GetMethod("Invoke") + Assert.NotNull(invoke) + let ps = invoke.GetParameters() + Assert.Equal(2, ps.Length) + Assert.Equal("sender", ps.[0].Name) + Assert.Equal(typeof, ps.[0].ParameterType) + Assert.Equal("e", ps.[1].Name) + Assert.Equal(typeof, ps.[1].ParameterType) + Assert.Equal(typeof, invoke.ReturnType) + +[] +let ``Generative delegate with value return type has correct Invoke signature``() = + let assembly = loadTestAssembly () + let containerType = assembly.ExportedTypes |> Seq.find (fun t -> t.Name = "Container") + let delegateType = containerType.GetNestedType("ValueHandler") + Assert.NotNull(delegateType) + Assert.Equal("System.MulticastDelegate", delegateType.BaseType.FullName) + let invoke = delegateType.GetMethod("Invoke") + Assert.NotNull(invoke) + let ps = invoke.GetParameters() + Assert.Equal(2, ps.Length) + Assert.Equal(typeof, ps.[0].ParameterType) + Assert.Equal(typeof, ps.[1].ParameterType) + Assert.Equal(typeof, invoke.ReturnType) + +[] +let ``Multiple delegate types can coexist in one container``() = + let assembly = loadTestAssembly () + let containerType = assembly.ExportedTypes |> Seq.find (fun t -> t.Name = "Container") + let nested = containerType.GetNestedTypes() + let names = nested |> Array.map (fun t -> t.Name) |> Array.sort + Assert.Contains("SimpleHandler", names) + Assert.Contains("ValueHandler", names) + for t in nested do + Assert.Equal("System.MulticastDelegate", t.BaseType.FullName)