diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..6ebb4b4 --- /dev/null +++ b/.gitignore @@ -0,0 +1,3 @@ +FtpProvider/FtpProvider/bin/ +FtpProvider/FtpProvider/obj/ +FtpProvider/packages/ diff --git a/FtpProvider/FtpProvider/FtpProvider.fs b/FtpProvider/FtpProvider/FtpProvider.fs index 7a31f8a..406dd3d 100644 --- a/FtpProvider/FtpProvider/FtpProvider.fs +++ b/FtpProvider/FtpProvider/FtpProvider.fs @@ -1,102 +1,198 @@ -module FtpTypeProviderImplementation - -open System -open System.Net -open System.IO -open System.Reflection -open ProviderImplementation.ProvidedTypes -open Microsoft.FSharp.Core.CompilerServices - -/// Get the directories and files in an FTP site using anonymous login -let getFtpDirectory (site:string, user:string, pwd:string) = - let request = - match WebRequest.Create(site) with - | :? FtpWebRequest as f -> f - | _ -> failwith (sprintf "site '%s' did not result in an FTP request. Do you need to add prefix 'ftp://' ?" site) - request.Method <- WebRequestMethods.Ftp.ListDirectoryDetails - request.Credentials <- NetworkCredential(user, pwd) - - use response = request.GetResponse() :?> FtpWebResponse - - use responseStream = response.GetResponseStream() - use reader = new StreamReader(responseStream) - let contents = - [ while not reader.EndOfStream do - yield reader.ReadLine().Split([| ' ';'\t' |],StringSplitOptions.RemoveEmptyEntries) ] - - let dirs = - [ for c in contents do - if c.Length > 1 then - if c.[0].StartsWith("d") then yield Seq.last c ] - - let files = - [ for c in contents do - if c.Length > 1 then - if c.[0].StartsWith("-") then yield Seq.last c ] - - files, dirs - -// getFtpDirectory "ftp://ftp.ncbi.nlm.nih.gov/" - - -[] -type FtpProviderImpl(config : TypeProviderConfig) as this = - inherit TypeProviderForNamespaces () - let nameSpace = "FSharp.Management" - let asm = Assembly.GetExecutingAssembly() - - // Recursive, on-demand adding of types - let createTypes (typeName, site, user, pwd) = - let rec addTypes (site:string, td:ProvidedTypeDefinition) = - - td.AddMembersDelayed(fun () -> - let files, dirs = getFtpDirectory (site, user, pwd) - - [ for dir in dirs do - let nestedType = ProvidedTypeDefinition(dir, Some typeof) - addTypes(site + dir + "/", nestedType) - yield nestedType :> MemberInfo - - for file in files do - //let nestedType = ProvidedTypeDefinition(file, Some typeof) - let myProp = ProvidedLiteralField("Contents", typeof, site + file) - (* - GetterCode = (fun args -> - <@@ let request = WebRequest.Create(site + file) :?> FtpWebRequest - request.Method <- WebRequestMethods.Ftp.DownloadFile - request.Credentials <- new NetworkCredential ("anonymous","janeDoe@contoso.com"); - let response = request.GetResponse() :?> FtpWebResponse - use responseStream = response.GetResponseStream() - use reader = new StreamReader(responseStream) - reader.ReadToEnd() @@>)) - *) - //nestedType.AddMember myProp - yield myProp :> MemberInfo ] ) - let actualType = ProvidedTypeDefinition(asm, nameSpace, typeName, Some typeof) - addTypes(site, actualType) - actualType - - let _ = - let topType = ProvidedTypeDefinition(asm, nameSpace, "FtpProvider", Some typeof) - let siteParam = - let p = ProvidedStaticParameter("Url",typeof) - p.AddXmlDoc("The URL of the FTP site, including ftp://") - p - let userParam = - let p = ProvidedStaticParameter("User",typeof, "anonymous") - p.AddXmlDoc("The user of the FTP site (default 'anonymous')") - p - let pwdParam = - let p = ProvidedStaticParameter("Password",typeof, "janedoe@contoso.com") - p.AddXmlDoc("The password used to access the FTP site (default 'janedoe@contoso.com')") - p - let staticParams = [ siteParam; userParam; pwdParam ] - topType.DefineStaticParameters(staticParams, (fun typeName args -> - let site = args.[0] :?> string - let user = args.[1] :?> string - let pwd = args.[2] :?> string - createTypes(typeName, site, user, pwd))) - this.AddNamespace(nameSpace, [topType]) - -[] -do () \ No newline at end of file +module FtpTypeProviderImplementation + +open System +open System.Net +open System.IO +open System.Reflection +open ProviderImplementation.ProvidedTypes +open Microsoft.FSharp.Core.CompilerServices + +/// Get the directories and files in an FTP site using anonymous login +let getFtpDirectory (site:string, user:string, pwd:string) = + let request = + match WebRequest.Create(site) with + | :? FtpWebRequest as f -> f + | _ -> failwith (sprintf "site '%s' did not result in an FTP request. Do you need to add prefix 'ftp://' ?" site) + request.Method <- WebRequestMethods.Ftp.ListDirectoryDetails + request.Credentials <- NetworkCredential(user, pwd) + + use response = request.GetResponse() :?> FtpWebResponse + + use responseStream = response.GetResponseStream() + use reader = new StreamReader(responseStream) + let contents = + [ while not reader.EndOfStream do + yield reader.ReadLine().Split([| ' ';'\t' |],StringSplitOptions.RemoveEmptyEntries) ] + + let dirs = + [ for c in contents do + if c.Length > 1 then + if c.[0].StartsWith("d") then yield Seq.last c ] + + let files = + [ for c in contents do + if c.Length > 1 then + if c.[0].StartsWith("-") then yield Seq.last c ] + + files, dirs + +open System +open System.Threading +open System.Threading.Tasks + +//This extends the Async module to add the +//AwaitTaskVoid function, which will now appear +//in intellisense +module Async = + let inline awaitPlainTask (task: Task) = + // rethrow exception from preceding task if it fauled + let continuation (t : Task) : unit = + match t.IsFaulted with + | true -> raise t.Exception + | arg -> () + task.ContinueWith continuation |> Async.AwaitTask + + let inline startAsPlainTask (work : Async) = + Task.Factory.StartNew(fun () -> work |> Async.RunSynchronously) + + let AwaitUnitTask : (Task -> Async) = + Async.AwaitIAsyncResult >> Async.Ignore + +[] +type FtpProviderImpl(config : TypeProviderConfig) as this = + inherit TypeProviderForNamespaces () + let nameSpace = "FSharp.Management" + let asm = Assembly.GetExecutingAssembly() + + // Recursive, on-demand adding of types + let createTypes (typeName, site, useBinary:bool, user, pwd:string) = + let rec addTypes (site:string, td:ProvidedTypeDefinition) = + td.AddMembersDelayed(fun () -> + let files, dirs = getFtpDirectory (site, user, pwd) + [ + for dir in dirs do + let nestedType = ProvidedTypeDefinition(dir, Some typeof) + addTypes(site + dir + "/", nestedType) + yield nestedType :> MemberInfo + + for file in files do + + let nestedType = ProvidedTypeDefinition(file, Some typeof) + + let getterQuotation = + (fun args -> + <@@ + let request = WebRequest.Create(site + file) :?> FtpWebRequest + + request.Method <- WebRequestMethods.Ftp.DownloadFile + request.UseBinary <- useBinary + request.Credentials <- new NetworkCredential(user, pwd) + let response = request.GetResponse() :?> FtpWebResponse + + use responseStream = response.GetResponseStream() + if useBinary then + use ms = new MemoryStream() + responseStream.CopyTo(ms) + ms.ToArray() :> obj + else + use reader = new StreamReader(responseStream) + reader.ReadToEnd() :> obj + @@>) + + let contentsProperty = + ProvidedProperty("GetContents", typeof, + IsStatic=true, + GetterCode = getterQuotation) + nestedType.AddMember contentsProperty + + let getterQuotationAsync = + (fun args -> + <@@ + async { + + let request = WebRequest.Create(site + file) :?> FtpWebRequest + + request.Method <- WebRequestMethods.Ftp.DownloadFile + request.UseBinary <- useBinary + request.Credentials <- new NetworkCredential(user, pwd) + let response = request.GetResponse() :?> FtpWebResponse + + use responseStream = response.GetResponseStream() + if useBinary then + use ms = new MemoryStream() + do! responseStream.CopyToAsync(ms) |> Async.AwaitUnitTask + return ms.ToArray() :> obj + else + use reader = new StreamReader(responseStream) + let! r = reader.ReadToEndAsync() |> Async.AwaitTask + return r :> obj + } + @@>) + + let contentsPropertyAsync = + ProvidedProperty("GetContentsAsync", typeof>, + IsStatic=true, + GetterCode = getterQuotationAsync) + nestedType.AddMember contentsPropertyAsync + + yield nestedType :> MemberInfo + ] + ) + let actualType = ProvidedTypeDefinition(asm, nameSpace, typeName, Some typeof) + addTypes(site, actualType) + actualType + + let addProvidedStaticParameter nme typ xmldoc = + let p = ProvidedStaticParameter(nme,typ) + p.AddXmlDoc(sprintf xmldoc) + p + + let _ = + let topType = ProvidedTypeDefinition(asm, nameSpace, "FtpProvider", Some typeof) + topType.AddXmlDoc("An FTP Type Provider which lets you 'dot' into directory structures, and then retrieve a file by 'dotting' into the '.GetContents' property. note: there are no progress updates, so if it's a large file over a slow connection, the only solution is to wait. Perhaps try a smaller file first to verify.") + + let siteParam = + let p = ProvidedStaticParameter("Url",typeof,"") + p.AddXmlDoc(sprintf "The URL of the FTP site, including ftp://") + p + let userParam = + let p = ProvidedStaticParameter("User",typeof, "anonymous") + p.AddXmlDoc("The user of the FTP site (default 'anonymous')") + p + let pwdParam = + let p = ProvidedStaticParameter("Password",typeof, "janedoe@contoso.com") + p.AddXmlDoc("The password used to access the FTP site (default 'janedoe@contoso.com')") + p + let useBinary = + let p = ProvidedStaticParameter("UseBinary",typeof, false) + p.AddXmlDoc("sets the data transfer data type to be binary (true) or the default of ascii (false). Binary mode gives a true, exact representation. More often than not is the safer thing to use as this mode will handle both text and binary. Use Ascii mode if you want to transfer text only, and you are happy to let FTP decide on appropriate line break characters translations, etc.") + p + let staticParams = [ siteParam; useBinary; userParam; pwdParam ] + topType.DefineStaticParameters(staticParams, (fun typeName args -> + let site = args.[0] :?> string + let useBinary = args.[1] :?> bool + let user = args.[2] :?> string + let pwd = args.[3] :?> string + createTypes(typeName, site, useBinary, user, pwd))) // pass in top type details + this.AddNamespace(nameSpace, [topType]) + +[] +do () + +// TODO +// ---- + +// TODO.1: pick up FTP courtesy details from environment variables? +// TODO.2: add progress updates via intellisense? ie. | | and |**** underneath for a text based left to right gauge +// TODO.3: return `notfound or exception on error +// TODO.6: add diag info to intellisense to cover command line + also IDE support (ie. so that it's transparent irrespective of usage style) +// TODO.8: include ways to get file sizes + +// BUG +// --- +// BUG.2: this text is not showing up in intellisense + + +// NOTES +// ----- +// NB. possibly the original example Don translated to F# live? https://msdn.microsoft.com/en-us/library/ms229711%28v=vs.110%29.aspx?f=255&MSPPError=-2147217396 diff --git a/FtpProvider/FtpProvider/FtpTypeProvider.fsproj b/FtpProvider/FtpProvider/FtpTypeProvider.fsproj index d19b7e4..3d4b680 100644 --- a/FtpProvider/FtpProvider/FtpTypeProvider.fsproj +++ b/FtpProvider/FtpProvider/FtpTypeProvider.fsproj @@ -51,7 +51,6 @@ - diff --git a/FtpProvider/FtpProvider/packages.config b/FtpProvider/FtpProvider/packages.config deleted file mode 100644 index 97faf56..0000000 --- a/FtpProvider/FtpProvider/packages.config +++ /dev/null @@ -1,4 +0,0 @@ - - - - \ No newline at end of file diff --git a/FtpProvider/ide.cmd b/FtpProvider/ide.cmd new file mode 100644 index 0000000..4427fc3 --- /dev/null +++ b/FtpProvider/ide.cmd @@ -0,0 +1,3 @@ +@REM it's better to load .fsx files in a different process, because when you are in a compile->test->compile loop, it's easier to kill off any references +@REM the VS IDE might make on your behalf just by having the .fsx file open. Saves you getting caught out asking intermittantly, 'why isn't it copying after compiling okay?' +devenv test.fsx diff --git a/FtpProvider/test.cmd b/FtpProvider/test.cmd new file mode 100644 index 0000000..4156dd1 --- /dev/null +++ b/FtpProvider/test.cmd @@ -0,0 +1,3 @@ +@fsc will compile and run test.fsx (ie. emulate fsi / VS Intellisense "interpreting" the dotted-into sub phrases) +@This way there are no side effects for the VS IDE. It's a cleaner way to test, because the process will die after being run and release any .dll file locks it may have so that you can compile again afterwards. +fsc.exe test.fsx diff --git a/FtpProvider/test.fsx b/FtpProvider/test.fsx index 0a5bf86..a210b4b 100644 --- a/FtpProvider/test.fsx +++ b/FtpProvider/test.fsx @@ -1,7 +1,10 @@ +open System #r @"FtpProvider\bin\Debug\FtpTypeProvider.dll" -type F = FSharp.Management.FtpProvider<"ftp://ftp.ncbi.nlm.nih.gov/"> +type F = FSharp.Management.FtpProvider<"ftp://ftp.ncbi.nlm.nih.gov/",false> -F.genomes.Drosophila_melanogaster.``RELEASE_4.1``.CHR_2.``NT_033778.faa``.Contests +let file = F.genomes.Drosophila_melanogaster.``RELEASE_4.1``.CHR_2.``NT_033778.asn``.GetContents +file :?> string |> (fun s->s.Substring(0,500)) -// F.genomes.Buceros_rhinoceros_silvestris.RNA.``Gnomon.mRNA.fsa.gz`` +let file2 = F.genomes.Drosophila_melanogaster.``RELEASE_4.1``.CHR_2.``NT_033778.asn``.GetContentsAsync +Async.RunSynchronously file2 diff --git a/MyFirstTypeProvider-Pristine/MyFirstTypeProvider.sln b/MyFirstTypeProvider-Pristine/MyFirstTypeProvider.sln deleted file mode 100644 index 1a33eb3..0000000 --- a/MyFirstTypeProvider-Pristine/MyFirstTypeProvider.sln +++ /dev/null @@ -1,22 +0,0 @@ - -Microsoft Visual Studio Solution File, Format Version 12.00 -# Visual Studio 2013 -VisualStudioVersion = 12.0.31101.0 -MinimumVisualStudioVersion = 10.0.40219.1 -Project("{F2A71F9B-5D33-465A-A702-920D77279786}") = "MyFirstTypeProvider", "MyFirstTypeProvider\MyFirstTypeProvider.fsproj", "{B8B2F477-FE17-417E-A95D-3E8AAE7FEF89}" -EndProject -Global - GlobalSection(SolutionConfigurationPlatforms) = preSolution - Debug|Any CPU = Debug|Any CPU - Release|Any CPU = Release|Any CPU - EndGlobalSection - GlobalSection(ProjectConfigurationPlatforms) = postSolution - {B8B2F477-FE17-417E-A95D-3E8AAE7FEF89}.Debug|Any CPU.ActiveCfg = Debug|Any CPU - {B8B2F477-FE17-417E-A95D-3E8AAE7FEF89}.Debug|Any CPU.Build.0 = Debug|Any CPU - {B8B2F477-FE17-417E-A95D-3E8AAE7FEF89}.Release|Any CPU.ActiveCfg = Release|Any CPU - {B8B2F477-FE17-417E-A95D-3E8AAE7FEF89}.Release|Any CPU.Build.0 = Release|Any CPU - EndGlobalSection - GlobalSection(SolutionProperties) = preSolution - HideSolutionNode = FALSE - EndGlobalSection -EndGlobal diff --git a/MyFirstTypeProvider-Pristine/MyFirstTypeProvider/Library1.fs b/MyFirstTypeProvider-Pristine/MyFirstTypeProvider/Library1.fs deleted file mode 100644 index 13a348c..0000000 --- a/MyFirstTypeProvider-Pristine/MyFirstTypeProvider/Library1.fs +++ /dev/null @@ -1,25 +0,0 @@ -module Mavnn.Blog.TypeProvider - -open ProviderImplementation.ProvidedTypes -open Microsoft.FSharp.Core.CompilerServices -open System.Reflection - -[] -type MavnnProvider (config : TypeProviderConfig) as this = - inherit TypeProviderForNamespaces () - - let ns = "Mavnn.Blog.TypeProvider.Provided" - let asm = Assembly.GetExecutingAssembly() - - let createTypes () = - let myType = ProvidedTypeDefinition(asm, ns, "MyType", Some typeof) - let myProp = ProvidedProperty("MyProperty", typeof, IsStatic = true, - GetterCode = (fun args -> <@@ "Hello world" @@>)) - myType.AddMember(myProp) - [myType] - - do - this.AddNamespace(ns, createTypes()) - -[] -do () diff --git a/MyFirstTypeProvider-Pristine/MyFirstTypeProvider/MyFirstTypeProvider.fsproj b/MyFirstTypeProvider-Pristine/MyFirstTypeProvider/MyFirstTypeProvider.fsproj deleted file mode 100644 index 0b4ac99..0000000 --- a/MyFirstTypeProvider-Pristine/MyFirstTypeProvider/MyFirstTypeProvider.fsproj +++ /dev/null @@ -1,73 +0,0 @@ - - - - - Debug - AnyCPU - 2.0 - b8b2f477-fe17-417e-a95d-3e8aae7fef89 - Library - MyFirstTypeProvider - MyFirstTypeProvider - v4.5 - 4.3.1.0 - MyFirstTypeProvider - - - true - full - false - false - bin\Debug\ - DEBUG;TRACE - 3 - bin\Debug\MyFirstTypeProvider.XML - - - pdbonly - true - true - bin\Release\ - TRACE - 3 - bin\Release\MyFirstTypeProvider.XML - - - 11 - - - - - $(MSBuildExtensionsPath32)\..\Microsoft SDKs\F#\3.0\Framework\v4.0\Microsoft.FSharp.Targets - - - - - $(MSBuildExtensionsPath32)\Microsoft\VisualStudio\v$(VisualStudioVersion)\FSharp\Microsoft.FSharp.Targets - - - - - - - - - - - - - - True - - - - - - - \ No newline at end of file diff --git a/MyFirstTypeProvider-Pristine/MyFirstTypeProvider/ProvidedTypes.fs b/MyFirstTypeProvider-Pristine/MyFirstTypeProvider/ProvidedTypes.fs deleted file mode 100644 index 4bcd1d0..0000000 --- a/MyFirstTypeProvider-Pristine/MyFirstTypeProvider/ProvidedTypes.fs +++ /dev/null @@ -1,2662 +0,0 @@ -#nowarn "40" -#nowarn "52" -// Based on code for the F# 3.0 Developer Preview release of September 2011, -// Copyright (c) Microsoft Corporation 2005-2012. -// This sample code is provided "as is" without warranty of any kind. -// We disclaim all warranties, either express or implied, including the -// warranties of merchantability and fitness for a particular purpose. - -// This file contains a set of helper types and methods for providing types in an implementation -// of ITypeProvider. - -// This code has been modified and is appropriate for use in conjunction with the F# 3.0, F# 3.1, and F# 3.1.1 releases - -namespace ProviderImplementation.ProvidedTypes - -open System -open System.Text -open System.IO -open System.Reflection -open System.Reflection.Emit -open System.Linq.Expressions -open System.Collections.Generic -open Microsoft.FSharp.Core.CompilerServices - -type E = Quotations.Expr -module P = Quotations.Patterns -module ES = Quotations.ExprShape -module DP = Quotations.DerivedPatterns - -type internal ExpectedStackState = - | Empty = 1 - | Address = 2 - | Value = 3 - -[] -module internal Misc = - let TypeBuilderInstantiationType = - let runningOnMono = try System.Type.GetType("Mono.Runtime") <> null with e -> false - let typeName = if runningOnMono then "System.Reflection.MonoGenericClass" else "System.Reflection.Emit.TypeBuilderInstantiation" - typeof.Assembly.GetType(typeName) - let GetTypeFromHandleMethod = typeof.GetMethod("GetTypeFromHandle") - let LanguagePrimitivesType = typedefof>.Assembly.GetType("Microsoft.FSharp.Core.LanguagePrimitives") - let ParseInt32Method = LanguagePrimitivesType.GetMethod "ParseInt32" - let DecimalConstructor = typeof.GetConstructor([| typeof; typeof; typeof; typeof; typeof |]) - let DateTimeConstructor = typeof.GetConstructor([| typeof; typeof |]) - let DateTimeOffsetConstructor = typeof.GetConstructor([| typeof; typeof |]) - let TimeSpanConstructor = typeof.GetConstructor([|typeof|]) - let isEmpty s = s = ExpectedStackState.Empty - let isAddress s = s = ExpectedStackState.Address - - let nonNull str x = if x=null then failwith ("Null in " + str) else x - - let notRequired opname item = - let msg = sprintf "The operation '%s' on item '%s' should not be called on provided type, member or parameter" opname item - System.Diagnostics.Debug.Assert (false, msg) - raise (System.NotSupportedException msg) - - let mkParamArrayCustomAttributeData() = -#if FX_NO_CUSTOMATTRIBUTEDATA - { new IProvidedCustomAttributeData with -#else - { new CustomAttributeData() with -#endif - member __.Constructor = typeof.GetConstructors().[0] - member __.ConstructorArguments = upcast [| |] - member __.NamedArguments = upcast [| |] } - -#if FX_NO_CUSTOMATTRIBUTEDATA - let CustomAttributeTypedArgument(ty,v) = - { new IProvidedCustomAttributeTypedArgument with - member x.ArgumentType = ty - member x.Value = v } - let CustomAttributeNamedArgument(memb,arg:IProvidedCustomAttributeTypedArgument) = - { new IProvidedCustomAttributeNamedArgument with - member x.MemberInfo = memb - member x.ArgumentType = arg.ArgumentType - member x.TypedValue = arg } - type CustomAttributeData = Microsoft.FSharp.Core.CompilerServices.IProvidedCustomAttributeData -#endif - - let mkEditorHideMethodsCustomAttributeData() = -#if FX_NO_CUSTOMATTRIBUTEDATA - { new IProvidedCustomAttributeData with -#else - { new CustomAttributeData() with -#endif - member __.Constructor = typeof.GetConstructors().[0] - member __.ConstructorArguments = upcast [| |] - member __.NamedArguments = upcast [| |] } - - let mkAllowNullLiteralCustomAttributeData value = -#if FX_NO_CUSTOMATTRIBUTEDATA - { new IProvidedCustomAttributeData with -#else - { new CustomAttributeData() with -#endif - member __.Constructor = typeof.GetConstructors().[0] - member __.ConstructorArguments = upcast [| CustomAttributeTypedArgument(typeof, value) |] - member __.NamedArguments = upcast [| |] } - - /// This makes an xml doc attribute w.r.t. an amortized computation of an xml doc string. - /// It is important that the text of the xml doc only get forced when poking on the ConstructorArguments - /// for the CustomAttributeData object. - let mkXmlDocCustomAttributeDataLazy(lazyText: Lazy) = -#if FX_NO_CUSTOMATTRIBUTEDATA - { new IProvidedCustomAttributeData with -#else - { new CustomAttributeData() with -#endif - member __.Constructor = typeof.GetConstructors().[0] - member __.ConstructorArguments = upcast [| CustomAttributeTypedArgument(typeof, lazyText.Force()) |] - member __.NamedArguments = upcast [| |] } - - let mkXmlDocCustomAttributeData(s:string) = mkXmlDocCustomAttributeDataLazy (lazy s) - - let mkDefinitionLocationAttributeCustomAttributeData(line:int,column:int,filePath:string) = -#if FX_NO_CUSTOMATTRIBUTEDATA - { new IProvidedCustomAttributeData with -#else - { new CustomAttributeData() with -#endif - member __.Constructor = typeof.GetConstructors().[0] - member __.ConstructorArguments = upcast [| |] - member __.NamedArguments = - upcast [| CustomAttributeNamedArgument(typeof.GetProperty("FilePath"), CustomAttributeTypedArgument(typeof, filePath)); - CustomAttributeNamedArgument(typeof.GetProperty("Line"), CustomAttributeTypedArgument(typeof, line)) ; - CustomAttributeNamedArgument(typeof.GetProperty("Column"), CustomAttributeTypedArgument(typeof, column)) - |] } - let mkObsoleteAttributeCustomAttributeData(message:string, isError: bool) = -#if FX_NO_CUSTOMATTRIBUTEDATA - { new IProvidedCustomAttributeData with -#else - { new CustomAttributeData() with -#endif - member __.Constructor = typeof.GetConstructors() |> Array.find (fun x -> x.GetParameters().Length = 1) - member __.ConstructorArguments = upcast [|CustomAttributeTypedArgument(typeof, message) ; CustomAttributeTypedArgument(typeof, isError) |] - member __.NamedArguments = upcast [| |] } - - type CustomAttributesImpl() = - let customAttributes = ResizeArray() - let mutable hideObjectMethods = false - let mutable nonNullable = false - let mutable obsoleteMessage = None - let mutable xmlDocDelayed = None - let mutable xmlDocAlwaysRecomputed = None - let mutable hasParamArray = false - - // XML doc text that we only compute once, if any. This must _not_ be forced until the ConstructorArguments - // property of the custom attribute is foced. - let xmlDocDelayedText = - lazy - (match xmlDocDelayed with None -> assert false; "" | Some f -> f()) - - // Custom atttributes that we only compute once - let customAttributesOnce = - lazy - [| if hideObjectMethods then yield mkEditorHideMethodsCustomAttributeData() - if nonNullable then yield mkAllowNullLiteralCustomAttributeData false - match xmlDocDelayed with None -> () | Some _ -> customAttributes.Add(mkXmlDocCustomAttributeDataLazy xmlDocDelayedText) - match obsoleteMessage with None -> () | Some s -> customAttributes.Add(mkObsoleteAttributeCustomAttributeData s) - if hasParamArray then yield mkParamArrayCustomAttributeData() - yield! customAttributes |] - - member __.AddDefinitionLocation(line:int,column:int,filePath:string) = customAttributes.Add(mkDefinitionLocationAttributeCustomAttributeData(line, column, filePath)) - member __.AddObsolete(msg : string, isError) = obsoleteMessage <- Some (msg,isError) - member __.HasParamArray with get() = hasParamArray and set(v) = hasParamArray <- v - member __.AddXmlDocComputed(xmlDoc : unit -> string) = xmlDocAlwaysRecomputed <- Some xmlDoc - member __.AddXmlDocDelayed(xmlDoc : unit -> string) = xmlDocDelayed <- Some xmlDoc - member this.AddXmlDoc(text:string) = this.AddXmlDocDelayed (fun () -> text) - member __.HideObjectMethods with set v = hideObjectMethods <- v - member __.NonNullable with set v = nonNullable <- v - member __.AddCustomAttribute(attribute) = customAttributes.Add(attribute) - member __.GetCustomAttributesData() = - [| yield! customAttributesOnce.Force() - match xmlDocAlwaysRecomputed with None -> () | Some f -> customAttributes.Add(mkXmlDocCustomAttributeData (f())) |] - :> IList<_> - - let transExpr isGenerated q = - let rec trans q = - match q with - // convert NewTuple to the call to the constructor of the Tuple type (only for generated types) - | Quotations.Patterns.NewTuple(items) when isGenerated -> - let rec mkCtor args ty = - let ctor, restTyOpt = Reflection.FSharpValue.PreComputeTupleConstructorInfo ty - match restTyOpt with - | None -> Quotations.Expr.NewObject(ctor, List.map trans args) - | Some restTy -> - let curr = [for a in Seq.take 7 args -> trans a] - let rest = List.ofSeq (Seq.skip 7 args) - Quotations.Expr.NewObject(ctor, curr @ [mkCtor rest restTy]) - let tys = [| for e in items -> e.Type |] - let tupleTy = Reflection.FSharpType.MakeTupleType tys - trans (mkCtor items tupleTy) - // convert TupleGet to the chain of PropertyGet calls (only for generated types) - | Quotations.Patterns.TupleGet(e, i) when isGenerated -> - let rec mkGet ty i (e : Quotations.Expr) = - let pi, restOpt = Reflection.FSharpValue.PreComputeTuplePropertyInfo(ty, i) - let propGet = Quotations.Expr.PropertyGet(e, pi) - match restOpt with - | None -> propGet - | Some (restTy, restI) -> mkGet restTy restI propGet - trans (mkGet e.Type i (trans e)) - | Quotations.Patterns.Value(value, ty) -> - if value <> null then - let tyOfValue = value.GetType() - transValue(value, tyOfValue, ty) - else q - // Eliminate F# property gets to method calls - | Quotations.Patterns.PropertyGet(obj,propInfo,args) -> - match obj with - | None -> trans (Quotations.Expr.Call(propInfo.GetGetMethod(),args)) - | Some o -> trans (Quotations.Expr.Call(trans o,propInfo.GetGetMethod(),args)) - // Eliminate F# property sets to method calls - | Quotations.Patterns.PropertySet(obj,propInfo,args,v) -> - match obj with - | None -> trans (Quotations.Expr.Call(propInfo.GetSetMethod(),args@[v])) - | Some o -> trans (Quotations.Expr.Call(trans o,propInfo.GetSetMethod(),args@[v])) - // Eliminate F# function applications to FSharpFunc<_,_>.Invoke calls - | Quotations.Patterns.Application(f,e) -> - trans (Quotations.Expr.Call(trans f, f.Type.GetMethod "Invoke", [ e ]) ) - | Quotations.Patterns.NewUnionCase(ci, es) -> - trans (Quotations.Expr.Call(Reflection.FSharpValue.PreComputeUnionConstructorInfo ci, es) ) - | Quotations.Patterns.NewRecord(ci, es) -> - trans (Quotations.Expr.NewObject(Reflection.FSharpValue.PreComputeRecordConstructorInfo ci, es) ) - | Quotations.Patterns.UnionCaseTest(e,uc) -> - let tagInfo = Reflection.FSharpValue.PreComputeUnionTagMemberInfo uc.DeclaringType - let tagExpr = - match tagInfo with - | :? PropertyInfo as tagProp -> - trans (Quotations.Expr.PropertyGet(e,tagProp) ) - | :? MethodInfo as tagMeth -> - if tagMeth.IsStatic then trans (Quotations.Expr.Call(tagMeth, [e])) - else trans (Quotations.Expr.Call(e,tagMeth,[])) - | _ -> failwith "unreachable: unexpected result from PreComputeUnionTagMemberInfo" - let tagNumber = uc.Tag - trans <@@ (%%(tagExpr) : int) = tagNumber @@> - - // Explicitly handle weird byref variables in lets (used to populate out parameters), since the generic handlers can't deal with byrefs - | Quotations.Patterns.Let(v,vexpr,bexpr) when v.Type.IsByRef -> - - // the binding must have leaves that are themselves variables (due to the limited support for byrefs in expressions) - // therefore, we can perform inlining to translate this to a form that can be compiled - inlineByref v vexpr bexpr - - // Eliminate recursive let bindings (which are unsupported by the type provider API) to regular let bindings - | Quotations.Patterns.LetRecursive(bindings, expr) -> - // This uses a "lets and sets" approach, converting something like - // let rec even = function - // | 0 -> true - // | n -> odd (n-1) - // and odd = function - // | 0 -> false - // | n -> even (n-1) - // X - // to something like - // let even = ref Unchecked.defaultof<_> - // let odd = ref Unchecked.defaultof<_> - // even := function - // | 0 -> true - // | n -> !odd (n-1) - // odd := function - // | 0 -> false - // | n -> !even (n-1) - // X' - // where X' is X but with occurrences of even/odd substituted by !even and !odd (since now even and odd are references) - // Translation relies on typedefof<_ ref> - does this affect ability to target different runtime and design time environments? - let vars = List.map fst bindings - let vars' = vars |> List.map (fun v -> Quotations.Var(v.Name, typedefof<_ ref>.MakeGenericType(v.Type))) - - // init t generates the equivalent of <@ ref Unchecked.defaultof @> - let init (t:Type) = - let r = match <@ ref 1 @> with Quotations.Patterns.Call(None, r, [_]) -> r | _ -> failwith "Extracting MethodInfo from <@ 1 @> failed" - let d = match <@ Unchecked.defaultof<_> @> with Quotations.Patterns.Call(None, d, []) -> d | _ -> failwith "Extracting MethodInfo from <@ Unchecked.defaultof<_> @> failed" - Quotations.Expr.Call(r.GetGenericMethodDefinition().MakeGenericMethod(t), [Quotations.Expr.Call(d.GetGenericMethodDefinition().MakeGenericMethod(t),[])]) - - // deref v generates the equivalent of <@ !v @> - // (so v's type must be ref) - let deref (v:Quotations.Var) = - let m = match <@ !(ref 1) @> with Quotations.Patterns.Call(None, m, [_]) -> m | _ -> failwith "Extracting MethodInfo from <@ !(ref 1) @> failed" - let tyArgs = v.Type.GetGenericArguments() - Quotations.Expr.Call(m.GetGenericMethodDefinition().MakeGenericMethod(tyArgs), [Quotations.Expr.Var v]) - - // substitution mapping a variable v to the expression <@ !v' @> using the corresponding new variable v' of ref type - let subst = - let map = - vars' - |> List.map deref - |> List.zip vars - |> Map.ofList - fun v -> Map.tryFind v map - - let expr' = expr.Substitute(subst) - - // maps variables to new variables - let varDict = List.zip vars vars' |> dict - - // given an old variable v and an expression e, returns a quotation like <@ v' := e @> using the corresponding new variable v' of ref type - let setRef (v:Quotations.Var) e = - let m = match <@ (ref 1) := 2 @> with Quotations.Patterns.Call(None, m, [_;_]) -> m | _ -> failwith "Extracting MethodInfo from <@ (ref 1) := 2 @> failed" - Quotations.Expr.Call(m.GetGenericMethodDefinition().MakeGenericMethod(v.Type), [Quotations.Expr.Var varDict.[v]; e]) - - // Something like - // <@ - // v1 := e1' - // v2 := e2' - // ... - // expr' - // @> - // Note that we must substitute our new variable dereferences into the bound expressions - let body = - bindings - |> List.fold (fun b (v,e) -> Quotations.Expr.Sequential(setRef v (e.Substitute subst), b)) expr' - - // Something like - // let v1 = ref Unchecked.defaultof - // let v2 = ref Unchecked.defaultof - // ... - // body - vars - |> List.fold (fun b v -> Quotations.Expr.Let(varDict.[v], init v.Type, b)) body - |> trans - - // Handle the generic cases - | Quotations.ExprShape.ShapeLambda(v,body) -> - Quotations.Expr.Lambda(v, trans body) - | Quotations.ExprShape.ShapeCombination(comb,args) -> - Quotations.ExprShape.RebuildShapeCombination(comb,List.map trans args) - | Quotations.ExprShape.ShapeVar _ -> q - and inlineByref v vexpr bexpr = - match vexpr with - | Quotations.Patterns.Sequential(e',vexpr') -> - (* let v = (e'; vexpr') in bexpr => e'; let v = vexpr' in bexpr *) - Quotations.Expr.Sequential(e', inlineByref v vexpr' bexpr) - |> trans - | Quotations.Patterns.IfThenElse(c,b1,b2) -> - (* let v = if c then b1 else b2 in bexpr => if c then let v = b1 in bexpr else let v = b2 in bexpr *) - Quotations.Expr.IfThenElse(c, inlineByref v b1 bexpr, inlineByref v b2 bexpr) - |> trans - | Quotations.Patterns.Var _ -> - (* let v = v1 in bexpr => bexpr[v/v1] *) - bexpr.Substitute(fun v' -> if v = v' then Some vexpr else None) - |> trans - | _ -> - failwith (sprintf "Unexpected byref binding: %A = %A" v vexpr) - and transValue (v : obj, tyOfValue : Type, expectedTy : Type) = - let rec transArray (o : Array, ty : Type) = - let elemTy = ty.GetElementType() - let converter = getConverterForType elemTy - let elements = - [ - for el in o do - yield converter el - ] - Quotations.Expr.NewArray(elemTy, elements) - and transList(o, ty : Type, nil, cons) = - let converter = getConverterForType (ty.GetGenericArguments().[0]) - o - |> Seq.cast - |> List.ofSeq - |> fun l -> List.foldBack(fun o s -> Quotations.Expr.NewUnionCase(cons, [ converter(o); s ])) l (Quotations.Expr.NewUnionCase(nil, [])) - |> trans - and getConverterForType (ty : Type) = - if ty.IsArray then - fun (v : obj) -> transArray(v :?> Array, ty) - elif ty.IsGenericType && ty.GetGenericTypeDefinition() = typedefof<_ list> then - let nil, cons = - let cases = Reflection.FSharpType.GetUnionCases(ty) - let a = cases.[0] - let b = cases.[1] - if a.Name = "Empty" then a,b - else b,a - - fun v -> transList (v :?> System.Collections.IEnumerable, ty, nil, cons) - else - fun v -> Quotations.Expr.Value(v, ty) - let converter = getConverterForType tyOfValue - let r = converter v - if tyOfValue <> expectedTy then Quotations.Expr.Coerce(r, expectedTy) - else r - trans q - - let getFastFuncType (args : list) resultType = - let types = - [| - for arg in args -> arg.Type - yield resultType - |] - let fastFuncTy = - match List.length args with - | 2 -> typedefof>.MakeGenericType(types) - | 3 -> typedefof>.MakeGenericType(types) - | 4 -> typedefof>.MakeGenericType(types) - | 5 -> typedefof>.MakeGenericType(types) - | _ -> invalidArg "args" "incorrect number of arguments" - fastFuncTy.GetMethod("Adapt") - - let inline (===) a b = LanguagePrimitives.PhysicalEquality a b - - let traverse f = - let rec fallback e = - match e with - | P.Let(v, value, body) -> - let fixedValue = f fallback value - let fixedBody = f fallback body - if fixedValue === value && fixedBody === body then - e - else - E.Let(v, fixedValue, fixedBody) - | ES.ShapeVar _ -> e - | ES.ShapeLambda(v, body) -> - let fixedBody = f fallback body - if fixedBody === body then - e - else - E.Lambda(v, fixedBody) - | ES.ShapeCombination(shape, exprs) -> - let exprs1 = List.map (f fallback) exprs - if List.forall2 (===) exprs exprs1 then - e - else - ES.RebuildShapeCombination(shape, exprs1) - fun e -> f fallback e - - let RightPipe = <@@ (|>) @@> - let inlineRightPipe expr = - let rec loop expr = traverse loopCore expr - and loopCore fallback orig = - match orig with - | DP.SpecificCall RightPipe (None, _, [operand; applicable]) -> - let fixedOperand = loop operand - match loop applicable with - | P.Lambda(arg, body) -> - let v = Quotations.Var("__temp", operand.Type) - let ev = E.Var v - - let fixedBody = loop body - E.Let(v, fixedOperand, fixedBody.Substitute(fun v1 -> if v1 = arg then Some ev else None)) - | fixedApplicable -> E.Application(fixedApplicable, fixedOperand) - | x -> fallback x - loop expr - - let inlineValueBindings e = - let map = Dictionary(HashIdentity.Reference) - let rec loop expr = traverse loopCore expr - and loopCore fallback orig = - match orig with - | P.Let(id, (P.Value(_) as v), body) when not id.IsMutable -> - map.[id] <- v - let fixedBody = loop body - map.Remove(id) |> ignore - fixedBody - | ES.ShapeVar v -> - match map.TryGetValue v with - | true, e -> e - | _ -> orig - | x -> fallback x - loop e - - - let optimizeCurriedApplications expr = - let rec loop expr = traverse loopCore expr - and loopCore fallback orig = - match orig with - | P.Application(e, arg) -> - let e1 = tryPeelApplications e [loop arg] - if e1 === e then - orig - else - e1 - | x -> fallback x - and tryPeelApplications orig args = - let n = List.length args - match orig with - | P.Application(e, arg) -> - let e1 = tryPeelApplications e ((loop arg)::args) - if e1 === e then - orig - else - e1 - | P.Let(id, applicable, (P.Lambda(_) as body)) when n > 0 -> - let numberOfApplication = countPeelableApplications body id 0 - if numberOfApplication = 0 then orig - elif n = 1 then E.Application(applicable, List.head args) - elif n <= 5 then - let resultType = - applicable.Type - |> Seq.unfold (fun t -> - if not t.IsGenericType then None - else - let args = t.GetGenericArguments() - if args.Length <> 2 then None - else - Some (args.[1], args.[1]) - ) - |> Seq.nth (n - 1) - - let adaptMethod = getFastFuncType args resultType - let adapted = E.Call(adaptMethod, [loop applicable]) - let invoke = adapted.Type.GetMethod("Invoke", [| for arg in args -> arg.Type |]) - E.Call(adapted, invoke, args) - else - (applicable, args) ||> List.fold (fun e a -> E.Application(e, a)) - | _ -> - orig - and countPeelableApplications expr v n = - match expr with - // v - applicable entity obtained on the prev step - // \arg -> let v1 = (f arg) in rest ==> f - | P.Lambda(arg, P.Let(v1, P.Application(P.Var f, P.Var arg1), rest)) when v = f && arg = arg1 -> countPeelableApplications rest v1 (n + 1) - // \arg -> (f arg) ==> f - | P.Lambda(arg, P.Application(P.Var f, P.Var arg1)) when v = f && arg = arg1 -> n - | _ -> n - loop expr - - // FSharp.Data change: use the real variable names instead of indices, to improve output of Debug.fs - let transQuotationToCode isGenerated qexprf (paramNames: string[]) (argExprs: Quotations.Expr[]) = - // add let bindings for arguments to ensure that arguments will be evaluated - let vars = argExprs |> Array.mapi (fun i e -> Quotations.Var(paramNames.[i], e.Type)) - let expr = qexprf ([for v in vars -> Quotations.Expr.Var v]) - - let pairs = Array.zip argExprs vars - let expr = Array.foldBack (fun (arg, var) e -> Quotations.Expr.Let(var, arg, e)) pairs expr - let expr = - if isGenerated then - let e1 = inlineRightPipe expr - let e2 = optimizeCurriedApplications e1 - let e3 = inlineValueBindings e2 - e3 - else - expr - - transExpr isGenerated expr - - let adjustTypeAttributes attributes isNested = - let visibilityAttributes = - match attributes &&& TypeAttributes.VisibilityMask with - | TypeAttributes.Public when isNested -> TypeAttributes.NestedPublic - | TypeAttributes.NotPublic when isNested -> TypeAttributes.NestedAssembly - | TypeAttributes.NestedPublic when not isNested -> TypeAttributes.Public - | TypeAttributes.NestedAssembly - | TypeAttributes.NestedPrivate - | TypeAttributes.NestedFamORAssem - | TypeAttributes.NestedFamily - | TypeAttributes.NestedFamANDAssem when not isNested -> TypeAttributes.NotPublic - | a -> a - (attributes &&& ~~~TypeAttributes.VisibilityMask) ||| visibilityAttributes - -type ProvidedStaticParameter(parameterName:string,parameterType:Type,?parameterDefaultValue:obj) = - inherit System.Reflection.ParameterInfo() - - let customAttributesImpl = CustomAttributesImpl() - member __.AddXmlDocDelayed(xmlDoc : unit -> string) = customAttributesImpl.AddXmlDocDelayed xmlDoc - member __.AddXmlDocComputed(xmlDoc : unit -> string) = customAttributesImpl.AddXmlDocComputed xmlDoc - member this.AddXmlDoc(text:string) = customAttributesImpl.AddXmlDoc text - - override __.RawDefaultValue = defaultArg parameterDefaultValue null - override __.Attributes = if parameterDefaultValue.IsNone then enum 0 else ParameterAttributes.Optional - override __.Position = 0 - override __.ParameterType = parameterType - override __.Name = parameterName - - override __.GetCustomAttributes(_inherit) = ignore(_inherit); notRequired "GetCustomAttributes" parameterName - override __.GetCustomAttributes(_attributeType, _inherit) = notRequired "GetCustomAttributes" parameterName - -type ProvidedParameter(name:string,parameterType:Type,?isOut:bool,?optionalValue:obj) = - inherit System.Reflection.ParameterInfo() - let customAttributesImpl = CustomAttributesImpl() - let isOut = defaultArg isOut false - member this.IsParamArray with get() = customAttributesImpl.HasParamArray and set(v) = customAttributesImpl.HasParamArray <- v - override this.Name = name - override this.ParameterType = parameterType - override this.Attributes = (base.Attributes ||| (if isOut then ParameterAttributes.Out else enum 0) - ||| (match optionalValue with None -> enum 0 | Some _ -> ParameterAttributes.Optional ||| ParameterAttributes.HasDefault)) - override this.RawDefaultValue = defaultArg optionalValue null - member this.HasDefaultParameterValue = Option.isSome optionalValue - member __.GetCustomAttributesDataImpl() = customAttributesImpl.GetCustomAttributesData() -#if FX_NO_CUSTOMATTRIBUTEDATA -#else - override __.GetCustomAttributesData() = customAttributesImpl.GetCustomAttributesData() -#endif - -type ProvidedConstructor(parameters : ProvidedParameter list) = - inherit ConstructorInfo() - let parameters = parameters |> List.map (fun p -> p :> ParameterInfo) - let mutable baseCall = None - - let mutable declaringType = null : System.Type - let mutable invokeCode = None : option Quotations.Expr> - let mutable isImplicitCtor = false - let mutable ctorAttributes = MethodAttributes.Public ||| MethodAttributes.RTSpecialName - let nameText () = sprintf "constructor for %s" (if declaringType=null then "" else declaringType.FullName) - - let customAttributesImpl = CustomAttributesImpl() - member this.IsTypeInitializer - with get() = ctorAttributes.HasFlag(MethodAttributes.Static) && ctorAttributes.HasFlag(MethodAttributes.Private) - and set(v) = - let typeInitializerAttributes = MethodAttributes.Static ||| MethodAttributes.Private - ctorAttributes <- if v then ctorAttributes ||| typeInitializerAttributes else ctorAttributes &&& ~~~typeInitializerAttributes - - member this.AddXmlDocComputed xmlDoc = customAttributesImpl.AddXmlDocComputed xmlDoc - member this.AddXmlDocDelayed xmlDoc = customAttributesImpl.AddXmlDocDelayed xmlDoc - member this.AddXmlDoc xmlDoc = customAttributesImpl.AddXmlDoc xmlDoc - member this.AddObsoleteAttribute (msg,?isError) = customAttributesImpl.AddObsolete (msg,defaultArg isError false) - member this.AddDefinitionLocation(line,column,filePath) = customAttributesImpl.AddDefinitionLocation(line, column, filePath) - member __.GetCustomAttributesDataImpl() = customAttributesImpl.GetCustomAttributesData() -#if FX_NO_CUSTOMATTRIBUTEDATA -#else - override this.GetCustomAttributesData() = customAttributesImpl.GetCustomAttributesData() -#endif - - member this.DeclaringTypeImpl - with set x = - if declaringType<>null then failwith (sprintf "ProvidedConstructor: declaringType already set on '%s'" (nameText())); - declaringType <- x - - member this.InvokeCode - with set (q:Quotations.Expr list -> Quotations.Expr) = - match invokeCode with - | None -> invokeCode <- Some q - | Some _ -> failwith (sprintf "ProvidedConstructor: code already given for '%s'" (nameText())) - - member this.BaseConstructorCall - with set (d:Quotations.Expr list -> (ConstructorInfo * Quotations.Expr list)) = - match baseCall with - | None -> baseCall <- Some d - | Some _ -> failwith (sprintf "ProvidedConstructor: base call already given for '%s'" (nameText())) - - member this.GetInvokeCodeInternal isGenerated = - match invokeCode with - | Some f -> - // FSharp.Data change: use the real variable names instead of indices, to improve output of Debug.fs - let paramNames = - parameters - |> List.map (fun p -> p.Name) - |> List.append (if not isGenerated || this.IsStatic then [] else ["this"]) - |> Array.ofList - transQuotationToCode isGenerated f paramNames - | None -> failwith (sprintf "ProvidedConstructor: no invoker for '%s'" (nameText())) - - member this.GetBaseConstructorCallInternal isGenerated = - match baseCall with - | Some f -> Some(fun ctorArgs -> let c,baseCtorArgExprs = f ctorArgs in c, List.map (transExpr isGenerated) baseCtorArgExprs) - | None -> None - member this.IsImplicitCtor with get() = isImplicitCtor and set v = isImplicitCtor <- v - - // Implement overloads - override this.GetParameters() = parameters |> List.toArray - override this.Attributes = ctorAttributes - override this.Name = if this.IsStatic then ".cctor" else ".ctor" - override this.DeclaringType = declaringType |> nonNull "ProvidedConstructor.DeclaringType" - override this.IsDefined(_attributeType, _inherit) = true - - override this.Invoke(_invokeAttr, _binder, _parameters, _culture) = notRequired "Invoke" (nameText()) - override this.Invoke(_obj, _invokeAttr, _binder, _parameters, _culture) = notRequired "Invoke" (nameText()) - override this.ReflectedType = notRequired "ReflectedType" (nameText()) - override this.GetMethodImplementationFlags() = notRequired "GetMethodImplementationFlags" (nameText()) - override this.MethodHandle = notRequired "MethodHandle" (nameText()) - override this.GetCustomAttributes(_inherit) = notRequired "GetCustomAttributes" (nameText()) - override this.GetCustomAttributes(_attributeType, _inherit) = notRequired "GetCustomAttributes" (nameText()) - -type ProvidedMethod(methodName: string, parameters: ProvidedParameter list, returnType: Type) = - inherit System.Reflection.MethodInfo() - let argParams = parameters |> List.map (fun p -> p :> ParameterInfo) - - // State - let mutable declaringType : Type = null - let mutable methodAttrs = MethodAttributes.Public - let mutable invokeCode = None : option Quotations.Expr> - - let customAttributesImpl = CustomAttributesImpl() - member this.AddXmlDocComputed xmlDoc = customAttributesImpl.AddXmlDocComputed xmlDoc - member this.AddXmlDocDelayed xmlDoc = customAttributesImpl.AddXmlDocDelayed xmlDoc - member this.AddXmlDoc xmlDoc = customAttributesImpl.AddXmlDoc xmlDoc - member this.AddObsoleteAttribute (msg,?isError) = customAttributesImpl.AddObsolete (msg,defaultArg isError false) - member this.AddDefinitionLocation(line,column,filePath) = customAttributesImpl.AddDefinitionLocation(line, column, filePath) - member __.AddCustomAttribute(attribute) = customAttributesImpl.AddCustomAttribute(attribute) - member __.GetCustomAttributesDataImpl() = customAttributesImpl.GetCustomAttributesData() -#if FX_NO_CUSTOMATTRIBUTEDATA -#else - override this.GetCustomAttributesData() = customAttributesImpl.GetCustomAttributesData() -#endif - - member this.SetMethodAttrs m = methodAttrs <- m - member this.AddMethodAttrs m = methodAttrs <- methodAttrs ||| m - member this.DeclaringTypeImpl with set x = declaringType <- x // check: not set twice - member this.IsStaticMethod - with get() = methodAttrs.HasFlag(MethodAttributes.Static) - and set x = if x then methodAttrs <- methodAttrs ||| MethodAttributes.Static - else methodAttrs <- methodAttrs &&& (~~~ MethodAttributes.Static) - member this.InvokeCode - with set (q:Quotations.Expr list -> Quotations.Expr) = - match invokeCode with - | None -> invokeCode <- Some q - | Some _ -> failwith (sprintf "ProvidedConstructor: code already given for %s on type %s" this.Name (if declaringType=null then "" else declaringType.FullName)) - - - member this.GetInvokeCodeInternal isGenerated = - match invokeCode with - | Some f -> - // FSharp.Data change: use the real variable names instead of indices, to improve output of Debug.fs - let paramNames = - parameters - |> List.map (fun p -> p.Name) - |> List.append (if this.IsStatic then [] else ["this"]) - |> Array.ofList - transQuotationToCode isGenerated f paramNames - | None -> failwith (sprintf "ProvidedMethod: no invoker for %s on type %s" this.Name (if declaringType=null then "" else declaringType.FullName)) - // Implement overloads - override this.GetParameters() = argParams |> Array.ofList - override this.Attributes = methodAttrs - override this.Name = methodName - override this.DeclaringType = declaringType |> nonNull "ProvidedMethod.DeclaringType" - override this.IsDefined(_attributeType, _inherit) : bool = true - override this.MemberType = MemberTypes.Method - override this.CallingConvention = - let cc = CallingConventions.Standard - let cc = if not (this.IsStatic) then cc ||| CallingConventions.HasThis else cc - cc - override this.ReturnType = returnType - override this.ReturnParameter = null // REVIEW: Give it a name and type? - override this.ToString() = "Method " + this.Name - - // These don't have to return fully accurate results - they are used - // by the F# Quotations library function SpecificCall as a pre-optimization - // when comparing methods - override this.MetadataToken = hash declaringType + hash this.Name - override this.MethodHandle = RuntimeMethodHandle() - - override this.ReturnTypeCustomAttributes = notRequired "ReturnTypeCustomAttributes" this.Name - override this.GetBaseDefinition() = notRequired "GetBaseDefinition" this.Name - override this.GetMethodImplementationFlags() = notRequired "GetMethodImplementationFlags" this.Name - override this.Invoke(_obj, _invokeAttr, _binder, _parameters, _culture) = notRequired "Invoke" this.Name - override this.ReflectedType = notRequired "ReflectedType" this.Name - override this.GetCustomAttributes(_inherit) = notRequired "GetCustomAttributes" this.Name - override this.GetCustomAttributes(_attributeType, _inherit) = notRequired "GetCustomAttributes" this.Name - - -type ProvidedProperty(propertyName:string,propertyType:Type, ?parameters:ProvidedParameter list) = - inherit System.Reflection.PropertyInfo() - // State - - let parameters = defaultArg parameters [] - let mutable declaringType = null - let mutable isStatic = false - let mutable getterCode = None : option Quotations.Expr> - let mutable setterCode = None : option Quotations.Expr> - - let hasGetter() = getterCode.IsSome - let hasSetter() = setterCode.IsSome - - // Delay construction - to pick up the latest isStatic - let markSpecialName (m:ProvidedMethod) = m.AddMethodAttrs(MethodAttributes.SpecialName); m - let getter = lazy (ProvidedMethod("get_" + propertyName,parameters,propertyType,IsStaticMethod=isStatic,DeclaringTypeImpl=declaringType,InvokeCode=getterCode.Value) |> markSpecialName) - let setter = lazy (ProvidedMethod("set_" + propertyName,parameters @ [ProvidedParameter("value",propertyType)],typeof,IsStaticMethod=isStatic,DeclaringTypeImpl=declaringType,InvokeCode=setterCode.Value) |> markSpecialName) - - let customAttributesImpl = CustomAttributesImpl() - member this.AddXmlDocComputed xmlDoc = customAttributesImpl.AddXmlDocComputed xmlDoc - member this.AddXmlDocDelayed xmlDoc = customAttributesImpl.AddXmlDocDelayed xmlDoc - member this.AddXmlDoc xmlDoc = customAttributesImpl.AddXmlDoc xmlDoc - member this.AddObsoleteAttribute (msg,?isError) = customAttributesImpl.AddObsolete (msg,defaultArg isError false) - member this.AddDefinitionLocation(line,column,filePath) = customAttributesImpl.AddDefinitionLocation(line, column, filePath) - member __.GetCustomAttributesDataImpl() = customAttributesImpl.GetCustomAttributesData() - member this.AddCustomAttribute attribute = customAttributesImpl.AddCustomAttribute attribute -#if FX_NO_CUSTOMATTRIBUTEDATA -#else - override this.GetCustomAttributesData() = customAttributesImpl.GetCustomAttributesData() -#endif - - member this.DeclaringTypeImpl with set x = declaringType <- x // check: not set twice - member this.IsStatic - with get() = isStatic - and set x = isStatic <- x - - member this.GetterCode - with set (q:Quotations.Expr list -> Quotations.Expr) = - if not getter.IsValueCreated then getterCode <- Some q else failwith "ProvidedProperty: getter MethodInfo has already been created" - - member this.SetterCode - with set (q:Quotations.Expr list -> Quotations.Expr) = - if not (setter.IsValueCreated) then setterCode <- Some q else failwith "ProvidedProperty: setter MethodInfo has already been created" - - // Implement overloads - override this.PropertyType = propertyType - override this.SetValue(_obj, _value, _invokeAttr, _binder, _index, _culture) = notRequired "SetValue" this.Name - override this.GetAccessors _nonPublic = notRequired "nonPublic" this.Name - override this.GetGetMethod _nonPublic = if hasGetter() then getter.Force() :> MethodInfo else null - override this.GetSetMethod _nonPublic = if hasSetter() then setter.Force() :> MethodInfo else null - override this.GetIndexParameters() = [| for p in parameters -> upcast p |] - override this.Attributes = PropertyAttributes.None - override this.CanRead = hasGetter() - override this.CanWrite = hasSetter() - override this.GetValue(_obj, _invokeAttr, _binder, _index, _culture) : obj = notRequired "GetValue" this.Name - override this.Name = propertyName - override this.DeclaringType = declaringType |> nonNull "ProvidedProperty.DeclaringType" - override this.MemberType : MemberTypes = MemberTypes.Property - - override this.ReflectedType = notRequired "ReflectedType" this.Name - override this.GetCustomAttributes(_inherit) = notRequired "GetCustomAttributes" this.Name - override this.GetCustomAttributes(_attributeType, _inherit) = notRequired "GetCustomAttributes" this.Name - override this.IsDefined(_attributeType, _inherit) = notRequired "IsDefined" this.Name - -type ProvidedEvent(eventName:string,eventHandlerType:Type) = - inherit System.Reflection.EventInfo() - // State - - let mutable declaringType = null - let mutable isStatic = false - let mutable adderCode = None : option Quotations.Expr> - let mutable removerCode = None : option Quotations.Expr> - - // Delay construction - to pick up the latest isStatic - let markSpecialName (m:ProvidedMethod) = m.AddMethodAttrs(MethodAttributes.SpecialName); m - let adder = lazy (ProvidedMethod("add_" + eventName, [ProvidedParameter("handler", eventHandlerType)],typeof,IsStaticMethod=isStatic,DeclaringTypeImpl=declaringType,InvokeCode=adderCode.Value) |> markSpecialName) - let remover = lazy (ProvidedMethod("remove_" + eventName, [ProvidedParameter("handler", eventHandlerType)],typeof,IsStaticMethod=isStatic,DeclaringTypeImpl=declaringType,InvokeCode=removerCode.Value) |> markSpecialName) - - let customAttributesImpl = CustomAttributesImpl() - member this.AddXmlDocComputed xmlDoc = customAttributesImpl.AddXmlDocComputed xmlDoc - member this.AddXmlDocDelayed xmlDoc = customAttributesImpl.AddXmlDocDelayed xmlDoc - member this.AddXmlDoc xmlDoc = customAttributesImpl.AddXmlDoc xmlDoc - member this.AddDefinitionLocation(line,column,filePath) = customAttributesImpl.AddDefinitionLocation(line, column, filePath) - member __.GetCustomAttributesDataImpl() = customAttributesImpl.GetCustomAttributesData() -#if FX_NO_CUSTOMATTRIBUTEDATA -#else - override this.GetCustomAttributesData() = customAttributesImpl.GetCustomAttributesData() -#endif - - member this.DeclaringTypeImpl with set x = declaringType <- x // check: not set twice - member this.IsStatic - with get() = isStatic - and set x = isStatic <- x - - member this.AdderCode - with get() = adderCode.Value - and set f = - if not adder.IsValueCreated then adderCode <- Some f else failwith "ProvidedEvent: Add MethodInfo has already been created" - - member this.RemoverCode - with get() = removerCode.Value - and set f = - if not (remover.IsValueCreated) then removerCode <- Some f else failwith "ProvidedEvent: Remove MethodInfo has already been created" - - // Implement overloads - override this.EventHandlerType = eventHandlerType - override this.GetAddMethod _nonPublic = adder.Force() :> MethodInfo - override this.GetRemoveMethod _nonPublic = remover.Force() :> MethodInfo - override this.Attributes = EventAttributes.None - override this.Name = eventName - override this.DeclaringType = declaringType |> nonNull "ProvidedEvent.DeclaringType" - override this.MemberType : MemberTypes = MemberTypes.Event - - override this.GetRaiseMethod _nonPublic = notRequired "GetRaiseMethod" this.Name - override this.ReflectedType = notRequired "ReflectedType" this.Name - override this.GetCustomAttributes(_inherit) = notRequired "GetCustomAttributes" this.Name - override this.GetCustomAttributes(_attributeType, _inherit) = notRequired "GetCustomAttributes" this.Name - override this.IsDefined(_attributeType, _inherit) = notRequired "IsDefined" this.Name - -type ProvidedLiteralField(fieldName:string,fieldType:Type,literalValue:obj) = - inherit System.Reflection.FieldInfo() - // State - - let mutable declaringType = null - - let customAttributesImpl = CustomAttributesImpl() - member this.AddXmlDocComputed xmlDoc = customAttributesImpl.AddXmlDocComputed xmlDoc - member this.AddXmlDocDelayed xmlDoc = customAttributesImpl.AddXmlDocDelayed xmlDoc - member this.AddXmlDoc xmlDoc = customAttributesImpl.AddXmlDoc xmlDoc - member this.AddObsoleteAttribute (msg,?isError) = customAttributesImpl.AddObsolete (msg,defaultArg isError false) - member this.AddDefinitionLocation(line,column,filePath) = customAttributesImpl.AddDefinitionLocation(line, column, filePath) - member __.GetCustomAttributesDataImpl() = customAttributesImpl.GetCustomAttributesData() -#if FX_NO_CUSTOMATTRIBUTEDATA -#else - override this.GetCustomAttributesData() = customAttributesImpl.GetCustomAttributesData() -#endif - - member this.DeclaringTypeImpl with set x = declaringType <- x // check: not set twice - - - // Implement overloads - override this.FieldType = fieldType - override this.GetRawConstantValue() = literalValue - override this.Attributes = FieldAttributes.Static ||| FieldAttributes.Literal ||| FieldAttributes.Public - override this.Name = fieldName - override this.DeclaringType = declaringType |> nonNull "ProvidedLiteralField.DeclaringType" - override this.MemberType : MemberTypes = MemberTypes.Field - - override this.ReflectedType = notRequired "ReflectedType" this.Name - override this.GetCustomAttributes(_inherit) = notRequired "GetCustomAttributes" this.Name - override this.GetCustomAttributes(_attributeType, _inherit) = notRequired "GetCustomAttributes" this.Name - override this.IsDefined(_attributeType, _inherit) = notRequired "IsDefined" this.Name - - override this.SetValue(_obj, _value, _invokeAttr, _binder, _culture) = notRequired "SetValue" this.Name - override this.GetValue(_obj) : obj = notRequired "GetValue" this.Name - override this.FieldHandle = notRequired "FieldHandle" this.Name - -type ProvidedField(fieldName:string,fieldType:Type) = - inherit System.Reflection.FieldInfo() - // State - - let mutable declaringType = null - - let customAttributesImpl = CustomAttributesImpl() - let mutable fieldAttrs = FieldAttributes.Private - member this.AddXmlDocComputed xmlDoc = customAttributesImpl.AddXmlDocComputed xmlDoc - member this.AddXmlDocDelayed xmlDoc = customAttributesImpl.AddXmlDocDelayed xmlDoc - member this.AddXmlDoc xmlDoc = customAttributesImpl.AddXmlDoc xmlDoc - member this.AddObsoleteAttribute (msg,?isError) = customAttributesImpl.AddObsolete (msg,defaultArg isError false) - member this.AddDefinitionLocation(line,column,filePath) = customAttributesImpl.AddDefinitionLocation(line, column, filePath) - member __.GetCustomAttributesDataImpl() = customAttributesImpl.GetCustomAttributesData() -#if FX_NO_CUSTOMATTRIBUTEDATA -#else - override this.GetCustomAttributesData() = customAttributesImpl.GetCustomAttributesData() -#endif - - member this.DeclaringTypeImpl with set x = declaringType <- x // check: not set twice - - member this.SetFieldAttributes attrs = fieldAttrs <- attrs - // Implement overloads - override this.FieldType = fieldType - override this.GetRawConstantValue() = null - override this.Attributes = fieldAttrs - override this.Name = fieldName - override this.DeclaringType = declaringType |> nonNull "ProvidedField.DeclaringType" - override this.MemberType : MemberTypes = MemberTypes.Field - - override this.ReflectedType = notRequired "ReflectedType" this.Name - override this.GetCustomAttributes(_inherit) = notRequired "GetCustomAttributes" this.Name - override this.GetCustomAttributes(_attributeType, _inherit) = notRequired "GetCustomAttributes" this.Name - override this.IsDefined(_attributeType, _inherit) = notRequired "IsDefined" this.Name - - override this.SetValue(_obj, _value, _invokeAttr, _binder, _culture) = notRequired "SetValue" this.Name - override this.GetValue(_obj) : obj = notRequired "GetValue" this.Name - override this.FieldHandle = notRequired "FieldHandle" this.Name - -/// Represents the type constructor in a provided symbol type. -[] -type SymbolKind = - | SDArray - | Array of int - | Pointer - | ByRef - | Generic of System.Type - | FSharpTypeAbbreviation of (System.Reflection.Assembly * string * string[]) - - -/// Represents an array or other symbolic type involving a provided type as the argument. -/// See the type provider spec for the methods that must be implemented. -/// Note that the type provider specification does not require us to implement pointer-equality for provided types. -type ProvidedSymbolType(kind: SymbolKind, args: Type list) = - inherit Type() - - let rec isEquivalentTo (thisTy: Type) (otherTy: Type) = - match thisTy, otherTy with - | (:? ProvidedSymbolType as thisTy), (:? ProvidedSymbolType as thatTy) -> (thisTy.Kind,thisTy.Args) = (thatTy.Kind, thatTy.Args) - | (:? ProvidedSymbolType as thisTy), otherTy | otherTy, (:? ProvidedSymbolType as thisTy) -> - match thisTy.Kind, thisTy.Args with - | SymbolKind.SDArray, [ty] | SymbolKind.Array _, [ty] when otherTy.IsArray-> ty.Equals(otherTy.GetElementType()) - | SymbolKind.ByRef, [ty] when otherTy.IsByRef -> ty.Equals(otherTy.GetElementType()) - | SymbolKind.Pointer, [ty] when otherTy.IsPointer -> ty.Equals(otherTy.GetElementType()) - | SymbolKind.Generic baseTy, args -> otherTy.IsGenericType && isEquivalentTo baseTy (otherTy.GetGenericTypeDefinition()) && Seq.forall2 isEquivalentTo args (otherTy.GetGenericArguments()) - | _ -> false - | a, b -> a.Equals b - - - static member convType (parameters: Type list) (ty:Type) = - if ty = null then null - elif ty.IsGenericType then - let args = Array.map (ProvidedSymbolType.convType parameters) (ty.GetGenericArguments()) - ProvidedSymbolType(Generic (ty.GetGenericTypeDefinition()), Array.toList args) :> Type - elif ty.HasElementType then - let ety = ProvidedSymbolType.convType parameters (ty.GetElementType()) - if ty.IsArray then - let rank = ty.GetArrayRank() - if rank = 1 then ProvidedSymbolType(SDArray,[ety]) :> Type - else ProvidedSymbolType(Array rank,[ety]) :> Type - elif ty.IsPointer then ProvidedSymbolType(Pointer,[ety]) :> Type - elif ty.IsByRef then ProvidedSymbolType(ByRef,[ety]) :> Type - else ty - elif ty.IsGenericParameter then - if ty.GenericParameterPosition <= parameters.Length - 1 then - parameters.[ty.GenericParameterPosition] - else - ty - else ty - - override this.FullName = - match kind,args with - | SymbolKind.SDArray,[arg] -> arg.FullName + "[]" - | SymbolKind.Array _,[arg] -> arg.FullName + "[*]" - | SymbolKind.Pointer,[arg] -> arg.FullName + "*" - | SymbolKind.ByRef,[arg] -> arg.FullName + "&" - | SymbolKind.Generic gty, args -> gty.FullName + "[" + (args |> List.map (fun arg -> arg.ToString()) |> String.concat ",") + "]" - | SymbolKind.FSharpTypeAbbreviation (_,nsp,path),args -> String.concat "." (Array.append [| nsp |] path) + args.ToString() - | _ -> failwith "unreachable" - - /// Although not strictly required by the type provider specification, this is required when doing basic operations like FullName on - /// .NET symbolic types made from this type, e.g. when building Nullable.FullName - override this.DeclaringType = - match kind,args with - | SymbolKind.SDArray,[arg] -> arg - | SymbolKind.Array _,[arg] -> arg - | SymbolKind.Pointer,[arg] -> arg - | SymbolKind.ByRef,[arg] -> arg - | SymbolKind.Generic gty,_ -> gty - | SymbolKind.FSharpTypeAbbreviation _,_ -> null - | _ -> failwith "unreachable" - - override this.IsAssignableFrom(otherTy) = - match kind with - | Generic gtd -> - if otherTy.IsGenericType then - let otherGtd = otherTy.GetGenericTypeDefinition() - let otherArgs = otherTy.GetGenericArguments() - let yes = gtd.Equals(otherGtd) && Seq.forall2 isEquivalentTo args otherArgs - yes - else - base.IsAssignableFrom(otherTy) - | _ -> base.IsAssignableFrom(otherTy) - - override this.Name = - match kind,args with - | SymbolKind.SDArray,[arg] -> arg.Name + "[]" - | SymbolKind.Array _,[arg] -> arg.Name + "[*]" - | SymbolKind.Pointer,[arg] -> arg.Name + "*" - | SymbolKind.ByRef,[arg] -> arg.Name + "&" - | SymbolKind.Generic gty, args -> gty.Name + (sprintf "%A" args) - | SymbolKind.FSharpTypeAbbreviation (_,_,path),_ -> path.[path.Length-1] - | _ -> failwith "unreachable" - - override this.BaseType = - match kind with - | SymbolKind.SDArray -> typeof - | SymbolKind.Array _ -> typeof - | SymbolKind.Pointer -> typeof - | SymbolKind.ByRef -> typeof - | SymbolKind.Generic gty -> - if gty.BaseType = null then null else - ProvidedSymbolType.convType args gty.BaseType - | SymbolKind.FSharpTypeAbbreviation _ -> typeof - - override this.GetArrayRank() = (match kind with SymbolKind.Array n -> n | SymbolKind.SDArray -> 1 | _ -> invalidOp "non-array type") - override this.IsArrayImpl() = (match kind with SymbolKind.Array _ | SymbolKind.SDArray -> true | _ -> false) - override this.IsByRefImpl() = (match kind with SymbolKind.ByRef _ -> true | _ -> false) - override this.IsPointerImpl() = (match kind with SymbolKind.Pointer _ -> true | _ -> false) - override this.IsPrimitiveImpl() = false - override this.IsGenericType = (match kind with SymbolKind.Generic _ -> true | _ -> false) - override this.GetGenericArguments() = (match kind with SymbolKind.Generic _ -> args |> List.toArray | _ -> invalidOp "non-generic type") - override this.GetGenericTypeDefinition() = (match kind with SymbolKind.Generic e -> e | _ -> invalidOp "non-generic type") - override this.IsCOMObjectImpl() = false - override this.HasElementTypeImpl() = (match kind with SymbolKind.Generic _ -> false | _ -> true) - override this.GetElementType() = (match kind,args with (SymbolKind.Array _ | SymbolKind.SDArray | SymbolKind.ByRef | SymbolKind.Pointer),[e] -> e | _ -> invalidOp "not an array, pointer or byref type") - override this.ToString() = this.FullName - - override this.Module : Module = notRequired "Module" this.Name - override this.Assembly = - match kind with - | SymbolKind.FSharpTypeAbbreviation (assembly,_nsp,_path) -> assembly - | SymbolKind.Generic gty -> gty.Assembly - | _ -> notRequired "Assembly" this.Name - override this.Namespace = - match kind with - | SymbolKind.FSharpTypeAbbreviation (_assembly,nsp,_path) -> nsp - | _ -> notRequired "Namespace" this.Name - - override this.GetHashCode() = - match kind,args with - | SymbolKind.SDArray,[arg] -> 10 + hash arg - | SymbolKind.Array _,[arg] -> 163 + hash arg - | SymbolKind.Pointer,[arg] -> 283 + hash arg - | SymbolKind.ByRef,[arg] -> 43904 + hash arg - | SymbolKind.Generic gty,_ -> 9797 + hash gty + List.sumBy hash args - | SymbolKind.FSharpTypeAbbreviation _,_ -> 3092 - | _ -> failwith "unreachable" - - override this.Equals(other: obj) = - match other with - | :? ProvidedSymbolType as otherTy -> (kind, args) = (otherTy.Kind, otherTy.Args) - | _ -> false - - member this.Kind = kind - member this.Args = args - - override this.GetConstructors _bindingAttr = notRequired "GetConstructors" this.Name - override this.GetMethodImpl(_name, _bindingAttr, _binderBinder, _callConvention, _types, _modifiers) = - match kind with - | Generic gtd -> - let ty = gtd.GetGenericTypeDefinition().MakeGenericType(Array.ofList args) - ty.GetMethod(_name, _bindingAttr) - | _ -> notRequired "GetMethodImpl" this.Name - override this.GetMembers _bindingAttr = notRequired "GetMembers" this.Name - override this.GetMethods _bindingAttr = notRequired "GetMethods" this.Name - override this.GetField(_name, _bindingAttr) = notRequired "GetField" this.Name - override this.GetFields _bindingAttr = notRequired "GetFields" this.Name - override this.GetInterface(_name, _ignoreCase) = notRequired "GetInterface" this.Name - override this.GetInterfaces() = notRequired "GetInterfaces" this.Name - override this.GetEvent(_name, _bindingAttr) = notRequired "GetEvent" this.Name - override this.GetEvents _bindingAttr = notRequired "GetEvents" this.Name - override this.GetProperties _bindingAttr = notRequired "GetProperties" this.Name - override this.GetPropertyImpl(_name, _bindingAttr, _binder, _returnType, _types, _modifiers) = notRequired "GetPropertyImpl" this.Name - override this.GetNestedTypes _bindingAttr = notRequired "GetNestedTypes" this.Name - override this.GetNestedType(_name, _bindingAttr) = notRequired "GetNestedType" this.Name - override this.GetAttributeFlagsImpl() = notRequired "GetAttributeFlagsImpl" this.Name - override this.UnderlyingSystemType = - match kind with - | SymbolKind.SDArray - | SymbolKind.Array _ - | SymbolKind.Pointer - | SymbolKind.FSharpTypeAbbreviation _ - | SymbolKind.ByRef -> notRequired "UnderlyingSystemType" this.Name - | SymbolKind.Generic gty -> gty.UnderlyingSystemType -#if FX_NO_CUSTOMATTRIBUTEDATA -#else - override this.GetCustomAttributesData() = ([| |] :> IList<_>) -#endif - override this.MemberType = notRequired "MemberType" this.Name - override this.GetMember(_name,_mt,_bindingAttr) = notRequired "GetMember" this.Name - override this.GUID = notRequired "GUID" this.Name - override this.InvokeMember(_name, _invokeAttr, _binder, _target, _args, _modifiers, _culture, _namedParameters) = notRequired "InvokeMember" this.Name - override this.AssemblyQualifiedName = notRequired "AssemblyQualifiedName" this.Name - override this.GetConstructorImpl(_bindingAttr, _binder, _callConvention, _types, _modifiers) = notRequired "GetConstructorImpl" this.Name - override this.GetCustomAttributes(_inherit) = [| |] - override this.GetCustomAttributes(_attributeType, _inherit) = [| |] - override this.IsDefined(_attributeType, _inherit) = false - // FSharp.Data addition: this was added to support arrays of arrays - override this.MakeArrayType() = ProvidedSymbolType(SymbolKind.SDArray, [this]) :> Type - override this.MakeArrayType arg = ProvidedSymbolType(SymbolKind.Array arg, [this]) :> Type - -type ProvidedSymbolMethod(genericMethodDefinition: MethodInfo, parameters: Type list) = - inherit System.Reflection.MethodInfo() - - let convParam (p:ParameterInfo) = - { new System.Reflection.ParameterInfo() with - override this.Name = p.Name - override this.ParameterType = ProvidedSymbolType.convType parameters p.ParameterType - override this.Attributes = p.Attributes - override this.RawDefaultValue = p.RawDefaultValue -#if FX_NO_CUSTOMATTRIBUTEDATA -#else - override __.GetCustomAttributesData() = p.GetCustomAttributesData() -#endif - } - override this.IsGenericMethod = - (if this.DeclaringType.IsGenericType then this.DeclaringType.GetGenericArguments().Length else 0) < parameters.Length - override this.GetGenericArguments() = - Seq.skip (if this.DeclaringType.IsGenericType then this.DeclaringType.GetGenericArguments().Length else 0) parameters |> Seq.toArray - override this.GetGenericMethodDefinition() = genericMethodDefinition - override this.DeclaringType = ProvidedSymbolType.convType parameters genericMethodDefinition.DeclaringType - override this.ToString() = "Method " + this.Name - override this.Name = genericMethodDefinition.Name - override this.MetadataToken = genericMethodDefinition.MetadataToken - override this.Attributes = genericMethodDefinition.Attributes - override this.CallingConvention = genericMethodDefinition.CallingConvention - override this.MemberType = genericMethodDefinition.MemberType - - override this.IsDefined(_attributeType, _inherit) : bool = notRequired "IsDefined" this.Name - override this.ReturnType = ProvidedSymbolType.convType parameters genericMethodDefinition.ReturnType - override this.GetParameters() = genericMethodDefinition.GetParameters() |> Array.map convParam - override this.ReturnParameter = genericMethodDefinition.ReturnParameter |> convParam - override this.ReturnTypeCustomAttributes = notRequired "ReturnTypeCustomAttributes" this.Name - override this.GetBaseDefinition() = notRequired "GetBaseDefinition" this.Name - override this.GetMethodImplementationFlags() = notRequired "GetMethodImplementationFlags" this.Name - override this.MethodHandle = notRequired "MethodHandle" this.Name - override this.Invoke(_obj, _invokeAttr, _binder, _parameters, _culture) = notRequired "Invoke" this.Name - override this.ReflectedType = notRequired "ReflectedType" this.Name - override this.GetCustomAttributes(_inherit) = notRequired "GetCustomAttributes" this.Name - override this.GetCustomAttributes(_attributeType, _inherit) = notRequired "GetCustomAttributes" this.Name - - - -type ProvidedTypeBuilder() = - static member MakeGenericType(genericTypeDefinition, genericArguments) = ProvidedSymbolType(Generic genericTypeDefinition, genericArguments) :> Type - static member MakeGenericMethod(genericMethodDefinition, genericArguments) = ProvidedSymbolMethod(genericMethodDefinition, genericArguments) :> MethodInfo - -[] -type ProvidedMeasureBuilder() = - - // TODO: this shouldn't be hardcoded, but without creating a dependency on Microsoft.FSharp.Metadata in F# PowerPack - // there seems to be no way to check if a type abbreviation exists - let unitNamesTypeAbbreviations = - [ "meter"; "hertz"; "newton"; "pascal"; "joule"; "watt"; "coulomb"; - "volt"; "farad"; "ohm"; "siemens"; "weber"; "tesla"; "henry" - "lumen"; "lux"; "becquerel"; "gray"; "sievert"; "katal" ] - |> Set.ofList - - let unitSymbolsTypeAbbreviations = - [ "m"; "kg"; "s"; "A"; "K"; "mol"; "cd"; "Hz"; "N"; "Pa"; "J"; "W"; "C" - "V"; "F"; "S"; "Wb"; "T"; "lm"; "lx"; "Bq"; "Gy"; "Sv"; "kat"; "H" ] - |> Set.ofList - - static let theBuilder = ProvidedMeasureBuilder() - static member Default = theBuilder - member b.One = typeof - member b.Product (m1,m2) = typedefof>.MakeGenericType [| m1;m2 |] - member b.Inverse m = typedefof>.MakeGenericType [| m |] - member b.Ratio (m1, m2) = b.Product(m1, b.Inverse m2) - member b.Square m = b.Product(m, m) - - // FSharp.Data change: if the unit is not a valid type, instead - // of assuming it's a type abbreviation, which may not be the case and cause a - // problem later on, check the list of valid abbreviations - member b.SI (m:string) = - let mLowerCase = m.ToLowerInvariant() - let abbreviation = - if unitNamesTypeAbbreviations.Contains mLowerCase then - Some ("Microsoft.FSharp.Data.UnitSystems.SI.UnitNames", mLowerCase) - elif unitSymbolsTypeAbbreviations.Contains m then - Some ("Microsoft.FSharp.Data.UnitSystems.SI.UnitSymbols", m) - else - None - match abbreviation with - | Some (ns, unitName) -> - ProvidedSymbolType - (SymbolKind.FSharpTypeAbbreviation - (typeof.Assembly, - ns, - [| unitName |]), - []) :> Type - | None -> - typedefof>.Assembly.GetType("Microsoft.FSharp.Data.UnitSystems.SI.UnitNames." + mLowerCase) - - member b.AnnotateType (basicType, annotation) = ProvidedSymbolType(Generic basicType, annotation) :> Type - - - -[] -type TypeContainer = - | Namespace of Assembly * string // namespace - | Type of System.Type - | TypeToBeDecided - -module GlobalProvidedAssemblyElementsTable = - let theTable = Dictionary>() - -type ProvidedTypeDefinition(container:TypeContainer,className : string, baseType : Type option) as this = - inherit Type() - - do match container, !ProvidedTypeDefinition.Logger with - | TypeContainer.Namespace _, Some logger -> logger (sprintf "Creating ProvidedTypeDefinition %s [%d]" className (System.Runtime.CompilerServices.RuntimeHelpers.GetHashCode this)) - | _ -> () - - // state - let mutable attributes = - TypeAttributes.Public ||| - TypeAttributes.Class ||| - TypeAttributes.Sealed ||| - enum (int32 TypeProviderTypeAttributes.IsErased) - - - let mutable enumUnderlyingType = typeof - let mutable baseType = lazy baseType - let mutable membersKnown = ResizeArray() - let mutable membersQueue = ResizeArray<(unit -> list)>() - let mutable staticParams = [ ] - let mutable staticParamsApply = None - let mutable container = container - let mutable interfaceImpls = ResizeArray() - let mutable interfaceImplsDelayed = ResizeArray list>() - let mutable methodOverrides = ResizeArray() - - // members API - let getMembers() = - if membersQueue.Count > 0 then - let elems = membersQueue |> Seq.toArray // take a copy in case more elements get added - membersQueue.Clear() - for f in elems do - for i in f() do - membersKnown.Add i - match i with - | :? ProvidedProperty as p -> - if p.CanRead then membersKnown.Add (p.GetGetMethod true) - if p.CanWrite then membersKnown.Add (p.GetSetMethod true) - | :? ProvidedEvent as e -> - membersKnown.Add (e.GetAddMethod true) - membersKnown.Add (e.GetRemoveMethod true) - | _ -> () - - membersKnown.ToArray() - - // members API - let getInterfaces() = - if interfaceImplsDelayed.Count > 0 then - let elems = interfaceImplsDelayed |> Seq.toArray // take a copy in case more elements get added - interfaceImplsDelayed.Clear() - for f in elems do - for i in f() do - interfaceImpls.Add i - - interfaceImpls.ToArray() - - let mutable theAssembly = - lazy - match container with - | TypeContainer.Namespace (theAssembly, rootNamespace) -> - if theAssembly = null then failwith "Null assemblies not allowed" - if rootNamespace<>null && rootNamespace.Length=0 then failwith "Use 'null' for global namespace" - theAssembly - | TypeContainer.Type superTy -> superTy.Assembly - | TypeContainer.TypeToBeDecided -> failwith (sprintf "type '%s' was not added as a member to a declaring type" this.Name) - - let rootNamespace = - lazy - match container with - | TypeContainer.Namespace (_,rootNamespace) -> rootNamespace - | TypeContainer.Type enclosingTyp -> enclosingTyp.Namespace - | TypeContainer.TypeToBeDecided -> failwith (sprintf "type '%s' was not added as a member to a declaring type" this.Name) - - let declaringType = - lazy - match container with - | TypeContainer.Namespace _ -> null - | TypeContainer.Type enclosingTyp -> enclosingTyp - | TypeContainer.TypeToBeDecided -> failwith (sprintf "type '%s' was not added as a member to a declaring type" this.Name) - - let fullName = - lazy - match container with - | TypeContainer.Type declaringType -> declaringType.FullName + "+" + className - | TypeContainer.Namespace (_,namespaceName) -> - if namespaceName="" then failwith "use null for global namespace" - match namespaceName with - | null -> className - | _ -> namespaceName + "." + className - | TypeContainer.TypeToBeDecided -> failwith (sprintf "type '%s' was not added as a member to a declaring type" this.Name) - - let patchUpAddedMemberInfo (this:Type) (m:MemberInfo) = - match m with - | :? ProvidedConstructor as c -> c.DeclaringTypeImpl <- this // patch up "declaring type" on provided MethodInfo - | :? ProvidedMethod as m -> m.DeclaringTypeImpl <- this // patch up "declaring type" on provided MethodInfo - | :? ProvidedProperty as p -> p.DeclaringTypeImpl <- this // patch up "declaring type" on provided MethodInfo - | :? ProvidedEvent as e -> e.DeclaringTypeImpl <- this // patch up "declaring type" on provided MethodInfo - | :? ProvidedTypeDefinition as t -> t.DeclaringTypeImpl <- this - | :? ProvidedLiteralField as l -> l.DeclaringTypeImpl <- this - | :? ProvidedField as l -> l.DeclaringTypeImpl <- this - | _ -> () - - let customAttributesImpl = CustomAttributesImpl() - member this.AddXmlDocComputed xmlDoc = customAttributesImpl.AddXmlDocComputed xmlDoc - member this.AddXmlDocDelayed xmlDoc = customAttributesImpl.AddXmlDocDelayed xmlDoc - member this.AddXmlDoc xmlDoc = customAttributesImpl.AddXmlDoc xmlDoc - member this.AddObsoleteAttribute (msg,?isError) = customAttributesImpl.AddObsolete (msg,defaultArg isError false) - member this.AddDefinitionLocation(line,column,filePath) = customAttributesImpl.AddDefinitionLocation(line, column, filePath) - member this.HideObjectMethods with set v = customAttributesImpl.HideObjectMethods <- v - member this.NonNullable with set v = customAttributesImpl.NonNullable <- v - member __.GetCustomAttributesDataImpl() = customAttributesImpl.GetCustomAttributesData() - member this.AddCustomAttribute attribute = customAttributesImpl.AddCustomAttribute attribute -#if FX_NO_CUSTOMATTRIBUTEDATA -#else - override this.GetCustomAttributesData() = customAttributesImpl.GetCustomAttributesData() -#endif - - member this.ResetEnclosingType (ty) = - container <- TypeContainer.Type ty - new (assembly:Assembly,namespaceName,className,baseType) = new ProvidedTypeDefinition(TypeContainer.Namespace (assembly,namespaceName), className, baseType) - new (className,baseType) = new ProvidedTypeDefinition(TypeContainer.TypeToBeDecided, className, baseType) - // state ops - - override this.UnderlyingSystemType = typeof - member this.SetEnumUnderlyingType(ty) = enumUnderlyingType <- ty - override this.GetEnumUnderlyingType() = if this.IsEnum then enumUnderlyingType else invalidOp "not enum type" - member this.SetBaseType t = baseType <- lazy Some t - member this.SetBaseTypeDelayed t = baseType <- t - member this.SetAttributes x = attributes <- x - // Add MemberInfos - member this.AddMembersDelayed(makeMS : unit -> list<#MemberInfo>) = - membersQueue.Add (fun () -> makeMS() |> List.map (fun x -> patchUpAddedMemberInfo this x; x :> MemberInfo )) - member this.AddMembers(ms:list<#MemberInfo>) = (* strict *) - ms |> List.iter (patchUpAddedMemberInfo this) // strict: patch up now - membersQueue.Add (fun () -> ms |> List.map (fun x -> x :> MemberInfo)) - member this.AddMember(m:MemberInfo) = this.AddMembers [m] - member this.AddMemberDelayed(m : unit -> #MemberInfo) = this.AddMembersDelayed(fun () -> [m()]) - - member this.AddAssemblyTypesAsNestedTypesDelayed (assemblyf : unit -> System.Reflection.Assembly) = - let bucketByPath nodef tipf (items: (string list * 'Value) list) = - // Find all the items with an empty key list and call 'tipf' - let tips = - [ for (keylist,v) in items do - match keylist with - | [] -> yield tipf v - | _ -> () ] - - // Find all the items with a non-empty key list. Bucket them together by - // the first key. For each bucket, call 'nodef' on that head key and the bucket. - let nodes = - let buckets = new Dictionary<_,_>(10) - for (keylist,v) in items do - match keylist with - | [] -> () - | key::rest -> - buckets.[key] <- (rest,v) :: (if buckets.ContainsKey key then buckets.[key] else []); - - [ for (KeyValue(key,items)) in buckets -> nodef key items ] - - tips @ nodes - this.AddMembersDelayed (fun _ -> - let topTypes = [ for ty in assemblyf().GetTypes() do - if not ty.IsNested then - let namespaceParts = match ty.Namespace with null -> [] | s -> s.Split '.' |> Array.toList - yield namespaceParts, ty ] - let rec loop types = - types - |> bucketByPath - (fun namespaceComponent typesUnderNamespaceComponent -> - let t = ProvidedTypeDefinition(namespaceComponent, baseType = Some typeof) - t.AddMembers (loop typesUnderNamespaceComponent) - (t :> Type)) - (fun ty -> ty) - loop topTypes) - - /// Abstract a type to a parametric-type. Requires "formal parameters" and "instantiation function". - member this.DefineStaticParameters(staticParameters : list, apply : (string -> obj[] -> ProvidedTypeDefinition)) = - staticParams <- staticParameters - staticParamsApply <- Some apply - - /// Get ParameterInfo[] for the parametric type parameters (//s GetGenericParameters) - member this.GetStaticParameters() = [| for p in staticParams -> p :> ParameterInfo |] - - /// Instantiate parametrics type - member this.MakeParametricType(name:string,args:obj[]) = - if staticParams.Length>0 then - if staticParams.Length <> args.Length then - failwith (sprintf "ProvidedTypeDefinition: expecting %d static parameters but given %d for type %s" staticParams.Length args.Length (fullName.Force())) - match staticParamsApply with - | None -> failwith "ProvidedTypeDefinition: DefineStaticParameters was not called" - | Some f -> f name args - - else - failwith (sprintf "ProvidedTypeDefinition: static parameters supplied but not expected for %s" (fullName.Force())) - - member this.DeclaringTypeImpl - with set x = - match container with TypeContainer.TypeToBeDecided -> () | _ -> failwith (sprintf "container type for '%s' was already set to '%s'" this.FullName x.FullName); - container <- TypeContainer.Type x - - // Implement overloads - override this.Assembly = theAssembly.Force() - member this.SetAssembly assembly = theAssembly <- lazy assembly - member this.SetAssemblyLazy assembly = theAssembly <- assembly - override this.FullName = fullName.Force() - override this.Namespace = rootNamespace.Force() - override this.BaseType = match baseType.Value with Some ty -> ty | None -> null - - // Constructors - override this.GetConstructors bindingAttr = - [| for m in this.GetMembers bindingAttr do - if m.MemberType = MemberTypes.Constructor then - yield (m :?> ConstructorInfo) |] - // Methods - override this.GetMethodImpl(name, bindingAttr, _binderBinder, _callConvention, _types, _modifiers) : MethodInfo = - let membersWithName = - [ for m in this.GetMembers(bindingAttr) do - if m.MemberType.HasFlag(MemberTypes.Method) && m.Name = name then - yield m ] - match membersWithName with - | [] -> null - | [meth] -> meth :?> MethodInfo - | _several -> failwith "GetMethodImpl. not support overloads" - - override this.GetMethods bindingAttr = - this.GetMembers bindingAttr - |> Array.filter (fun m -> m.MemberType.HasFlag(MemberTypes.Method)) - |> Array.map (fun m -> m :?> MethodInfo) - - // Fields - override this.GetField(name, bindingAttr) = - let fields = [| for m in this.GetMembers bindingAttr do - if m.MemberType.HasFlag(MemberTypes.Field) && (name = null || m.Name = name) then // REVIEW: name = null. Is that a valid query?! - yield m |] - if fields.Length > 0 then fields.[0] :?> FieldInfo else null - - override this.GetFields bindingAttr = - [| for m in this.GetMembers bindingAttr do if m.MemberType.HasFlag(MemberTypes.Field) then yield m :?> FieldInfo |] - - override this.GetInterface(_name, _ignoreCase) = notRequired "GetInterface" this.Name - - override this.GetInterfaces() = - [| yield! getInterfaces() |] - - member this.GetInterfaceImplementations() = - [| yield! getInterfaces() |] - - member this.AddInterfaceImplementation ityp = interfaceImpls.Add ityp - member this.AddInterfaceImplementationsDelayed itypf = interfaceImplsDelayed.Add itypf - member this.GetMethodOverrides() = - [| yield! methodOverrides |] - member this.DefineMethodOverride (bodyMethInfo,declMethInfo) = methodOverrides.Add (bodyMethInfo, declMethInfo) - - // Events - override this.GetEvent(name, bindingAttr) = - let events = this.GetMembers bindingAttr - |> Array.filter(fun m -> m.MemberType.HasFlag(MemberTypes.Event) && (name = null || m.Name = name)) - if events.Length > 0 then events.[0] :?> EventInfo else null - - override this.GetEvents bindingAttr = - [| for m in this.GetMembers bindingAttr do if m.MemberType.HasFlag(MemberTypes.Event) then yield downcast m |] - - // Properties - override this.GetProperties bindingAttr = - [| for m in this.GetMembers bindingAttr do if m.MemberType.HasFlag(MemberTypes.Property) then yield downcast m |] - - override this.GetPropertyImpl(name, bindingAttr, binder, returnType, types, modifiers) = - if returnType <> null then failwith "Need to handle specified return type in GetPropertyImpl" - if types <> null then failwith "Need to handle specified parameter types in GetPropertyImpl" - if modifiers <> null then failwith "Need to handle specified modifiers in GetPropertyImpl" - if binder <> null then failwith "Need to handle binder in GetPropertyImpl" - let props = this.GetMembers bindingAttr |> Array.filter(fun m -> m.MemberType.HasFlag(MemberTypes.Property) && (name = null || m.Name = name)) // Review: nam = null, valid query!? - if props.Length > 0 then - props.[0] :?> PropertyInfo - else - null - // Nested Types - override this.MakeArrayType() = ProvidedSymbolType(SymbolKind.SDArray, [this]) :> Type - override this.MakeArrayType arg = ProvidedSymbolType(SymbolKind.Array arg, [this]) :> Type - override this.MakePointerType() = ProvidedSymbolType(SymbolKind.Pointer, [this]) :> Type - override this.MakeByRefType() = ProvidedSymbolType(SymbolKind.ByRef, [this]) :> Type - - // FSharp.Data addition: this method is used by Debug.fs and QuotationBuilder.fs - // Emulate the F# type provider type erasure mechanism to get the - // actual (erased) type. We erase ProvidedTypes to their base type - // and we erase array of provided type to array of base type. In the - // case of generics all the generic type arguments are also recursively - // replaced with the erased-to types - static member EraseType(t:Type) = - match t with - | :? ProvidedTypeDefinition -> ProvidedTypeDefinition.EraseType t.BaseType - | :? ProvidedSymbolType as sym -> - match sym.Kind, sym.Args with - | SymbolKind.SDArray, [typ] -> - let (t:Type) = ProvidedTypeDefinition.EraseType typ - t.MakeArrayType() - | SymbolKind.Generic genericTypeDefinition, _ when not genericTypeDefinition.IsGenericTypeDefinition -> - // Unit of measure parameters can match here, but not really generic types. - genericTypeDefinition.UnderlyingSystemType - | SymbolKind.Generic genericTypeDefinition, typeArgs -> - let genericArguments = - typeArgs - |> List.toArray - |> Array.map ProvidedTypeDefinition.EraseType - genericTypeDefinition.MakeGenericType(genericArguments) - | _ -> failwith "getTypeErasedTo: Unsupported ProvidedSymbolType" - | t when t.IsGenericType && not t.IsGenericTypeDefinition -> - let genericTypeDefinition = t.GetGenericTypeDefinition() - let genericArguments = - t.GetGenericArguments() - |> Array.map ProvidedTypeDefinition.EraseType - genericTypeDefinition.MakeGenericType(genericArguments) - | t -> t - - static member Logger : (string -> unit) option ref = ref None - - // The binding attributes are always set to DeclaredOnly ||| Static ||| Instance ||| Public when GetMembers is called directly by the F# compiler - // However, it's possible for the framework to generate other sets of flags in some corner cases (e.g. via use of `enum` with a provided type as the target) - override this.GetMembers bindingAttr = - let mems = - getMembers() - |> Array.filter (fun mem -> - let isStatic, isPublic = - match mem with - | :? FieldInfo as f -> f.IsStatic, f.IsPublic - | :? MethodInfo as m -> m.IsStatic, m.IsPublic - | :? ConstructorInfo as c -> c.IsStatic, c.IsPublic - | :? PropertyInfo as p -> - let m = if p.CanRead then p.GetGetMethod() else p.GetSetMethod() - m.IsStatic, m.IsPublic - | :? EventInfo as e -> - let m = e.GetAddMethod() - m.IsStatic, m.IsPublic - | :? Type as ty -> - true, ty.IsNestedPublic - | _ -> failwith (sprintf "Member %O is of unexpected type" mem) - bindingAttr.HasFlag(if isStatic then BindingFlags.Static else BindingFlags.Instance) && - ( - (bindingAttr.HasFlag(BindingFlags.Public) && isPublic) || (bindingAttr.HasFlag(BindingFlags.NonPublic) && not isPublic) - )) - - if bindingAttr.HasFlag(BindingFlags.DeclaredOnly) || this.BaseType = null then mems - else - // FSharp.Data change: just using this.BaseType is not enough in the case of CsvProvider, - // because the base type is CsvRow, so we have to erase recursively to CsvRow - let baseMems = (ProvidedTypeDefinition.EraseType this.BaseType).GetMembers bindingAttr - Array.append mems baseMems - - override this.GetNestedTypes bindingAttr = - this.GetMembers bindingAttr - |> Array.filter(fun m -> - m.MemberType.HasFlag(MemberTypes.NestedType) || - // Allow 'fake' nested types that are actually real .NET types - m.MemberType.HasFlag(MemberTypes.TypeInfo)) |> Array.map(fun m -> m :?> Type) - - override this.GetMember(name,mt,_bindingAttr) = - let mt = - if mt &&& MemberTypes.NestedType = MemberTypes.NestedType then - mt ||| MemberTypes.TypeInfo - else - mt - getMembers() |> Array.filter(fun m->0<>(int(m.MemberType &&& mt)) && m.Name = name) - - override this.GetNestedType(name, bindingAttr) = - let nt = this.GetMember(name, MemberTypes.NestedType ||| MemberTypes.TypeInfo, bindingAttr) - match nt.Length with - | 0 -> null - | 1 -> downcast nt.[0] - | _ -> failwith (sprintf "There is more than one nested type called '%s' in type '%s'" name this.FullName) - - // Attributes, etc.. - override this.GetAttributeFlagsImpl() = adjustTypeAttributes attributes this.IsNested - override this.IsArrayImpl() = false - override this.IsByRefImpl() = false - override this.IsPointerImpl() = false - override this.IsPrimitiveImpl() = false - override this.IsCOMObjectImpl() = false - override this.HasElementTypeImpl() = false - override this.Name = className - override this.DeclaringType = declaringType.Force() - override this.MemberType = if this.IsNested then MemberTypes.NestedType else MemberTypes.TypeInfo - override this.GetHashCode() = rootNamespace.GetHashCode() ^^^ className.GetHashCode() - override this.Equals(that:obj) = - match that with - | null -> false - | :? ProvidedTypeDefinition as ti -> System.Object.ReferenceEquals(this,ti) - | _ -> false - - override this.GetGenericArguments() = [||] - override this.ToString() = this.Name - - - override this.Module : Module = notRequired "Module" this.Name - override this.GUID = Guid.Empty - override this.GetConstructorImpl(_bindingAttr, _binder, _callConvention, _types, _modifiers) = null - override this.GetCustomAttributes(_inherit) = [| |] - override this.GetCustomAttributes(_attributeType, _inherit) = [| |] - override this.IsDefined(_attributeType: Type, _inherit) = false - - override this.GetElementType() = notRequired "Module" this.Name - override this.InvokeMember(_name, _invokeAttr, _binder, _target, _args, _modifiers, _culture, _namedParameters) = notRequired "Module" this.Name - override this.AssemblyQualifiedName = notRequired "Module" this.Name - member this.IsErased - with get() = (attributes &&& enum (int32 TypeProviderTypeAttributes.IsErased)) <> enum 0 - and set v = - if v then attributes <- attributes ||| enum (int32 TypeProviderTypeAttributes.IsErased) - else attributes <- attributes &&& ~~~(enum (int32 TypeProviderTypeAttributes.IsErased)) - - member this.SuppressRelocation - with get() = (attributes &&& enum (int32 TypeProviderTypeAttributes.SuppressRelocate)) <> enum 0 - and set v = - if v then attributes <- attributes ||| enum (int32 TypeProviderTypeAttributes.SuppressRelocate) - else attributes <- attributes &&& ~~~(enum (int32 TypeProviderTypeAttributes.SuppressRelocate)) - -type AssemblyGenerator(assemblyFileName) = - let assemblyShortName = Path.GetFileNameWithoutExtension assemblyFileName - let assemblyName = AssemblyName assemblyShortName -#if FX_NO_LOCAL_FILESYSTEM - let assembly = - System.AppDomain.CurrentDomain.DefineDynamicAssembly(name=assemblyName,access=AssemblyBuilderAccess.Run) - let assemblyMainModule = - assembly.DefineDynamicModule("MainModule") -#else - let assembly = - System.AppDomain.CurrentDomain.DefineDynamicAssembly(name=assemblyName,access=(AssemblyBuilderAccess.Save ||| AssemblyBuilderAccess.Run),dir=Path.GetDirectoryName assemblyFileName) - let assemblyMainModule = - assembly.DefineDynamicModule("MainModule", Path.GetFileName assemblyFileName) -#endif - let typeMap = Dictionary(HashIdentity.Reference) - let typeMapExtra = Dictionary(HashIdentity.Structural) - let uniqueLambdaTypeName() = - // lambda name should be unique across all types that all type provider might contribute in result assembly - sprintf "Lambda%O" (Guid.NewGuid()) - - member __.Assembly = assembly :> Assembly - /// Emit the given provided type definitions into an assembly and adjust 'Assembly' property of all type definitions to return that - /// assembly. - member __.Generate(providedTypeDefinitions:(ProvidedTypeDefinition * string list option) list) = - let ALL = BindingFlags.Public ||| BindingFlags.NonPublic ||| BindingFlags.Static ||| BindingFlags.Instance - // phase 1 - set assembly fields and emit type definitions - begin - let rec typeMembers (tb:TypeBuilder) (td : ProvidedTypeDefinition) = - for ntd in td.GetNestedTypes(ALL) do - nestedType tb ntd - - and nestedType (tb:TypeBuilder) (ntd : Type) = - match ntd with - | :? ProvidedTypeDefinition as pntd -> - if pntd.IsErased then invalidOp ("The nested provided type "+pntd.Name+"is marked as erased and cannot be converted to a generated type. Set 'IsErased' to false on the ProvidedTypeDefinition") - // Adjust the attributes - we're codegen'ing this type as nested - let attributes = adjustTypeAttributes ntd.Attributes true - let ntb = tb.DefineNestedType(pntd.Name,attr=attributes) - pntd.SetAssembly null - typeMap.[pntd] <- ntb - typeMembers ntb pntd - | _ -> () - - for (pt,enclosingGeneratedTypeNames) in providedTypeDefinitions do - match enclosingGeneratedTypeNames with - | None -> - // Filter out the additional TypeProviderTypeAttributes flags - let attributes = pt.Attributes &&& ~~~(enum (int32 TypeProviderTypeAttributes.SuppressRelocate)) - &&& ~~~(enum (int32 TypeProviderTypeAttributes.IsErased)) - // Adjust the attributes - we're codegen'ing as non-nested - let attributes = adjustTypeAttributes attributes false - let tb = assemblyMainModule.DefineType(name=pt.FullName,attr=attributes) - pt.SetAssembly null - typeMap.[pt] <- tb - typeMembers tb pt - | Some ns -> - let otb,_ = - ((None,""),ns) ||> List.fold (fun (otb:TypeBuilder option,fullName) n -> - let fullName = if fullName = "" then n else fullName + "." + n - let priorType = if typeMapExtra.ContainsKey(fullName) then Some typeMapExtra.[fullName] else None - let tb = - match priorType with - | Some tbb -> tbb - | None -> - // OK, the implied nested type is not defined, define it now - let attributes = - TypeAttributes.Public ||| - TypeAttributes.Class ||| - TypeAttributes.Sealed - // Filter out the additional TypeProviderTypeAttributes flags - let attributes = adjustTypeAttributes attributes otb.IsSome - let tb = - match otb with - | None -> assemblyMainModule.DefineType(name=n,attr=attributes) - | Some (otb:TypeBuilder) -> otb.DefineNestedType(name=n,attr=attributes) - typeMapExtra.[fullName] <- tb - tb - (Some tb, fullName)) - nestedType otb.Value pt - end - let rec convType (ty:Type) = - match ty with - | :? ProvidedTypeDefinition as ptd -> - if typeMap.ContainsKey ptd then typeMap.[ptd] :> Type else ty - | _ -> - if ty.IsGenericType then ty.GetGenericTypeDefinition().MakeGenericType (Array.map convType (ty.GetGenericArguments())) - elif ty.HasElementType then - let ety = convType (ty.GetElementType()) - if ty.IsArray then - let rank = ty.GetArrayRank() - if rank = 1 then ety.MakeArrayType() - else ety.MakeArrayType rank - elif ty.IsPointer then ety.MakePointerType() - elif ty.IsByRef then ety.MakeByRefType() - else ty - else ty - - let ctorMap = Dictionary(HashIdentity.Reference) - let methMap = Dictionary(HashIdentity.Reference) - let fieldMap = Dictionary(HashIdentity.Reference) - - let iterateTypes f = - let rec typeMembers (ptd : ProvidedTypeDefinition) = - let tb = typeMap.[ptd] - f tb (Some ptd) - for ntd in ptd.GetNestedTypes(ALL) do - nestedType ntd - - and nestedType (ntd : Type) = - match ntd with - | :? ProvidedTypeDefinition as pntd -> typeMembers pntd - | _ -> () - - for (pt,enclosingGeneratedTypeNames) in providedTypeDefinitions do - match enclosingGeneratedTypeNames with - | None -> - typeMembers pt - | Some ns -> - let _fullName = - ("",ns) ||> List.fold (fun fullName n -> - let fullName = if fullName = "" then n else fullName + "." + n - f typeMapExtra.[fullName] None - fullName) - nestedType pt - - - // phase 1b - emit base types - iterateTypes (fun tb ptd -> - match ptd with - | None -> () - | Some ptd -> - match ptd.BaseType with null -> () | bt -> tb.SetParent(convType bt)) - - let defineCustomAttrs f (cattrs: IList) = - for attr in cattrs do - let constructorArgs = [ for x in attr.ConstructorArguments -> x.Value ] - let namedProps,namedPropVals = [ for x in attr.NamedArguments do match x.MemberInfo with :? PropertyInfo as pi -> yield (pi, x.TypedValue.Value) | _ -> () ] |> List.unzip - let namedFields,namedFieldVals = [ for x in attr.NamedArguments do match x.MemberInfo with :? FieldInfo as pi -> yield (pi, x.TypedValue.Value) | _ -> () ] |> List.unzip - let cab = CustomAttributeBuilder(attr.Constructor, Array.ofList constructorArgs, Array.ofList namedProps, Array.ofList namedPropVals, Array.ofList namedFields, Array.ofList namedFieldVals) - f cab - - // phase 2 - emit member definitions - iterateTypes (fun tb ptd -> - match ptd with - | None -> () - | Some ptd -> - for cinfo in ptd.GetConstructors(ALL) do - match cinfo with - | :? ProvidedConstructor as pcinfo when not (ctorMap.ContainsKey pcinfo) -> - let cb = - if pcinfo.IsTypeInitializer then - if (cinfo.GetParameters()).Length <> 0 then failwith "Type initializer should not have parameters" - tb.DefineTypeInitializer() - else - let cb = tb.DefineConstructor(cinfo.Attributes, CallingConventions.Standard, [| for p in cinfo.GetParameters() -> convType p.ParameterType |]) - for (i,p) in cinfo.GetParameters() |> Seq.mapi (fun i x -> (i,x)) do - cb.DefineParameter(i+1, ParameterAttributes.None, p.Name) |> ignore - cb - ctorMap.[pcinfo] <- cb - | _ -> () - - if ptd.IsEnum then - tb.DefineField("value__", ptd.GetEnumUnderlyingType(), FieldAttributes.Public ||| FieldAttributes.SpecialName ||| FieldAttributes.RTSpecialName) - |> ignore - - for finfo in ptd.GetFields(ALL) do - let fieldInfo = - match finfo with - | :? ProvidedField as pinfo -> - Some (pinfo.Name, convType finfo.FieldType, finfo.Attributes, pinfo.GetCustomAttributesDataImpl(), None) - | :? ProvidedLiteralField as pinfo -> - Some (pinfo.Name, convType finfo.FieldType, finfo.Attributes, pinfo.GetCustomAttributesDataImpl(), Some (pinfo.GetRawConstantValue())) - | _ -> None - match fieldInfo with - | Some (name, ty, attr, cattr, constantVal) when not (fieldMap.ContainsKey finfo) -> - let fb = tb.DefineField(name, ty, attr) - if constantVal.IsSome then - fb.SetConstant constantVal.Value - defineCustomAttrs fb.SetCustomAttribute cattr - fieldMap.[finfo] <- fb - | _ -> () - for minfo in ptd.GetMethods(ALL) do - match minfo with - | :? ProvidedMethod as pminfo when not (methMap.ContainsKey pminfo) -> - let mb = tb.DefineMethod(minfo.Name, minfo.Attributes, convType minfo.ReturnType, [| for p in minfo.GetParameters() -> convType p.ParameterType |]) - for (i, p) in minfo.GetParameters() |> Seq.mapi (fun i x -> (i,x :?> ProvidedParameter)) do - // TODO: check why F# compiler doesn't emit default value when just p.Attributes is used (thus bad metadata is emitted) -// let mutable attrs = ParameterAttributes.None -// -// if p.IsOut then attrs <- attrs ||| ParameterAttributes.Out -// if p.HasDefaultParameterValue then attrs <- attrs ||| ParameterAttributes.Optional - - let pb = mb.DefineParameter(i+1, p.Attributes, p.Name) - if p.HasDefaultParameterValue then - do - let ctor = typeof.GetConstructor([|typeof|]) - let builder = new CustomAttributeBuilder(ctor, [|p.RawDefaultValue|]) - pb.SetCustomAttribute builder - do - let ctor = typeof.GetConstructor([||]) - let builder = new CustomAttributeBuilder(ctor, [||]) - pb.SetCustomAttribute builder - pb.SetConstant p.RawDefaultValue - methMap.[pminfo] <- mb - | _ -> () - - for ityp in ptd.GetInterfaceImplementations() do - tb.AddInterfaceImplementation ityp) - - // phase 3 - emit member code - iterateTypes (fun tb ptd -> - match ptd with - | None -> () - | Some ptd -> - let cattr = ptd.GetCustomAttributesDataImpl() - defineCustomAttrs tb.SetCustomAttribute cattr - // Allow at most one constructor, and use its arguments as the fields of the type - let ctors = - ptd.GetConstructors(ALL) // exclude type initializer - |> Seq.choose (function :? ProvidedConstructor as pcinfo when not pcinfo.IsTypeInitializer -> Some pcinfo | _ -> None) - |> Seq.toList - let implictCtorArgs = - match ctors |> List.filter (fun x -> x.IsImplicitCtor) with - | [] -> [] - | [ pcinfo ] -> [ for p in pcinfo.GetParameters() -> p ] - | _ -> failwith "at most one implicit constructor allowed" - - let implicitCtorArgsAsFields = - [ for ctorArg in implictCtorArgs -> - tb.DefineField(ctorArg.Name, convType ctorArg.ParameterType, FieldAttributes.Private) ] - - let rec emitLambda(callSiteIlg : ILGenerator, v : Quotations.Var, body : Quotations.Expr, freeVars : seq, locals : Dictionary<_, LocalBuilder>, parameters) = - let lambda = assemblyMainModule.DefineType(uniqueLambdaTypeName(), TypeAttributes.Class) - let baseType = typedefof>.MakeGenericType(v.Type, body.Type) - lambda.SetParent(baseType) - let ctor = lambda.DefineDefaultConstructor(MethodAttributes.Public) - let decl = baseType.GetMethod "Invoke" - let paramTypes = [| for p in decl.GetParameters() -> p.ParameterType |] - let invoke = lambda.DefineMethod("Invoke", MethodAttributes.Virtual ||| MethodAttributes.Final ||| MethodAttributes.Public, decl.ReturnType, paramTypes) - lambda.DefineMethodOverride(invoke, decl) - - // promote free vars to fields - let fields = ResizeArray() - for v in freeVars do - let f = lambda.DefineField(v.Name, v.Type, FieldAttributes.Assembly) - fields.Add(v, f) - - let copyOfLocals = Dictionary() - - let ilg = invoke.GetILGenerator() - for (v, f) in fields do - let l = ilg.DeclareLocal(v.Type) - ilg.Emit(OpCodes.Ldarg_0) - ilg.Emit(OpCodes.Ldfld, f) - ilg.Emit(OpCodes.Stloc, l) - copyOfLocals.[v] <- l - - let expectedState = if (invoke.ReturnType = typeof) then ExpectedStackState.Empty else ExpectedStackState.Value - emitExpr (ilg, copyOfLocals, [| Quotations.Var("this", lambda); v|]) expectedState body - ilg.Emit(OpCodes.Ret) - - lambda.CreateType() |> ignore - - callSiteIlg.Emit(OpCodes.Newobj, ctor) - for (v, f) in fields do - callSiteIlg.Emit(OpCodes.Dup) - match locals.TryGetValue v with - | true, loc -> - callSiteIlg.Emit(OpCodes.Ldloc, loc) - | false, _ -> - let index = parameters |> Array.findIndex ((=) v) - callSiteIlg.Emit(OpCodes.Ldarg, index) - callSiteIlg.Emit(OpCodes.Stfld, f) - - and emitExpr (ilg: ILGenerator, locals:Dictionary, parameterVars) expectedState expr = - let pop () = ilg.Emit(OpCodes.Pop) - let popIfEmptyExpected s = if isEmpty s then pop() - let emitConvIfNecessary t1 = - if t1 = typeof then - ilg.Emit(OpCodes.Conv_I2) - elif t1 = typeof then - ilg.Emit(OpCodes.Conv_U2) - elif t1 = typeof then - ilg.Emit(OpCodes.Conv_I1) - elif t1 = typeof then - ilg.Emit(OpCodes.Conv_U1) - /// emits given expression to corresponding IL - let rec emit (expectedState : ExpectedStackState) (expr: Quotations.Expr) = - match expr with - | Quotations.Patterns.ForIntegerRangeLoop(loopVar, first, last, body) -> - // for(loopVar = first..last) body - let lb = - match locals.TryGetValue loopVar with - | true, lb -> lb - | false, _ -> - let lb = ilg.DeclareLocal(convType loopVar.Type) - locals.Add(loopVar, lb) - lb - - // loopVar = first - emit ExpectedStackState.Value first - ilg.Emit(OpCodes.Stloc, lb) - - let before = ilg.DefineLabel() - let after = ilg.DefineLabel() - - ilg.MarkLabel before - ilg.Emit(OpCodes.Ldloc, lb) - - emit ExpectedStackState.Value last - ilg.Emit(OpCodes.Bgt, after) - - emit ExpectedStackState.Empty body - - // loopVar++ - ilg.Emit(OpCodes.Ldloc, lb) - ilg.Emit(OpCodes.Ldc_I4_1) - ilg.Emit(OpCodes.Add) - ilg.Emit(OpCodes.Stloc, lb) - - ilg.Emit(OpCodes.Br, before) - ilg.MarkLabel(after) - - | Quotations.Patterns.NewArray(elementTy, elements) -> - ilg.Emit(OpCodes.Ldc_I4, List.length elements) - ilg.Emit(OpCodes.Newarr, convType elementTy) - - elements - |> List.iteri (fun i el -> - ilg.Emit(OpCodes.Dup) - ilg.Emit(OpCodes.Ldc_I4, i) - emit ExpectedStackState.Value el - ilg.Emit(OpCodes.Stelem, convType elementTy) - ) - - popIfEmptyExpected expectedState - - | Quotations.Patterns.WhileLoop(cond, body) -> - let before = ilg.DefineLabel() - let after = ilg.DefineLabel() - - ilg.MarkLabel before - emit ExpectedStackState.Value cond - ilg.Emit(OpCodes.Brfalse, after) - emit ExpectedStackState.Empty body - ilg.Emit(OpCodes.Br, before) - - ilg.MarkLabel after - - | Quotations.Patterns.Var v -> - if isEmpty expectedState then () else - let methIdx = parameterVars |> Array.tryFindIndex (fun p -> p = v) - match methIdx with - | Some idx -> - ilg.Emit((if isAddress expectedState then OpCodes.Ldarga else OpCodes.Ldarg), idx) - | None -> - let implicitCtorArgFieldOpt = implicitCtorArgsAsFields |> List.tryFind (fun f -> f.Name = v.Name) - match implicitCtorArgFieldOpt with - | Some ctorArgField -> - ilg.Emit(OpCodes.Ldarg_0) - ilg.Emit(OpCodes.Ldfld, ctorArgField) - | None -> - match locals.TryGetValue v with - | true, localBuilder -> - ilg.Emit((if isAddress expectedState then OpCodes.Ldloca else OpCodes.Ldloc), localBuilder.LocalIndex) - | false, _ -> - failwith "unknown parameter/field" - - | Quotations.Patterns.Coerce (arg,ty) -> - // castClass may lead to observable side-effects - InvalidCastException - emit ExpectedStackState.Value arg - let argTy = convType arg.Type - let targetTy = convType ty - if argTy.IsValueType && not targetTy.IsValueType then - ilg.Emit(OpCodes.Box, argTy) - elif not argTy.IsValueType && targetTy.IsValueType then - ilg.Emit(OpCodes.Unbox_Any, targetTy) - // emit castclass if - // - targettype is not obj (assume this is always possible for ref types) - // AND - // - HACK: targettype is TypeBuilderInstantiationType - // (its implementation of IsAssignableFrom raises NotSupportedException so it will be safer to always emit castclass) - // OR - // - not (argTy :> targetTy) - elif targetTy <> typeof && (Misc.TypeBuilderInstantiationType.Equals(targetTy.GetType()) || not (targetTy.IsAssignableFrom(argTy))) then - ilg.Emit(OpCodes.Castclass, targetTy) - - popIfEmptyExpected expectedState - | Quotations.DerivedPatterns.SpecificCall <@ (-) @>(None, [t1; t2; _], [a1; a2]) -> - assert(t1 = t2) - emit ExpectedStackState.Value a1 - emit ExpectedStackState.Value a2 - if t1 = typeof then - ilg.Emit(OpCodes.Call, typeof.GetMethod "op_Subtraction") - else - ilg.Emit(OpCodes.Sub) - emitConvIfNecessary t1 - - popIfEmptyExpected expectedState - - | Quotations.DerivedPatterns.SpecificCall <@ (/) @> (None, [t1; t2; _], [a1; a2]) -> - assert (t1 = t2) - emit ExpectedStackState.Value a1 - emit ExpectedStackState.Value a2 - if t1 = typeof then - ilg.Emit(OpCodes.Call, typeof.GetMethod "op_Division") - else - match Type.GetTypeCode t1 with - | TypeCode.UInt32 - | TypeCode.UInt64 - | TypeCode.UInt16 - | TypeCode.Byte - | _ when t1 = typeof -> ilg.Emit (OpCodes.Div_Un) - | _ -> ilg.Emit(OpCodes.Div) - - emitConvIfNecessary t1 - - popIfEmptyExpected expectedState - - | Quotations.DerivedPatterns.SpecificCall <@ int @>(None, [sourceTy], [v]) -> - emit ExpectedStackState.Value v - match Type.GetTypeCode(sourceTy) with - | TypeCode.String -> - ilg.Emit(OpCodes.Call, Misc.ParseInt32Method) - | TypeCode.Single - | TypeCode.Double - | TypeCode.Int64 - | TypeCode.UInt64 - | TypeCode.UInt16 - | TypeCode.Char - | TypeCode.Byte - | _ when sourceTy = typeof || sourceTy = typeof -> - ilg.Emit(OpCodes.Conv_I4) - | TypeCode.Int32 - | TypeCode.UInt32 - | TypeCode.Int16 - | TypeCode.SByte -> () // no op - | _ -> failwith "TODO: search for op_Explicit on sourceTy" - - | Quotations.DerivedPatterns.SpecificCall <@ LanguagePrimitives.IntrinsicFunctions.GetArray @> (None, [ty], [arr; index]) -> - // observable side-effect - IndexOutOfRangeException - emit ExpectedStackState.Value arr - emit ExpectedStackState.Value index - if isAddress expectedState then - ilg.Emit(OpCodes.Readonly) - ilg.Emit(OpCodes.Ldelema, convType ty) - else - ilg.Emit(OpCodes.Ldelem, convType ty) - - popIfEmptyExpected expectedState - - | Quotations.DerivedPatterns.SpecificCall <@ LanguagePrimitives.IntrinsicFunctions.GetArray2D @> (None, _ty, arr::indices) - | Quotations.DerivedPatterns.SpecificCall <@ LanguagePrimitives.IntrinsicFunctions.GetArray3D @> (None, _ty, arr::indices) - | Quotations.DerivedPatterns.SpecificCall <@ LanguagePrimitives.IntrinsicFunctions.GetArray4D @> (None, _ty, arr::indices) -> - - let meth = - let name = if isAddress expectedState then "Address" else "Get" - arr.Type.GetMethod(name) - - // observable side-effect - IndexOutOfRangeException - emit ExpectedStackState.Value arr - for index in indices do - emit ExpectedStackState.Value index - - if isAddress expectedState then - ilg.Emit(OpCodes.Readonly) - - ilg.Emit(OpCodes.Call, meth) - - popIfEmptyExpected expectedState - - | Quotations.Patterns.FieldGet (objOpt,field) -> - match field with - | :? ProvidedLiteralField as plf when plf.DeclaringType.IsEnum -> - if expectedState <> ExpectedStackState.Empty then - emit expectedState (Quotations.Expr.Value(field.GetRawConstantValue(), field.FieldType.GetEnumUnderlyingType())) - | _ -> - match objOpt with - | None -> () - | Some e -> - let s = if e.Type.IsValueType then ExpectedStackState.Address else ExpectedStackState.Value - emit s e - let field = - match field with - | :? ProvidedField as pf when fieldMap.ContainsKey pf -> fieldMap.[pf] :> FieldInfo - | m -> m - if field.IsStatic then - ilg.Emit(OpCodes.Ldsfld, field) - else - ilg.Emit(OpCodes.Ldfld, field) - - | Quotations.Patterns.FieldSet (objOpt,field,v) -> - match objOpt with - | None -> () - | Some e -> - let s = if e.Type.IsValueType then ExpectedStackState.Address else ExpectedStackState.Value - emit s e - emit ExpectedStackState.Value v - let field = match field with :? ProvidedField as pf when fieldMap.ContainsKey pf -> fieldMap.[pf] :> FieldInfo | m -> m - if field.IsStatic then - ilg.Emit(OpCodes.Stsfld, field) - else - ilg.Emit(OpCodes.Stfld, field) - | Quotations.Patterns.Call (objOpt,meth,args) -> - match objOpt with - | None -> () - | Some e -> - let s = if e.Type.IsValueType then ExpectedStackState.Address else ExpectedStackState.Value - emit s e - for pe in args do - emit ExpectedStackState.Value pe - let getMeth (m:MethodInfo) = match m with :? ProvidedMethod as pm when methMap.ContainsKey pm -> methMap.[pm] :> MethodInfo | m -> m - // Handle the case where this is a generic method instantiated at a type being compiled - let mappedMeth = - if meth.IsGenericMethod then - let args = meth.GetGenericArguments() |> Array.map convType - let gmd = meth.GetGenericMethodDefinition() |> getMeth - gmd.GetGenericMethodDefinition().MakeGenericMethod args - elif meth.DeclaringType.IsGenericType then - let gdty = convType (meth.DeclaringType.GetGenericTypeDefinition()) - let gdtym = gdty.GetMethods() |> Seq.find (fun x -> x.Name = meth.Name) - assert (gdtym <> null) // ?? will never happen - if method is not found - KeyNotFoundException will be raised - let dtym = - match convType meth.DeclaringType with - | :? TypeBuilder as dty -> TypeBuilder.GetMethod(dty, gdtym) - | dty -> MethodBase.GetMethodFromHandle(meth.MethodHandle, dty.TypeHandle) :?> _ - - assert (dtym <> null) - dtym - else - getMeth meth - match objOpt with - | Some obj when mappedMeth.IsAbstract || mappedMeth.IsVirtual -> - if obj.Type.IsValueType then ilg.Emit(OpCodes.Constrained, convType obj.Type) - ilg.Emit(OpCodes.Callvirt, mappedMeth) - | _ -> - ilg.Emit(OpCodes.Call, mappedMeth) - - let returnTypeIsVoid = mappedMeth.ReturnType = typeof - match returnTypeIsVoid, (isEmpty expectedState) with - | false, true -> - // method produced something, but we don't need it - pop() - | true, false when expr.Type = typeof -> - // if we need result and method produce void and result should be unit - push null as unit value on stack - ilg.Emit(OpCodes.Ldnull) - | _ -> () - - | Quotations.Patterns.NewObject (ctor,args) -> - for pe in args do - emit ExpectedStackState.Value pe - let meth = match ctor with :? ProvidedConstructor as pc when ctorMap.ContainsKey pc -> ctorMap.[pc] :> ConstructorInfo | c -> c - ilg.Emit(OpCodes.Newobj, meth) - - popIfEmptyExpected expectedState - - | Quotations.Patterns.Value (obj, _ty) -> - let rec emitC (v:obj) = - match v with - | :? string as x -> ilg.Emit(OpCodes.Ldstr, x) - | :? int8 as x -> ilg.Emit(OpCodes.Ldc_I4, int32 x) - | :? uint8 as x -> ilg.Emit(OpCodes.Ldc_I4, int32 (int8 x)) - | :? int16 as x -> ilg.Emit(OpCodes.Ldc_I4, int32 x) - | :? uint16 as x -> ilg.Emit(OpCodes.Ldc_I4, int32 (int16 x)) - | :? int32 as x -> ilg.Emit(OpCodes.Ldc_I4, x) - | :? uint32 as x -> ilg.Emit(OpCodes.Ldc_I4, int32 x) - | :? int64 as x -> ilg.Emit(OpCodes.Ldc_I8, x) - | :? uint64 as x -> ilg.Emit(OpCodes.Ldc_I8, int64 x) - | :? char as x -> ilg.Emit(OpCodes.Ldc_I4, int32 x) - | :? bool as x -> ilg.Emit(OpCodes.Ldc_I4, if x then 1 else 0) - | :? float32 as x -> ilg.Emit(OpCodes.Ldc_R4, x) - | :? float as x -> ilg.Emit(OpCodes.Ldc_R8, x) -#if FX_NO_GET_ENUM_UNDERLYING_TYPE -#else - | :? System.Enum as x when x.GetType().GetEnumUnderlyingType() = typeof -> ilg.Emit(OpCodes.Ldc_I4, unbox v) -#endif - | :? Type as ty -> - ilg.Emit(OpCodes.Ldtoken, convType ty) - ilg.Emit(OpCodes.Call, Misc.GetTypeFromHandleMethod) - | :? decimal as x -> - let bits = System.Decimal.GetBits x - ilg.Emit(OpCodes.Ldc_I4, bits.[0]) - ilg.Emit(OpCodes.Ldc_I4, bits.[1]) - ilg.Emit(OpCodes.Ldc_I4, bits.[2]) - do - let sign = (bits.[3] &&& 0x80000000) <> 0 - ilg.Emit(if sign then OpCodes.Ldc_I4_1 else OpCodes.Ldc_I4_0) - do - let scale = byte ((bits.[3] >>> 16) &&& 0x7F) - ilg.Emit(OpCodes.Ldc_I4_S, scale) - ilg.Emit(OpCodes.Newobj, Misc.DecimalConstructor) - | :? DateTime as x -> - ilg.Emit(OpCodes.Ldc_I8, x.Ticks) - ilg.Emit(OpCodes.Ldc_I4, int x.Kind) - ilg.Emit(OpCodes.Newobj, Misc.DateTimeConstructor) - | :? DateTimeOffset as x -> - ilg.Emit(OpCodes.Ldc_I8, x.Ticks) - ilg.Emit(OpCodes.Ldc_I8, x.Offset.Ticks) - ilg.Emit(OpCodes.Newobj, Misc.TimeSpanConstructor) - ilg.Emit(OpCodes.Newobj, Misc.DateTimeOffsetConstructor) - | null -> ilg.Emit(OpCodes.Ldnull) - | _ -> failwithf "unknown constant '%A' in generated method" v - if isEmpty expectedState then () - else emitC obj - - | Quotations.Patterns.Let(v,e,b) -> - let lb = ilg.DeclareLocal (convType v.Type) - locals.Add (v, lb) - emit ExpectedStackState.Value e - ilg.Emit(OpCodes.Stloc, lb.LocalIndex) - emit expectedState b - - | Quotations.Patterns.Sequential(e1, e2) -> - emit ExpectedStackState.Empty e1 - emit expectedState e2 - - | Quotations.Patterns.IfThenElse(cond, ifTrue, ifFalse) -> - let ifFalseLabel = ilg.DefineLabel() - let endLabel = ilg.DefineLabel() - - emit ExpectedStackState.Value cond - - ilg.Emit(OpCodes.Brfalse, ifFalseLabel) - - emit expectedState ifTrue - ilg.Emit(OpCodes.Br, endLabel) - - ilg.MarkLabel(ifFalseLabel) - emit expectedState ifFalse - - ilg.Emit(OpCodes.Nop) - ilg.MarkLabel(endLabel) - - | Quotations.Patterns.TryWith(body, _filterVar, _filterBody, catchVar, catchBody) -> - - let stres, ldres = - if isEmpty expectedState then ignore, ignore - else - let local = ilg.DeclareLocal (convType body.Type) - let stres = fun () -> ilg.Emit(OpCodes.Stloc, local) - let ldres = fun () -> ilg.Emit(OpCodes.Ldloc, local) - stres, ldres - - let exceptionVar = ilg.DeclareLocal(convType catchVar.Type) - locals.Add(catchVar, exceptionVar) - - let _exnBlock = ilg.BeginExceptionBlock() - - emit expectedState body - stres() - - ilg.BeginCatchBlock(convType catchVar.Type) - ilg.Emit(OpCodes.Stloc, exceptionVar) - emit expectedState catchBody - stres() - ilg.EndExceptionBlock() - - ldres() - - | Quotations.Patterns.VarSet(v,e) -> - emit ExpectedStackState.Value e - match locals.TryGetValue v with - | true, localBuilder -> - ilg.Emit(OpCodes.Stloc, localBuilder.LocalIndex) - | false, _ -> - failwith "unknown parameter/field in assignment. Only assignments to locals are currently supported by TypeProviderEmit" - | Quotations.Patterns.Lambda(v, body) -> - emitLambda(ilg, v, body, expr.GetFreeVars(), locals, parameterVars) - popIfEmptyExpected expectedState - | n -> - failwith (sprintf "unknown expression '%A' in generated method" n) - emit expectedState expr - - - // Emit the constructor (if any) - for pcinfo in ctors do - assert ctorMap.ContainsKey pcinfo - let cb = ctorMap.[pcinfo] - let cattr = pcinfo.GetCustomAttributesDataImpl() - defineCustomAttrs cb.SetCustomAttribute cattr - let ilg = cb.GetILGenerator() - let locals = Dictionary() - let parameterVars = - [| yield Quotations.Var("this", pcinfo.DeclaringType) - for p in pcinfo.GetParameters() do - yield Quotations.Var(p.Name, p.ParameterType) |] - let parameters = - [| for v in parameterVars -> Quotations.Expr.Var v |] - match pcinfo.GetBaseConstructorCallInternal true with - | None -> - ilg.Emit(OpCodes.Ldarg_0) - let cinfo = ptd.BaseType.GetConstructor(BindingFlags.Public ||| BindingFlags.NonPublic ||| BindingFlags.Instance, null, [| |], null) - ilg.Emit(OpCodes.Call,cinfo) - | Some f -> - // argExprs should always include 'this' - let (cinfo,argExprs) = f (Array.toList parameters) - for argExpr in argExprs do - emitExpr (ilg, locals, parameterVars) ExpectedStackState.Value argExpr - ilg.Emit(OpCodes.Call,cinfo) - - if pcinfo.IsImplicitCtor then - for ctorArgsAsFieldIdx,ctorArgsAsField in List.mapi (fun i x -> (i,x)) implicitCtorArgsAsFields do - ilg.Emit(OpCodes.Ldarg_0) - ilg.Emit(OpCodes.Ldarg, ctorArgsAsFieldIdx+1) - ilg.Emit(OpCodes.Stfld, ctorArgsAsField) - else - let code = pcinfo.GetInvokeCodeInternal true - let code = code parameters - emitExpr (ilg, locals, parameterVars) ExpectedStackState.Empty code - ilg.Emit(OpCodes.Ret) - - match ptd.GetConstructors(ALL) |> Seq.tryPick (function :? ProvidedConstructor as pc when pc.IsTypeInitializer -> Some pc | _ -> None) with - | None -> () - | Some pc -> - let cb = ctorMap.[pc] - let ilg = cb.GetILGenerator() - let cattr = pc.GetCustomAttributesDataImpl() - defineCustomAttrs cb.SetCustomAttribute cattr - let expr = pc.GetInvokeCodeInternal true [||] - emitExpr(ilg, new Dictionary<_, _>(), [||]) ExpectedStackState.Empty expr - ilg.Emit OpCodes.Ret - - // Emit the methods - for minfo in ptd.GetMethods(ALL) do - match minfo with - | :? ProvidedMethod as pminfo -> - let mb = methMap.[pminfo] - let ilg = mb.GetILGenerator() - let cattr = pminfo.GetCustomAttributesDataImpl() - defineCustomAttrs mb.SetCustomAttribute cattr - - let parameterVars = - [| if not pminfo.IsStatic then - yield Quotations.Var("this", pminfo.DeclaringType) - for p in pminfo.GetParameters() do - yield Quotations.Var(p.Name, p.ParameterType) |] - let parameters = - [| for v in parameterVars -> Quotations.Expr.Var v |] - - let expr = pminfo.GetInvokeCodeInternal true parameters - - let locals = Dictionary() - //printfn "Emitting linqCode for %s::%s, code = %s" pminfo.DeclaringType.FullName pminfo.Name (try linqCode.ToString() with _ -> "") - - - let expectedState = if (minfo.ReturnType = typeof) then ExpectedStackState.Empty else ExpectedStackState.Value - emitExpr (ilg, locals, parameterVars) expectedState expr - ilg.Emit OpCodes.Ret - | _ -> () - - for (bodyMethInfo,declMethInfo) in ptd.GetMethodOverrides() do - let bodyMethBuilder = methMap.[bodyMethInfo] - tb.DefineMethodOverride(bodyMethBuilder,declMethInfo) - - for evt in ptd.GetEvents(ALL) |> Seq.choose (function :? ProvidedEvent as pe -> Some pe | _ -> None) do - let eb = tb.DefineEvent(evt.Name, evt.Attributes, evt.EventHandlerType) - defineCustomAttrs eb.SetCustomAttribute (evt.GetCustomAttributesDataImpl()) - eb.SetAddOnMethod(methMap.[evt.GetAddMethod(true) :?> _]) - eb.SetRemoveOnMethod(methMap.[evt.GetRemoveMethod(true) :?> _]) - // TODO: add raiser - - for pinfo in ptd.GetProperties(ALL) |> Seq.choose (function :? ProvidedProperty as pe -> Some pe | _ -> None) do - let pb = tb.DefineProperty(pinfo.Name, pinfo.Attributes, convType pinfo.PropertyType, [| for p in pinfo.GetIndexParameters() -> convType p.ParameterType |]) - let cattr = pinfo.GetCustomAttributesDataImpl() - defineCustomAttrs pb.SetCustomAttribute cattr - if pinfo.CanRead then - let minfo = pinfo.GetGetMethod(true) - pb.SetGetMethod (methMap.[minfo :?> ProvidedMethod ]) - if pinfo.CanWrite then - let minfo = pinfo.GetSetMethod(true) - pb.SetSetMethod (methMap.[minfo :?> ProvidedMethod ])) - - - // phase 4 - complete types - iterateTypes (fun tb _ptd -> tb.CreateType() |> ignore) - -#if FX_NO_LOCAL_FILESYSTEM -#else - assembly.Save (Path.GetFileName assemblyFileName) -#endif - - let assemblyLoadedInMemory = assemblyMainModule.Assembly - - iterateTypes (fun _tb ptd -> - match ptd with - | None -> () - | Some ptd -> ptd.SetAssembly assemblyLoadedInMemory) - -#if FX_NO_LOCAL_FILESYSTEM -#else - member __.GetFinalBytes() = - let assemblyBytes = File.ReadAllBytes assemblyFileName - let _assemblyLoadedInMemory = System.Reflection.Assembly.Load(assemblyBytes,null,System.Security.SecurityContextSource.CurrentAppDomain) - //printfn "final bytes in '%s'" assemblyFileName - //File.Delete assemblyFileName - assemblyBytes -#endif - -type ProvidedAssembly(assemblyFileName: string) = - let theTypes = ResizeArray<_>() - let assemblyGenerator = AssemblyGenerator(assemblyFileName) - let assemblyLazy = - lazy - assemblyGenerator.Generate(theTypes |> Seq.toList) - assemblyGenerator.Assembly -#if FX_NO_LOCAL_FILESYSTEM -#else - let theAssemblyBytesLazy = - lazy - assemblyGenerator.GetFinalBytes() - - do - GlobalProvidedAssemblyElementsTable.theTable.Add(assemblyGenerator.Assembly, theAssemblyBytesLazy) - -#endif - - let add (providedTypeDefinitions:ProvidedTypeDefinition list, enclosingTypeNames: string list option) = - for pt in providedTypeDefinitions do - if pt.IsErased then invalidOp ("The provided type "+pt.Name+"is marked as erased and cannot be converted to a generated type. Set 'IsErased' to false on the ProvidedTypeDefinition") - theTypes.Add(pt,enclosingTypeNames) - pt.SetAssemblyLazy assemblyLazy - - member x.AddNestedTypes (providedTypeDefinitions, enclosingTypeNames) = add (providedTypeDefinitions, Some enclosingTypeNames) - member x.AddTypes (providedTypeDefinitions) = add (providedTypeDefinitions, None) -#if FX_NO_LOCAL_FILESYSTEM -#else - static member RegisterGenerated (fileName:string) = - //printfn "registered assembly in '%s'" fileName - let assemblyBytes = System.IO.File.ReadAllBytes fileName - let assembly = Assembly.Load(assemblyBytes,null,System.Security.SecurityContextSource.CurrentAppDomain) - GlobalProvidedAssemblyElementsTable.theTable.Add(assembly, Lazy<_>.CreateFromValue assemblyBytes) - assembly -#endif - - -module Local = - - let makeProvidedNamespace (namespaceName:string) (types:ProvidedTypeDefinition list) = - let types = [| for ty in types -> ty :> Type |] - {new IProvidedNamespace with - member __.GetNestedNamespaces() = [| |] - member __.NamespaceName = namespaceName - member __.GetTypes() = types |> Array.copy - member __.ResolveTypeName typeName : System.Type = - match types |> Array.tryFind (fun ty -> ty.Name = typeName) with - | Some ty -> ty - | None -> null - // let typenames = String.concat "," (types |> Array.map (fun t -> t.Name)) - // failwith (sprintf "Unknown type '%s' in namespace '%s' (contains %s)" typeName namespaceName typenames) - } - - -#if FX_NO_LOCAL_FILESYSTEM -type TypeProviderForNamespaces(namespacesAndTypes : list<(string * list)>) = -#else -type TypeProviderForNamespaces(namespacesAndTypes : list<(string * list)>) as this = -#endif - let otherNamespaces = ResizeArray>() - - let providedNamespaces = - lazy [| for (namespaceName,types) in namespacesAndTypes do - yield Local.makeProvidedNamespace namespaceName types - for (namespaceName,types) in otherNamespaces do - yield Local.makeProvidedNamespace namespaceName types |] - - let invalidateE = new Event() - - let disposing = Event() - -#if FX_NO_LOCAL_FILESYSTEM -#else - let probingFolders = ResizeArray() - let handler = ResolveEventHandler(fun _ args -> this.ResolveAssembly(args)) - do AppDomain.CurrentDomain.add_AssemblyResolve handler -#endif - - new (namespaceName:string,types:list) = new TypeProviderForNamespaces([(namespaceName,types)]) - new () = new TypeProviderForNamespaces([]) - - [] - member this.Disposing = disposing.Publish - -#if FX_NO_LOCAL_FILESYSTEM - interface System.IDisposable with - member x.Dispose() = - disposing.Trigger(x, EventArgs.Empty) -#else - abstract member ResolveAssembly : args : System.ResolveEventArgs -> Assembly - default this.ResolveAssembly(args) = - let expectedName = (AssemblyName(args.Name)).Name + ".dll" - let expectedLocationOpt = - probingFolders - |> Seq.map (fun f -> IO.Path.Combine(f, expectedName)) - |> Seq.tryFind IO.File.Exists - match expectedLocationOpt with - | Some f -> Assembly.LoadFrom f - | None -> null - - member this.RegisterProbingFolder (folder) = - // use GetFullPath to ensure that folder is valid - ignore(IO.Path.GetFullPath folder) - probingFolders.Add folder - member this.RegisterRuntimeAssemblyLocationAsProbingFolder (cfg : Core.CompilerServices.TypeProviderConfig) = - cfg.RuntimeAssembly - |> IO.Path.GetDirectoryName - |> this.RegisterProbingFolder - - interface System.IDisposable with - member x.Dispose() = - disposing.Trigger(x, EventArgs.Empty) - AppDomain.CurrentDomain.remove_AssemblyResolve handler -#endif - - member __.AddNamespace (namespaceName,types:list<_>) = otherNamespaces.Add (namespaceName,types) - // FSharp.Data addition: this method is used by Debug.fs - member __.Namespaces = Seq.readonly otherNamespaces - member self.Invalidate() = invalidateE.Trigger(self,EventArgs()) - interface ITypeProvider with - [] - override this.Invalidate = invalidateE.Publish - override this.GetNamespaces() = Array.copy providedNamespaces.Value - member __.GetInvokerExpression(methodBase, parameters) = - let rec getInvokerExpression (methodBase : MethodBase) parameters = - match methodBase with - | :? ProvidedMethod as m when (match methodBase.DeclaringType with :? ProvidedTypeDefinition as pt -> pt.IsErased | _ -> true) -> - m.GetInvokeCodeInternal false parameters - |> expand - | :? ProvidedConstructor as m when (match methodBase.DeclaringType with :? ProvidedTypeDefinition as pt -> pt.IsErased | _ -> true) -> - m.GetInvokeCodeInternal false parameters - |> expand - // Otherwise, assume this is a generative assembly and just emit a call to the constructor or method - | :? ConstructorInfo as cinfo -> - Quotations.Expr.NewObject(cinfo, Array.toList parameters) - | :? System.Reflection.MethodInfo as minfo -> - if minfo.IsStatic then - Quotations.Expr.Call(minfo, Array.toList parameters) - else - Quotations.Expr.Call(parameters.[0], minfo, Array.toList parameters.[1..]) - | _ -> failwith ("TypeProviderForNamespaces.GetInvokerExpression: not a ProvidedMethod/ProvidedConstructor/ConstructorInfo/MethodInfo, name=" + methodBase.Name + " class=" + methodBase.GetType().FullName) - and expand expr = - match expr with - | Quotations.Patterns.NewObject(ctor, args) -> getInvokerExpression ctor [| for arg in args -> expand arg|] - | Quotations.Patterns.Call(inst, mi, args) -> - let args = - [| - match inst with - | Some inst -> yield expand inst - | _ -> () - yield! List.map expand args - |] - getInvokerExpression mi args - | Quotations.ExprShape.ShapeVar v -> Quotations.Expr.Var v - | Quotations.ExprShape.ShapeLambda(v, body) -> Quotations.Expr.Lambda(v, expand body) - | Quotations.ExprShape.ShapeCombination(shape, args) -> Quotations.ExprShape.RebuildShapeCombination(shape, List.map expand args) - getInvokerExpression methodBase parameters -#if FX_NO_CUSTOMATTRIBUTEDATA - - member __.GetMemberCustomAttributesData(methodBase) = - match methodBase with - | :? ProvidedTypeDefinition as m -> m.GetCustomAttributesDataImpl() - | :? ProvidedMethod as m -> m.GetCustomAttributesDataImpl() - | :? ProvidedProperty as m -> m.GetCustomAttributesDataImpl() - | :? ProvidedConstructor as m -> m.GetCustomAttributesDataImpl() - | :? ProvidedEvent as m -> m.GetCustomAttributesDataImpl() - | :? ProvidedLiteralField as m -> m.GetCustomAttributesDataImpl() - | :? ProvidedField as m -> m.GetCustomAttributesDataImpl() - | _ -> [| |] :> IList<_> - - member __.GetParameterCustomAttributesData(methodBase) = - match methodBase with - | :? ProvidedParameter as m -> m.GetCustomAttributesDataImpl() - | _ -> [| |] :> IList<_> - - -#endif - override this.GetStaticParameters(ty) = - match ty with - | :? ProvidedTypeDefinition as t -> - if ty.Name = t.Name (* REVIEW: use equality? *) then - t.GetStaticParameters() - else - [| |] - | _ -> [| |] - - override this.ApplyStaticArguments(ty,typePathAfterArguments:string[],objs) = - let typePathAfterArguments = typePathAfterArguments.[typePathAfterArguments.Length-1] - match ty with - | :? ProvidedTypeDefinition as t -> (t.MakeParametricType(typePathAfterArguments,objs) :> Type) - | _ -> failwith (sprintf "ApplyStaticArguments: static params for type %s are unexpected" ty.FullName) - -#if FX_NO_LOCAL_FILESYSTEM - override x.GetGeneratedAssemblyContents(_assembly) = - // TODO: this is very fake, we rely on the fact it is never needed - match System.Windows.Application.GetResourceStream(System.Uri("FSharp.Core.dll",System.UriKind.Relative)) with - | null -> failwith "FSharp.Core.dll not found as Manifest Resource, we're just trying to read some random .NET assembly, ok?" - | resStream -> - use stream = resStream.Stream - let len = stream.Length - let buf = Array.zeroCreate (int len) - let rec loop where rem = - let n = stream.Read(buf, 0, int rem) - if n < rem then loop (where + n) (rem - n) - loop 0 (int len) - buf - - //failwith "no file system" -#else - override x.GetGeneratedAssemblyContents(assembly:Assembly) = - //printfn "looking up assembly '%s'" assembly.FullName - match GlobalProvidedAssemblyElementsTable.theTable.TryGetValue assembly with - | true,bytes -> bytes.Force() - | _ -> - let bytes = System.IO.File.ReadAllBytes assembly.ManifestModule.FullyQualifiedName - GlobalProvidedAssemblyElementsTable.theTable.[assembly] <- Lazy<_>.CreateFromValue bytes - bytes -#endif diff --git a/MyFirstTypeProvider-Pristine/MyFirstTypeProvider/ProvidedTypes.fsi b/MyFirstTypeProvider-Pristine/MyFirstTypeProvider/ProvidedTypes.fsi deleted file mode 100644 index 5e8511b..0000000 --- a/MyFirstTypeProvider-Pristine/MyFirstTypeProvider/ProvidedTypes.fsi +++ /dev/null @@ -1,445 +0,0 @@ -// Based on code developed for the F# 3.0 Beta release of March 2012, -// Copyright (c) Microsoft Corporation 2005-2012. -// This sample code is provided "as is" without warranty of any kind. -// We disclaim all warranties, either express or implied, including the -// warranties of merchantability and fitness for a particular purpose. - -// This file contains a set of helper types and methods for providing types in an implementation -// of ITypeProvider. - -// This code has been modified and is appropriate for use in conjunction with the F# 3.0, F# 3.1, and F# 3.1.1 releases - - -namespace ProviderImplementation.ProvidedTypes - -open System -open System.Reflection -open System.Linq.Expressions -open Microsoft.FSharp.Core.CompilerServices - -/// Represents an erased provided parameter -type ProvidedParameter = - inherit System.Reflection.ParameterInfo - new : parameterName: string * parameterType: Type * ?isOut:bool * ?optionalValue:obj -> ProvidedParameter - member IsParamArray : bool with get,set - -/// Represents an erased provided constructor. -type ProvidedConstructor = - inherit System.Reflection.ConstructorInfo - - /// Create a new provided constructor. It is not initially associated with any specific provided type definition. - new : parameters: ProvidedParameter list -> ProvidedConstructor - - /// Add a 'System.Obsolete' attribute to this provided constructor - member AddObsoleteAttribute : message: string * ?isError: bool -> unit - - /// Add XML documentation information to this provided constructor - member AddXmlDoc : xmlDoc: string -> unit - - /// Add XML documentation information to this provided constructor, where the computation of the documentation is delayed until necessary - member AddXmlDocDelayed : xmlDocFunction: (unit -> string) -> unit - - /// Add XML documentation information to this provided constructor, where the documentation is re-computed every time it is required. - member AddXmlDocComputed : xmlDocFunction: (unit -> string) -> unit - - /// Set the quotation used to compute the implementation of invocations of this constructor. - member InvokeCode : (Quotations.Expr list -> Quotations.Expr) with set - - /// FSharp.Data addition: this method is used by Debug.fs - member internal GetInvokeCodeInternal : bool -> (Quotations.Expr [] -> Quotations.Expr) - - /// Set the target and arguments of the base constructor call. Only used for generated types. - member BaseConstructorCall : (Quotations.Expr list -> ConstructorInfo * Quotations.Expr list) with set - - /// Set a flag indicating that the constructor acts like an F# implicit constructor, so the - /// parameters of the constructor become fields and can be accessed using Expr.GlobalVar with the - /// same name. - member IsImplicitCtor : bool with get,set - - /// Add definition location information to the provided constructor. - member AddDefinitionLocation : line:int * column:int * filePath:string -> unit - - member IsTypeInitializer : bool with get,set - -type ProvidedMethod = - inherit System.Reflection.MethodInfo - - /// Create a new provided method. It is not initially associated with any specific provided type definition. - new : methodName:string * parameters: ProvidedParameter list * returnType: Type -> ProvidedMethod - - /// Add XML documentation information to this provided method - member AddObsoleteAttribute : message: string * ?isError: bool -> unit - - /// Add XML documentation information to this provided constructor - member AddXmlDoc : xmlDoc: string -> unit - - /// Add XML documentation information to this provided constructor, where the computation of the documentation is delayed until necessary - member AddXmlDocDelayed : xmlDocFunction: (unit -> string) -> unit - - /// Add XML documentation information to this provided constructor, where the computation of the documentation is delayed until necessary - /// The documentation is re-computed every time it is required. - member AddXmlDocComputed : xmlDocFunction: (unit -> string) -> unit - - member AddMethodAttrs : attributes:MethodAttributes -> unit - - /// Set the method attributes of the method. By default these are simple 'MethodAttributes.Public' - member SetMethodAttrs : attributes:MethodAttributes -> unit - - /// Get or set a flag indicating if the property is static. - member IsStaticMethod : bool with get, set - - /// Set the quotation used to compute the implementation of invocations of this method. - member InvokeCode : (Quotations.Expr list -> Quotations.Expr) with set - - /// FSharp.Data addition: this method is used by Debug.fs - member internal GetInvokeCodeInternal : bool -> (Quotations.Expr [] -> Quotations.Expr) - - /// Add definition location information to the provided type definition. - member AddDefinitionLocation : line:int * column:int * filePath:string -> unit - - /// Add a custom attribute to the provided method definition. - member AddCustomAttribute : CustomAttributeData -> unit - - - -/// Represents an erased provided property. -type ProvidedProperty = - inherit System.Reflection.PropertyInfo - - /// Create a new provided type. It is not initially associated with any specific provided type definition. - new : propertyName: string * propertyType: Type * ?parameters:ProvidedParameter list -> ProvidedProperty - - /// Add a 'System.Obsolete' attribute to this provided property - member AddObsoleteAttribute : message: string * ?isError: bool -> unit - - /// Add XML documentation information to this provided constructor - member AddXmlDoc : xmlDoc: string -> unit - - /// Add XML documentation information to this provided constructor, where the computation of the documentation is delayed until necessary - member AddXmlDocDelayed : xmlDocFunction: (unit -> string) -> unit - - /// Add XML documentation information to this provided constructor, where the computation of the documentation is delayed until necessary - /// The documentation is re-computed every time it is required. - member AddXmlDocComputed : xmlDocFunction: (unit -> string) -> unit - - /// Get or set a flag indicating if the property is static. - /// FSharp.Data addition: the getter is used by Debug.fs - member IsStatic : bool with get,set - - /// Set the quotation used to compute the implementation of gets of this property. - member GetterCode : (Quotations.Expr list -> Quotations.Expr) with set - - /// Set the function used to compute the implementation of sets of this property. - member SetterCode : (Quotations.Expr list -> Quotations.Expr) with set - - /// Add definition location information to the provided type definition. - member AddDefinitionLocation : line:int * column:int * filePath:string -> unit - - /// Add a custom attribute to the provided property definition. - member AddCustomAttribute : CustomAttributeData -> unit - -/// Represents an erased provided property. -type ProvidedEvent = - inherit System.Reflection.EventInfo - - /// Create a new provided type. It is not initially associated with any specific provided type definition. - new : propertyName: string * eventHandlerType: Type -> ProvidedEvent - - /// Add XML documentation information to this provided constructor - member AddXmlDoc : xmlDoc: string -> unit - - /// Add XML documentation information to this provided constructor, where the computation of the documentation is delayed until necessary - member AddXmlDocDelayed : xmlDocFunction: (unit -> string) -> unit - - /// Add XML documentation information to this provided constructor, where the computation of the documentation is delayed until necessary - /// The documentation is re-computed every time it is required. - member AddXmlDocComputed : xmlDocFunction: (unit -> string) -> unit - - /// Get or set a flag indicating if the property is static. - member IsStatic : bool with set - - /// Set the quotation used to compute the implementation of gets of this property. - member AdderCode : (Quotations.Expr list -> Quotations.Expr) with set - - /// Set the function used to compute the implementation of sets of this property. - member RemoverCode : (Quotations.Expr list -> Quotations.Expr) with set - - /// Add definition location information to the provided type definition. - member AddDefinitionLocation : line:int * column:int * filePath:string -> unit - -/// Represents an erased provided field. -type ProvidedLiteralField = - inherit System.Reflection.FieldInfo - - /// Create a new provided field. It is not initially associated with any specific provided type definition. - new : fieldName: string * fieldType: Type * literalValue: obj -> ProvidedLiteralField - - /// Add a 'System.Obsolete' attribute to this provided field - member AddObsoleteAttribute : message: string * ?isError: bool -> unit - - /// Add XML documentation information to this provided field - member AddXmlDoc : xmlDoc: string -> unit - - /// Add XML documentation information to this provided field, where the computation of the documentation is delayed until necessary - member AddXmlDocDelayed : xmlDocFunction: (unit -> string) -> unit - - /// Add XML documentation information to this provided field, where the computation of the documentation is delayed until necessary - /// The documentation is re-computed every time it is required. - member AddXmlDocComputed : xmlDocFunction: (unit -> string) -> unit - - /// Add definition location information to the provided field. - member AddDefinitionLocation : line:int * column:int * filePath:string -> unit - -/// Represents an erased provided field. -type ProvidedField = - inherit System.Reflection.FieldInfo - - /// Create a new provided field. It is not initially associated with any specific provided type definition. - new : fieldName: string * fieldType: Type -> ProvidedField - - /// Add a 'System.Obsolete' attribute to this provided field - member AddObsoleteAttribute : message: string * ?isError: bool -> unit - - /// Add XML documentation information to this provided field - member AddXmlDoc : xmlDoc: string -> unit - - /// Add XML documentation information to this provided field, where the computation of the documentation is delayed until necessary - member AddXmlDocDelayed : xmlDocFunction: (unit -> string) -> unit - - /// Add XML documentation information to this provided field, where the computation of the documentation is delayed until necessary - /// The documentation is re-computed every time it is required. - member AddXmlDocComputed : xmlDocFunction: (unit -> string) -> unit - - /// Add definition location information to the provided field definition. - member AddDefinitionLocation : line:int * column:int * filePath:string -> unit - - member SetFieldAttributes : attributes : FieldAttributes -> unit - -/// FSharp.Data addition: SymbolKind is used by AssemblyReplacer.fs -/// Represents the type constructor in a provided symbol type. -[] -type SymbolKind = - | SDArray - | Array of int - | Pointer - | ByRef - | Generic of System.Type - | FSharpTypeAbbreviation of (System.Reflection.Assembly * string * string[]) - -/// FSharp.Data addition: ProvidedSymbolType is used by AssemblyReplacer.fs -/// Represents an array or other symbolic type involving a provided type as the argument. -/// See the type provider spec for the methods that must be implemented. -/// Note that the type provider specification does not require us to implement pointer-equality for provided types. -[] -type ProvidedSymbolType = - inherit System.Type - - /// Returns the kind of this symbolic type - member Kind : SymbolKind - /// Return the provided types used as arguments of this symbolic type - member Args : list - - -/// Provides symbolic provided types -[] -type ProvidedTypeBuilder = - /// Like typ.MakeGenericType, but will also work with unit-annotated types - static member MakeGenericType: genericTypeDefinition: System.Type * genericArguments: System.Type list -> System.Type - /// Like methodInfo.MakeGenericMethod, but will also work with unit-annotated types and provided types - static member MakeGenericMethod: genericMethodDefinition: System.Reflection.MethodInfo * genericArguments: System.Type list -> MethodInfo - -/// Helps create erased provided unit-of-measure annotations. -[] -type ProvidedMeasureBuilder = - - /// The ProvidedMeasureBuilder for building measures. - static member Default : ProvidedMeasureBuilder - - /// e.g. 1 - member One : System.Type - /// e.g. m * kg - member Product : measure1: System.Type * measure1: System.Type -> System.Type - /// e.g. 1 / kg - member Inverse : denominator: System.Type -> System.Type - - /// e.g. kg / m - member Ratio : numerator: System.Type * denominator: System.Type -> System.Type - - /// e.g. m * m - member Square : ``measure``: System.Type -> System.Type - - /// the SI unit from the F# core library, where the string is in capitals and US spelling, e.g. Meter - member SI : string -> System.Type - - /// e.g. float, Vector - member AnnotateType : basic: System.Type * argument: System.Type list -> System.Type - - -/// Represents a provided static parameter. -type ProvidedStaticParameter = - inherit System.Reflection.ParameterInfo - new : parameterName: string * parameterType:Type * ?parameterDefaultValue:obj -> ProvidedStaticParameter - - /// Add XML documentation information to this provided constructor - member AddXmlDoc : xmlDoc: string -> unit - - /// Add XML documentation information to this provided constructor, where the computation of the documentation is delayed until necessary - member AddXmlDocDelayed : xmlDocFunction: (unit -> string) -> unit - -/// Represents a provided type definition. -type ProvidedTypeDefinition = - inherit System.Type - - /// Create a new provided type definition in a namespace. - new : assembly: Assembly * namespaceName: string * className: string * baseType: Type option -> ProvidedTypeDefinition - - /// Create a new provided type definition, to be located as a nested type in some type definition. - new : className : string * baseType: Type option -> ProvidedTypeDefinition - - /// Add the given type as an implemented interface. - member AddInterfaceImplementation : interfaceType: Type -> unit - - /// Add the given function as a set of on-demand computed interfaces. - member AddInterfaceImplementationsDelayed : interfacesFunction:(unit -> Type list)-> unit - - /// Specifies that the given method body implements the given method declaration. - member DefineMethodOverride : methodInfoBody: ProvidedMethod * methodInfoDeclaration: MethodInfo -> unit - - /// Add a 'System.Obsolete' attribute to this provided type definition - member AddObsoleteAttribute : message: string * ?isError: bool -> unit - - /// Add XML documentation information to this provided constructor - member AddXmlDoc : xmlDoc: string -> unit - - /// Set the base type - member SetBaseType : Type -> unit - - /// Set the base type to a lazily evaluated value - member SetBaseTypeDelayed : Lazy -> unit - - /// Set underlying type for generated enums - member SetEnumUnderlyingType : Type -> unit - - /// Add XML documentation information to this provided constructor, where the computation of the documentation is delayed until necessary. - /// The documentation is only computed once. - member AddXmlDocDelayed : xmlDocFunction: (unit -> string) -> unit - - /// Add XML documentation information to this provided constructor, where the computation of the documentation is delayed until necessary - /// The documentation is re-computed every time it is required. - member AddXmlDocComputed : xmlDocFunction: (unit -> string) -> unit - - /// Set the attributes on the provided type. This fully replaces the default TypeAttributes. - member SetAttributes : System.Reflection.TypeAttributes -> unit - - /// Reset the enclosing type (for generated nested types) - member ResetEnclosingType: enclosingType:System.Type -> unit - - /// Add a method, property, nested type or other member to a ProvidedTypeDefinition - member AddMember : memberInfo:MemberInfo -> unit - /// Add a set of members to a ProvidedTypeDefinition - member AddMembers : memberInfos:list<#MemberInfo> -> unit - - /// Add a member to a ProvidedTypeDefinition, delaying computation of the members until required by the compilation context. - member AddMemberDelayed : memberFunction:(unit -> #MemberInfo) -> unit - - /// Add a set of members to a ProvidedTypeDefinition, delaying computation of the members until required by the compilation context. - member AddMembersDelayed : (unit -> list<#MemberInfo>) -> unit - - /// Add the types of the generated assembly as generative types, where types in namespaces get hierarchically positioned as nested types. - member AddAssemblyTypesAsNestedTypesDelayed : assemblyFunction:(unit -> System.Reflection.Assembly) -> unit - - // Parametric types - member DefineStaticParameters : parameters: ProvidedStaticParameter list * instantiationFunction: (string -> obj[] -> ProvidedTypeDefinition) -> unit - - /// Add definition location information to the provided type definition. - member AddDefinitionLocation : line:int * column:int * filePath:string -> unit - - /// Suppress System.Object entries in intellisense menus in instances of this provided type - member HideObjectMethods : bool with set - - /// Disallows the use of the null literal. - member NonNullable : bool with set - - /// Get or set a flag indicating if the ProvidedTypeDefinition is erased - member IsErased : bool with get,set - - /// Get or set a flag indicating if the ProvidedTypeDefinition has type-relocation suppressed - [] - member SuppressRelocation : bool with get,set - - /// FSharp.Data addition: this method is used by Debug.fs - member MakeParametricType : name:string * args:obj[] -> ProvidedTypeDefinition - - /// Add a custom attribute to the provided type definition. - member AddCustomAttribute : CustomAttributeData -> unit - - /// FSharp.Data addition: this method is used by Debug.fs and QuotationBuilder.fs - /// Emulate the F# type provider type erasure mechanism to get the - /// actual (erased) type. We erase ProvidedTypes to their base type - /// and we erase array of provided type to array of base type. In the - /// case of generics all the generic type arguments are also recursively - /// replaced with the erased-to types - static member EraseType : t:Type -> Type - - /// FSharp.Data addition: this is used to log the creation of root Provided Types to be able to debug caching/invalidation - static member Logger : (string -> unit) option ref - -/// A provided generated assembly -type ProvidedAssembly = - new : assemblyFileName:string -> ProvidedAssembly - /// - /// Emit the given provided type definitions as part of the assembly - /// and adjust the 'Assembly' property of all provided type definitions to return that - /// assembly. - /// - /// The assembly is only emitted when the Assembly property on the root type is accessed for the first time. - /// The host F# compiler does this when processing a generative type declaration for the type. - /// - /// An optional path of type names to wrap the generated types. The generated types are then generated as nested types. - member AddTypes : types : ProvidedTypeDefinition list -> unit - member AddNestedTypes : types : ProvidedTypeDefinition list * enclosingGeneratedTypeNames: string list -> unit - -#if FX_NO_LOCAL_FILESYSTEM -#else - /// Register that a given file is a provided generated assembly - static member RegisterGenerated : fileName:string -> Assembly -#endif - - -/// A base type providing default implementations of type provider functionality when all provided -/// types are of type ProvidedTypeDefinition. -type TypeProviderForNamespaces = - - /// Initializes a type provider to provide the types in the given namespace. - new : namespaceName:string * types: ProvidedTypeDefinition list -> TypeProviderForNamespaces - - /// Initializes a type provider - new : unit -> TypeProviderForNamespaces - - /// Add a namespace of provided types. - member AddNamespace : namespaceName:string * types: ProvidedTypeDefinition list -> unit - - /// FSharp.Data addition: this method is used by Debug.fs - /// Get all namespace with their provided types. - member Namespaces : (string * ProvidedTypeDefinition list) seq with get - - /// Invalidate the information provided by the provider - member Invalidate : unit -> unit - -#if FX_NO_LOCAL_FILESYSTEM -#else - /// AssemblyResolve handler. Default implementation searches .dll file in registered folders - abstract ResolveAssembly : System.ResolveEventArgs -> Assembly - default ResolveAssembly : System.ResolveEventArgs -> Assembly - - /// Registers custom probing path that can be used for probing assemblies - member RegisterProbingFolder : folder : string -> unit - /// Registers location of RuntimeAssembly (from TypeProviderConfig) as probing folder - member RegisterRuntimeAssemblyLocationAsProbingFolder : cfg : Core.CompilerServices.TypeProviderConfig -> unit - -#endif - - [] - member Disposing : IEvent - - interface ITypeProvider diff --git a/MyFirstTypeProvider-Pristine/MyFirstTypeProvider/packages.config b/MyFirstTypeProvider-Pristine/MyFirstTypeProvider/packages.config deleted file mode 100644 index 97faf56..0000000 --- a/MyFirstTypeProvider-Pristine/MyFirstTypeProvider/packages.config +++ /dev/null @@ -1,4 +0,0 @@ - - - - \ No newline at end of file diff --git a/MyFirstTypeProvider-Pristine/test.fsx b/MyFirstTypeProvider-Pristine/test.fsx deleted file mode 100644 index dcdf64b..0000000 --- a/MyFirstTypeProvider-Pristine/test.fsx +++ /dev/null @@ -1,8 +0,0 @@ -#r @"MyFirstTypeProvider\bin\Debug\MyFirstTypeProvider.dll" - - -Mavnn.Blog.TypeProvider.Provided.MyType.MyProperty -//MyProvider.FtpProvider.Contents.genomes.Drosophila_melanogaster.``RELEASE_4.1``.CHR_2.``NT_033778.faa``.Contents - - -// MyProvider.FtpProvider.Contents.genomes.Buceros_rhinoceros_silvestris.RNA.``Gnomon_mRNA.fsa.gz`` diff --git a/MyFirstTypeProvider/MyFirstTypeProvider.sln b/MyFirstTypeProvider/MyFirstTypeProvider.sln deleted file mode 100644 index 1a33eb3..0000000 --- a/MyFirstTypeProvider/MyFirstTypeProvider.sln +++ /dev/null @@ -1,22 +0,0 @@ - -Microsoft Visual Studio Solution File, Format Version 12.00 -# Visual Studio 2013 -VisualStudioVersion = 12.0.31101.0 -MinimumVisualStudioVersion = 10.0.40219.1 -Project("{F2A71F9B-5D33-465A-A702-920D77279786}") = "MyFirstTypeProvider", "MyFirstTypeProvider\MyFirstTypeProvider.fsproj", "{B8B2F477-FE17-417E-A95D-3E8AAE7FEF89}" -EndProject -Global - GlobalSection(SolutionConfigurationPlatforms) = preSolution - Debug|Any CPU = Debug|Any CPU - Release|Any CPU = Release|Any CPU - EndGlobalSection - GlobalSection(ProjectConfigurationPlatforms) = postSolution - {B8B2F477-FE17-417E-A95D-3E8AAE7FEF89}.Debug|Any CPU.ActiveCfg = Debug|Any CPU - {B8B2F477-FE17-417E-A95D-3E8AAE7FEF89}.Debug|Any CPU.Build.0 = Debug|Any CPU - {B8B2F477-FE17-417E-A95D-3E8AAE7FEF89}.Release|Any CPU.ActiveCfg = Release|Any CPU - {B8B2F477-FE17-417E-A95D-3E8AAE7FEF89}.Release|Any CPU.Build.0 = Release|Any CPU - EndGlobalSection - GlobalSection(SolutionProperties) = preSolution - HideSolutionNode = FALSE - EndGlobalSection -EndGlobal diff --git a/MyFirstTypeProvider/MyFirstTypeProvider/Library1.fs b/MyFirstTypeProvider/MyFirstTypeProvider/Library1.fs deleted file mode 100644 index f8ebe27..0000000 --- a/MyFirstTypeProvider/MyFirstTypeProvider/Library1.fs +++ /dev/null @@ -1,93 +0,0 @@ -module Mavnn.Blog.TypeProvider - -open ProviderImplementation.ProvidedTypes -open Microsoft.FSharp.Core.CompilerServices -open System -open System.Reflection -open System.IO -open System.Net -let site = "ftp://ftp.ncbi.nlm.nih.gov/" - - -/// Get the directories and files in an FTP site using anonymous login -let getFtpDirectory (site:string, userName:string , pwd:string) = - let request = WebRequest.Create(site) :?> FtpWebRequest - request.Method <- WebRequestMethods.Ftp.ListDirectoryDetails - - // This example assumes the FTP site uses anonymous logon. - request.Credentials <- new NetworkCredential (userName, pwd); - - let response = request.GetResponse() :?> FtpWebResponse - - let responseStream = response.GetResponseStream() - let reader = new StreamReader(responseStream) - let contents = - [ while not reader.EndOfStream do - yield reader.ReadLine().Split([| ' ';'\t' |],StringSplitOptions.RemoveEmptyEntries) ] - - let dirs = - [ for c in contents do - if c.[0].StartsWith("d") then yield Seq.last c ] - - let files = - [ for c in contents do - if c.[0].StartsWith("-") then yield Seq.last c ] - - files, dirs - - - - -[] -type MavnnProvider (config : TypeProviderConfig) as this = - inherit TypeProviderForNamespaces () - - let ns = "FSharp.Data" - let asm = Assembly.GetExecutingAssembly() - - let rec addFtpTypesIntoTypeDefinition (userName, pwd, ftpUrl, td: ProvidedTypeDefinition ) = - - td.AddMembersDelayed(fun () -> - - let files, dirs = getFtpDirectory (ftpUrl, userName, pwd) - - [ for dir in dirs do - let nestedType = ProvidedTypeDefinition(dir, Some typeof) - addFtpTypesIntoTypeDefinition(userName, pwd, ftpUrl + dir + "/", nestedType) - yield nestedType :> MemberInfo - - for file in files do - let nestedType = ProvidedTypeDefinition(file, Some typeof) - let myProp = ProvidedProperty("Contents", typeof, IsStatic = true, - GetterCode = (fun args -> - <@@ let request = WebRequest.Create(ftpUrl + file) :?> FtpWebRequest - request.Method <- WebRequestMethods.Ftp.DownloadFile - request.Credentials <- new NetworkCredential (userName, pwd); - let response = request.GetResponse() :?> FtpWebResponse - use responseStream = response.GetResponseStream() - use reader = new StreamReader(responseStream) - reader.ReadToEnd() @@>)) - nestedType.AddMember myProp - yield nestedType :> MemberInfo ] ) - - do - let topType = ProvidedTypeDefinition(asm, ns, "FtpProvider", Some typeof) - let staticParams = - [ ProvidedStaticParameter("Url",typeof) - ProvidedStaticParameter("User",typeof, "anonymous") - ProvidedStaticParameter("Pwd",typeof, "janeDoe@anonymous.org") ] - - topType.DefineStaticParameters(staticParams, (fun typeName args -> - let site = args.[0] :?> string - let userName = args.[1] :?> string - let pwd = args.[2] :?> string - let actualType = ProvidedTypeDefinition(asm, ns, typeName, Some typeof) - addFtpTypesIntoTypeDefinition(userName, pwd, site, actualType) - actualType)) - this.AddNamespace(ns, [ topType ] ) - - - - -[] -do () diff --git a/MyFirstTypeProvider/MyFirstTypeProvider/MyFirstTypeProvider.fsproj b/MyFirstTypeProvider/MyFirstTypeProvider/MyFirstTypeProvider.fsproj deleted file mode 100644 index 0b4ac99..0000000 --- a/MyFirstTypeProvider/MyFirstTypeProvider/MyFirstTypeProvider.fsproj +++ /dev/null @@ -1,73 +0,0 @@ - - - - - Debug - AnyCPU - 2.0 - b8b2f477-fe17-417e-a95d-3e8aae7fef89 - Library - MyFirstTypeProvider - MyFirstTypeProvider - v4.5 - 4.3.1.0 - MyFirstTypeProvider - - - true - full - false - false - bin\Debug\ - DEBUG;TRACE - 3 - bin\Debug\MyFirstTypeProvider.XML - - - pdbonly - true - true - bin\Release\ - TRACE - 3 - bin\Release\MyFirstTypeProvider.XML - - - 11 - - - - - $(MSBuildExtensionsPath32)\..\Microsoft SDKs\F#\3.0\Framework\v4.0\Microsoft.FSharp.Targets - - - - - $(MSBuildExtensionsPath32)\Microsoft\VisualStudio\v$(VisualStudioVersion)\FSharp\Microsoft.FSharp.Targets - - - - - - - - - - - - - - True - - - - - - - \ No newline at end of file diff --git a/MyFirstTypeProvider/MyFirstTypeProvider/ProvidedTypes.fs b/MyFirstTypeProvider/MyFirstTypeProvider/ProvidedTypes.fs deleted file mode 100644 index 4bcd1d0..0000000 --- a/MyFirstTypeProvider/MyFirstTypeProvider/ProvidedTypes.fs +++ /dev/null @@ -1,2662 +0,0 @@ -#nowarn "40" -#nowarn "52" -// Based on code for the F# 3.0 Developer Preview release of September 2011, -// Copyright (c) Microsoft Corporation 2005-2012. -// This sample code is provided "as is" without warranty of any kind. -// We disclaim all warranties, either express or implied, including the -// warranties of merchantability and fitness for a particular purpose. - -// This file contains a set of helper types and methods for providing types in an implementation -// of ITypeProvider. - -// This code has been modified and is appropriate for use in conjunction with the F# 3.0, F# 3.1, and F# 3.1.1 releases - -namespace ProviderImplementation.ProvidedTypes - -open System -open System.Text -open System.IO -open System.Reflection -open System.Reflection.Emit -open System.Linq.Expressions -open System.Collections.Generic -open Microsoft.FSharp.Core.CompilerServices - -type E = Quotations.Expr -module P = Quotations.Patterns -module ES = Quotations.ExprShape -module DP = Quotations.DerivedPatterns - -type internal ExpectedStackState = - | Empty = 1 - | Address = 2 - | Value = 3 - -[] -module internal Misc = - let TypeBuilderInstantiationType = - let runningOnMono = try System.Type.GetType("Mono.Runtime") <> null with e -> false - let typeName = if runningOnMono then "System.Reflection.MonoGenericClass" else "System.Reflection.Emit.TypeBuilderInstantiation" - typeof.Assembly.GetType(typeName) - let GetTypeFromHandleMethod = typeof.GetMethod("GetTypeFromHandle") - let LanguagePrimitivesType = typedefof>.Assembly.GetType("Microsoft.FSharp.Core.LanguagePrimitives") - let ParseInt32Method = LanguagePrimitivesType.GetMethod "ParseInt32" - let DecimalConstructor = typeof.GetConstructor([| typeof; typeof; typeof; typeof; typeof |]) - let DateTimeConstructor = typeof.GetConstructor([| typeof; typeof |]) - let DateTimeOffsetConstructor = typeof.GetConstructor([| typeof; typeof |]) - let TimeSpanConstructor = typeof.GetConstructor([|typeof|]) - let isEmpty s = s = ExpectedStackState.Empty - let isAddress s = s = ExpectedStackState.Address - - let nonNull str x = if x=null then failwith ("Null in " + str) else x - - let notRequired opname item = - let msg = sprintf "The operation '%s' on item '%s' should not be called on provided type, member or parameter" opname item - System.Diagnostics.Debug.Assert (false, msg) - raise (System.NotSupportedException msg) - - let mkParamArrayCustomAttributeData() = -#if FX_NO_CUSTOMATTRIBUTEDATA - { new IProvidedCustomAttributeData with -#else - { new CustomAttributeData() with -#endif - member __.Constructor = typeof.GetConstructors().[0] - member __.ConstructorArguments = upcast [| |] - member __.NamedArguments = upcast [| |] } - -#if FX_NO_CUSTOMATTRIBUTEDATA - let CustomAttributeTypedArgument(ty,v) = - { new IProvidedCustomAttributeTypedArgument with - member x.ArgumentType = ty - member x.Value = v } - let CustomAttributeNamedArgument(memb,arg:IProvidedCustomAttributeTypedArgument) = - { new IProvidedCustomAttributeNamedArgument with - member x.MemberInfo = memb - member x.ArgumentType = arg.ArgumentType - member x.TypedValue = arg } - type CustomAttributeData = Microsoft.FSharp.Core.CompilerServices.IProvidedCustomAttributeData -#endif - - let mkEditorHideMethodsCustomAttributeData() = -#if FX_NO_CUSTOMATTRIBUTEDATA - { new IProvidedCustomAttributeData with -#else - { new CustomAttributeData() with -#endif - member __.Constructor = typeof.GetConstructors().[0] - member __.ConstructorArguments = upcast [| |] - member __.NamedArguments = upcast [| |] } - - let mkAllowNullLiteralCustomAttributeData value = -#if FX_NO_CUSTOMATTRIBUTEDATA - { new IProvidedCustomAttributeData with -#else - { new CustomAttributeData() with -#endif - member __.Constructor = typeof.GetConstructors().[0] - member __.ConstructorArguments = upcast [| CustomAttributeTypedArgument(typeof, value) |] - member __.NamedArguments = upcast [| |] } - - /// This makes an xml doc attribute w.r.t. an amortized computation of an xml doc string. - /// It is important that the text of the xml doc only get forced when poking on the ConstructorArguments - /// for the CustomAttributeData object. - let mkXmlDocCustomAttributeDataLazy(lazyText: Lazy) = -#if FX_NO_CUSTOMATTRIBUTEDATA - { new IProvidedCustomAttributeData with -#else - { new CustomAttributeData() with -#endif - member __.Constructor = typeof.GetConstructors().[0] - member __.ConstructorArguments = upcast [| CustomAttributeTypedArgument(typeof, lazyText.Force()) |] - member __.NamedArguments = upcast [| |] } - - let mkXmlDocCustomAttributeData(s:string) = mkXmlDocCustomAttributeDataLazy (lazy s) - - let mkDefinitionLocationAttributeCustomAttributeData(line:int,column:int,filePath:string) = -#if FX_NO_CUSTOMATTRIBUTEDATA - { new IProvidedCustomAttributeData with -#else - { new CustomAttributeData() with -#endif - member __.Constructor = typeof.GetConstructors().[0] - member __.ConstructorArguments = upcast [| |] - member __.NamedArguments = - upcast [| CustomAttributeNamedArgument(typeof.GetProperty("FilePath"), CustomAttributeTypedArgument(typeof, filePath)); - CustomAttributeNamedArgument(typeof.GetProperty("Line"), CustomAttributeTypedArgument(typeof, line)) ; - CustomAttributeNamedArgument(typeof.GetProperty("Column"), CustomAttributeTypedArgument(typeof, column)) - |] } - let mkObsoleteAttributeCustomAttributeData(message:string, isError: bool) = -#if FX_NO_CUSTOMATTRIBUTEDATA - { new IProvidedCustomAttributeData with -#else - { new CustomAttributeData() with -#endif - member __.Constructor = typeof.GetConstructors() |> Array.find (fun x -> x.GetParameters().Length = 1) - member __.ConstructorArguments = upcast [|CustomAttributeTypedArgument(typeof, message) ; CustomAttributeTypedArgument(typeof, isError) |] - member __.NamedArguments = upcast [| |] } - - type CustomAttributesImpl() = - let customAttributes = ResizeArray() - let mutable hideObjectMethods = false - let mutable nonNullable = false - let mutable obsoleteMessage = None - let mutable xmlDocDelayed = None - let mutable xmlDocAlwaysRecomputed = None - let mutable hasParamArray = false - - // XML doc text that we only compute once, if any. This must _not_ be forced until the ConstructorArguments - // property of the custom attribute is foced. - let xmlDocDelayedText = - lazy - (match xmlDocDelayed with None -> assert false; "" | Some f -> f()) - - // Custom atttributes that we only compute once - let customAttributesOnce = - lazy - [| if hideObjectMethods then yield mkEditorHideMethodsCustomAttributeData() - if nonNullable then yield mkAllowNullLiteralCustomAttributeData false - match xmlDocDelayed with None -> () | Some _ -> customAttributes.Add(mkXmlDocCustomAttributeDataLazy xmlDocDelayedText) - match obsoleteMessage with None -> () | Some s -> customAttributes.Add(mkObsoleteAttributeCustomAttributeData s) - if hasParamArray then yield mkParamArrayCustomAttributeData() - yield! customAttributes |] - - member __.AddDefinitionLocation(line:int,column:int,filePath:string) = customAttributes.Add(mkDefinitionLocationAttributeCustomAttributeData(line, column, filePath)) - member __.AddObsolete(msg : string, isError) = obsoleteMessage <- Some (msg,isError) - member __.HasParamArray with get() = hasParamArray and set(v) = hasParamArray <- v - member __.AddXmlDocComputed(xmlDoc : unit -> string) = xmlDocAlwaysRecomputed <- Some xmlDoc - member __.AddXmlDocDelayed(xmlDoc : unit -> string) = xmlDocDelayed <- Some xmlDoc - member this.AddXmlDoc(text:string) = this.AddXmlDocDelayed (fun () -> text) - member __.HideObjectMethods with set v = hideObjectMethods <- v - member __.NonNullable with set v = nonNullable <- v - member __.AddCustomAttribute(attribute) = customAttributes.Add(attribute) - member __.GetCustomAttributesData() = - [| yield! customAttributesOnce.Force() - match xmlDocAlwaysRecomputed with None -> () | Some f -> customAttributes.Add(mkXmlDocCustomAttributeData (f())) |] - :> IList<_> - - let transExpr isGenerated q = - let rec trans q = - match q with - // convert NewTuple to the call to the constructor of the Tuple type (only for generated types) - | Quotations.Patterns.NewTuple(items) when isGenerated -> - let rec mkCtor args ty = - let ctor, restTyOpt = Reflection.FSharpValue.PreComputeTupleConstructorInfo ty - match restTyOpt with - | None -> Quotations.Expr.NewObject(ctor, List.map trans args) - | Some restTy -> - let curr = [for a in Seq.take 7 args -> trans a] - let rest = List.ofSeq (Seq.skip 7 args) - Quotations.Expr.NewObject(ctor, curr @ [mkCtor rest restTy]) - let tys = [| for e in items -> e.Type |] - let tupleTy = Reflection.FSharpType.MakeTupleType tys - trans (mkCtor items tupleTy) - // convert TupleGet to the chain of PropertyGet calls (only for generated types) - | Quotations.Patterns.TupleGet(e, i) when isGenerated -> - let rec mkGet ty i (e : Quotations.Expr) = - let pi, restOpt = Reflection.FSharpValue.PreComputeTuplePropertyInfo(ty, i) - let propGet = Quotations.Expr.PropertyGet(e, pi) - match restOpt with - | None -> propGet - | Some (restTy, restI) -> mkGet restTy restI propGet - trans (mkGet e.Type i (trans e)) - | Quotations.Patterns.Value(value, ty) -> - if value <> null then - let tyOfValue = value.GetType() - transValue(value, tyOfValue, ty) - else q - // Eliminate F# property gets to method calls - | Quotations.Patterns.PropertyGet(obj,propInfo,args) -> - match obj with - | None -> trans (Quotations.Expr.Call(propInfo.GetGetMethod(),args)) - | Some o -> trans (Quotations.Expr.Call(trans o,propInfo.GetGetMethod(),args)) - // Eliminate F# property sets to method calls - | Quotations.Patterns.PropertySet(obj,propInfo,args,v) -> - match obj with - | None -> trans (Quotations.Expr.Call(propInfo.GetSetMethod(),args@[v])) - | Some o -> trans (Quotations.Expr.Call(trans o,propInfo.GetSetMethod(),args@[v])) - // Eliminate F# function applications to FSharpFunc<_,_>.Invoke calls - | Quotations.Patterns.Application(f,e) -> - trans (Quotations.Expr.Call(trans f, f.Type.GetMethod "Invoke", [ e ]) ) - | Quotations.Patterns.NewUnionCase(ci, es) -> - trans (Quotations.Expr.Call(Reflection.FSharpValue.PreComputeUnionConstructorInfo ci, es) ) - | Quotations.Patterns.NewRecord(ci, es) -> - trans (Quotations.Expr.NewObject(Reflection.FSharpValue.PreComputeRecordConstructorInfo ci, es) ) - | Quotations.Patterns.UnionCaseTest(e,uc) -> - let tagInfo = Reflection.FSharpValue.PreComputeUnionTagMemberInfo uc.DeclaringType - let tagExpr = - match tagInfo with - | :? PropertyInfo as tagProp -> - trans (Quotations.Expr.PropertyGet(e,tagProp) ) - | :? MethodInfo as tagMeth -> - if tagMeth.IsStatic then trans (Quotations.Expr.Call(tagMeth, [e])) - else trans (Quotations.Expr.Call(e,tagMeth,[])) - | _ -> failwith "unreachable: unexpected result from PreComputeUnionTagMemberInfo" - let tagNumber = uc.Tag - trans <@@ (%%(tagExpr) : int) = tagNumber @@> - - // Explicitly handle weird byref variables in lets (used to populate out parameters), since the generic handlers can't deal with byrefs - | Quotations.Patterns.Let(v,vexpr,bexpr) when v.Type.IsByRef -> - - // the binding must have leaves that are themselves variables (due to the limited support for byrefs in expressions) - // therefore, we can perform inlining to translate this to a form that can be compiled - inlineByref v vexpr bexpr - - // Eliminate recursive let bindings (which are unsupported by the type provider API) to regular let bindings - | Quotations.Patterns.LetRecursive(bindings, expr) -> - // This uses a "lets and sets" approach, converting something like - // let rec even = function - // | 0 -> true - // | n -> odd (n-1) - // and odd = function - // | 0 -> false - // | n -> even (n-1) - // X - // to something like - // let even = ref Unchecked.defaultof<_> - // let odd = ref Unchecked.defaultof<_> - // even := function - // | 0 -> true - // | n -> !odd (n-1) - // odd := function - // | 0 -> false - // | n -> !even (n-1) - // X' - // where X' is X but with occurrences of even/odd substituted by !even and !odd (since now even and odd are references) - // Translation relies on typedefof<_ ref> - does this affect ability to target different runtime and design time environments? - let vars = List.map fst bindings - let vars' = vars |> List.map (fun v -> Quotations.Var(v.Name, typedefof<_ ref>.MakeGenericType(v.Type))) - - // init t generates the equivalent of <@ ref Unchecked.defaultof @> - let init (t:Type) = - let r = match <@ ref 1 @> with Quotations.Patterns.Call(None, r, [_]) -> r | _ -> failwith "Extracting MethodInfo from <@ 1 @> failed" - let d = match <@ Unchecked.defaultof<_> @> with Quotations.Patterns.Call(None, d, []) -> d | _ -> failwith "Extracting MethodInfo from <@ Unchecked.defaultof<_> @> failed" - Quotations.Expr.Call(r.GetGenericMethodDefinition().MakeGenericMethod(t), [Quotations.Expr.Call(d.GetGenericMethodDefinition().MakeGenericMethod(t),[])]) - - // deref v generates the equivalent of <@ !v @> - // (so v's type must be ref) - let deref (v:Quotations.Var) = - let m = match <@ !(ref 1) @> with Quotations.Patterns.Call(None, m, [_]) -> m | _ -> failwith "Extracting MethodInfo from <@ !(ref 1) @> failed" - let tyArgs = v.Type.GetGenericArguments() - Quotations.Expr.Call(m.GetGenericMethodDefinition().MakeGenericMethod(tyArgs), [Quotations.Expr.Var v]) - - // substitution mapping a variable v to the expression <@ !v' @> using the corresponding new variable v' of ref type - let subst = - let map = - vars' - |> List.map deref - |> List.zip vars - |> Map.ofList - fun v -> Map.tryFind v map - - let expr' = expr.Substitute(subst) - - // maps variables to new variables - let varDict = List.zip vars vars' |> dict - - // given an old variable v and an expression e, returns a quotation like <@ v' := e @> using the corresponding new variable v' of ref type - let setRef (v:Quotations.Var) e = - let m = match <@ (ref 1) := 2 @> with Quotations.Patterns.Call(None, m, [_;_]) -> m | _ -> failwith "Extracting MethodInfo from <@ (ref 1) := 2 @> failed" - Quotations.Expr.Call(m.GetGenericMethodDefinition().MakeGenericMethod(v.Type), [Quotations.Expr.Var varDict.[v]; e]) - - // Something like - // <@ - // v1 := e1' - // v2 := e2' - // ... - // expr' - // @> - // Note that we must substitute our new variable dereferences into the bound expressions - let body = - bindings - |> List.fold (fun b (v,e) -> Quotations.Expr.Sequential(setRef v (e.Substitute subst), b)) expr' - - // Something like - // let v1 = ref Unchecked.defaultof - // let v2 = ref Unchecked.defaultof - // ... - // body - vars - |> List.fold (fun b v -> Quotations.Expr.Let(varDict.[v], init v.Type, b)) body - |> trans - - // Handle the generic cases - | Quotations.ExprShape.ShapeLambda(v,body) -> - Quotations.Expr.Lambda(v, trans body) - | Quotations.ExprShape.ShapeCombination(comb,args) -> - Quotations.ExprShape.RebuildShapeCombination(comb,List.map trans args) - | Quotations.ExprShape.ShapeVar _ -> q - and inlineByref v vexpr bexpr = - match vexpr with - | Quotations.Patterns.Sequential(e',vexpr') -> - (* let v = (e'; vexpr') in bexpr => e'; let v = vexpr' in bexpr *) - Quotations.Expr.Sequential(e', inlineByref v vexpr' bexpr) - |> trans - | Quotations.Patterns.IfThenElse(c,b1,b2) -> - (* let v = if c then b1 else b2 in bexpr => if c then let v = b1 in bexpr else let v = b2 in bexpr *) - Quotations.Expr.IfThenElse(c, inlineByref v b1 bexpr, inlineByref v b2 bexpr) - |> trans - | Quotations.Patterns.Var _ -> - (* let v = v1 in bexpr => bexpr[v/v1] *) - bexpr.Substitute(fun v' -> if v = v' then Some vexpr else None) - |> trans - | _ -> - failwith (sprintf "Unexpected byref binding: %A = %A" v vexpr) - and transValue (v : obj, tyOfValue : Type, expectedTy : Type) = - let rec transArray (o : Array, ty : Type) = - let elemTy = ty.GetElementType() - let converter = getConverterForType elemTy - let elements = - [ - for el in o do - yield converter el - ] - Quotations.Expr.NewArray(elemTy, elements) - and transList(o, ty : Type, nil, cons) = - let converter = getConverterForType (ty.GetGenericArguments().[0]) - o - |> Seq.cast - |> List.ofSeq - |> fun l -> List.foldBack(fun o s -> Quotations.Expr.NewUnionCase(cons, [ converter(o); s ])) l (Quotations.Expr.NewUnionCase(nil, [])) - |> trans - and getConverterForType (ty : Type) = - if ty.IsArray then - fun (v : obj) -> transArray(v :?> Array, ty) - elif ty.IsGenericType && ty.GetGenericTypeDefinition() = typedefof<_ list> then - let nil, cons = - let cases = Reflection.FSharpType.GetUnionCases(ty) - let a = cases.[0] - let b = cases.[1] - if a.Name = "Empty" then a,b - else b,a - - fun v -> transList (v :?> System.Collections.IEnumerable, ty, nil, cons) - else - fun v -> Quotations.Expr.Value(v, ty) - let converter = getConverterForType tyOfValue - let r = converter v - if tyOfValue <> expectedTy then Quotations.Expr.Coerce(r, expectedTy) - else r - trans q - - let getFastFuncType (args : list) resultType = - let types = - [| - for arg in args -> arg.Type - yield resultType - |] - let fastFuncTy = - match List.length args with - | 2 -> typedefof>.MakeGenericType(types) - | 3 -> typedefof>.MakeGenericType(types) - | 4 -> typedefof>.MakeGenericType(types) - | 5 -> typedefof>.MakeGenericType(types) - | _ -> invalidArg "args" "incorrect number of arguments" - fastFuncTy.GetMethod("Adapt") - - let inline (===) a b = LanguagePrimitives.PhysicalEquality a b - - let traverse f = - let rec fallback e = - match e with - | P.Let(v, value, body) -> - let fixedValue = f fallback value - let fixedBody = f fallback body - if fixedValue === value && fixedBody === body then - e - else - E.Let(v, fixedValue, fixedBody) - | ES.ShapeVar _ -> e - | ES.ShapeLambda(v, body) -> - let fixedBody = f fallback body - if fixedBody === body then - e - else - E.Lambda(v, fixedBody) - | ES.ShapeCombination(shape, exprs) -> - let exprs1 = List.map (f fallback) exprs - if List.forall2 (===) exprs exprs1 then - e - else - ES.RebuildShapeCombination(shape, exprs1) - fun e -> f fallback e - - let RightPipe = <@@ (|>) @@> - let inlineRightPipe expr = - let rec loop expr = traverse loopCore expr - and loopCore fallback orig = - match orig with - | DP.SpecificCall RightPipe (None, _, [operand; applicable]) -> - let fixedOperand = loop operand - match loop applicable with - | P.Lambda(arg, body) -> - let v = Quotations.Var("__temp", operand.Type) - let ev = E.Var v - - let fixedBody = loop body - E.Let(v, fixedOperand, fixedBody.Substitute(fun v1 -> if v1 = arg then Some ev else None)) - | fixedApplicable -> E.Application(fixedApplicable, fixedOperand) - | x -> fallback x - loop expr - - let inlineValueBindings e = - let map = Dictionary(HashIdentity.Reference) - let rec loop expr = traverse loopCore expr - and loopCore fallback orig = - match orig with - | P.Let(id, (P.Value(_) as v), body) when not id.IsMutable -> - map.[id] <- v - let fixedBody = loop body - map.Remove(id) |> ignore - fixedBody - | ES.ShapeVar v -> - match map.TryGetValue v with - | true, e -> e - | _ -> orig - | x -> fallback x - loop e - - - let optimizeCurriedApplications expr = - let rec loop expr = traverse loopCore expr - and loopCore fallback orig = - match orig with - | P.Application(e, arg) -> - let e1 = tryPeelApplications e [loop arg] - if e1 === e then - orig - else - e1 - | x -> fallback x - and tryPeelApplications orig args = - let n = List.length args - match orig with - | P.Application(e, arg) -> - let e1 = tryPeelApplications e ((loop arg)::args) - if e1 === e then - orig - else - e1 - | P.Let(id, applicable, (P.Lambda(_) as body)) when n > 0 -> - let numberOfApplication = countPeelableApplications body id 0 - if numberOfApplication = 0 then orig - elif n = 1 then E.Application(applicable, List.head args) - elif n <= 5 then - let resultType = - applicable.Type - |> Seq.unfold (fun t -> - if not t.IsGenericType then None - else - let args = t.GetGenericArguments() - if args.Length <> 2 then None - else - Some (args.[1], args.[1]) - ) - |> Seq.nth (n - 1) - - let adaptMethod = getFastFuncType args resultType - let adapted = E.Call(adaptMethod, [loop applicable]) - let invoke = adapted.Type.GetMethod("Invoke", [| for arg in args -> arg.Type |]) - E.Call(adapted, invoke, args) - else - (applicable, args) ||> List.fold (fun e a -> E.Application(e, a)) - | _ -> - orig - and countPeelableApplications expr v n = - match expr with - // v - applicable entity obtained on the prev step - // \arg -> let v1 = (f arg) in rest ==> f - | P.Lambda(arg, P.Let(v1, P.Application(P.Var f, P.Var arg1), rest)) when v = f && arg = arg1 -> countPeelableApplications rest v1 (n + 1) - // \arg -> (f arg) ==> f - | P.Lambda(arg, P.Application(P.Var f, P.Var arg1)) when v = f && arg = arg1 -> n - | _ -> n - loop expr - - // FSharp.Data change: use the real variable names instead of indices, to improve output of Debug.fs - let transQuotationToCode isGenerated qexprf (paramNames: string[]) (argExprs: Quotations.Expr[]) = - // add let bindings for arguments to ensure that arguments will be evaluated - let vars = argExprs |> Array.mapi (fun i e -> Quotations.Var(paramNames.[i], e.Type)) - let expr = qexprf ([for v in vars -> Quotations.Expr.Var v]) - - let pairs = Array.zip argExprs vars - let expr = Array.foldBack (fun (arg, var) e -> Quotations.Expr.Let(var, arg, e)) pairs expr - let expr = - if isGenerated then - let e1 = inlineRightPipe expr - let e2 = optimizeCurriedApplications e1 - let e3 = inlineValueBindings e2 - e3 - else - expr - - transExpr isGenerated expr - - let adjustTypeAttributes attributes isNested = - let visibilityAttributes = - match attributes &&& TypeAttributes.VisibilityMask with - | TypeAttributes.Public when isNested -> TypeAttributes.NestedPublic - | TypeAttributes.NotPublic when isNested -> TypeAttributes.NestedAssembly - | TypeAttributes.NestedPublic when not isNested -> TypeAttributes.Public - | TypeAttributes.NestedAssembly - | TypeAttributes.NestedPrivate - | TypeAttributes.NestedFamORAssem - | TypeAttributes.NestedFamily - | TypeAttributes.NestedFamANDAssem when not isNested -> TypeAttributes.NotPublic - | a -> a - (attributes &&& ~~~TypeAttributes.VisibilityMask) ||| visibilityAttributes - -type ProvidedStaticParameter(parameterName:string,parameterType:Type,?parameterDefaultValue:obj) = - inherit System.Reflection.ParameterInfo() - - let customAttributesImpl = CustomAttributesImpl() - member __.AddXmlDocDelayed(xmlDoc : unit -> string) = customAttributesImpl.AddXmlDocDelayed xmlDoc - member __.AddXmlDocComputed(xmlDoc : unit -> string) = customAttributesImpl.AddXmlDocComputed xmlDoc - member this.AddXmlDoc(text:string) = customAttributesImpl.AddXmlDoc text - - override __.RawDefaultValue = defaultArg parameterDefaultValue null - override __.Attributes = if parameterDefaultValue.IsNone then enum 0 else ParameterAttributes.Optional - override __.Position = 0 - override __.ParameterType = parameterType - override __.Name = parameterName - - override __.GetCustomAttributes(_inherit) = ignore(_inherit); notRequired "GetCustomAttributes" parameterName - override __.GetCustomAttributes(_attributeType, _inherit) = notRequired "GetCustomAttributes" parameterName - -type ProvidedParameter(name:string,parameterType:Type,?isOut:bool,?optionalValue:obj) = - inherit System.Reflection.ParameterInfo() - let customAttributesImpl = CustomAttributesImpl() - let isOut = defaultArg isOut false - member this.IsParamArray with get() = customAttributesImpl.HasParamArray and set(v) = customAttributesImpl.HasParamArray <- v - override this.Name = name - override this.ParameterType = parameterType - override this.Attributes = (base.Attributes ||| (if isOut then ParameterAttributes.Out else enum 0) - ||| (match optionalValue with None -> enum 0 | Some _ -> ParameterAttributes.Optional ||| ParameterAttributes.HasDefault)) - override this.RawDefaultValue = defaultArg optionalValue null - member this.HasDefaultParameterValue = Option.isSome optionalValue - member __.GetCustomAttributesDataImpl() = customAttributesImpl.GetCustomAttributesData() -#if FX_NO_CUSTOMATTRIBUTEDATA -#else - override __.GetCustomAttributesData() = customAttributesImpl.GetCustomAttributesData() -#endif - -type ProvidedConstructor(parameters : ProvidedParameter list) = - inherit ConstructorInfo() - let parameters = parameters |> List.map (fun p -> p :> ParameterInfo) - let mutable baseCall = None - - let mutable declaringType = null : System.Type - let mutable invokeCode = None : option Quotations.Expr> - let mutable isImplicitCtor = false - let mutable ctorAttributes = MethodAttributes.Public ||| MethodAttributes.RTSpecialName - let nameText () = sprintf "constructor for %s" (if declaringType=null then "" else declaringType.FullName) - - let customAttributesImpl = CustomAttributesImpl() - member this.IsTypeInitializer - with get() = ctorAttributes.HasFlag(MethodAttributes.Static) && ctorAttributes.HasFlag(MethodAttributes.Private) - and set(v) = - let typeInitializerAttributes = MethodAttributes.Static ||| MethodAttributes.Private - ctorAttributes <- if v then ctorAttributes ||| typeInitializerAttributes else ctorAttributes &&& ~~~typeInitializerAttributes - - member this.AddXmlDocComputed xmlDoc = customAttributesImpl.AddXmlDocComputed xmlDoc - member this.AddXmlDocDelayed xmlDoc = customAttributesImpl.AddXmlDocDelayed xmlDoc - member this.AddXmlDoc xmlDoc = customAttributesImpl.AddXmlDoc xmlDoc - member this.AddObsoleteAttribute (msg,?isError) = customAttributesImpl.AddObsolete (msg,defaultArg isError false) - member this.AddDefinitionLocation(line,column,filePath) = customAttributesImpl.AddDefinitionLocation(line, column, filePath) - member __.GetCustomAttributesDataImpl() = customAttributesImpl.GetCustomAttributesData() -#if FX_NO_CUSTOMATTRIBUTEDATA -#else - override this.GetCustomAttributesData() = customAttributesImpl.GetCustomAttributesData() -#endif - - member this.DeclaringTypeImpl - with set x = - if declaringType<>null then failwith (sprintf "ProvidedConstructor: declaringType already set on '%s'" (nameText())); - declaringType <- x - - member this.InvokeCode - with set (q:Quotations.Expr list -> Quotations.Expr) = - match invokeCode with - | None -> invokeCode <- Some q - | Some _ -> failwith (sprintf "ProvidedConstructor: code already given for '%s'" (nameText())) - - member this.BaseConstructorCall - with set (d:Quotations.Expr list -> (ConstructorInfo * Quotations.Expr list)) = - match baseCall with - | None -> baseCall <- Some d - | Some _ -> failwith (sprintf "ProvidedConstructor: base call already given for '%s'" (nameText())) - - member this.GetInvokeCodeInternal isGenerated = - match invokeCode with - | Some f -> - // FSharp.Data change: use the real variable names instead of indices, to improve output of Debug.fs - let paramNames = - parameters - |> List.map (fun p -> p.Name) - |> List.append (if not isGenerated || this.IsStatic then [] else ["this"]) - |> Array.ofList - transQuotationToCode isGenerated f paramNames - | None -> failwith (sprintf "ProvidedConstructor: no invoker for '%s'" (nameText())) - - member this.GetBaseConstructorCallInternal isGenerated = - match baseCall with - | Some f -> Some(fun ctorArgs -> let c,baseCtorArgExprs = f ctorArgs in c, List.map (transExpr isGenerated) baseCtorArgExprs) - | None -> None - member this.IsImplicitCtor with get() = isImplicitCtor and set v = isImplicitCtor <- v - - // Implement overloads - override this.GetParameters() = parameters |> List.toArray - override this.Attributes = ctorAttributes - override this.Name = if this.IsStatic then ".cctor" else ".ctor" - override this.DeclaringType = declaringType |> nonNull "ProvidedConstructor.DeclaringType" - override this.IsDefined(_attributeType, _inherit) = true - - override this.Invoke(_invokeAttr, _binder, _parameters, _culture) = notRequired "Invoke" (nameText()) - override this.Invoke(_obj, _invokeAttr, _binder, _parameters, _culture) = notRequired "Invoke" (nameText()) - override this.ReflectedType = notRequired "ReflectedType" (nameText()) - override this.GetMethodImplementationFlags() = notRequired "GetMethodImplementationFlags" (nameText()) - override this.MethodHandle = notRequired "MethodHandle" (nameText()) - override this.GetCustomAttributes(_inherit) = notRequired "GetCustomAttributes" (nameText()) - override this.GetCustomAttributes(_attributeType, _inherit) = notRequired "GetCustomAttributes" (nameText()) - -type ProvidedMethod(methodName: string, parameters: ProvidedParameter list, returnType: Type) = - inherit System.Reflection.MethodInfo() - let argParams = parameters |> List.map (fun p -> p :> ParameterInfo) - - // State - let mutable declaringType : Type = null - let mutable methodAttrs = MethodAttributes.Public - let mutable invokeCode = None : option Quotations.Expr> - - let customAttributesImpl = CustomAttributesImpl() - member this.AddXmlDocComputed xmlDoc = customAttributesImpl.AddXmlDocComputed xmlDoc - member this.AddXmlDocDelayed xmlDoc = customAttributesImpl.AddXmlDocDelayed xmlDoc - member this.AddXmlDoc xmlDoc = customAttributesImpl.AddXmlDoc xmlDoc - member this.AddObsoleteAttribute (msg,?isError) = customAttributesImpl.AddObsolete (msg,defaultArg isError false) - member this.AddDefinitionLocation(line,column,filePath) = customAttributesImpl.AddDefinitionLocation(line, column, filePath) - member __.AddCustomAttribute(attribute) = customAttributesImpl.AddCustomAttribute(attribute) - member __.GetCustomAttributesDataImpl() = customAttributesImpl.GetCustomAttributesData() -#if FX_NO_CUSTOMATTRIBUTEDATA -#else - override this.GetCustomAttributesData() = customAttributesImpl.GetCustomAttributesData() -#endif - - member this.SetMethodAttrs m = methodAttrs <- m - member this.AddMethodAttrs m = methodAttrs <- methodAttrs ||| m - member this.DeclaringTypeImpl with set x = declaringType <- x // check: not set twice - member this.IsStaticMethod - with get() = methodAttrs.HasFlag(MethodAttributes.Static) - and set x = if x then methodAttrs <- methodAttrs ||| MethodAttributes.Static - else methodAttrs <- methodAttrs &&& (~~~ MethodAttributes.Static) - member this.InvokeCode - with set (q:Quotations.Expr list -> Quotations.Expr) = - match invokeCode with - | None -> invokeCode <- Some q - | Some _ -> failwith (sprintf "ProvidedConstructor: code already given for %s on type %s" this.Name (if declaringType=null then "" else declaringType.FullName)) - - - member this.GetInvokeCodeInternal isGenerated = - match invokeCode with - | Some f -> - // FSharp.Data change: use the real variable names instead of indices, to improve output of Debug.fs - let paramNames = - parameters - |> List.map (fun p -> p.Name) - |> List.append (if this.IsStatic then [] else ["this"]) - |> Array.ofList - transQuotationToCode isGenerated f paramNames - | None -> failwith (sprintf "ProvidedMethod: no invoker for %s on type %s" this.Name (if declaringType=null then "" else declaringType.FullName)) - // Implement overloads - override this.GetParameters() = argParams |> Array.ofList - override this.Attributes = methodAttrs - override this.Name = methodName - override this.DeclaringType = declaringType |> nonNull "ProvidedMethod.DeclaringType" - override this.IsDefined(_attributeType, _inherit) : bool = true - override this.MemberType = MemberTypes.Method - override this.CallingConvention = - let cc = CallingConventions.Standard - let cc = if not (this.IsStatic) then cc ||| CallingConventions.HasThis else cc - cc - override this.ReturnType = returnType - override this.ReturnParameter = null // REVIEW: Give it a name and type? - override this.ToString() = "Method " + this.Name - - // These don't have to return fully accurate results - they are used - // by the F# Quotations library function SpecificCall as a pre-optimization - // when comparing methods - override this.MetadataToken = hash declaringType + hash this.Name - override this.MethodHandle = RuntimeMethodHandle() - - override this.ReturnTypeCustomAttributes = notRequired "ReturnTypeCustomAttributes" this.Name - override this.GetBaseDefinition() = notRequired "GetBaseDefinition" this.Name - override this.GetMethodImplementationFlags() = notRequired "GetMethodImplementationFlags" this.Name - override this.Invoke(_obj, _invokeAttr, _binder, _parameters, _culture) = notRequired "Invoke" this.Name - override this.ReflectedType = notRequired "ReflectedType" this.Name - override this.GetCustomAttributes(_inherit) = notRequired "GetCustomAttributes" this.Name - override this.GetCustomAttributes(_attributeType, _inherit) = notRequired "GetCustomAttributes" this.Name - - -type ProvidedProperty(propertyName:string,propertyType:Type, ?parameters:ProvidedParameter list) = - inherit System.Reflection.PropertyInfo() - // State - - let parameters = defaultArg parameters [] - let mutable declaringType = null - let mutable isStatic = false - let mutable getterCode = None : option Quotations.Expr> - let mutable setterCode = None : option Quotations.Expr> - - let hasGetter() = getterCode.IsSome - let hasSetter() = setterCode.IsSome - - // Delay construction - to pick up the latest isStatic - let markSpecialName (m:ProvidedMethod) = m.AddMethodAttrs(MethodAttributes.SpecialName); m - let getter = lazy (ProvidedMethod("get_" + propertyName,parameters,propertyType,IsStaticMethod=isStatic,DeclaringTypeImpl=declaringType,InvokeCode=getterCode.Value) |> markSpecialName) - let setter = lazy (ProvidedMethod("set_" + propertyName,parameters @ [ProvidedParameter("value",propertyType)],typeof,IsStaticMethod=isStatic,DeclaringTypeImpl=declaringType,InvokeCode=setterCode.Value) |> markSpecialName) - - let customAttributesImpl = CustomAttributesImpl() - member this.AddXmlDocComputed xmlDoc = customAttributesImpl.AddXmlDocComputed xmlDoc - member this.AddXmlDocDelayed xmlDoc = customAttributesImpl.AddXmlDocDelayed xmlDoc - member this.AddXmlDoc xmlDoc = customAttributesImpl.AddXmlDoc xmlDoc - member this.AddObsoleteAttribute (msg,?isError) = customAttributesImpl.AddObsolete (msg,defaultArg isError false) - member this.AddDefinitionLocation(line,column,filePath) = customAttributesImpl.AddDefinitionLocation(line, column, filePath) - member __.GetCustomAttributesDataImpl() = customAttributesImpl.GetCustomAttributesData() - member this.AddCustomAttribute attribute = customAttributesImpl.AddCustomAttribute attribute -#if FX_NO_CUSTOMATTRIBUTEDATA -#else - override this.GetCustomAttributesData() = customAttributesImpl.GetCustomAttributesData() -#endif - - member this.DeclaringTypeImpl with set x = declaringType <- x // check: not set twice - member this.IsStatic - with get() = isStatic - and set x = isStatic <- x - - member this.GetterCode - with set (q:Quotations.Expr list -> Quotations.Expr) = - if not getter.IsValueCreated then getterCode <- Some q else failwith "ProvidedProperty: getter MethodInfo has already been created" - - member this.SetterCode - with set (q:Quotations.Expr list -> Quotations.Expr) = - if not (setter.IsValueCreated) then setterCode <- Some q else failwith "ProvidedProperty: setter MethodInfo has already been created" - - // Implement overloads - override this.PropertyType = propertyType - override this.SetValue(_obj, _value, _invokeAttr, _binder, _index, _culture) = notRequired "SetValue" this.Name - override this.GetAccessors _nonPublic = notRequired "nonPublic" this.Name - override this.GetGetMethod _nonPublic = if hasGetter() then getter.Force() :> MethodInfo else null - override this.GetSetMethod _nonPublic = if hasSetter() then setter.Force() :> MethodInfo else null - override this.GetIndexParameters() = [| for p in parameters -> upcast p |] - override this.Attributes = PropertyAttributes.None - override this.CanRead = hasGetter() - override this.CanWrite = hasSetter() - override this.GetValue(_obj, _invokeAttr, _binder, _index, _culture) : obj = notRequired "GetValue" this.Name - override this.Name = propertyName - override this.DeclaringType = declaringType |> nonNull "ProvidedProperty.DeclaringType" - override this.MemberType : MemberTypes = MemberTypes.Property - - override this.ReflectedType = notRequired "ReflectedType" this.Name - override this.GetCustomAttributes(_inherit) = notRequired "GetCustomAttributes" this.Name - override this.GetCustomAttributes(_attributeType, _inherit) = notRequired "GetCustomAttributes" this.Name - override this.IsDefined(_attributeType, _inherit) = notRequired "IsDefined" this.Name - -type ProvidedEvent(eventName:string,eventHandlerType:Type) = - inherit System.Reflection.EventInfo() - // State - - let mutable declaringType = null - let mutable isStatic = false - let mutable adderCode = None : option Quotations.Expr> - let mutable removerCode = None : option Quotations.Expr> - - // Delay construction - to pick up the latest isStatic - let markSpecialName (m:ProvidedMethod) = m.AddMethodAttrs(MethodAttributes.SpecialName); m - let adder = lazy (ProvidedMethod("add_" + eventName, [ProvidedParameter("handler", eventHandlerType)],typeof,IsStaticMethod=isStatic,DeclaringTypeImpl=declaringType,InvokeCode=adderCode.Value) |> markSpecialName) - let remover = lazy (ProvidedMethod("remove_" + eventName, [ProvidedParameter("handler", eventHandlerType)],typeof,IsStaticMethod=isStatic,DeclaringTypeImpl=declaringType,InvokeCode=removerCode.Value) |> markSpecialName) - - let customAttributesImpl = CustomAttributesImpl() - member this.AddXmlDocComputed xmlDoc = customAttributesImpl.AddXmlDocComputed xmlDoc - member this.AddXmlDocDelayed xmlDoc = customAttributesImpl.AddXmlDocDelayed xmlDoc - member this.AddXmlDoc xmlDoc = customAttributesImpl.AddXmlDoc xmlDoc - member this.AddDefinitionLocation(line,column,filePath) = customAttributesImpl.AddDefinitionLocation(line, column, filePath) - member __.GetCustomAttributesDataImpl() = customAttributesImpl.GetCustomAttributesData() -#if FX_NO_CUSTOMATTRIBUTEDATA -#else - override this.GetCustomAttributesData() = customAttributesImpl.GetCustomAttributesData() -#endif - - member this.DeclaringTypeImpl with set x = declaringType <- x // check: not set twice - member this.IsStatic - with get() = isStatic - and set x = isStatic <- x - - member this.AdderCode - with get() = adderCode.Value - and set f = - if not adder.IsValueCreated then adderCode <- Some f else failwith "ProvidedEvent: Add MethodInfo has already been created" - - member this.RemoverCode - with get() = removerCode.Value - and set f = - if not (remover.IsValueCreated) then removerCode <- Some f else failwith "ProvidedEvent: Remove MethodInfo has already been created" - - // Implement overloads - override this.EventHandlerType = eventHandlerType - override this.GetAddMethod _nonPublic = adder.Force() :> MethodInfo - override this.GetRemoveMethod _nonPublic = remover.Force() :> MethodInfo - override this.Attributes = EventAttributes.None - override this.Name = eventName - override this.DeclaringType = declaringType |> nonNull "ProvidedEvent.DeclaringType" - override this.MemberType : MemberTypes = MemberTypes.Event - - override this.GetRaiseMethod _nonPublic = notRequired "GetRaiseMethod" this.Name - override this.ReflectedType = notRequired "ReflectedType" this.Name - override this.GetCustomAttributes(_inherit) = notRequired "GetCustomAttributes" this.Name - override this.GetCustomAttributes(_attributeType, _inherit) = notRequired "GetCustomAttributes" this.Name - override this.IsDefined(_attributeType, _inherit) = notRequired "IsDefined" this.Name - -type ProvidedLiteralField(fieldName:string,fieldType:Type,literalValue:obj) = - inherit System.Reflection.FieldInfo() - // State - - let mutable declaringType = null - - let customAttributesImpl = CustomAttributesImpl() - member this.AddXmlDocComputed xmlDoc = customAttributesImpl.AddXmlDocComputed xmlDoc - member this.AddXmlDocDelayed xmlDoc = customAttributesImpl.AddXmlDocDelayed xmlDoc - member this.AddXmlDoc xmlDoc = customAttributesImpl.AddXmlDoc xmlDoc - member this.AddObsoleteAttribute (msg,?isError) = customAttributesImpl.AddObsolete (msg,defaultArg isError false) - member this.AddDefinitionLocation(line,column,filePath) = customAttributesImpl.AddDefinitionLocation(line, column, filePath) - member __.GetCustomAttributesDataImpl() = customAttributesImpl.GetCustomAttributesData() -#if FX_NO_CUSTOMATTRIBUTEDATA -#else - override this.GetCustomAttributesData() = customAttributesImpl.GetCustomAttributesData() -#endif - - member this.DeclaringTypeImpl with set x = declaringType <- x // check: not set twice - - - // Implement overloads - override this.FieldType = fieldType - override this.GetRawConstantValue() = literalValue - override this.Attributes = FieldAttributes.Static ||| FieldAttributes.Literal ||| FieldAttributes.Public - override this.Name = fieldName - override this.DeclaringType = declaringType |> nonNull "ProvidedLiteralField.DeclaringType" - override this.MemberType : MemberTypes = MemberTypes.Field - - override this.ReflectedType = notRequired "ReflectedType" this.Name - override this.GetCustomAttributes(_inherit) = notRequired "GetCustomAttributes" this.Name - override this.GetCustomAttributes(_attributeType, _inherit) = notRequired "GetCustomAttributes" this.Name - override this.IsDefined(_attributeType, _inherit) = notRequired "IsDefined" this.Name - - override this.SetValue(_obj, _value, _invokeAttr, _binder, _culture) = notRequired "SetValue" this.Name - override this.GetValue(_obj) : obj = notRequired "GetValue" this.Name - override this.FieldHandle = notRequired "FieldHandle" this.Name - -type ProvidedField(fieldName:string,fieldType:Type) = - inherit System.Reflection.FieldInfo() - // State - - let mutable declaringType = null - - let customAttributesImpl = CustomAttributesImpl() - let mutable fieldAttrs = FieldAttributes.Private - member this.AddXmlDocComputed xmlDoc = customAttributesImpl.AddXmlDocComputed xmlDoc - member this.AddXmlDocDelayed xmlDoc = customAttributesImpl.AddXmlDocDelayed xmlDoc - member this.AddXmlDoc xmlDoc = customAttributesImpl.AddXmlDoc xmlDoc - member this.AddObsoleteAttribute (msg,?isError) = customAttributesImpl.AddObsolete (msg,defaultArg isError false) - member this.AddDefinitionLocation(line,column,filePath) = customAttributesImpl.AddDefinitionLocation(line, column, filePath) - member __.GetCustomAttributesDataImpl() = customAttributesImpl.GetCustomAttributesData() -#if FX_NO_CUSTOMATTRIBUTEDATA -#else - override this.GetCustomAttributesData() = customAttributesImpl.GetCustomAttributesData() -#endif - - member this.DeclaringTypeImpl with set x = declaringType <- x // check: not set twice - - member this.SetFieldAttributes attrs = fieldAttrs <- attrs - // Implement overloads - override this.FieldType = fieldType - override this.GetRawConstantValue() = null - override this.Attributes = fieldAttrs - override this.Name = fieldName - override this.DeclaringType = declaringType |> nonNull "ProvidedField.DeclaringType" - override this.MemberType : MemberTypes = MemberTypes.Field - - override this.ReflectedType = notRequired "ReflectedType" this.Name - override this.GetCustomAttributes(_inherit) = notRequired "GetCustomAttributes" this.Name - override this.GetCustomAttributes(_attributeType, _inherit) = notRequired "GetCustomAttributes" this.Name - override this.IsDefined(_attributeType, _inherit) = notRequired "IsDefined" this.Name - - override this.SetValue(_obj, _value, _invokeAttr, _binder, _culture) = notRequired "SetValue" this.Name - override this.GetValue(_obj) : obj = notRequired "GetValue" this.Name - override this.FieldHandle = notRequired "FieldHandle" this.Name - -/// Represents the type constructor in a provided symbol type. -[] -type SymbolKind = - | SDArray - | Array of int - | Pointer - | ByRef - | Generic of System.Type - | FSharpTypeAbbreviation of (System.Reflection.Assembly * string * string[]) - - -/// Represents an array or other symbolic type involving a provided type as the argument. -/// See the type provider spec for the methods that must be implemented. -/// Note that the type provider specification does not require us to implement pointer-equality for provided types. -type ProvidedSymbolType(kind: SymbolKind, args: Type list) = - inherit Type() - - let rec isEquivalentTo (thisTy: Type) (otherTy: Type) = - match thisTy, otherTy with - | (:? ProvidedSymbolType as thisTy), (:? ProvidedSymbolType as thatTy) -> (thisTy.Kind,thisTy.Args) = (thatTy.Kind, thatTy.Args) - | (:? ProvidedSymbolType as thisTy), otherTy | otherTy, (:? ProvidedSymbolType as thisTy) -> - match thisTy.Kind, thisTy.Args with - | SymbolKind.SDArray, [ty] | SymbolKind.Array _, [ty] when otherTy.IsArray-> ty.Equals(otherTy.GetElementType()) - | SymbolKind.ByRef, [ty] when otherTy.IsByRef -> ty.Equals(otherTy.GetElementType()) - | SymbolKind.Pointer, [ty] when otherTy.IsPointer -> ty.Equals(otherTy.GetElementType()) - | SymbolKind.Generic baseTy, args -> otherTy.IsGenericType && isEquivalentTo baseTy (otherTy.GetGenericTypeDefinition()) && Seq.forall2 isEquivalentTo args (otherTy.GetGenericArguments()) - | _ -> false - | a, b -> a.Equals b - - - static member convType (parameters: Type list) (ty:Type) = - if ty = null then null - elif ty.IsGenericType then - let args = Array.map (ProvidedSymbolType.convType parameters) (ty.GetGenericArguments()) - ProvidedSymbolType(Generic (ty.GetGenericTypeDefinition()), Array.toList args) :> Type - elif ty.HasElementType then - let ety = ProvidedSymbolType.convType parameters (ty.GetElementType()) - if ty.IsArray then - let rank = ty.GetArrayRank() - if rank = 1 then ProvidedSymbolType(SDArray,[ety]) :> Type - else ProvidedSymbolType(Array rank,[ety]) :> Type - elif ty.IsPointer then ProvidedSymbolType(Pointer,[ety]) :> Type - elif ty.IsByRef then ProvidedSymbolType(ByRef,[ety]) :> Type - else ty - elif ty.IsGenericParameter then - if ty.GenericParameterPosition <= parameters.Length - 1 then - parameters.[ty.GenericParameterPosition] - else - ty - else ty - - override this.FullName = - match kind,args with - | SymbolKind.SDArray,[arg] -> arg.FullName + "[]" - | SymbolKind.Array _,[arg] -> arg.FullName + "[*]" - | SymbolKind.Pointer,[arg] -> arg.FullName + "*" - | SymbolKind.ByRef,[arg] -> arg.FullName + "&" - | SymbolKind.Generic gty, args -> gty.FullName + "[" + (args |> List.map (fun arg -> arg.ToString()) |> String.concat ",") + "]" - | SymbolKind.FSharpTypeAbbreviation (_,nsp,path),args -> String.concat "." (Array.append [| nsp |] path) + args.ToString() - | _ -> failwith "unreachable" - - /// Although not strictly required by the type provider specification, this is required when doing basic operations like FullName on - /// .NET symbolic types made from this type, e.g. when building Nullable.FullName - override this.DeclaringType = - match kind,args with - | SymbolKind.SDArray,[arg] -> arg - | SymbolKind.Array _,[arg] -> arg - | SymbolKind.Pointer,[arg] -> arg - | SymbolKind.ByRef,[arg] -> arg - | SymbolKind.Generic gty,_ -> gty - | SymbolKind.FSharpTypeAbbreviation _,_ -> null - | _ -> failwith "unreachable" - - override this.IsAssignableFrom(otherTy) = - match kind with - | Generic gtd -> - if otherTy.IsGenericType then - let otherGtd = otherTy.GetGenericTypeDefinition() - let otherArgs = otherTy.GetGenericArguments() - let yes = gtd.Equals(otherGtd) && Seq.forall2 isEquivalentTo args otherArgs - yes - else - base.IsAssignableFrom(otherTy) - | _ -> base.IsAssignableFrom(otherTy) - - override this.Name = - match kind,args with - | SymbolKind.SDArray,[arg] -> arg.Name + "[]" - | SymbolKind.Array _,[arg] -> arg.Name + "[*]" - | SymbolKind.Pointer,[arg] -> arg.Name + "*" - | SymbolKind.ByRef,[arg] -> arg.Name + "&" - | SymbolKind.Generic gty, args -> gty.Name + (sprintf "%A" args) - | SymbolKind.FSharpTypeAbbreviation (_,_,path),_ -> path.[path.Length-1] - | _ -> failwith "unreachable" - - override this.BaseType = - match kind with - | SymbolKind.SDArray -> typeof - | SymbolKind.Array _ -> typeof - | SymbolKind.Pointer -> typeof - | SymbolKind.ByRef -> typeof - | SymbolKind.Generic gty -> - if gty.BaseType = null then null else - ProvidedSymbolType.convType args gty.BaseType - | SymbolKind.FSharpTypeAbbreviation _ -> typeof - - override this.GetArrayRank() = (match kind with SymbolKind.Array n -> n | SymbolKind.SDArray -> 1 | _ -> invalidOp "non-array type") - override this.IsArrayImpl() = (match kind with SymbolKind.Array _ | SymbolKind.SDArray -> true | _ -> false) - override this.IsByRefImpl() = (match kind with SymbolKind.ByRef _ -> true | _ -> false) - override this.IsPointerImpl() = (match kind with SymbolKind.Pointer _ -> true | _ -> false) - override this.IsPrimitiveImpl() = false - override this.IsGenericType = (match kind with SymbolKind.Generic _ -> true | _ -> false) - override this.GetGenericArguments() = (match kind with SymbolKind.Generic _ -> args |> List.toArray | _ -> invalidOp "non-generic type") - override this.GetGenericTypeDefinition() = (match kind with SymbolKind.Generic e -> e | _ -> invalidOp "non-generic type") - override this.IsCOMObjectImpl() = false - override this.HasElementTypeImpl() = (match kind with SymbolKind.Generic _ -> false | _ -> true) - override this.GetElementType() = (match kind,args with (SymbolKind.Array _ | SymbolKind.SDArray | SymbolKind.ByRef | SymbolKind.Pointer),[e] -> e | _ -> invalidOp "not an array, pointer or byref type") - override this.ToString() = this.FullName - - override this.Module : Module = notRequired "Module" this.Name - override this.Assembly = - match kind with - | SymbolKind.FSharpTypeAbbreviation (assembly,_nsp,_path) -> assembly - | SymbolKind.Generic gty -> gty.Assembly - | _ -> notRequired "Assembly" this.Name - override this.Namespace = - match kind with - | SymbolKind.FSharpTypeAbbreviation (_assembly,nsp,_path) -> nsp - | _ -> notRequired "Namespace" this.Name - - override this.GetHashCode() = - match kind,args with - | SymbolKind.SDArray,[arg] -> 10 + hash arg - | SymbolKind.Array _,[arg] -> 163 + hash arg - | SymbolKind.Pointer,[arg] -> 283 + hash arg - | SymbolKind.ByRef,[arg] -> 43904 + hash arg - | SymbolKind.Generic gty,_ -> 9797 + hash gty + List.sumBy hash args - | SymbolKind.FSharpTypeAbbreviation _,_ -> 3092 - | _ -> failwith "unreachable" - - override this.Equals(other: obj) = - match other with - | :? ProvidedSymbolType as otherTy -> (kind, args) = (otherTy.Kind, otherTy.Args) - | _ -> false - - member this.Kind = kind - member this.Args = args - - override this.GetConstructors _bindingAttr = notRequired "GetConstructors" this.Name - override this.GetMethodImpl(_name, _bindingAttr, _binderBinder, _callConvention, _types, _modifiers) = - match kind with - | Generic gtd -> - let ty = gtd.GetGenericTypeDefinition().MakeGenericType(Array.ofList args) - ty.GetMethod(_name, _bindingAttr) - | _ -> notRequired "GetMethodImpl" this.Name - override this.GetMembers _bindingAttr = notRequired "GetMembers" this.Name - override this.GetMethods _bindingAttr = notRequired "GetMethods" this.Name - override this.GetField(_name, _bindingAttr) = notRequired "GetField" this.Name - override this.GetFields _bindingAttr = notRequired "GetFields" this.Name - override this.GetInterface(_name, _ignoreCase) = notRequired "GetInterface" this.Name - override this.GetInterfaces() = notRequired "GetInterfaces" this.Name - override this.GetEvent(_name, _bindingAttr) = notRequired "GetEvent" this.Name - override this.GetEvents _bindingAttr = notRequired "GetEvents" this.Name - override this.GetProperties _bindingAttr = notRequired "GetProperties" this.Name - override this.GetPropertyImpl(_name, _bindingAttr, _binder, _returnType, _types, _modifiers) = notRequired "GetPropertyImpl" this.Name - override this.GetNestedTypes _bindingAttr = notRequired "GetNestedTypes" this.Name - override this.GetNestedType(_name, _bindingAttr) = notRequired "GetNestedType" this.Name - override this.GetAttributeFlagsImpl() = notRequired "GetAttributeFlagsImpl" this.Name - override this.UnderlyingSystemType = - match kind with - | SymbolKind.SDArray - | SymbolKind.Array _ - | SymbolKind.Pointer - | SymbolKind.FSharpTypeAbbreviation _ - | SymbolKind.ByRef -> notRequired "UnderlyingSystemType" this.Name - | SymbolKind.Generic gty -> gty.UnderlyingSystemType -#if FX_NO_CUSTOMATTRIBUTEDATA -#else - override this.GetCustomAttributesData() = ([| |] :> IList<_>) -#endif - override this.MemberType = notRequired "MemberType" this.Name - override this.GetMember(_name,_mt,_bindingAttr) = notRequired "GetMember" this.Name - override this.GUID = notRequired "GUID" this.Name - override this.InvokeMember(_name, _invokeAttr, _binder, _target, _args, _modifiers, _culture, _namedParameters) = notRequired "InvokeMember" this.Name - override this.AssemblyQualifiedName = notRequired "AssemblyQualifiedName" this.Name - override this.GetConstructorImpl(_bindingAttr, _binder, _callConvention, _types, _modifiers) = notRequired "GetConstructorImpl" this.Name - override this.GetCustomAttributes(_inherit) = [| |] - override this.GetCustomAttributes(_attributeType, _inherit) = [| |] - override this.IsDefined(_attributeType, _inherit) = false - // FSharp.Data addition: this was added to support arrays of arrays - override this.MakeArrayType() = ProvidedSymbolType(SymbolKind.SDArray, [this]) :> Type - override this.MakeArrayType arg = ProvidedSymbolType(SymbolKind.Array arg, [this]) :> Type - -type ProvidedSymbolMethod(genericMethodDefinition: MethodInfo, parameters: Type list) = - inherit System.Reflection.MethodInfo() - - let convParam (p:ParameterInfo) = - { new System.Reflection.ParameterInfo() with - override this.Name = p.Name - override this.ParameterType = ProvidedSymbolType.convType parameters p.ParameterType - override this.Attributes = p.Attributes - override this.RawDefaultValue = p.RawDefaultValue -#if FX_NO_CUSTOMATTRIBUTEDATA -#else - override __.GetCustomAttributesData() = p.GetCustomAttributesData() -#endif - } - override this.IsGenericMethod = - (if this.DeclaringType.IsGenericType then this.DeclaringType.GetGenericArguments().Length else 0) < parameters.Length - override this.GetGenericArguments() = - Seq.skip (if this.DeclaringType.IsGenericType then this.DeclaringType.GetGenericArguments().Length else 0) parameters |> Seq.toArray - override this.GetGenericMethodDefinition() = genericMethodDefinition - override this.DeclaringType = ProvidedSymbolType.convType parameters genericMethodDefinition.DeclaringType - override this.ToString() = "Method " + this.Name - override this.Name = genericMethodDefinition.Name - override this.MetadataToken = genericMethodDefinition.MetadataToken - override this.Attributes = genericMethodDefinition.Attributes - override this.CallingConvention = genericMethodDefinition.CallingConvention - override this.MemberType = genericMethodDefinition.MemberType - - override this.IsDefined(_attributeType, _inherit) : bool = notRequired "IsDefined" this.Name - override this.ReturnType = ProvidedSymbolType.convType parameters genericMethodDefinition.ReturnType - override this.GetParameters() = genericMethodDefinition.GetParameters() |> Array.map convParam - override this.ReturnParameter = genericMethodDefinition.ReturnParameter |> convParam - override this.ReturnTypeCustomAttributes = notRequired "ReturnTypeCustomAttributes" this.Name - override this.GetBaseDefinition() = notRequired "GetBaseDefinition" this.Name - override this.GetMethodImplementationFlags() = notRequired "GetMethodImplementationFlags" this.Name - override this.MethodHandle = notRequired "MethodHandle" this.Name - override this.Invoke(_obj, _invokeAttr, _binder, _parameters, _culture) = notRequired "Invoke" this.Name - override this.ReflectedType = notRequired "ReflectedType" this.Name - override this.GetCustomAttributes(_inherit) = notRequired "GetCustomAttributes" this.Name - override this.GetCustomAttributes(_attributeType, _inherit) = notRequired "GetCustomAttributes" this.Name - - - -type ProvidedTypeBuilder() = - static member MakeGenericType(genericTypeDefinition, genericArguments) = ProvidedSymbolType(Generic genericTypeDefinition, genericArguments) :> Type - static member MakeGenericMethod(genericMethodDefinition, genericArguments) = ProvidedSymbolMethod(genericMethodDefinition, genericArguments) :> MethodInfo - -[] -type ProvidedMeasureBuilder() = - - // TODO: this shouldn't be hardcoded, but without creating a dependency on Microsoft.FSharp.Metadata in F# PowerPack - // there seems to be no way to check if a type abbreviation exists - let unitNamesTypeAbbreviations = - [ "meter"; "hertz"; "newton"; "pascal"; "joule"; "watt"; "coulomb"; - "volt"; "farad"; "ohm"; "siemens"; "weber"; "tesla"; "henry" - "lumen"; "lux"; "becquerel"; "gray"; "sievert"; "katal" ] - |> Set.ofList - - let unitSymbolsTypeAbbreviations = - [ "m"; "kg"; "s"; "A"; "K"; "mol"; "cd"; "Hz"; "N"; "Pa"; "J"; "W"; "C" - "V"; "F"; "S"; "Wb"; "T"; "lm"; "lx"; "Bq"; "Gy"; "Sv"; "kat"; "H" ] - |> Set.ofList - - static let theBuilder = ProvidedMeasureBuilder() - static member Default = theBuilder - member b.One = typeof - member b.Product (m1,m2) = typedefof>.MakeGenericType [| m1;m2 |] - member b.Inverse m = typedefof>.MakeGenericType [| m |] - member b.Ratio (m1, m2) = b.Product(m1, b.Inverse m2) - member b.Square m = b.Product(m, m) - - // FSharp.Data change: if the unit is not a valid type, instead - // of assuming it's a type abbreviation, which may not be the case and cause a - // problem later on, check the list of valid abbreviations - member b.SI (m:string) = - let mLowerCase = m.ToLowerInvariant() - let abbreviation = - if unitNamesTypeAbbreviations.Contains mLowerCase then - Some ("Microsoft.FSharp.Data.UnitSystems.SI.UnitNames", mLowerCase) - elif unitSymbolsTypeAbbreviations.Contains m then - Some ("Microsoft.FSharp.Data.UnitSystems.SI.UnitSymbols", m) - else - None - match abbreviation with - | Some (ns, unitName) -> - ProvidedSymbolType - (SymbolKind.FSharpTypeAbbreviation - (typeof.Assembly, - ns, - [| unitName |]), - []) :> Type - | None -> - typedefof>.Assembly.GetType("Microsoft.FSharp.Data.UnitSystems.SI.UnitNames." + mLowerCase) - - member b.AnnotateType (basicType, annotation) = ProvidedSymbolType(Generic basicType, annotation) :> Type - - - -[] -type TypeContainer = - | Namespace of Assembly * string // namespace - | Type of System.Type - | TypeToBeDecided - -module GlobalProvidedAssemblyElementsTable = - let theTable = Dictionary>() - -type ProvidedTypeDefinition(container:TypeContainer,className : string, baseType : Type option) as this = - inherit Type() - - do match container, !ProvidedTypeDefinition.Logger with - | TypeContainer.Namespace _, Some logger -> logger (sprintf "Creating ProvidedTypeDefinition %s [%d]" className (System.Runtime.CompilerServices.RuntimeHelpers.GetHashCode this)) - | _ -> () - - // state - let mutable attributes = - TypeAttributes.Public ||| - TypeAttributes.Class ||| - TypeAttributes.Sealed ||| - enum (int32 TypeProviderTypeAttributes.IsErased) - - - let mutable enumUnderlyingType = typeof - let mutable baseType = lazy baseType - let mutable membersKnown = ResizeArray() - let mutable membersQueue = ResizeArray<(unit -> list)>() - let mutable staticParams = [ ] - let mutable staticParamsApply = None - let mutable container = container - let mutable interfaceImpls = ResizeArray() - let mutable interfaceImplsDelayed = ResizeArray list>() - let mutable methodOverrides = ResizeArray() - - // members API - let getMembers() = - if membersQueue.Count > 0 then - let elems = membersQueue |> Seq.toArray // take a copy in case more elements get added - membersQueue.Clear() - for f in elems do - for i in f() do - membersKnown.Add i - match i with - | :? ProvidedProperty as p -> - if p.CanRead then membersKnown.Add (p.GetGetMethod true) - if p.CanWrite then membersKnown.Add (p.GetSetMethod true) - | :? ProvidedEvent as e -> - membersKnown.Add (e.GetAddMethod true) - membersKnown.Add (e.GetRemoveMethod true) - | _ -> () - - membersKnown.ToArray() - - // members API - let getInterfaces() = - if interfaceImplsDelayed.Count > 0 then - let elems = interfaceImplsDelayed |> Seq.toArray // take a copy in case more elements get added - interfaceImplsDelayed.Clear() - for f in elems do - for i in f() do - interfaceImpls.Add i - - interfaceImpls.ToArray() - - let mutable theAssembly = - lazy - match container with - | TypeContainer.Namespace (theAssembly, rootNamespace) -> - if theAssembly = null then failwith "Null assemblies not allowed" - if rootNamespace<>null && rootNamespace.Length=0 then failwith "Use 'null' for global namespace" - theAssembly - | TypeContainer.Type superTy -> superTy.Assembly - | TypeContainer.TypeToBeDecided -> failwith (sprintf "type '%s' was not added as a member to a declaring type" this.Name) - - let rootNamespace = - lazy - match container with - | TypeContainer.Namespace (_,rootNamespace) -> rootNamespace - | TypeContainer.Type enclosingTyp -> enclosingTyp.Namespace - | TypeContainer.TypeToBeDecided -> failwith (sprintf "type '%s' was not added as a member to a declaring type" this.Name) - - let declaringType = - lazy - match container with - | TypeContainer.Namespace _ -> null - | TypeContainer.Type enclosingTyp -> enclosingTyp - | TypeContainer.TypeToBeDecided -> failwith (sprintf "type '%s' was not added as a member to a declaring type" this.Name) - - let fullName = - lazy - match container with - | TypeContainer.Type declaringType -> declaringType.FullName + "+" + className - | TypeContainer.Namespace (_,namespaceName) -> - if namespaceName="" then failwith "use null for global namespace" - match namespaceName with - | null -> className - | _ -> namespaceName + "." + className - | TypeContainer.TypeToBeDecided -> failwith (sprintf "type '%s' was not added as a member to a declaring type" this.Name) - - let patchUpAddedMemberInfo (this:Type) (m:MemberInfo) = - match m with - | :? ProvidedConstructor as c -> c.DeclaringTypeImpl <- this // patch up "declaring type" on provided MethodInfo - | :? ProvidedMethod as m -> m.DeclaringTypeImpl <- this // patch up "declaring type" on provided MethodInfo - | :? ProvidedProperty as p -> p.DeclaringTypeImpl <- this // patch up "declaring type" on provided MethodInfo - | :? ProvidedEvent as e -> e.DeclaringTypeImpl <- this // patch up "declaring type" on provided MethodInfo - | :? ProvidedTypeDefinition as t -> t.DeclaringTypeImpl <- this - | :? ProvidedLiteralField as l -> l.DeclaringTypeImpl <- this - | :? ProvidedField as l -> l.DeclaringTypeImpl <- this - | _ -> () - - let customAttributesImpl = CustomAttributesImpl() - member this.AddXmlDocComputed xmlDoc = customAttributesImpl.AddXmlDocComputed xmlDoc - member this.AddXmlDocDelayed xmlDoc = customAttributesImpl.AddXmlDocDelayed xmlDoc - member this.AddXmlDoc xmlDoc = customAttributesImpl.AddXmlDoc xmlDoc - member this.AddObsoleteAttribute (msg,?isError) = customAttributesImpl.AddObsolete (msg,defaultArg isError false) - member this.AddDefinitionLocation(line,column,filePath) = customAttributesImpl.AddDefinitionLocation(line, column, filePath) - member this.HideObjectMethods with set v = customAttributesImpl.HideObjectMethods <- v - member this.NonNullable with set v = customAttributesImpl.NonNullable <- v - member __.GetCustomAttributesDataImpl() = customAttributesImpl.GetCustomAttributesData() - member this.AddCustomAttribute attribute = customAttributesImpl.AddCustomAttribute attribute -#if FX_NO_CUSTOMATTRIBUTEDATA -#else - override this.GetCustomAttributesData() = customAttributesImpl.GetCustomAttributesData() -#endif - - member this.ResetEnclosingType (ty) = - container <- TypeContainer.Type ty - new (assembly:Assembly,namespaceName,className,baseType) = new ProvidedTypeDefinition(TypeContainer.Namespace (assembly,namespaceName), className, baseType) - new (className,baseType) = new ProvidedTypeDefinition(TypeContainer.TypeToBeDecided, className, baseType) - // state ops - - override this.UnderlyingSystemType = typeof - member this.SetEnumUnderlyingType(ty) = enumUnderlyingType <- ty - override this.GetEnumUnderlyingType() = if this.IsEnum then enumUnderlyingType else invalidOp "not enum type" - member this.SetBaseType t = baseType <- lazy Some t - member this.SetBaseTypeDelayed t = baseType <- t - member this.SetAttributes x = attributes <- x - // Add MemberInfos - member this.AddMembersDelayed(makeMS : unit -> list<#MemberInfo>) = - membersQueue.Add (fun () -> makeMS() |> List.map (fun x -> patchUpAddedMemberInfo this x; x :> MemberInfo )) - member this.AddMembers(ms:list<#MemberInfo>) = (* strict *) - ms |> List.iter (patchUpAddedMemberInfo this) // strict: patch up now - membersQueue.Add (fun () -> ms |> List.map (fun x -> x :> MemberInfo)) - member this.AddMember(m:MemberInfo) = this.AddMembers [m] - member this.AddMemberDelayed(m : unit -> #MemberInfo) = this.AddMembersDelayed(fun () -> [m()]) - - member this.AddAssemblyTypesAsNestedTypesDelayed (assemblyf : unit -> System.Reflection.Assembly) = - let bucketByPath nodef tipf (items: (string list * 'Value) list) = - // Find all the items with an empty key list and call 'tipf' - let tips = - [ for (keylist,v) in items do - match keylist with - | [] -> yield tipf v - | _ -> () ] - - // Find all the items with a non-empty key list. Bucket them together by - // the first key. For each bucket, call 'nodef' on that head key and the bucket. - let nodes = - let buckets = new Dictionary<_,_>(10) - for (keylist,v) in items do - match keylist with - | [] -> () - | key::rest -> - buckets.[key] <- (rest,v) :: (if buckets.ContainsKey key then buckets.[key] else []); - - [ for (KeyValue(key,items)) in buckets -> nodef key items ] - - tips @ nodes - this.AddMembersDelayed (fun _ -> - let topTypes = [ for ty in assemblyf().GetTypes() do - if not ty.IsNested then - let namespaceParts = match ty.Namespace with null -> [] | s -> s.Split '.' |> Array.toList - yield namespaceParts, ty ] - let rec loop types = - types - |> bucketByPath - (fun namespaceComponent typesUnderNamespaceComponent -> - let t = ProvidedTypeDefinition(namespaceComponent, baseType = Some typeof) - t.AddMembers (loop typesUnderNamespaceComponent) - (t :> Type)) - (fun ty -> ty) - loop topTypes) - - /// Abstract a type to a parametric-type. Requires "formal parameters" and "instantiation function". - member this.DefineStaticParameters(staticParameters : list, apply : (string -> obj[] -> ProvidedTypeDefinition)) = - staticParams <- staticParameters - staticParamsApply <- Some apply - - /// Get ParameterInfo[] for the parametric type parameters (//s GetGenericParameters) - member this.GetStaticParameters() = [| for p in staticParams -> p :> ParameterInfo |] - - /// Instantiate parametrics type - member this.MakeParametricType(name:string,args:obj[]) = - if staticParams.Length>0 then - if staticParams.Length <> args.Length then - failwith (sprintf "ProvidedTypeDefinition: expecting %d static parameters but given %d for type %s" staticParams.Length args.Length (fullName.Force())) - match staticParamsApply with - | None -> failwith "ProvidedTypeDefinition: DefineStaticParameters was not called" - | Some f -> f name args - - else - failwith (sprintf "ProvidedTypeDefinition: static parameters supplied but not expected for %s" (fullName.Force())) - - member this.DeclaringTypeImpl - with set x = - match container with TypeContainer.TypeToBeDecided -> () | _ -> failwith (sprintf "container type for '%s' was already set to '%s'" this.FullName x.FullName); - container <- TypeContainer.Type x - - // Implement overloads - override this.Assembly = theAssembly.Force() - member this.SetAssembly assembly = theAssembly <- lazy assembly - member this.SetAssemblyLazy assembly = theAssembly <- assembly - override this.FullName = fullName.Force() - override this.Namespace = rootNamespace.Force() - override this.BaseType = match baseType.Value with Some ty -> ty | None -> null - - // Constructors - override this.GetConstructors bindingAttr = - [| for m in this.GetMembers bindingAttr do - if m.MemberType = MemberTypes.Constructor then - yield (m :?> ConstructorInfo) |] - // Methods - override this.GetMethodImpl(name, bindingAttr, _binderBinder, _callConvention, _types, _modifiers) : MethodInfo = - let membersWithName = - [ for m in this.GetMembers(bindingAttr) do - if m.MemberType.HasFlag(MemberTypes.Method) && m.Name = name then - yield m ] - match membersWithName with - | [] -> null - | [meth] -> meth :?> MethodInfo - | _several -> failwith "GetMethodImpl. not support overloads" - - override this.GetMethods bindingAttr = - this.GetMembers bindingAttr - |> Array.filter (fun m -> m.MemberType.HasFlag(MemberTypes.Method)) - |> Array.map (fun m -> m :?> MethodInfo) - - // Fields - override this.GetField(name, bindingAttr) = - let fields = [| for m in this.GetMembers bindingAttr do - if m.MemberType.HasFlag(MemberTypes.Field) && (name = null || m.Name = name) then // REVIEW: name = null. Is that a valid query?! - yield m |] - if fields.Length > 0 then fields.[0] :?> FieldInfo else null - - override this.GetFields bindingAttr = - [| for m in this.GetMembers bindingAttr do if m.MemberType.HasFlag(MemberTypes.Field) then yield m :?> FieldInfo |] - - override this.GetInterface(_name, _ignoreCase) = notRequired "GetInterface" this.Name - - override this.GetInterfaces() = - [| yield! getInterfaces() |] - - member this.GetInterfaceImplementations() = - [| yield! getInterfaces() |] - - member this.AddInterfaceImplementation ityp = interfaceImpls.Add ityp - member this.AddInterfaceImplementationsDelayed itypf = interfaceImplsDelayed.Add itypf - member this.GetMethodOverrides() = - [| yield! methodOverrides |] - member this.DefineMethodOverride (bodyMethInfo,declMethInfo) = methodOverrides.Add (bodyMethInfo, declMethInfo) - - // Events - override this.GetEvent(name, bindingAttr) = - let events = this.GetMembers bindingAttr - |> Array.filter(fun m -> m.MemberType.HasFlag(MemberTypes.Event) && (name = null || m.Name = name)) - if events.Length > 0 then events.[0] :?> EventInfo else null - - override this.GetEvents bindingAttr = - [| for m in this.GetMembers bindingAttr do if m.MemberType.HasFlag(MemberTypes.Event) then yield downcast m |] - - // Properties - override this.GetProperties bindingAttr = - [| for m in this.GetMembers bindingAttr do if m.MemberType.HasFlag(MemberTypes.Property) then yield downcast m |] - - override this.GetPropertyImpl(name, bindingAttr, binder, returnType, types, modifiers) = - if returnType <> null then failwith "Need to handle specified return type in GetPropertyImpl" - if types <> null then failwith "Need to handle specified parameter types in GetPropertyImpl" - if modifiers <> null then failwith "Need to handle specified modifiers in GetPropertyImpl" - if binder <> null then failwith "Need to handle binder in GetPropertyImpl" - let props = this.GetMembers bindingAttr |> Array.filter(fun m -> m.MemberType.HasFlag(MemberTypes.Property) && (name = null || m.Name = name)) // Review: nam = null, valid query!? - if props.Length > 0 then - props.[0] :?> PropertyInfo - else - null - // Nested Types - override this.MakeArrayType() = ProvidedSymbolType(SymbolKind.SDArray, [this]) :> Type - override this.MakeArrayType arg = ProvidedSymbolType(SymbolKind.Array arg, [this]) :> Type - override this.MakePointerType() = ProvidedSymbolType(SymbolKind.Pointer, [this]) :> Type - override this.MakeByRefType() = ProvidedSymbolType(SymbolKind.ByRef, [this]) :> Type - - // FSharp.Data addition: this method is used by Debug.fs and QuotationBuilder.fs - // Emulate the F# type provider type erasure mechanism to get the - // actual (erased) type. We erase ProvidedTypes to their base type - // and we erase array of provided type to array of base type. In the - // case of generics all the generic type arguments are also recursively - // replaced with the erased-to types - static member EraseType(t:Type) = - match t with - | :? ProvidedTypeDefinition -> ProvidedTypeDefinition.EraseType t.BaseType - | :? ProvidedSymbolType as sym -> - match sym.Kind, sym.Args with - | SymbolKind.SDArray, [typ] -> - let (t:Type) = ProvidedTypeDefinition.EraseType typ - t.MakeArrayType() - | SymbolKind.Generic genericTypeDefinition, _ when not genericTypeDefinition.IsGenericTypeDefinition -> - // Unit of measure parameters can match here, but not really generic types. - genericTypeDefinition.UnderlyingSystemType - | SymbolKind.Generic genericTypeDefinition, typeArgs -> - let genericArguments = - typeArgs - |> List.toArray - |> Array.map ProvidedTypeDefinition.EraseType - genericTypeDefinition.MakeGenericType(genericArguments) - | _ -> failwith "getTypeErasedTo: Unsupported ProvidedSymbolType" - | t when t.IsGenericType && not t.IsGenericTypeDefinition -> - let genericTypeDefinition = t.GetGenericTypeDefinition() - let genericArguments = - t.GetGenericArguments() - |> Array.map ProvidedTypeDefinition.EraseType - genericTypeDefinition.MakeGenericType(genericArguments) - | t -> t - - static member Logger : (string -> unit) option ref = ref None - - // The binding attributes are always set to DeclaredOnly ||| Static ||| Instance ||| Public when GetMembers is called directly by the F# compiler - // However, it's possible for the framework to generate other sets of flags in some corner cases (e.g. via use of `enum` with a provided type as the target) - override this.GetMembers bindingAttr = - let mems = - getMembers() - |> Array.filter (fun mem -> - let isStatic, isPublic = - match mem with - | :? FieldInfo as f -> f.IsStatic, f.IsPublic - | :? MethodInfo as m -> m.IsStatic, m.IsPublic - | :? ConstructorInfo as c -> c.IsStatic, c.IsPublic - | :? PropertyInfo as p -> - let m = if p.CanRead then p.GetGetMethod() else p.GetSetMethod() - m.IsStatic, m.IsPublic - | :? EventInfo as e -> - let m = e.GetAddMethod() - m.IsStatic, m.IsPublic - | :? Type as ty -> - true, ty.IsNestedPublic - | _ -> failwith (sprintf "Member %O is of unexpected type" mem) - bindingAttr.HasFlag(if isStatic then BindingFlags.Static else BindingFlags.Instance) && - ( - (bindingAttr.HasFlag(BindingFlags.Public) && isPublic) || (bindingAttr.HasFlag(BindingFlags.NonPublic) && not isPublic) - )) - - if bindingAttr.HasFlag(BindingFlags.DeclaredOnly) || this.BaseType = null then mems - else - // FSharp.Data change: just using this.BaseType is not enough in the case of CsvProvider, - // because the base type is CsvRow, so we have to erase recursively to CsvRow - let baseMems = (ProvidedTypeDefinition.EraseType this.BaseType).GetMembers bindingAttr - Array.append mems baseMems - - override this.GetNestedTypes bindingAttr = - this.GetMembers bindingAttr - |> Array.filter(fun m -> - m.MemberType.HasFlag(MemberTypes.NestedType) || - // Allow 'fake' nested types that are actually real .NET types - m.MemberType.HasFlag(MemberTypes.TypeInfo)) |> Array.map(fun m -> m :?> Type) - - override this.GetMember(name,mt,_bindingAttr) = - let mt = - if mt &&& MemberTypes.NestedType = MemberTypes.NestedType then - mt ||| MemberTypes.TypeInfo - else - mt - getMembers() |> Array.filter(fun m->0<>(int(m.MemberType &&& mt)) && m.Name = name) - - override this.GetNestedType(name, bindingAttr) = - let nt = this.GetMember(name, MemberTypes.NestedType ||| MemberTypes.TypeInfo, bindingAttr) - match nt.Length with - | 0 -> null - | 1 -> downcast nt.[0] - | _ -> failwith (sprintf "There is more than one nested type called '%s' in type '%s'" name this.FullName) - - // Attributes, etc.. - override this.GetAttributeFlagsImpl() = adjustTypeAttributes attributes this.IsNested - override this.IsArrayImpl() = false - override this.IsByRefImpl() = false - override this.IsPointerImpl() = false - override this.IsPrimitiveImpl() = false - override this.IsCOMObjectImpl() = false - override this.HasElementTypeImpl() = false - override this.Name = className - override this.DeclaringType = declaringType.Force() - override this.MemberType = if this.IsNested then MemberTypes.NestedType else MemberTypes.TypeInfo - override this.GetHashCode() = rootNamespace.GetHashCode() ^^^ className.GetHashCode() - override this.Equals(that:obj) = - match that with - | null -> false - | :? ProvidedTypeDefinition as ti -> System.Object.ReferenceEquals(this,ti) - | _ -> false - - override this.GetGenericArguments() = [||] - override this.ToString() = this.Name - - - override this.Module : Module = notRequired "Module" this.Name - override this.GUID = Guid.Empty - override this.GetConstructorImpl(_bindingAttr, _binder, _callConvention, _types, _modifiers) = null - override this.GetCustomAttributes(_inherit) = [| |] - override this.GetCustomAttributes(_attributeType, _inherit) = [| |] - override this.IsDefined(_attributeType: Type, _inherit) = false - - override this.GetElementType() = notRequired "Module" this.Name - override this.InvokeMember(_name, _invokeAttr, _binder, _target, _args, _modifiers, _culture, _namedParameters) = notRequired "Module" this.Name - override this.AssemblyQualifiedName = notRequired "Module" this.Name - member this.IsErased - with get() = (attributes &&& enum (int32 TypeProviderTypeAttributes.IsErased)) <> enum 0 - and set v = - if v then attributes <- attributes ||| enum (int32 TypeProviderTypeAttributes.IsErased) - else attributes <- attributes &&& ~~~(enum (int32 TypeProviderTypeAttributes.IsErased)) - - member this.SuppressRelocation - with get() = (attributes &&& enum (int32 TypeProviderTypeAttributes.SuppressRelocate)) <> enum 0 - and set v = - if v then attributes <- attributes ||| enum (int32 TypeProviderTypeAttributes.SuppressRelocate) - else attributes <- attributes &&& ~~~(enum (int32 TypeProviderTypeAttributes.SuppressRelocate)) - -type AssemblyGenerator(assemblyFileName) = - let assemblyShortName = Path.GetFileNameWithoutExtension assemblyFileName - let assemblyName = AssemblyName assemblyShortName -#if FX_NO_LOCAL_FILESYSTEM - let assembly = - System.AppDomain.CurrentDomain.DefineDynamicAssembly(name=assemblyName,access=AssemblyBuilderAccess.Run) - let assemblyMainModule = - assembly.DefineDynamicModule("MainModule") -#else - let assembly = - System.AppDomain.CurrentDomain.DefineDynamicAssembly(name=assemblyName,access=(AssemblyBuilderAccess.Save ||| AssemblyBuilderAccess.Run),dir=Path.GetDirectoryName assemblyFileName) - let assemblyMainModule = - assembly.DefineDynamicModule("MainModule", Path.GetFileName assemblyFileName) -#endif - let typeMap = Dictionary(HashIdentity.Reference) - let typeMapExtra = Dictionary(HashIdentity.Structural) - let uniqueLambdaTypeName() = - // lambda name should be unique across all types that all type provider might contribute in result assembly - sprintf "Lambda%O" (Guid.NewGuid()) - - member __.Assembly = assembly :> Assembly - /// Emit the given provided type definitions into an assembly and adjust 'Assembly' property of all type definitions to return that - /// assembly. - member __.Generate(providedTypeDefinitions:(ProvidedTypeDefinition * string list option) list) = - let ALL = BindingFlags.Public ||| BindingFlags.NonPublic ||| BindingFlags.Static ||| BindingFlags.Instance - // phase 1 - set assembly fields and emit type definitions - begin - let rec typeMembers (tb:TypeBuilder) (td : ProvidedTypeDefinition) = - for ntd in td.GetNestedTypes(ALL) do - nestedType tb ntd - - and nestedType (tb:TypeBuilder) (ntd : Type) = - match ntd with - | :? ProvidedTypeDefinition as pntd -> - if pntd.IsErased then invalidOp ("The nested provided type "+pntd.Name+"is marked as erased and cannot be converted to a generated type. Set 'IsErased' to false on the ProvidedTypeDefinition") - // Adjust the attributes - we're codegen'ing this type as nested - let attributes = adjustTypeAttributes ntd.Attributes true - let ntb = tb.DefineNestedType(pntd.Name,attr=attributes) - pntd.SetAssembly null - typeMap.[pntd] <- ntb - typeMembers ntb pntd - | _ -> () - - for (pt,enclosingGeneratedTypeNames) in providedTypeDefinitions do - match enclosingGeneratedTypeNames with - | None -> - // Filter out the additional TypeProviderTypeAttributes flags - let attributes = pt.Attributes &&& ~~~(enum (int32 TypeProviderTypeAttributes.SuppressRelocate)) - &&& ~~~(enum (int32 TypeProviderTypeAttributes.IsErased)) - // Adjust the attributes - we're codegen'ing as non-nested - let attributes = adjustTypeAttributes attributes false - let tb = assemblyMainModule.DefineType(name=pt.FullName,attr=attributes) - pt.SetAssembly null - typeMap.[pt] <- tb - typeMembers tb pt - | Some ns -> - let otb,_ = - ((None,""),ns) ||> List.fold (fun (otb:TypeBuilder option,fullName) n -> - let fullName = if fullName = "" then n else fullName + "." + n - let priorType = if typeMapExtra.ContainsKey(fullName) then Some typeMapExtra.[fullName] else None - let tb = - match priorType with - | Some tbb -> tbb - | None -> - // OK, the implied nested type is not defined, define it now - let attributes = - TypeAttributes.Public ||| - TypeAttributes.Class ||| - TypeAttributes.Sealed - // Filter out the additional TypeProviderTypeAttributes flags - let attributes = adjustTypeAttributes attributes otb.IsSome - let tb = - match otb with - | None -> assemblyMainModule.DefineType(name=n,attr=attributes) - | Some (otb:TypeBuilder) -> otb.DefineNestedType(name=n,attr=attributes) - typeMapExtra.[fullName] <- tb - tb - (Some tb, fullName)) - nestedType otb.Value pt - end - let rec convType (ty:Type) = - match ty with - | :? ProvidedTypeDefinition as ptd -> - if typeMap.ContainsKey ptd then typeMap.[ptd] :> Type else ty - | _ -> - if ty.IsGenericType then ty.GetGenericTypeDefinition().MakeGenericType (Array.map convType (ty.GetGenericArguments())) - elif ty.HasElementType then - let ety = convType (ty.GetElementType()) - if ty.IsArray then - let rank = ty.GetArrayRank() - if rank = 1 then ety.MakeArrayType() - else ety.MakeArrayType rank - elif ty.IsPointer then ety.MakePointerType() - elif ty.IsByRef then ety.MakeByRefType() - else ty - else ty - - let ctorMap = Dictionary(HashIdentity.Reference) - let methMap = Dictionary(HashIdentity.Reference) - let fieldMap = Dictionary(HashIdentity.Reference) - - let iterateTypes f = - let rec typeMembers (ptd : ProvidedTypeDefinition) = - let tb = typeMap.[ptd] - f tb (Some ptd) - for ntd in ptd.GetNestedTypes(ALL) do - nestedType ntd - - and nestedType (ntd : Type) = - match ntd with - | :? ProvidedTypeDefinition as pntd -> typeMembers pntd - | _ -> () - - for (pt,enclosingGeneratedTypeNames) in providedTypeDefinitions do - match enclosingGeneratedTypeNames with - | None -> - typeMembers pt - | Some ns -> - let _fullName = - ("",ns) ||> List.fold (fun fullName n -> - let fullName = if fullName = "" then n else fullName + "." + n - f typeMapExtra.[fullName] None - fullName) - nestedType pt - - - // phase 1b - emit base types - iterateTypes (fun tb ptd -> - match ptd with - | None -> () - | Some ptd -> - match ptd.BaseType with null -> () | bt -> tb.SetParent(convType bt)) - - let defineCustomAttrs f (cattrs: IList) = - for attr in cattrs do - let constructorArgs = [ for x in attr.ConstructorArguments -> x.Value ] - let namedProps,namedPropVals = [ for x in attr.NamedArguments do match x.MemberInfo with :? PropertyInfo as pi -> yield (pi, x.TypedValue.Value) | _ -> () ] |> List.unzip - let namedFields,namedFieldVals = [ for x in attr.NamedArguments do match x.MemberInfo with :? FieldInfo as pi -> yield (pi, x.TypedValue.Value) | _ -> () ] |> List.unzip - let cab = CustomAttributeBuilder(attr.Constructor, Array.ofList constructorArgs, Array.ofList namedProps, Array.ofList namedPropVals, Array.ofList namedFields, Array.ofList namedFieldVals) - f cab - - // phase 2 - emit member definitions - iterateTypes (fun tb ptd -> - match ptd with - | None -> () - | Some ptd -> - for cinfo in ptd.GetConstructors(ALL) do - match cinfo with - | :? ProvidedConstructor as pcinfo when not (ctorMap.ContainsKey pcinfo) -> - let cb = - if pcinfo.IsTypeInitializer then - if (cinfo.GetParameters()).Length <> 0 then failwith "Type initializer should not have parameters" - tb.DefineTypeInitializer() - else - let cb = tb.DefineConstructor(cinfo.Attributes, CallingConventions.Standard, [| for p in cinfo.GetParameters() -> convType p.ParameterType |]) - for (i,p) in cinfo.GetParameters() |> Seq.mapi (fun i x -> (i,x)) do - cb.DefineParameter(i+1, ParameterAttributes.None, p.Name) |> ignore - cb - ctorMap.[pcinfo] <- cb - | _ -> () - - if ptd.IsEnum then - tb.DefineField("value__", ptd.GetEnumUnderlyingType(), FieldAttributes.Public ||| FieldAttributes.SpecialName ||| FieldAttributes.RTSpecialName) - |> ignore - - for finfo in ptd.GetFields(ALL) do - let fieldInfo = - match finfo with - | :? ProvidedField as pinfo -> - Some (pinfo.Name, convType finfo.FieldType, finfo.Attributes, pinfo.GetCustomAttributesDataImpl(), None) - | :? ProvidedLiteralField as pinfo -> - Some (pinfo.Name, convType finfo.FieldType, finfo.Attributes, pinfo.GetCustomAttributesDataImpl(), Some (pinfo.GetRawConstantValue())) - | _ -> None - match fieldInfo with - | Some (name, ty, attr, cattr, constantVal) when not (fieldMap.ContainsKey finfo) -> - let fb = tb.DefineField(name, ty, attr) - if constantVal.IsSome then - fb.SetConstant constantVal.Value - defineCustomAttrs fb.SetCustomAttribute cattr - fieldMap.[finfo] <- fb - | _ -> () - for minfo in ptd.GetMethods(ALL) do - match minfo with - | :? ProvidedMethod as pminfo when not (methMap.ContainsKey pminfo) -> - let mb = tb.DefineMethod(minfo.Name, minfo.Attributes, convType minfo.ReturnType, [| for p in minfo.GetParameters() -> convType p.ParameterType |]) - for (i, p) in minfo.GetParameters() |> Seq.mapi (fun i x -> (i,x :?> ProvidedParameter)) do - // TODO: check why F# compiler doesn't emit default value when just p.Attributes is used (thus bad metadata is emitted) -// let mutable attrs = ParameterAttributes.None -// -// if p.IsOut then attrs <- attrs ||| ParameterAttributes.Out -// if p.HasDefaultParameterValue then attrs <- attrs ||| ParameterAttributes.Optional - - let pb = mb.DefineParameter(i+1, p.Attributes, p.Name) - if p.HasDefaultParameterValue then - do - let ctor = typeof.GetConstructor([|typeof|]) - let builder = new CustomAttributeBuilder(ctor, [|p.RawDefaultValue|]) - pb.SetCustomAttribute builder - do - let ctor = typeof.GetConstructor([||]) - let builder = new CustomAttributeBuilder(ctor, [||]) - pb.SetCustomAttribute builder - pb.SetConstant p.RawDefaultValue - methMap.[pminfo] <- mb - | _ -> () - - for ityp in ptd.GetInterfaceImplementations() do - tb.AddInterfaceImplementation ityp) - - // phase 3 - emit member code - iterateTypes (fun tb ptd -> - match ptd with - | None -> () - | Some ptd -> - let cattr = ptd.GetCustomAttributesDataImpl() - defineCustomAttrs tb.SetCustomAttribute cattr - // Allow at most one constructor, and use its arguments as the fields of the type - let ctors = - ptd.GetConstructors(ALL) // exclude type initializer - |> Seq.choose (function :? ProvidedConstructor as pcinfo when not pcinfo.IsTypeInitializer -> Some pcinfo | _ -> None) - |> Seq.toList - let implictCtorArgs = - match ctors |> List.filter (fun x -> x.IsImplicitCtor) with - | [] -> [] - | [ pcinfo ] -> [ for p in pcinfo.GetParameters() -> p ] - | _ -> failwith "at most one implicit constructor allowed" - - let implicitCtorArgsAsFields = - [ for ctorArg in implictCtorArgs -> - tb.DefineField(ctorArg.Name, convType ctorArg.ParameterType, FieldAttributes.Private) ] - - let rec emitLambda(callSiteIlg : ILGenerator, v : Quotations.Var, body : Quotations.Expr, freeVars : seq, locals : Dictionary<_, LocalBuilder>, parameters) = - let lambda = assemblyMainModule.DefineType(uniqueLambdaTypeName(), TypeAttributes.Class) - let baseType = typedefof>.MakeGenericType(v.Type, body.Type) - lambda.SetParent(baseType) - let ctor = lambda.DefineDefaultConstructor(MethodAttributes.Public) - let decl = baseType.GetMethod "Invoke" - let paramTypes = [| for p in decl.GetParameters() -> p.ParameterType |] - let invoke = lambda.DefineMethod("Invoke", MethodAttributes.Virtual ||| MethodAttributes.Final ||| MethodAttributes.Public, decl.ReturnType, paramTypes) - lambda.DefineMethodOverride(invoke, decl) - - // promote free vars to fields - let fields = ResizeArray() - for v in freeVars do - let f = lambda.DefineField(v.Name, v.Type, FieldAttributes.Assembly) - fields.Add(v, f) - - let copyOfLocals = Dictionary() - - let ilg = invoke.GetILGenerator() - for (v, f) in fields do - let l = ilg.DeclareLocal(v.Type) - ilg.Emit(OpCodes.Ldarg_0) - ilg.Emit(OpCodes.Ldfld, f) - ilg.Emit(OpCodes.Stloc, l) - copyOfLocals.[v] <- l - - let expectedState = if (invoke.ReturnType = typeof) then ExpectedStackState.Empty else ExpectedStackState.Value - emitExpr (ilg, copyOfLocals, [| Quotations.Var("this", lambda); v|]) expectedState body - ilg.Emit(OpCodes.Ret) - - lambda.CreateType() |> ignore - - callSiteIlg.Emit(OpCodes.Newobj, ctor) - for (v, f) in fields do - callSiteIlg.Emit(OpCodes.Dup) - match locals.TryGetValue v with - | true, loc -> - callSiteIlg.Emit(OpCodes.Ldloc, loc) - | false, _ -> - let index = parameters |> Array.findIndex ((=) v) - callSiteIlg.Emit(OpCodes.Ldarg, index) - callSiteIlg.Emit(OpCodes.Stfld, f) - - and emitExpr (ilg: ILGenerator, locals:Dictionary, parameterVars) expectedState expr = - let pop () = ilg.Emit(OpCodes.Pop) - let popIfEmptyExpected s = if isEmpty s then pop() - let emitConvIfNecessary t1 = - if t1 = typeof then - ilg.Emit(OpCodes.Conv_I2) - elif t1 = typeof then - ilg.Emit(OpCodes.Conv_U2) - elif t1 = typeof then - ilg.Emit(OpCodes.Conv_I1) - elif t1 = typeof then - ilg.Emit(OpCodes.Conv_U1) - /// emits given expression to corresponding IL - let rec emit (expectedState : ExpectedStackState) (expr: Quotations.Expr) = - match expr with - | Quotations.Patterns.ForIntegerRangeLoop(loopVar, first, last, body) -> - // for(loopVar = first..last) body - let lb = - match locals.TryGetValue loopVar with - | true, lb -> lb - | false, _ -> - let lb = ilg.DeclareLocal(convType loopVar.Type) - locals.Add(loopVar, lb) - lb - - // loopVar = first - emit ExpectedStackState.Value first - ilg.Emit(OpCodes.Stloc, lb) - - let before = ilg.DefineLabel() - let after = ilg.DefineLabel() - - ilg.MarkLabel before - ilg.Emit(OpCodes.Ldloc, lb) - - emit ExpectedStackState.Value last - ilg.Emit(OpCodes.Bgt, after) - - emit ExpectedStackState.Empty body - - // loopVar++ - ilg.Emit(OpCodes.Ldloc, lb) - ilg.Emit(OpCodes.Ldc_I4_1) - ilg.Emit(OpCodes.Add) - ilg.Emit(OpCodes.Stloc, lb) - - ilg.Emit(OpCodes.Br, before) - ilg.MarkLabel(after) - - | Quotations.Patterns.NewArray(elementTy, elements) -> - ilg.Emit(OpCodes.Ldc_I4, List.length elements) - ilg.Emit(OpCodes.Newarr, convType elementTy) - - elements - |> List.iteri (fun i el -> - ilg.Emit(OpCodes.Dup) - ilg.Emit(OpCodes.Ldc_I4, i) - emit ExpectedStackState.Value el - ilg.Emit(OpCodes.Stelem, convType elementTy) - ) - - popIfEmptyExpected expectedState - - | Quotations.Patterns.WhileLoop(cond, body) -> - let before = ilg.DefineLabel() - let after = ilg.DefineLabel() - - ilg.MarkLabel before - emit ExpectedStackState.Value cond - ilg.Emit(OpCodes.Brfalse, after) - emit ExpectedStackState.Empty body - ilg.Emit(OpCodes.Br, before) - - ilg.MarkLabel after - - | Quotations.Patterns.Var v -> - if isEmpty expectedState then () else - let methIdx = parameterVars |> Array.tryFindIndex (fun p -> p = v) - match methIdx with - | Some idx -> - ilg.Emit((if isAddress expectedState then OpCodes.Ldarga else OpCodes.Ldarg), idx) - | None -> - let implicitCtorArgFieldOpt = implicitCtorArgsAsFields |> List.tryFind (fun f -> f.Name = v.Name) - match implicitCtorArgFieldOpt with - | Some ctorArgField -> - ilg.Emit(OpCodes.Ldarg_0) - ilg.Emit(OpCodes.Ldfld, ctorArgField) - | None -> - match locals.TryGetValue v with - | true, localBuilder -> - ilg.Emit((if isAddress expectedState then OpCodes.Ldloca else OpCodes.Ldloc), localBuilder.LocalIndex) - | false, _ -> - failwith "unknown parameter/field" - - | Quotations.Patterns.Coerce (arg,ty) -> - // castClass may lead to observable side-effects - InvalidCastException - emit ExpectedStackState.Value arg - let argTy = convType arg.Type - let targetTy = convType ty - if argTy.IsValueType && not targetTy.IsValueType then - ilg.Emit(OpCodes.Box, argTy) - elif not argTy.IsValueType && targetTy.IsValueType then - ilg.Emit(OpCodes.Unbox_Any, targetTy) - // emit castclass if - // - targettype is not obj (assume this is always possible for ref types) - // AND - // - HACK: targettype is TypeBuilderInstantiationType - // (its implementation of IsAssignableFrom raises NotSupportedException so it will be safer to always emit castclass) - // OR - // - not (argTy :> targetTy) - elif targetTy <> typeof && (Misc.TypeBuilderInstantiationType.Equals(targetTy.GetType()) || not (targetTy.IsAssignableFrom(argTy))) then - ilg.Emit(OpCodes.Castclass, targetTy) - - popIfEmptyExpected expectedState - | Quotations.DerivedPatterns.SpecificCall <@ (-) @>(None, [t1; t2; _], [a1; a2]) -> - assert(t1 = t2) - emit ExpectedStackState.Value a1 - emit ExpectedStackState.Value a2 - if t1 = typeof then - ilg.Emit(OpCodes.Call, typeof.GetMethod "op_Subtraction") - else - ilg.Emit(OpCodes.Sub) - emitConvIfNecessary t1 - - popIfEmptyExpected expectedState - - | Quotations.DerivedPatterns.SpecificCall <@ (/) @> (None, [t1; t2; _], [a1; a2]) -> - assert (t1 = t2) - emit ExpectedStackState.Value a1 - emit ExpectedStackState.Value a2 - if t1 = typeof then - ilg.Emit(OpCodes.Call, typeof.GetMethod "op_Division") - else - match Type.GetTypeCode t1 with - | TypeCode.UInt32 - | TypeCode.UInt64 - | TypeCode.UInt16 - | TypeCode.Byte - | _ when t1 = typeof -> ilg.Emit (OpCodes.Div_Un) - | _ -> ilg.Emit(OpCodes.Div) - - emitConvIfNecessary t1 - - popIfEmptyExpected expectedState - - | Quotations.DerivedPatterns.SpecificCall <@ int @>(None, [sourceTy], [v]) -> - emit ExpectedStackState.Value v - match Type.GetTypeCode(sourceTy) with - | TypeCode.String -> - ilg.Emit(OpCodes.Call, Misc.ParseInt32Method) - | TypeCode.Single - | TypeCode.Double - | TypeCode.Int64 - | TypeCode.UInt64 - | TypeCode.UInt16 - | TypeCode.Char - | TypeCode.Byte - | _ when sourceTy = typeof || sourceTy = typeof -> - ilg.Emit(OpCodes.Conv_I4) - | TypeCode.Int32 - | TypeCode.UInt32 - | TypeCode.Int16 - | TypeCode.SByte -> () // no op - | _ -> failwith "TODO: search for op_Explicit on sourceTy" - - | Quotations.DerivedPatterns.SpecificCall <@ LanguagePrimitives.IntrinsicFunctions.GetArray @> (None, [ty], [arr; index]) -> - // observable side-effect - IndexOutOfRangeException - emit ExpectedStackState.Value arr - emit ExpectedStackState.Value index - if isAddress expectedState then - ilg.Emit(OpCodes.Readonly) - ilg.Emit(OpCodes.Ldelema, convType ty) - else - ilg.Emit(OpCodes.Ldelem, convType ty) - - popIfEmptyExpected expectedState - - | Quotations.DerivedPatterns.SpecificCall <@ LanguagePrimitives.IntrinsicFunctions.GetArray2D @> (None, _ty, arr::indices) - | Quotations.DerivedPatterns.SpecificCall <@ LanguagePrimitives.IntrinsicFunctions.GetArray3D @> (None, _ty, arr::indices) - | Quotations.DerivedPatterns.SpecificCall <@ LanguagePrimitives.IntrinsicFunctions.GetArray4D @> (None, _ty, arr::indices) -> - - let meth = - let name = if isAddress expectedState then "Address" else "Get" - arr.Type.GetMethod(name) - - // observable side-effect - IndexOutOfRangeException - emit ExpectedStackState.Value arr - for index in indices do - emit ExpectedStackState.Value index - - if isAddress expectedState then - ilg.Emit(OpCodes.Readonly) - - ilg.Emit(OpCodes.Call, meth) - - popIfEmptyExpected expectedState - - | Quotations.Patterns.FieldGet (objOpt,field) -> - match field with - | :? ProvidedLiteralField as plf when plf.DeclaringType.IsEnum -> - if expectedState <> ExpectedStackState.Empty then - emit expectedState (Quotations.Expr.Value(field.GetRawConstantValue(), field.FieldType.GetEnumUnderlyingType())) - | _ -> - match objOpt with - | None -> () - | Some e -> - let s = if e.Type.IsValueType then ExpectedStackState.Address else ExpectedStackState.Value - emit s e - let field = - match field with - | :? ProvidedField as pf when fieldMap.ContainsKey pf -> fieldMap.[pf] :> FieldInfo - | m -> m - if field.IsStatic then - ilg.Emit(OpCodes.Ldsfld, field) - else - ilg.Emit(OpCodes.Ldfld, field) - - | Quotations.Patterns.FieldSet (objOpt,field,v) -> - match objOpt with - | None -> () - | Some e -> - let s = if e.Type.IsValueType then ExpectedStackState.Address else ExpectedStackState.Value - emit s e - emit ExpectedStackState.Value v - let field = match field with :? ProvidedField as pf when fieldMap.ContainsKey pf -> fieldMap.[pf] :> FieldInfo | m -> m - if field.IsStatic then - ilg.Emit(OpCodes.Stsfld, field) - else - ilg.Emit(OpCodes.Stfld, field) - | Quotations.Patterns.Call (objOpt,meth,args) -> - match objOpt with - | None -> () - | Some e -> - let s = if e.Type.IsValueType then ExpectedStackState.Address else ExpectedStackState.Value - emit s e - for pe in args do - emit ExpectedStackState.Value pe - let getMeth (m:MethodInfo) = match m with :? ProvidedMethod as pm when methMap.ContainsKey pm -> methMap.[pm] :> MethodInfo | m -> m - // Handle the case where this is a generic method instantiated at a type being compiled - let mappedMeth = - if meth.IsGenericMethod then - let args = meth.GetGenericArguments() |> Array.map convType - let gmd = meth.GetGenericMethodDefinition() |> getMeth - gmd.GetGenericMethodDefinition().MakeGenericMethod args - elif meth.DeclaringType.IsGenericType then - let gdty = convType (meth.DeclaringType.GetGenericTypeDefinition()) - let gdtym = gdty.GetMethods() |> Seq.find (fun x -> x.Name = meth.Name) - assert (gdtym <> null) // ?? will never happen - if method is not found - KeyNotFoundException will be raised - let dtym = - match convType meth.DeclaringType with - | :? TypeBuilder as dty -> TypeBuilder.GetMethod(dty, gdtym) - | dty -> MethodBase.GetMethodFromHandle(meth.MethodHandle, dty.TypeHandle) :?> _ - - assert (dtym <> null) - dtym - else - getMeth meth - match objOpt with - | Some obj when mappedMeth.IsAbstract || mappedMeth.IsVirtual -> - if obj.Type.IsValueType then ilg.Emit(OpCodes.Constrained, convType obj.Type) - ilg.Emit(OpCodes.Callvirt, mappedMeth) - | _ -> - ilg.Emit(OpCodes.Call, mappedMeth) - - let returnTypeIsVoid = mappedMeth.ReturnType = typeof - match returnTypeIsVoid, (isEmpty expectedState) with - | false, true -> - // method produced something, but we don't need it - pop() - | true, false when expr.Type = typeof -> - // if we need result and method produce void and result should be unit - push null as unit value on stack - ilg.Emit(OpCodes.Ldnull) - | _ -> () - - | Quotations.Patterns.NewObject (ctor,args) -> - for pe in args do - emit ExpectedStackState.Value pe - let meth = match ctor with :? ProvidedConstructor as pc when ctorMap.ContainsKey pc -> ctorMap.[pc] :> ConstructorInfo | c -> c - ilg.Emit(OpCodes.Newobj, meth) - - popIfEmptyExpected expectedState - - | Quotations.Patterns.Value (obj, _ty) -> - let rec emitC (v:obj) = - match v with - | :? string as x -> ilg.Emit(OpCodes.Ldstr, x) - | :? int8 as x -> ilg.Emit(OpCodes.Ldc_I4, int32 x) - | :? uint8 as x -> ilg.Emit(OpCodes.Ldc_I4, int32 (int8 x)) - | :? int16 as x -> ilg.Emit(OpCodes.Ldc_I4, int32 x) - | :? uint16 as x -> ilg.Emit(OpCodes.Ldc_I4, int32 (int16 x)) - | :? int32 as x -> ilg.Emit(OpCodes.Ldc_I4, x) - | :? uint32 as x -> ilg.Emit(OpCodes.Ldc_I4, int32 x) - | :? int64 as x -> ilg.Emit(OpCodes.Ldc_I8, x) - | :? uint64 as x -> ilg.Emit(OpCodes.Ldc_I8, int64 x) - | :? char as x -> ilg.Emit(OpCodes.Ldc_I4, int32 x) - | :? bool as x -> ilg.Emit(OpCodes.Ldc_I4, if x then 1 else 0) - | :? float32 as x -> ilg.Emit(OpCodes.Ldc_R4, x) - | :? float as x -> ilg.Emit(OpCodes.Ldc_R8, x) -#if FX_NO_GET_ENUM_UNDERLYING_TYPE -#else - | :? System.Enum as x when x.GetType().GetEnumUnderlyingType() = typeof -> ilg.Emit(OpCodes.Ldc_I4, unbox v) -#endif - | :? Type as ty -> - ilg.Emit(OpCodes.Ldtoken, convType ty) - ilg.Emit(OpCodes.Call, Misc.GetTypeFromHandleMethod) - | :? decimal as x -> - let bits = System.Decimal.GetBits x - ilg.Emit(OpCodes.Ldc_I4, bits.[0]) - ilg.Emit(OpCodes.Ldc_I4, bits.[1]) - ilg.Emit(OpCodes.Ldc_I4, bits.[2]) - do - let sign = (bits.[3] &&& 0x80000000) <> 0 - ilg.Emit(if sign then OpCodes.Ldc_I4_1 else OpCodes.Ldc_I4_0) - do - let scale = byte ((bits.[3] >>> 16) &&& 0x7F) - ilg.Emit(OpCodes.Ldc_I4_S, scale) - ilg.Emit(OpCodes.Newobj, Misc.DecimalConstructor) - | :? DateTime as x -> - ilg.Emit(OpCodes.Ldc_I8, x.Ticks) - ilg.Emit(OpCodes.Ldc_I4, int x.Kind) - ilg.Emit(OpCodes.Newobj, Misc.DateTimeConstructor) - | :? DateTimeOffset as x -> - ilg.Emit(OpCodes.Ldc_I8, x.Ticks) - ilg.Emit(OpCodes.Ldc_I8, x.Offset.Ticks) - ilg.Emit(OpCodes.Newobj, Misc.TimeSpanConstructor) - ilg.Emit(OpCodes.Newobj, Misc.DateTimeOffsetConstructor) - | null -> ilg.Emit(OpCodes.Ldnull) - | _ -> failwithf "unknown constant '%A' in generated method" v - if isEmpty expectedState then () - else emitC obj - - | Quotations.Patterns.Let(v,e,b) -> - let lb = ilg.DeclareLocal (convType v.Type) - locals.Add (v, lb) - emit ExpectedStackState.Value e - ilg.Emit(OpCodes.Stloc, lb.LocalIndex) - emit expectedState b - - | Quotations.Patterns.Sequential(e1, e2) -> - emit ExpectedStackState.Empty e1 - emit expectedState e2 - - | Quotations.Patterns.IfThenElse(cond, ifTrue, ifFalse) -> - let ifFalseLabel = ilg.DefineLabel() - let endLabel = ilg.DefineLabel() - - emit ExpectedStackState.Value cond - - ilg.Emit(OpCodes.Brfalse, ifFalseLabel) - - emit expectedState ifTrue - ilg.Emit(OpCodes.Br, endLabel) - - ilg.MarkLabel(ifFalseLabel) - emit expectedState ifFalse - - ilg.Emit(OpCodes.Nop) - ilg.MarkLabel(endLabel) - - | Quotations.Patterns.TryWith(body, _filterVar, _filterBody, catchVar, catchBody) -> - - let stres, ldres = - if isEmpty expectedState then ignore, ignore - else - let local = ilg.DeclareLocal (convType body.Type) - let stres = fun () -> ilg.Emit(OpCodes.Stloc, local) - let ldres = fun () -> ilg.Emit(OpCodes.Ldloc, local) - stres, ldres - - let exceptionVar = ilg.DeclareLocal(convType catchVar.Type) - locals.Add(catchVar, exceptionVar) - - let _exnBlock = ilg.BeginExceptionBlock() - - emit expectedState body - stres() - - ilg.BeginCatchBlock(convType catchVar.Type) - ilg.Emit(OpCodes.Stloc, exceptionVar) - emit expectedState catchBody - stres() - ilg.EndExceptionBlock() - - ldres() - - | Quotations.Patterns.VarSet(v,e) -> - emit ExpectedStackState.Value e - match locals.TryGetValue v with - | true, localBuilder -> - ilg.Emit(OpCodes.Stloc, localBuilder.LocalIndex) - | false, _ -> - failwith "unknown parameter/field in assignment. Only assignments to locals are currently supported by TypeProviderEmit" - | Quotations.Patterns.Lambda(v, body) -> - emitLambda(ilg, v, body, expr.GetFreeVars(), locals, parameterVars) - popIfEmptyExpected expectedState - | n -> - failwith (sprintf "unknown expression '%A' in generated method" n) - emit expectedState expr - - - // Emit the constructor (if any) - for pcinfo in ctors do - assert ctorMap.ContainsKey pcinfo - let cb = ctorMap.[pcinfo] - let cattr = pcinfo.GetCustomAttributesDataImpl() - defineCustomAttrs cb.SetCustomAttribute cattr - let ilg = cb.GetILGenerator() - let locals = Dictionary() - let parameterVars = - [| yield Quotations.Var("this", pcinfo.DeclaringType) - for p in pcinfo.GetParameters() do - yield Quotations.Var(p.Name, p.ParameterType) |] - let parameters = - [| for v in parameterVars -> Quotations.Expr.Var v |] - match pcinfo.GetBaseConstructorCallInternal true with - | None -> - ilg.Emit(OpCodes.Ldarg_0) - let cinfo = ptd.BaseType.GetConstructor(BindingFlags.Public ||| BindingFlags.NonPublic ||| BindingFlags.Instance, null, [| |], null) - ilg.Emit(OpCodes.Call,cinfo) - | Some f -> - // argExprs should always include 'this' - let (cinfo,argExprs) = f (Array.toList parameters) - for argExpr in argExprs do - emitExpr (ilg, locals, parameterVars) ExpectedStackState.Value argExpr - ilg.Emit(OpCodes.Call,cinfo) - - if pcinfo.IsImplicitCtor then - for ctorArgsAsFieldIdx,ctorArgsAsField in List.mapi (fun i x -> (i,x)) implicitCtorArgsAsFields do - ilg.Emit(OpCodes.Ldarg_0) - ilg.Emit(OpCodes.Ldarg, ctorArgsAsFieldIdx+1) - ilg.Emit(OpCodes.Stfld, ctorArgsAsField) - else - let code = pcinfo.GetInvokeCodeInternal true - let code = code parameters - emitExpr (ilg, locals, parameterVars) ExpectedStackState.Empty code - ilg.Emit(OpCodes.Ret) - - match ptd.GetConstructors(ALL) |> Seq.tryPick (function :? ProvidedConstructor as pc when pc.IsTypeInitializer -> Some pc | _ -> None) with - | None -> () - | Some pc -> - let cb = ctorMap.[pc] - let ilg = cb.GetILGenerator() - let cattr = pc.GetCustomAttributesDataImpl() - defineCustomAttrs cb.SetCustomAttribute cattr - let expr = pc.GetInvokeCodeInternal true [||] - emitExpr(ilg, new Dictionary<_, _>(), [||]) ExpectedStackState.Empty expr - ilg.Emit OpCodes.Ret - - // Emit the methods - for minfo in ptd.GetMethods(ALL) do - match minfo with - | :? ProvidedMethod as pminfo -> - let mb = methMap.[pminfo] - let ilg = mb.GetILGenerator() - let cattr = pminfo.GetCustomAttributesDataImpl() - defineCustomAttrs mb.SetCustomAttribute cattr - - let parameterVars = - [| if not pminfo.IsStatic then - yield Quotations.Var("this", pminfo.DeclaringType) - for p in pminfo.GetParameters() do - yield Quotations.Var(p.Name, p.ParameterType) |] - let parameters = - [| for v in parameterVars -> Quotations.Expr.Var v |] - - let expr = pminfo.GetInvokeCodeInternal true parameters - - let locals = Dictionary() - //printfn "Emitting linqCode for %s::%s, code = %s" pminfo.DeclaringType.FullName pminfo.Name (try linqCode.ToString() with _ -> "") - - - let expectedState = if (minfo.ReturnType = typeof) then ExpectedStackState.Empty else ExpectedStackState.Value - emitExpr (ilg, locals, parameterVars) expectedState expr - ilg.Emit OpCodes.Ret - | _ -> () - - for (bodyMethInfo,declMethInfo) in ptd.GetMethodOverrides() do - let bodyMethBuilder = methMap.[bodyMethInfo] - tb.DefineMethodOverride(bodyMethBuilder,declMethInfo) - - for evt in ptd.GetEvents(ALL) |> Seq.choose (function :? ProvidedEvent as pe -> Some pe | _ -> None) do - let eb = tb.DefineEvent(evt.Name, evt.Attributes, evt.EventHandlerType) - defineCustomAttrs eb.SetCustomAttribute (evt.GetCustomAttributesDataImpl()) - eb.SetAddOnMethod(methMap.[evt.GetAddMethod(true) :?> _]) - eb.SetRemoveOnMethod(methMap.[evt.GetRemoveMethod(true) :?> _]) - // TODO: add raiser - - for pinfo in ptd.GetProperties(ALL) |> Seq.choose (function :? ProvidedProperty as pe -> Some pe | _ -> None) do - let pb = tb.DefineProperty(pinfo.Name, pinfo.Attributes, convType pinfo.PropertyType, [| for p in pinfo.GetIndexParameters() -> convType p.ParameterType |]) - let cattr = pinfo.GetCustomAttributesDataImpl() - defineCustomAttrs pb.SetCustomAttribute cattr - if pinfo.CanRead then - let minfo = pinfo.GetGetMethod(true) - pb.SetGetMethod (methMap.[minfo :?> ProvidedMethod ]) - if pinfo.CanWrite then - let minfo = pinfo.GetSetMethod(true) - pb.SetSetMethod (methMap.[minfo :?> ProvidedMethod ])) - - - // phase 4 - complete types - iterateTypes (fun tb _ptd -> tb.CreateType() |> ignore) - -#if FX_NO_LOCAL_FILESYSTEM -#else - assembly.Save (Path.GetFileName assemblyFileName) -#endif - - let assemblyLoadedInMemory = assemblyMainModule.Assembly - - iterateTypes (fun _tb ptd -> - match ptd with - | None -> () - | Some ptd -> ptd.SetAssembly assemblyLoadedInMemory) - -#if FX_NO_LOCAL_FILESYSTEM -#else - member __.GetFinalBytes() = - let assemblyBytes = File.ReadAllBytes assemblyFileName - let _assemblyLoadedInMemory = System.Reflection.Assembly.Load(assemblyBytes,null,System.Security.SecurityContextSource.CurrentAppDomain) - //printfn "final bytes in '%s'" assemblyFileName - //File.Delete assemblyFileName - assemblyBytes -#endif - -type ProvidedAssembly(assemblyFileName: string) = - let theTypes = ResizeArray<_>() - let assemblyGenerator = AssemblyGenerator(assemblyFileName) - let assemblyLazy = - lazy - assemblyGenerator.Generate(theTypes |> Seq.toList) - assemblyGenerator.Assembly -#if FX_NO_LOCAL_FILESYSTEM -#else - let theAssemblyBytesLazy = - lazy - assemblyGenerator.GetFinalBytes() - - do - GlobalProvidedAssemblyElementsTable.theTable.Add(assemblyGenerator.Assembly, theAssemblyBytesLazy) - -#endif - - let add (providedTypeDefinitions:ProvidedTypeDefinition list, enclosingTypeNames: string list option) = - for pt in providedTypeDefinitions do - if pt.IsErased then invalidOp ("The provided type "+pt.Name+"is marked as erased and cannot be converted to a generated type. Set 'IsErased' to false on the ProvidedTypeDefinition") - theTypes.Add(pt,enclosingTypeNames) - pt.SetAssemblyLazy assemblyLazy - - member x.AddNestedTypes (providedTypeDefinitions, enclosingTypeNames) = add (providedTypeDefinitions, Some enclosingTypeNames) - member x.AddTypes (providedTypeDefinitions) = add (providedTypeDefinitions, None) -#if FX_NO_LOCAL_FILESYSTEM -#else - static member RegisterGenerated (fileName:string) = - //printfn "registered assembly in '%s'" fileName - let assemblyBytes = System.IO.File.ReadAllBytes fileName - let assembly = Assembly.Load(assemblyBytes,null,System.Security.SecurityContextSource.CurrentAppDomain) - GlobalProvidedAssemblyElementsTable.theTable.Add(assembly, Lazy<_>.CreateFromValue assemblyBytes) - assembly -#endif - - -module Local = - - let makeProvidedNamespace (namespaceName:string) (types:ProvidedTypeDefinition list) = - let types = [| for ty in types -> ty :> Type |] - {new IProvidedNamespace with - member __.GetNestedNamespaces() = [| |] - member __.NamespaceName = namespaceName - member __.GetTypes() = types |> Array.copy - member __.ResolveTypeName typeName : System.Type = - match types |> Array.tryFind (fun ty -> ty.Name = typeName) with - | Some ty -> ty - | None -> null - // let typenames = String.concat "," (types |> Array.map (fun t -> t.Name)) - // failwith (sprintf "Unknown type '%s' in namespace '%s' (contains %s)" typeName namespaceName typenames) - } - - -#if FX_NO_LOCAL_FILESYSTEM -type TypeProviderForNamespaces(namespacesAndTypes : list<(string * list)>) = -#else -type TypeProviderForNamespaces(namespacesAndTypes : list<(string * list)>) as this = -#endif - let otherNamespaces = ResizeArray>() - - let providedNamespaces = - lazy [| for (namespaceName,types) in namespacesAndTypes do - yield Local.makeProvidedNamespace namespaceName types - for (namespaceName,types) in otherNamespaces do - yield Local.makeProvidedNamespace namespaceName types |] - - let invalidateE = new Event() - - let disposing = Event() - -#if FX_NO_LOCAL_FILESYSTEM -#else - let probingFolders = ResizeArray() - let handler = ResolveEventHandler(fun _ args -> this.ResolveAssembly(args)) - do AppDomain.CurrentDomain.add_AssemblyResolve handler -#endif - - new (namespaceName:string,types:list) = new TypeProviderForNamespaces([(namespaceName,types)]) - new () = new TypeProviderForNamespaces([]) - - [] - member this.Disposing = disposing.Publish - -#if FX_NO_LOCAL_FILESYSTEM - interface System.IDisposable with - member x.Dispose() = - disposing.Trigger(x, EventArgs.Empty) -#else - abstract member ResolveAssembly : args : System.ResolveEventArgs -> Assembly - default this.ResolveAssembly(args) = - let expectedName = (AssemblyName(args.Name)).Name + ".dll" - let expectedLocationOpt = - probingFolders - |> Seq.map (fun f -> IO.Path.Combine(f, expectedName)) - |> Seq.tryFind IO.File.Exists - match expectedLocationOpt with - | Some f -> Assembly.LoadFrom f - | None -> null - - member this.RegisterProbingFolder (folder) = - // use GetFullPath to ensure that folder is valid - ignore(IO.Path.GetFullPath folder) - probingFolders.Add folder - member this.RegisterRuntimeAssemblyLocationAsProbingFolder (cfg : Core.CompilerServices.TypeProviderConfig) = - cfg.RuntimeAssembly - |> IO.Path.GetDirectoryName - |> this.RegisterProbingFolder - - interface System.IDisposable with - member x.Dispose() = - disposing.Trigger(x, EventArgs.Empty) - AppDomain.CurrentDomain.remove_AssemblyResolve handler -#endif - - member __.AddNamespace (namespaceName,types:list<_>) = otherNamespaces.Add (namespaceName,types) - // FSharp.Data addition: this method is used by Debug.fs - member __.Namespaces = Seq.readonly otherNamespaces - member self.Invalidate() = invalidateE.Trigger(self,EventArgs()) - interface ITypeProvider with - [] - override this.Invalidate = invalidateE.Publish - override this.GetNamespaces() = Array.copy providedNamespaces.Value - member __.GetInvokerExpression(methodBase, parameters) = - let rec getInvokerExpression (methodBase : MethodBase) parameters = - match methodBase with - | :? ProvidedMethod as m when (match methodBase.DeclaringType with :? ProvidedTypeDefinition as pt -> pt.IsErased | _ -> true) -> - m.GetInvokeCodeInternal false parameters - |> expand - | :? ProvidedConstructor as m when (match methodBase.DeclaringType with :? ProvidedTypeDefinition as pt -> pt.IsErased | _ -> true) -> - m.GetInvokeCodeInternal false parameters - |> expand - // Otherwise, assume this is a generative assembly and just emit a call to the constructor or method - | :? ConstructorInfo as cinfo -> - Quotations.Expr.NewObject(cinfo, Array.toList parameters) - | :? System.Reflection.MethodInfo as minfo -> - if minfo.IsStatic then - Quotations.Expr.Call(minfo, Array.toList parameters) - else - Quotations.Expr.Call(parameters.[0], minfo, Array.toList parameters.[1..]) - | _ -> failwith ("TypeProviderForNamespaces.GetInvokerExpression: not a ProvidedMethod/ProvidedConstructor/ConstructorInfo/MethodInfo, name=" + methodBase.Name + " class=" + methodBase.GetType().FullName) - and expand expr = - match expr with - | Quotations.Patterns.NewObject(ctor, args) -> getInvokerExpression ctor [| for arg in args -> expand arg|] - | Quotations.Patterns.Call(inst, mi, args) -> - let args = - [| - match inst with - | Some inst -> yield expand inst - | _ -> () - yield! List.map expand args - |] - getInvokerExpression mi args - | Quotations.ExprShape.ShapeVar v -> Quotations.Expr.Var v - | Quotations.ExprShape.ShapeLambda(v, body) -> Quotations.Expr.Lambda(v, expand body) - | Quotations.ExprShape.ShapeCombination(shape, args) -> Quotations.ExprShape.RebuildShapeCombination(shape, List.map expand args) - getInvokerExpression methodBase parameters -#if FX_NO_CUSTOMATTRIBUTEDATA - - member __.GetMemberCustomAttributesData(methodBase) = - match methodBase with - | :? ProvidedTypeDefinition as m -> m.GetCustomAttributesDataImpl() - | :? ProvidedMethod as m -> m.GetCustomAttributesDataImpl() - | :? ProvidedProperty as m -> m.GetCustomAttributesDataImpl() - | :? ProvidedConstructor as m -> m.GetCustomAttributesDataImpl() - | :? ProvidedEvent as m -> m.GetCustomAttributesDataImpl() - | :? ProvidedLiteralField as m -> m.GetCustomAttributesDataImpl() - | :? ProvidedField as m -> m.GetCustomAttributesDataImpl() - | _ -> [| |] :> IList<_> - - member __.GetParameterCustomAttributesData(methodBase) = - match methodBase with - | :? ProvidedParameter as m -> m.GetCustomAttributesDataImpl() - | _ -> [| |] :> IList<_> - - -#endif - override this.GetStaticParameters(ty) = - match ty with - | :? ProvidedTypeDefinition as t -> - if ty.Name = t.Name (* REVIEW: use equality? *) then - t.GetStaticParameters() - else - [| |] - | _ -> [| |] - - override this.ApplyStaticArguments(ty,typePathAfterArguments:string[],objs) = - let typePathAfterArguments = typePathAfterArguments.[typePathAfterArguments.Length-1] - match ty with - | :? ProvidedTypeDefinition as t -> (t.MakeParametricType(typePathAfterArguments,objs) :> Type) - | _ -> failwith (sprintf "ApplyStaticArguments: static params for type %s are unexpected" ty.FullName) - -#if FX_NO_LOCAL_FILESYSTEM - override x.GetGeneratedAssemblyContents(_assembly) = - // TODO: this is very fake, we rely on the fact it is never needed - match System.Windows.Application.GetResourceStream(System.Uri("FSharp.Core.dll",System.UriKind.Relative)) with - | null -> failwith "FSharp.Core.dll not found as Manifest Resource, we're just trying to read some random .NET assembly, ok?" - | resStream -> - use stream = resStream.Stream - let len = stream.Length - let buf = Array.zeroCreate (int len) - let rec loop where rem = - let n = stream.Read(buf, 0, int rem) - if n < rem then loop (where + n) (rem - n) - loop 0 (int len) - buf - - //failwith "no file system" -#else - override x.GetGeneratedAssemblyContents(assembly:Assembly) = - //printfn "looking up assembly '%s'" assembly.FullName - match GlobalProvidedAssemblyElementsTable.theTable.TryGetValue assembly with - | true,bytes -> bytes.Force() - | _ -> - let bytes = System.IO.File.ReadAllBytes assembly.ManifestModule.FullyQualifiedName - GlobalProvidedAssemblyElementsTable.theTable.[assembly] <- Lazy<_>.CreateFromValue bytes - bytes -#endif diff --git a/MyFirstTypeProvider/MyFirstTypeProvider/ProvidedTypes.fsi b/MyFirstTypeProvider/MyFirstTypeProvider/ProvidedTypes.fsi deleted file mode 100644 index 5e8511b..0000000 --- a/MyFirstTypeProvider/MyFirstTypeProvider/ProvidedTypes.fsi +++ /dev/null @@ -1,445 +0,0 @@ -// Based on code developed for the F# 3.0 Beta release of March 2012, -// Copyright (c) Microsoft Corporation 2005-2012. -// This sample code is provided "as is" without warranty of any kind. -// We disclaim all warranties, either express or implied, including the -// warranties of merchantability and fitness for a particular purpose. - -// This file contains a set of helper types and methods for providing types in an implementation -// of ITypeProvider. - -// This code has been modified and is appropriate for use in conjunction with the F# 3.0, F# 3.1, and F# 3.1.1 releases - - -namespace ProviderImplementation.ProvidedTypes - -open System -open System.Reflection -open System.Linq.Expressions -open Microsoft.FSharp.Core.CompilerServices - -/// Represents an erased provided parameter -type ProvidedParameter = - inherit System.Reflection.ParameterInfo - new : parameterName: string * parameterType: Type * ?isOut:bool * ?optionalValue:obj -> ProvidedParameter - member IsParamArray : bool with get,set - -/// Represents an erased provided constructor. -type ProvidedConstructor = - inherit System.Reflection.ConstructorInfo - - /// Create a new provided constructor. It is not initially associated with any specific provided type definition. - new : parameters: ProvidedParameter list -> ProvidedConstructor - - /// Add a 'System.Obsolete' attribute to this provided constructor - member AddObsoleteAttribute : message: string * ?isError: bool -> unit - - /// Add XML documentation information to this provided constructor - member AddXmlDoc : xmlDoc: string -> unit - - /// Add XML documentation information to this provided constructor, where the computation of the documentation is delayed until necessary - member AddXmlDocDelayed : xmlDocFunction: (unit -> string) -> unit - - /// Add XML documentation information to this provided constructor, where the documentation is re-computed every time it is required. - member AddXmlDocComputed : xmlDocFunction: (unit -> string) -> unit - - /// Set the quotation used to compute the implementation of invocations of this constructor. - member InvokeCode : (Quotations.Expr list -> Quotations.Expr) with set - - /// FSharp.Data addition: this method is used by Debug.fs - member internal GetInvokeCodeInternal : bool -> (Quotations.Expr [] -> Quotations.Expr) - - /// Set the target and arguments of the base constructor call. Only used for generated types. - member BaseConstructorCall : (Quotations.Expr list -> ConstructorInfo * Quotations.Expr list) with set - - /// Set a flag indicating that the constructor acts like an F# implicit constructor, so the - /// parameters of the constructor become fields and can be accessed using Expr.GlobalVar with the - /// same name. - member IsImplicitCtor : bool with get,set - - /// Add definition location information to the provided constructor. - member AddDefinitionLocation : line:int * column:int * filePath:string -> unit - - member IsTypeInitializer : bool with get,set - -type ProvidedMethod = - inherit System.Reflection.MethodInfo - - /// Create a new provided method. It is not initially associated with any specific provided type definition. - new : methodName:string * parameters: ProvidedParameter list * returnType: Type -> ProvidedMethod - - /// Add XML documentation information to this provided method - member AddObsoleteAttribute : message: string * ?isError: bool -> unit - - /// Add XML documentation information to this provided constructor - member AddXmlDoc : xmlDoc: string -> unit - - /// Add XML documentation information to this provided constructor, where the computation of the documentation is delayed until necessary - member AddXmlDocDelayed : xmlDocFunction: (unit -> string) -> unit - - /// Add XML documentation information to this provided constructor, where the computation of the documentation is delayed until necessary - /// The documentation is re-computed every time it is required. - member AddXmlDocComputed : xmlDocFunction: (unit -> string) -> unit - - member AddMethodAttrs : attributes:MethodAttributes -> unit - - /// Set the method attributes of the method. By default these are simple 'MethodAttributes.Public' - member SetMethodAttrs : attributes:MethodAttributes -> unit - - /// Get or set a flag indicating if the property is static. - member IsStaticMethod : bool with get, set - - /// Set the quotation used to compute the implementation of invocations of this method. - member InvokeCode : (Quotations.Expr list -> Quotations.Expr) with set - - /// FSharp.Data addition: this method is used by Debug.fs - member internal GetInvokeCodeInternal : bool -> (Quotations.Expr [] -> Quotations.Expr) - - /// Add definition location information to the provided type definition. - member AddDefinitionLocation : line:int * column:int * filePath:string -> unit - - /// Add a custom attribute to the provided method definition. - member AddCustomAttribute : CustomAttributeData -> unit - - - -/// Represents an erased provided property. -type ProvidedProperty = - inherit System.Reflection.PropertyInfo - - /// Create a new provided type. It is not initially associated with any specific provided type definition. - new : propertyName: string * propertyType: Type * ?parameters:ProvidedParameter list -> ProvidedProperty - - /// Add a 'System.Obsolete' attribute to this provided property - member AddObsoleteAttribute : message: string * ?isError: bool -> unit - - /// Add XML documentation information to this provided constructor - member AddXmlDoc : xmlDoc: string -> unit - - /// Add XML documentation information to this provided constructor, where the computation of the documentation is delayed until necessary - member AddXmlDocDelayed : xmlDocFunction: (unit -> string) -> unit - - /// Add XML documentation information to this provided constructor, where the computation of the documentation is delayed until necessary - /// The documentation is re-computed every time it is required. - member AddXmlDocComputed : xmlDocFunction: (unit -> string) -> unit - - /// Get or set a flag indicating if the property is static. - /// FSharp.Data addition: the getter is used by Debug.fs - member IsStatic : bool with get,set - - /// Set the quotation used to compute the implementation of gets of this property. - member GetterCode : (Quotations.Expr list -> Quotations.Expr) with set - - /// Set the function used to compute the implementation of sets of this property. - member SetterCode : (Quotations.Expr list -> Quotations.Expr) with set - - /// Add definition location information to the provided type definition. - member AddDefinitionLocation : line:int * column:int * filePath:string -> unit - - /// Add a custom attribute to the provided property definition. - member AddCustomAttribute : CustomAttributeData -> unit - -/// Represents an erased provided property. -type ProvidedEvent = - inherit System.Reflection.EventInfo - - /// Create a new provided type. It is not initially associated with any specific provided type definition. - new : propertyName: string * eventHandlerType: Type -> ProvidedEvent - - /// Add XML documentation information to this provided constructor - member AddXmlDoc : xmlDoc: string -> unit - - /// Add XML documentation information to this provided constructor, where the computation of the documentation is delayed until necessary - member AddXmlDocDelayed : xmlDocFunction: (unit -> string) -> unit - - /// Add XML documentation information to this provided constructor, where the computation of the documentation is delayed until necessary - /// The documentation is re-computed every time it is required. - member AddXmlDocComputed : xmlDocFunction: (unit -> string) -> unit - - /// Get or set a flag indicating if the property is static. - member IsStatic : bool with set - - /// Set the quotation used to compute the implementation of gets of this property. - member AdderCode : (Quotations.Expr list -> Quotations.Expr) with set - - /// Set the function used to compute the implementation of sets of this property. - member RemoverCode : (Quotations.Expr list -> Quotations.Expr) with set - - /// Add definition location information to the provided type definition. - member AddDefinitionLocation : line:int * column:int * filePath:string -> unit - -/// Represents an erased provided field. -type ProvidedLiteralField = - inherit System.Reflection.FieldInfo - - /// Create a new provided field. It is not initially associated with any specific provided type definition. - new : fieldName: string * fieldType: Type * literalValue: obj -> ProvidedLiteralField - - /// Add a 'System.Obsolete' attribute to this provided field - member AddObsoleteAttribute : message: string * ?isError: bool -> unit - - /// Add XML documentation information to this provided field - member AddXmlDoc : xmlDoc: string -> unit - - /// Add XML documentation information to this provided field, where the computation of the documentation is delayed until necessary - member AddXmlDocDelayed : xmlDocFunction: (unit -> string) -> unit - - /// Add XML documentation information to this provided field, where the computation of the documentation is delayed until necessary - /// The documentation is re-computed every time it is required. - member AddXmlDocComputed : xmlDocFunction: (unit -> string) -> unit - - /// Add definition location information to the provided field. - member AddDefinitionLocation : line:int * column:int * filePath:string -> unit - -/// Represents an erased provided field. -type ProvidedField = - inherit System.Reflection.FieldInfo - - /// Create a new provided field. It is not initially associated with any specific provided type definition. - new : fieldName: string * fieldType: Type -> ProvidedField - - /// Add a 'System.Obsolete' attribute to this provided field - member AddObsoleteAttribute : message: string * ?isError: bool -> unit - - /// Add XML documentation information to this provided field - member AddXmlDoc : xmlDoc: string -> unit - - /// Add XML documentation information to this provided field, where the computation of the documentation is delayed until necessary - member AddXmlDocDelayed : xmlDocFunction: (unit -> string) -> unit - - /// Add XML documentation information to this provided field, where the computation of the documentation is delayed until necessary - /// The documentation is re-computed every time it is required. - member AddXmlDocComputed : xmlDocFunction: (unit -> string) -> unit - - /// Add definition location information to the provided field definition. - member AddDefinitionLocation : line:int * column:int * filePath:string -> unit - - member SetFieldAttributes : attributes : FieldAttributes -> unit - -/// FSharp.Data addition: SymbolKind is used by AssemblyReplacer.fs -/// Represents the type constructor in a provided symbol type. -[] -type SymbolKind = - | SDArray - | Array of int - | Pointer - | ByRef - | Generic of System.Type - | FSharpTypeAbbreviation of (System.Reflection.Assembly * string * string[]) - -/// FSharp.Data addition: ProvidedSymbolType is used by AssemblyReplacer.fs -/// Represents an array or other symbolic type involving a provided type as the argument. -/// See the type provider spec for the methods that must be implemented. -/// Note that the type provider specification does not require us to implement pointer-equality for provided types. -[] -type ProvidedSymbolType = - inherit System.Type - - /// Returns the kind of this symbolic type - member Kind : SymbolKind - /// Return the provided types used as arguments of this symbolic type - member Args : list - - -/// Provides symbolic provided types -[] -type ProvidedTypeBuilder = - /// Like typ.MakeGenericType, but will also work with unit-annotated types - static member MakeGenericType: genericTypeDefinition: System.Type * genericArguments: System.Type list -> System.Type - /// Like methodInfo.MakeGenericMethod, but will also work with unit-annotated types and provided types - static member MakeGenericMethod: genericMethodDefinition: System.Reflection.MethodInfo * genericArguments: System.Type list -> MethodInfo - -/// Helps create erased provided unit-of-measure annotations. -[] -type ProvidedMeasureBuilder = - - /// The ProvidedMeasureBuilder for building measures. - static member Default : ProvidedMeasureBuilder - - /// e.g. 1 - member One : System.Type - /// e.g. m * kg - member Product : measure1: System.Type * measure1: System.Type -> System.Type - /// e.g. 1 / kg - member Inverse : denominator: System.Type -> System.Type - - /// e.g. kg / m - member Ratio : numerator: System.Type * denominator: System.Type -> System.Type - - /// e.g. m * m - member Square : ``measure``: System.Type -> System.Type - - /// the SI unit from the F# core library, where the string is in capitals and US spelling, e.g. Meter - member SI : string -> System.Type - - /// e.g. float, Vector - member AnnotateType : basic: System.Type * argument: System.Type list -> System.Type - - -/// Represents a provided static parameter. -type ProvidedStaticParameter = - inherit System.Reflection.ParameterInfo - new : parameterName: string * parameterType:Type * ?parameterDefaultValue:obj -> ProvidedStaticParameter - - /// Add XML documentation information to this provided constructor - member AddXmlDoc : xmlDoc: string -> unit - - /// Add XML documentation information to this provided constructor, where the computation of the documentation is delayed until necessary - member AddXmlDocDelayed : xmlDocFunction: (unit -> string) -> unit - -/// Represents a provided type definition. -type ProvidedTypeDefinition = - inherit System.Type - - /// Create a new provided type definition in a namespace. - new : assembly: Assembly * namespaceName: string * className: string * baseType: Type option -> ProvidedTypeDefinition - - /// Create a new provided type definition, to be located as a nested type in some type definition. - new : className : string * baseType: Type option -> ProvidedTypeDefinition - - /// Add the given type as an implemented interface. - member AddInterfaceImplementation : interfaceType: Type -> unit - - /// Add the given function as a set of on-demand computed interfaces. - member AddInterfaceImplementationsDelayed : interfacesFunction:(unit -> Type list)-> unit - - /// Specifies that the given method body implements the given method declaration. - member DefineMethodOverride : methodInfoBody: ProvidedMethod * methodInfoDeclaration: MethodInfo -> unit - - /// Add a 'System.Obsolete' attribute to this provided type definition - member AddObsoleteAttribute : message: string * ?isError: bool -> unit - - /// Add XML documentation information to this provided constructor - member AddXmlDoc : xmlDoc: string -> unit - - /// Set the base type - member SetBaseType : Type -> unit - - /// Set the base type to a lazily evaluated value - member SetBaseTypeDelayed : Lazy -> unit - - /// Set underlying type for generated enums - member SetEnumUnderlyingType : Type -> unit - - /// Add XML documentation information to this provided constructor, where the computation of the documentation is delayed until necessary. - /// The documentation is only computed once. - member AddXmlDocDelayed : xmlDocFunction: (unit -> string) -> unit - - /// Add XML documentation information to this provided constructor, where the computation of the documentation is delayed until necessary - /// The documentation is re-computed every time it is required. - member AddXmlDocComputed : xmlDocFunction: (unit -> string) -> unit - - /// Set the attributes on the provided type. This fully replaces the default TypeAttributes. - member SetAttributes : System.Reflection.TypeAttributes -> unit - - /// Reset the enclosing type (for generated nested types) - member ResetEnclosingType: enclosingType:System.Type -> unit - - /// Add a method, property, nested type or other member to a ProvidedTypeDefinition - member AddMember : memberInfo:MemberInfo -> unit - /// Add a set of members to a ProvidedTypeDefinition - member AddMembers : memberInfos:list<#MemberInfo> -> unit - - /// Add a member to a ProvidedTypeDefinition, delaying computation of the members until required by the compilation context. - member AddMemberDelayed : memberFunction:(unit -> #MemberInfo) -> unit - - /// Add a set of members to a ProvidedTypeDefinition, delaying computation of the members until required by the compilation context. - member AddMembersDelayed : (unit -> list<#MemberInfo>) -> unit - - /// Add the types of the generated assembly as generative types, where types in namespaces get hierarchically positioned as nested types. - member AddAssemblyTypesAsNestedTypesDelayed : assemblyFunction:(unit -> System.Reflection.Assembly) -> unit - - // Parametric types - member DefineStaticParameters : parameters: ProvidedStaticParameter list * instantiationFunction: (string -> obj[] -> ProvidedTypeDefinition) -> unit - - /// Add definition location information to the provided type definition. - member AddDefinitionLocation : line:int * column:int * filePath:string -> unit - - /// Suppress System.Object entries in intellisense menus in instances of this provided type - member HideObjectMethods : bool with set - - /// Disallows the use of the null literal. - member NonNullable : bool with set - - /// Get or set a flag indicating if the ProvidedTypeDefinition is erased - member IsErased : bool with get,set - - /// Get or set a flag indicating if the ProvidedTypeDefinition has type-relocation suppressed - [] - member SuppressRelocation : bool with get,set - - /// FSharp.Data addition: this method is used by Debug.fs - member MakeParametricType : name:string * args:obj[] -> ProvidedTypeDefinition - - /// Add a custom attribute to the provided type definition. - member AddCustomAttribute : CustomAttributeData -> unit - - /// FSharp.Data addition: this method is used by Debug.fs and QuotationBuilder.fs - /// Emulate the F# type provider type erasure mechanism to get the - /// actual (erased) type. We erase ProvidedTypes to their base type - /// and we erase array of provided type to array of base type. In the - /// case of generics all the generic type arguments are also recursively - /// replaced with the erased-to types - static member EraseType : t:Type -> Type - - /// FSharp.Data addition: this is used to log the creation of root Provided Types to be able to debug caching/invalidation - static member Logger : (string -> unit) option ref - -/// A provided generated assembly -type ProvidedAssembly = - new : assemblyFileName:string -> ProvidedAssembly - /// - /// Emit the given provided type definitions as part of the assembly - /// and adjust the 'Assembly' property of all provided type definitions to return that - /// assembly. - /// - /// The assembly is only emitted when the Assembly property on the root type is accessed for the first time. - /// The host F# compiler does this when processing a generative type declaration for the type. - /// - /// An optional path of type names to wrap the generated types. The generated types are then generated as nested types. - member AddTypes : types : ProvidedTypeDefinition list -> unit - member AddNestedTypes : types : ProvidedTypeDefinition list * enclosingGeneratedTypeNames: string list -> unit - -#if FX_NO_LOCAL_FILESYSTEM -#else - /// Register that a given file is a provided generated assembly - static member RegisterGenerated : fileName:string -> Assembly -#endif - - -/// A base type providing default implementations of type provider functionality when all provided -/// types are of type ProvidedTypeDefinition. -type TypeProviderForNamespaces = - - /// Initializes a type provider to provide the types in the given namespace. - new : namespaceName:string * types: ProvidedTypeDefinition list -> TypeProviderForNamespaces - - /// Initializes a type provider - new : unit -> TypeProviderForNamespaces - - /// Add a namespace of provided types. - member AddNamespace : namespaceName:string * types: ProvidedTypeDefinition list -> unit - - /// FSharp.Data addition: this method is used by Debug.fs - /// Get all namespace with their provided types. - member Namespaces : (string * ProvidedTypeDefinition list) seq with get - - /// Invalidate the information provided by the provider - member Invalidate : unit -> unit - -#if FX_NO_LOCAL_FILESYSTEM -#else - /// AssemblyResolve handler. Default implementation searches .dll file in registered folders - abstract ResolveAssembly : System.ResolveEventArgs -> Assembly - default ResolveAssembly : System.ResolveEventArgs -> Assembly - - /// Registers custom probing path that can be used for probing assemblies - member RegisterProbingFolder : folder : string -> unit - /// Registers location of RuntimeAssembly (from TypeProviderConfig) as probing folder - member RegisterRuntimeAssemblyLocationAsProbingFolder : cfg : Core.CompilerServices.TypeProviderConfig -> unit - -#endif - - [] - member Disposing : IEvent - - interface ITypeProvider diff --git a/MyFirstTypeProvider/MyFirstTypeProvider/packages.config b/MyFirstTypeProvider/MyFirstTypeProvider/packages.config deleted file mode 100644 index 97faf56..0000000 --- a/MyFirstTypeProvider/MyFirstTypeProvider/packages.config +++ /dev/null @@ -1,4 +0,0 @@ - - - - \ No newline at end of file diff --git a/MyFirstTypeProvider/test.fsx b/MyFirstTypeProvider/test.fsx deleted file mode 100644 index 4e0227c..0000000 --- a/MyFirstTypeProvider/test.fsx +++ /dev/null @@ -1,11 +0,0 @@ -#r @"MyFirstTypeProvider\bin\Debug\MyFirstTypeProvider.dll" - - - -type BioData = FSharp.Data.FtpProvider< "ftp://ftp.ncbi.nlm.nih.gov/", User="anonymous", Pwd="mypwd" > - - -let MyFunction() = BioData.genomes.Drosophila_melanogaster.``RELEASE_4.1``.CHR_2 .``NT_033778.faa``.Contents - - -