From 67c7ab08224f10d07b5502575db097fb16d582d9 Mon Sep 17 00:00:00 2001 From: Dave Thomas Date: Mon, 26 Jun 2017 11:16:52 +0100 Subject: [PATCH 01/10] Partial work on providing support for View / Cells --- .../unified/SingleViewUniversal/Info.plist | 2 +- .../MainStoryboard_iPad.storyboard | 29 +++++---- .../MainStoryboard_iPhone.storyboard | 33 ++++++---- .../SingleViewUniversalViewController.fs | 2 +- src/Xamarin.iOSProviders/Designtime.fs | 3 - src/Xamarin.iOSProviders/IOSParsing.fs | 65 ++++++++++--------- src/Xamarin.iOSProviders/MacParsing.fs | 2 +- src/Xamarin.iOSProviders/Model.fs | 8 ++- src/Xamarin.iOSProviders/TypeMapper.fs | 3 - .../Xamarin.UIProviders.DesignTime.fsproj | 25 +++---- .../iOSDesignerProvider.fs | 9 +-- 11 files changed, 99 insertions(+), 82 deletions(-) diff --git a/samples/unified/SingleViewUniversal/Info.plist b/samples/unified/SingleViewUniversal/Info.plist index fa5418f..69dfec9 100644 --- a/samples/unified/SingleViewUniversal/Info.plist +++ b/samples/unified/SingleViewUniversal/Info.plist @@ -25,6 +25,6 @@ UIMainStoryboardFile~ipad MainStoryboard_iPad MinimumOSVersion - 8.0 + 9.3 diff --git a/samples/unified/SingleViewUniversal/MainStoryboard_iPad.storyboard b/samples/unified/SingleViewUniversal/MainStoryboard_iPad.storyboard index 9ac10ec..3c09577 100644 --- a/samples/unified/SingleViewUniversal/MainStoryboard_iPad.storyboard +++ b/samples/unified/SingleViewUniversal/MainStoryboard_iPad.storyboard @@ -1,10 +1,11 @@ - + - + + - + @@ -15,36 +16,40 @@ - - - + + - + @@ -53,6 +58,6 @@ - + \ No newline at end of file diff --git a/samples/unified/SingleViewUniversal/MainStoryboard_iPhone.storyboard b/samples/unified/SingleViewUniversal/MainStoryboard_iPhone.storyboard index 63548d7..8c651ab 100644 --- a/samples/unified/SingleViewUniversal/MainStoryboard_iPhone.storyboard +++ b/samples/unified/SingleViewUniversal/MainStoryboard_iPhone.storyboard @@ -1,10 +1,11 @@ - + - + + - + @@ -13,46 +14,50 @@ - + - - - + + - + - + - + \ No newline at end of file diff --git a/samples/unified/SingleViewUniversal/SingleViewUniversalViewController.fs b/samples/unified/SingleViewUniversal/SingleViewUniversalViewController.fs index 9c8e8ba..8726237 100644 --- a/samples/unified/SingleViewUniversal/SingleViewUniversalViewController.fs +++ b/samples/unified/SingleViewUniversal/SingleViewUniversalViewController.fs @@ -18,7 +18,7 @@ type MyViewController (handle) = override x.ViewDidLoad () = base.ViewDidLoad () - x.button1.TouchUpInside.Add(fun _ -> x.View.BackgroundColor <- UIColor.Blue) + x.myButton.TouchUpInside.Add(fun _ -> x.View.BackgroundColor <- UIColor.Blue) // Perform any additional setup after loading the view, typically from a nib. diff --git a/src/Xamarin.iOSProviders/Designtime.fs b/src/Xamarin.iOSProviders/Designtime.fs index f436992..40bf75c 100644 --- a/src/Xamarin.iOSProviders/Designtime.fs +++ b/src/Xamarin.iOSProviders/Designtime.fs @@ -1,14 +1,11 @@ namespace Xamarin.UIProviders.DesignTime open System -open System.IO open System.Reflection open ProviderImplementation.ProvidedTypes open Microsoft.FSharp.Core.CompilerServices open Microsoft.FSharp.Quotations open ProvidedTypes -open ExtCore.Control -open Swensen.Unquote module Sanitise = let cleanTrailing = String.trimEnd [|':'|] diff --git a/src/Xamarin.iOSProviders/IOSParsing.fs b/src/Xamarin.iOSProviders/IOSParsing.fs index 7e50990..177f485 100644 --- a/src/Xamarin.iOSProviders/IOSParsing.fs +++ b/src/Xamarin.iOSProviders/IOSParsing.fs @@ -1,9 +1,6 @@ namespace Xamarin.UIProviders.DesignTime open System -open System.IO -open System.Xml open System.Xml.Linq -open System.Linq open ExtCore open ExtCore.Control open MonoTouch.Design @@ -19,35 +16,45 @@ module IOS = let! destination = vc.FindById(ac.Destination) |> Option.ofObj return {Selector=ac.Selector;ElementName= destination.Element.Name.LocalName}} + let createScene (scene : MonoTouch.Design.Scene) = + let vc = scene.ViewController + let outlets = vc.Outlets + + let newOutlets = + outlets + |> Seq.choose (outletMap vc) + |> Seq.toList + + let actions = maybe { + let! view = vc.View |> Option.ofObj + let! subviews = view.Subviews |> Option.ofObj + return subviews + |> Seq.collect (fun sv -> sv.Actions) + |> Seq.distinct + |> Seq.choose (actionMap vc) + |> Seq.toList } |> Option.fill List.empty + + let newVc = {ViewController.XmlType = vc.Element.Name.LocalName + CustomClass = vc.CustomClass + Outlets = newOutlets + Actions = actions} + + let view = Unchecked.defaultof<_> + + let scene = {ViewController = newVc + View = view } + scene + let scenesFromXDoc (xdoc:XDocument) = + let idProvider = MonoTouch.Design.DefaultIdProvider() + let context = ModelObjectContext.Create(idProvider, Version(8,3,2), DeviceFamily.Undefined) let scenes = - match Parser.Instance.Parse(xdoc.Root, DeviceFamily.Undefined) with + match Parser.Instance.Parse(xdoc.Root, DeviceFamily.Undefined, context) with | :? Storyboard as sb -> sb.Scenes | :? Xib as _xib -> failwith "Xib files are currently not supported" | _ -> failwith "Could not parse file, no supported files were found" scenes - |> Seq.map (fun scene -> - let vc = scene.ViewController - let outlets = vc.Outlets - - let newOutlets = - outlets - |> Seq.choose (outletMap vc) - |> Seq.toList - - let actions = maybe { - let! view = vc.View |> Option.ofObj - let! subviews = view.Subviews |> Option.ofObj - return subviews - |> Seq.collect (fun sv -> sv.Actions) - |> Seq.distinct - |> Seq.choose (actionMap vc) - |> Seq.toList } |> Option.fill List.empty - - let newVc = {XmlType = vc.Element.Name.LocalName - CustomClass = vc.CustomClass - Outlets = newOutlets - Actions = actions} - - let scene = {ViewController=newVc} - scene) \ No newline at end of file + |> Seq.choose (fun scene -> + if String.IsNullOrWhiteSpace scene.CustomClass + then None + else Some (createScene scene)) \ No newline at end of file diff --git a/src/Xamarin.iOSProviders/MacParsing.fs b/src/Xamarin.iOSProviders/MacParsing.fs index 7e85505..8b0de72 100644 --- a/src/Xamarin.iOSProviders/MacParsing.fs +++ b/src/Xamarin.iOSProviders/MacParsing.fs @@ -70,7 +70,7 @@ module Mac = |> Seq.collect (fun scene -> let vcElement = scene.Descendants(xn "viewController") vcElement |> Seq.choose (viewControllerMapping tryLookup) - |> Seq.map (fun vc -> {ViewController=vc})) + |> Seq.map (fun vc -> {ViewControllers=vc})) let scenesFromStoryBoardFileName (sb:string) = let xdoc = XDocument.Load(new StreamReader(sb, true)) diff --git a/src/Xamarin.iOSProviders/Model.fs b/src/Xamarin.iOSProviders/Model.fs index 481138b..e4a7cda 100644 --- a/src/Xamarin.iOSProviders/Model.fs +++ b/src/Xamarin.iOSProviders/Model.fs @@ -17,6 +17,12 @@ type ViewController = { CustomClass : string Outlets: Outlet List Actions: Action List} + +type View = { + XmlType: string + CustomClass : string + Outlets: Outlet List} type Scene = { - ViewController : ViewController } \ No newline at end of file + ViewController : ViewController + View : View list } \ No newline at end of file diff --git a/src/Xamarin.iOSProviders/TypeMapper.fs b/src/Xamarin.iOSProviders/TypeMapper.fs index 005cbde..7ac66db 100644 --- a/src/Xamarin.iOSProviders/TypeMapper.fs +++ b/src/Xamarin.iOSProviders/TypeMapper.fs @@ -1,9 +1,6 @@ namespace Xamarin.UIProviders.DesignTime open System open System.Reflection -open System.IO -open System.Xml -open System.Xml.Linq module internal MacMappings = let rawmap = diff --git a/src/Xamarin.iOSProviders/Xamarin.UIProviders.DesignTime.fsproj b/src/Xamarin.iOSProviders/Xamarin.UIProviders.DesignTime.fsproj index a7a5deb..504e3b1 100644 --- a/src/Xamarin.iOSProviders/Xamarin.UIProviders.DesignTime.fsproj +++ b/src/Xamarin.iOSProviders/Xamarin.UIProviders.DesignTime.fsproj @@ -16,11 +16,6 @@ prompt true - - - - - false false @@ -35,6 +30,13 @@ true + + Program + ..\..\..\..\..\..\Applications\Visual Studio.app\Contents\Resources\lib\monodevelop\bin\VisualStudio.exe + --no-redirect + ..\..\..\..\..\..\Applications\Visual Studio.app\Contents\Resources\lib\monodevelop\bin\ + false + @@ -42,10 +44,10 @@ - \Applications\Xamarin Studio.app\Contents\Resources\lib\monodevelop\AddIns\MonoDevelop.IPhone\MonoTouch.Design.dll + /Applications/Visual Studio.app/Contents/Resources/lib/monodevelop/AddIns/MonoDevelop.IPhone/MonoTouch.Design.dll - \Applications\Xamarin Studio.app\Contents\Resources\lib\monodevelop\AddIns\MonoDevelop.IPhone\MonoTouch.Design.Client.dll + /Applications/Visual Studio.app/Contents/Resources/lib/monodevelop/AddIns/MonoDevelop.IPhone/MonoTouch.Design.Client.dll @@ -55,9 +57,13 @@ ..\packages\Unquote.3.1.1\lib\net45\Unquote.dll - ..\..\..\md-addins\MonoDevelop.MacDev\build\MonoDevelop.MacDev.dll + /Applications/Visual Studio.app/Contents/Resources/lib/monodevelop/AddIns/MonoDevelop.MacDev/MonoDevelop.MacDev.dll + + + ..\..\..\..\..\..\Applications\Visual Studio.app\Contents\Resources\lib\monodevelop\AddIns\Xamarin.Ide\Xamarin.Designer.dll + @@ -73,9 +79,6 @@ - - - diff --git a/src/Xamarin.iOSProviders/iOSDesignerProvider.fs b/src/Xamarin.iOSProviders/iOSDesignerProvider.fs index 74513cc..47c3adc 100644 --- a/src/Xamarin.iOSProviders/iOSDesignerProvider.fs +++ b/src/Xamarin.iOSProviders/iOSDesignerProvider.fs @@ -8,7 +8,6 @@ open System.Xml.Linq open System.Reflection open ProviderImplementation.ProvidedTypes open Microsoft.FSharp.Core.CompilerServices -open MonoTouch.Design open ProvidedTypes [] @@ -46,9 +45,8 @@ type iOSDesignerProvider(config: TypeProviderConfig) as this = | RunTime.TVOS -> IOS.scenesFromXDoc xdoc yield! scenes } - let groupedViewControllers = + let groupedViewControllers = query {for scene in scenes do - where (not (String.IsNullOrWhiteSpace scene.ViewController.CustomClass)) groupValBy scene.ViewController scene.ViewController.CustomClass} @@ -57,9 +55,8 @@ type iOSDesignerProvider(config: TypeProviderConfig) as this = let generatedTypes = [ for sc in groupedViewControllers do - let vcs = sc.AsEnumerable() -// if not (String.IsNullOrWhiteSpace sc.ViewController.CustomClass) then - yield TypeBuilder.buildController runtimeBinding vcs isAbstract addUnitCtor register config ] + let viewControllers = sc.AsEnumerable() + yield TypeBuilder.buildController runtimeBinding viewControllers isAbstract addUnitCtor register config ] //Add the types to the container container.AddMembers generatedTypes From fc683fa038835b82fb319f2b743473fda4fc6481 Mon Sep 17 00:00:00 2001 From: Dave Thomas Date: Mon, 26 Jun 2017 18:58:00 +0100 Subject: [PATCH 02/10] Update to packet at root, update old provided types --- .paket/paket.exe | Bin 0 -> 54272 bytes paket.dependencies | 8 + paket.lock | 9 + samples/CocoaApp/paket.references | 0 samples/iosDesignerUsage.sln | 259 +- samples/unified/MasterDetail/paket.references | 0 .../SingleViewUniversal/paket.references | 0 .../unified/WatchkitTest/WatchkitTest.fsproj | 15 +- samples/unified/WatchkitTest/packages.config | 4 - samples/unified/WatchkitTest/paket.references | 1 + samples/unified/fullTest/fullTest.sln | 5 + samples/unified/fullTest/paket.references | 0 .../unified/singleview_tvOS/paket.references | 0 .../DisposalIssue/DisposalIssue.fsproj | 148 +- src/Testing/DisposalIssue/packages.config | 4 - src/Testing/DisposalIssue/paket.references | 1 + .../paket.references | 0 .../DesignerTest.sln | 5 + .../DesignerTest/paket.references | 0 .../cs_test/cs_test.csproj | 32 +- .../cs_test/packages.config | 5 - .../cs_test/paket.references | 2 + src/Xamarin.Android.UIPRovider.sln | 5 + .../ProvidedTypes.fs | 5479 ++++++++--------- .../ProvidedTypes.fsi | 3 - .../Xamarin.Android.UIPRovider.fsproj | 39 +- .../Xamarin.Android.UIPRovider.sln | 5 + .../packages.config | 5 - .../paket.references | 2 + .../paket.references | 0 .../paket.references | 0 .../paket.references | 0 src/Xamarin.iOSProviders.sln | 217 +- src/Xamarin.iOSProviders/ProvidedTypes.fs | 5472 ++++++++-------- .../Xamarin.UIProviders.DesignTime.fsproj | 71 +- .../Xamarin.iOSProviders.sln | 5 + src/Xamarin.iOSProviders/packages.config | 6 - src/Xamarin.iOSProviders/paket.references | 3 + 38 files changed, 5975 insertions(+), 5835 deletions(-) create mode 100644 .paket/paket.exe create mode 100644 paket.dependencies create mode 100644 paket.lock create mode 100644 samples/CocoaApp/paket.references create mode 100644 samples/unified/MasterDetail/paket.references create mode 100644 samples/unified/SingleViewUniversal/paket.references delete mode 100644 samples/unified/WatchkitTest/packages.config create mode 100644 samples/unified/WatchkitTest/paket.references create mode 100644 samples/unified/fullTest/paket.references create mode 100644 samples/unified/singleview_tvOS/paket.references delete mode 100644 src/Testing/DisposalIssue/packages.config create mode 100644 src/Testing/DisposalIssue/paket.references create mode 100644 src/XAmarin.UIProvider.iOSRuntime/paket.references create mode 100644 src/Xamarin.Android.DesignerTest/DesignerTest/paket.references delete mode 100644 src/Xamarin.Android.DesignerTest/cs_test/packages.config create mode 100644 src/Xamarin.Android.DesignerTest/cs_test/paket.references delete mode 100644 src/Xamarin.Android.UIPRovider/packages.config create mode 100644 src/Xamarin.Android.UIPRovider/paket.references create mode 100644 src/Xamarin.Android.UIProvider.Runtime/paket.references create mode 100644 src/Xamarin.UIProvider.OSXRuntime/paket.references create mode 100644 src/Xamarin.UIProvider.TVOSRuntime/paket.references delete mode 100644 src/Xamarin.iOSProviders/packages.config create mode 100644 src/Xamarin.iOSProviders/paket.references diff --git a/.paket/paket.exe b/.paket/paket.exe new file mode 100644 index 0000000000000000000000000000000000000000..e8f18a1b5f28d93e046398a24b565a5d751f3f32 GIT binary patch literal 54272 zcmc$H2Vh*q(f_{p?%oyMoph%zThd9k%vsId*c4;A8{Fjz82c=pZP}8Zcqh4F?3^eL zDYTf-0{ILfjS@Z*l2E<`99n=BNZ|{KV<3f+PI?HK|8HjZ-Mv#G+?SBMAjO+RxPzBkCAI#T;kMBE?vcHINovTxU|-Px6n_u1AC zJJ}QONcQ$x{qb$7xINGt@9K>&SlJ%$u{u+&;c#%g61{4n5X&?}EWKytCa1TTMZGA{ zCJXURP=b=$`YOKTRMzmBE6cjno2VuM`k9M*(CNnzTQ3))i2u)hD^#+GDN06-(9$asJh0 zJ6)XbGAlE^4^TW=7jwY}4Wb_FKOrFz!6Y`cm=kQ!`hrGF*tFqseThQQn@mpvGi(;< zKI>F`>po_;W}w_yJlP}0$)QBk<)8%h1kk1eZvs{@L;mI>pACAS6@{qMlUkEjW?B`f z@_UKVG>rs$GR=sG+a)l+COU+#o6WY_U{#?|zR4Oxz&yrYNwh8IBo=QV?4jBr*OR<}+PJ;^w2eDPsB(UKH@fim;|ExTR*O z;Fgf2lv`(U3+oho+0d}hZXw%Y)WHNs8f^BNm2v=$f^5G}+1{|X5MKeBHT(2(s}=>r z-kV3OX4;iRgWH%vvpJ-*Ql@n#SA90it}4n{9mD>b)26`ZwDDQ9(FSv-^E!duqlW!M z;tP);8+=~&6U+tpvXdAzOIs&FU78EsFv~X@RwYJhZo)KSw&cVZrbDHX2O-N4k0{?X z>^IS;g{2y7F3ygdX&7#Bf?*eGPCa!bZNN0HZ>rMs{KBxCh+nnkGRbavF~_)(?Qhsq zT#Q_njD~$`wnx&aj!nxnmMTqdBz$B(%%LHs!*}5*u*)9!8aZr0{^ zbHHQWsxVV2L{Ptxllm}f8;@?X_eF|ER1elwN^B7P9g63DFx!>8=Zb6h@ko>4{% zFK8bmG3?zXy5n+0lkAPU;*(zLAgprZ1-cA66G#r6uy0HPODEVk26m-5kChiqBtQw8 ziHZ2qtwunr3E&VypWB*V8fG&p8ZuNvp`TEjYdV-H zE;T_=AYV`nf{4$W2_A~iByFDFVsa>N)GcThY!qZ$ID)|FqIv>hAn0%iJ#iY)1iUr) z9Ac4{KM~O{~StfljTZskuHXA>qTMJRJ@5OxBPmoV70*Yn1 zn7)hzLcVEXGYmF9sVA1=yB~h2HAvR8fj5*}=g^lfS(j0{(pru$wlmowNOnlCKp|+x zv;^4A=BUrK;D69(6=1XOYfP+0p+J#CelvkJjEa&*e;SK7*pPszpasvPE-{_t!@5Ag z;~ztf%iwXHFeaQ3&>oY8`H=R)-d-dO@M~ibYcaC|6A(38LiVpQY+^Obv6QT%D72K> zr|Y7x{7S@Xt)a|wJ9RFrKaawpO>hE^GaFGjX@S?zQd&rGVFO$nUc@gPOPizGv$o^g{!S3fVFyaqP6Ay3SmWHzYe6wyg8rE*qAq>d^#aR=9198GDY_!LCpwEAR8r02nH+Y$)z}FJ7Pm)0L&63cG zbC49?iDEdA?g3M=C+eZ8H$x|;L_N(uH|n$2yh62 z!jr&gf-SnySbilUAr_AP4jSHWP}hGnVze8JiQB>EhgQzvEIN(O>5OJ2F zp;7E9EA}?chjR(`n`YFkji1!E2B{FBf)9my6bh(tJ{6+g@{Psbs26iZ0;fJ| zHW%o%^-_bTkgp{GC&^GJjb)*-aMLQoFQxmUzS{GrnSt_+;igkjuAf$;2g(x|qFI(3 zgC6xMQN?3>zZ}Wb&*}k_>&@msRsk4}V(JQv9SbHJe;0-HAhf}pT!OEH zrdpqMDGJEO$tukOj97MP`e`3WJh=??mKRS1ec9k*%AFDp0in8xiKa89kI{Jsv5v7*`w!kFkIZUdGcp>uzxC*@^YHL}+ST{WPzwdU?n{ z8+wSC2h*CEicz=h4>ZrExt=zOCRhrcR0|2^8+rOr6O~hsCTfNjVtU(h=uGZ{U1wT( zSqPRq6`ENe1n^l`08VHs<}N(t;if>go#Rll&$AZ4`|i8`=5qK7JdBOy7Q~?#fm+5y zE+9x&IRq|%fT%7xxBvq71xern2-OaO3m_oLmKB}|9X@GN0wd2-6u;?5wJ{{4M>h2)W>7O6Z(%!pdnwVvHzz&# z_EBDhZ@-k+t6Lv}Vfpab&=Nxa_+bY{Z1)PpN{&_bG=!G~@**Ug@|f!@;{examR|`b z1iIShTV;xWXfwvisloXuoHV1fuYUw$8!}WwX>Ajo01*yh1Fu+&J`l5_hIJ*Fvf@s= zwZggzgrG?$hVf?E&FrXUQz|_uC$2`7SuVfR*8o{v-smY=4QD4`M}QP1kZCW3-i90_ z7H3cm0nyMbM;>-9NX_l`CNTM|j{)&nM*wBUcpXZdvT^bi(tS9wEP(}@ef|I^VSbr} z`90Rh!Kxpq$LJ8Ot_Omlu^uzk*!08=B<)6kgT$uhE`hOQ$FuiB0h4k|Q@01R<;DvR z)q$7g>efwYYgjjv@YeL%V9iivW7VN?^i`v0_afND^xCM<>^-SH3%~2dRm9p^!-6@^zZksrddYvkpN@Ni$=$WJ; z(Ug=6Sg?_}6`kpcPXclg{$~ohq$$NbrekoT;GyvtDrE`5l9T2I5S>0s+_wRw(GFKe ziQ9?rDFB~L#ISZuzSKz|q~mafi7^w?07A&ma?E}@v6=@V(_5vcQ#3qy* z6&(@6WLXNIKzIb++?=ql#MC(nv;A9|M=6VWJ`JUAr;OfI)QViOCRap!F%w$>!uFpa zAz=N82%n*0Z9pmDYV5=Dte6(pXQ_4zYH=R$3N#jF6jQ8vkeWBh+XOnWsguvbJnMZ9 zja@9d1tXh@76P9~)rs<;T^i1f%ej8b0xm4dY2CG>iJZ$j zA;h|iG=!Dp0bHhs=jLykROfs*yKoe)~+F2`wguq;y~0N4Olic2u6ctC-tajON$?+Gv3CumK0-_Xi(OJ)c9OGP?WQ_lc&qk zhqHP;K*9>5VL9l9?iS%u$7^5f=2IsCDLLdwc1>lp!1@ZhiH2k+54#(OM(^Yu7oQAN zBiWx0(M=`xjA(AGa0sHxHawZQyw3XF=%Uu6k=ObX=Juyp!=gA+UR*fb0gr;K^#MV(ZXiGFB-A#hk7SM z#Zg~0D$Am=Z925Y59L08Lf9RHwS5c9SaWc=9Q~`HBUhkUhS=f}7ol89F#t)O$?-n@ zU6gcdE+FMkI6`Hs_!0|svxxWi`D_KA<^o^HS7QAH^rmuyF;ijzYz#gw`gOWJf{2-b ziERLli;QMnZ`5Vq$B1&MP~!{!<`PNu0LQ`%rvFN{I(F)>0L#$6MRx!V^i6jFTmS(( zgCuYPgi{;>7eIiOBnKBjnCK9=00Ls9xh7>R|xnS}}t%TAU;kXY!O zS*YN!^f3#;1Qvg=`Ai=jqfK=sY)Zt#_rnw!w=@T122T1)hg@sxA*mI`B9kN1G<4a^ z7(sbsjB}KaD_h1&rsfjKWM6^dE1vR3S=TaF@*=dcAU98`k|Q}=W0F&1bS^eg@9Nwc z8j)fqk4DNwNQOrQDU8z4%&5;9TCTMmnmoJdVmEw$jC=ktCOwgxuW2jw1kHh*nrUr% zA~y@urs)ZnfpATkGoT!NOi$!GmiNq@N9*F_=$C$EU-2v9M(4_&k`6*0WfAJ9#VBh+ zCPqc;VGJ`{*`2GTVtyqlpjuKfzmgPIl~k0KjnIp7M7qZu3)|=w&Pk-@)`s%hrdzH5 zLhnHw7P4oGR!J-HUDXxBv7&rR1&$CyYeApv<7say9ih7X=CIu7aQEadn~cHweK?PN z4SmtwnF(sSq~dhK)E$yqA*mIL+Qn4TVzQ67{tkmbTl)3l{Z@#GBIFT z{H&`#C{NT@_@<2PFoHaw(E(*s4x;yKvlM$ zqSlmWYhnUyTT8Z0#7OQpQPYp@TEpBwjq=dPTigU38xw0b)*Bv5K4sxMR5R6}9Y2_Oju5PU5AA6pPWp01L*f$f zHw3Nc!C+e7BevGWo%rGd2vnF$qv^E4K#se5Q?;khxLo6dlI zgh$*jk$MIn8iFU9Cg{|o*%C(^%)VJ*7nSBxPM=IjeZdp@$tqKw^KchjD4O6z$i=+k z^N@@5EUF(M1r7Q3#!sObVg*(=R^CyPUu)mxl50r0y5TXs3Ai*8Bxd#+CM8kC{_A}9 zHK4lK?G0r)EtNF;2GFwkE3#HRsaj9Xq#mAf>o)2M`jX!B@l8L<9-fGYbA9`se8D*Z zUOu&w`zVPXZ<&%v@~(ocoPGHu(}L%9Fe{c0y`17Q#t!?9{9e|wP&qM3ZA?7vKwEo$ zxjOpg4b6w4sZ*wsI#e?sURa^AnvJ-tky7axhnQ(_{!oYcN>}pv**J*Q0e(f=$tmO! zn!K?c#4eU!cQ@E@XMo@ksae&4{zCjBE z!9=bDE`Tt@A#kC}z7^b!!ScrS((7T#XGlp8#R@qVTJ!9Cw2I9ja&kD5p1^9yBVDX~ znrw;<2f;T6W3Et7VhnbUL)b~>?c^>LPMXy;25cvYuT(>Uu?b@xfE+or7zl^D^BdJr zqgS{Q)zEX_CW=+`+*&;eH!ajCzca*{S)CC^P5UkklAa>a(=G}@=AoYa4r+5+Q4K8* zx-MlO#-dQ;XIb6~N0w>YJ%s!midAnk?Sl?d1H@Ic$@&F2vT09TCPn2pE4!Ty`Sq|{ zS&$zP6g0J%wFMi4hJ7{Unbt4SHe{H7Q;G@u0{m)Ciw^~CI^a8!6N(^4fkG4*4YIbITPLI(GcY$6|6sOAg0&w$zZY6-a~xtpuHDc z$o_@H*3@Y4uF7?%E&^~GAAu@6^QrKmFn;>XcWht4SjJ&2xy=P@oz#;zK8A&e9Yl2g zF8bq}l}5W^j5F#2`(f~zU@~G~KrPmR ze4=WC{S^n1D)}YP$tui)d=H>UOgJK{%2X^r&6$@-wWHz4^TG>x_`LXNUC)GNIhzB7GXDUA=0TmhJlJ z%X9ET`tlyMl@z=UC@(S-% zpThS<$dJu^hV?q^(`eV$Or!&_wFq&bPmw7u}g0s@k3$;TW8P5U_6lPaVeQE46^-EfI! zH32I||L`@O{dm8~9&yj3Bktx~EsQ-E$+J)35G~xg&2;)~$WV>!**9#LgI`W1&R>(d zPHx!+1k80?qpy|-ze4bg3goX^&&`U8*A%Ba>N8Cog+7&4`J&HML!ki2> z05bPx2q~}^!q_2$uj*S$ki51qbvLMT_Xz0;sA|%L%U8P)E@?gkoXiCL{Fs3ZICPTR zrBFQfFH0bs#w!@o{&r5bY-{H2Pf@i&Nr6$!iA)7&-HKJ4$EjkvoH}|d1!gx->@UVE z4A$?VZS}M*hP+tc0LmXg;ZqjhtG@{>ejRKxt=RrZcC1lf`j4o%2p8|na1Ak3*-sM# zXn#Uo;yQpVpL}@Ek6=z#DUCe=>oa5@yC9B3hCy%QQeIZbPsSRix%(KpZ=pDKC))Gj3i}^58h!txH|tz(j_XF6<&a$tUBb>RBjV94hwKfY z%2~#w=FhS-qcH1T=rQUE$jMTpaIfZ7qfK;9ylm^wo4%-e*rUwikE)!%sXmV_%S8(m zOlp%RGw|yzWb3F$8v9y|M;hDA?exVyWi&W}+|#)&j7XSkQy-JJsWTJa5+tVF+^X4f z_V~G4VyDLME(P(P72TUGgqPA!?l}1fl#<6uFMA^rmUHVI60Qv9VgVzf9z^!)(LD#x zqA%~kIru^><^Ae5e8Ux@yt?rSoLLSK2S51=;-yVlg?AAXC!udk+a0iNU9_SUROLRVD5(+woC~yb zl`M~!&w$uSh!uw?)x}o{JJ((@j{Np*Ao=HgraVYI*r7Gnbt z?Q;OEt%Rxep2U$w)z1u@oUZM?!qijyhY8{kwDICbosavnUl$} zmR{GTftOSFbX$iDrhk%rS{oWY&k~a`=LSCw#p37$OEaF!?m{!{JqJ?23r<8#+^S7* zFyXx0jNExVo`b{At?9AU0a|$)8|Ah^FLwkDvNOHqYQYuh`tN`R7X3gkp!G7Tc9DL7 za%cTOA4AHV^#e9lze3e$K`F6*fHGq1XNt6!NqdO&b0RI$bGfVC1!K@_&`INr5rAm#rQomTI9jTGPsnxrjCef zbWXjRkxbJRmB7g5m|pzug_)rwkM0Sv1Yqi%JJ!n-tZ|OPnGGi^G&>mUy!Nx_X>!T% zbId){TPL?pn>=mGY*ga6IdDH9N~Yi(c}R#1zW;Lq%I*DjSMLtY8lH#3^*0i2UAwpf zJVl_5TfA=R0({>H{BaP*&Fi+{dHkcpS2on%9tcE$zNJm$2d5}@;WHJV!}uUO6WDg? zcL#Vilb$!>13wki>{NWV;8TJR*ywjo=zR_@SK?cUKjU>S`Z2{7MbA~4qC85lli`A* z8>))MAF8PKpIp1KsI$xzr$z~$;PNLJKETi_YK@tqFTT0N6q}4+dxGMUvRk~SczgWn z8dH206jQ7)sMhv;WxOdSvdrHyrKEgwNl?65_px|T^w$%7zJcHc#l-*DvZv6tqU0&a ztREMHG^>KjpNUcV&2p;U28t=3E+zg<3BkdNXX;IH6ZiXP)@QJoWc~t@O|dFUJkzSE z-|xn5z^KotCd&FUf)}$^*FjEDyirE{rxy@?G1E7Mi5@5<`a`VSoZ_cE5wWD8wZatF z#)vaePjFui!7p&DH5j8Q8e*hXX9-!Lon`JRBl|2aAlMb6QM@#sEc_CBF~z0e35ws; z+)#z_LX)7_$M$)+ipoz03HDbL`~honXC?6`Dq=N3aeW!VwGpz?4X{#Be58gbpD8D4 zF9VvQyNddqTS2XM2dKx(Apwx>c5#Tx|3qy}yjsx)tuAJrLp+v=9%>b4J8W(s&2`LC znec>OEH%Yt=dli{iviSSfQB9d4#ZLv6tKZ z75&Yi-o$N?x_*Lh!{g3GyD8#}jBOh) zv4^xd)i@H~t^GxwqaS6uvCbEGU zq7618Y;l~hWeVF|P1tH+MqQD34RbU@tRW1XH$v77yh~~_h9_FUHVD6qbE62lu=7PB zb9QpO3q*`DobSF2=YxcM%3%KE#~8_=Q-)US+IL z)H4PI?fS)d#wcda5PQS~#?~?CKD?3Wgx+B0AE9MPwU^_9;RnCA1I9~P|7==EO*e0@B@BgG5@ zBy)w2da3pk{F9g9ph=QnH>tdZ%S8;Y^Zf|&ZwkCrP$!Oz`FTN>3F@%_`b-0tzYwJII))bJE5Gg20is-pS##vPgtjxqou2Yg znYdpY1NfFsuw0A_nc^^dk&t+rK;NxR20X6M2E5;x9U}TXl=q9p;J>kEB_QdKy`lP{ z0_+4B1@W|lXNhC58e1KnEWWR>pN(w* zcAT;6MWVVjJVi890xN)priZ7BZiPKu@vYEwQG&}w%nDm+hB!rHqO|_Z@C#u`){boX!FHu3cJ0c2+yGZps-ux8Et|1yTU#fFT(HUX_Shi-R*&l zwon8V_C>rLyHLawHm7ixSR|?xwzBZJwn&Uq*rC#lwpcVN?3z;S(_*^9ZjbCj+&DvF zUyU5smWYK4yE(WEZ*MPG*qy=S+ETGzVdZ1@htC!lC~VT$L0~&2#$I=hxFw5yIDC%y z4P)1ePe-dnyYSON82jN(^^3H%qFZ6tR^J?6D;`zYZyW9iuNO;j3KHTnmbp=Un6c}{ z>y>wfH;UUCle2lQ_=2qSU(;}Z_+0U2g?+N&L114~*i!E!;q$~Zj2#ils>gu+B#S+( zZ5FR8Y)R~~@CD*;S?pPDtI%ot$J)HI{IPISlx4AJwGJ^}VOIqn3wMg?S?pPDyO^V} zsqx3cJH+ZN_N>+=E@13hu{ZQgc$er?SV80m;T~~?!fq`&9=61P;qHe#EAIVSxKGTY zWE0p&ysw8Z6xT3zy;v9fLpUw2n?-fki>JrE6W%MT_-uKtnC&$q7l~$t?eaz<7mH;Q z=MlBB?|jW%nR%z z3bP|)BA19G3LA{Xf!(68n~O8rrQ!~SeYUs=dG0+5I|Dv{nfS88R>9{l6JJ+Y0(F;* zClxjob(f3h7<*N_sC+`?u(;-Qvc!|(YjP@b%yu$7&L9Qr%tgw%TGTMj5&lL8FP?7ks__e~8Rm_ZhMEpr% z8!F}idz-QA#f-wmk&lX7=1_l9&nxqKze@CtHd1&D;T#C*xd^Id;JaO z)x?IMC%u{2W-W((w%`Tr8u0*g$`O4`Jj>Xi{|9xQk&lV*E9|AZE?~zQdsQPTN5tP{ zI}t9iBG-vC=28!@Y9#aHVuQlk8#3Ar;sS;JqxKc=4Pv{(QlWv!jiOIsj}#P%Pl$aA zyT8DS+#)gxD=yuv-72n7*fZ$ilj2&1&24x=J1TBg*k$31Be#psDeT2qk@%GOj=~z@ zJ$Hy7E6mT>D+-G@6p1^;uN2lX=F-Tg#UB;siNE6gjCf07lN&x7`K&P71b$xCj*t0R zbw0>A3z)0)=%3@@fuVpc^%h$6Q+2xTeMwWOq zi;K8uBEb>y&*j{lEH4!dpq9XZTit_{y22!9o1DLZMZP1x$=KuKtjL{_=R|xS_5QeMirgD{Ui^r$LGeQH z>BtWR{Wc}l{WZK<`;qvD!p265#EarN#s-DA;Lga8#o`6Td06}|xLNy&IG3?O|BeaI zM~;ha3Og|21z@`sMtc5K(4QE@_7mbTV-yRHM^1=a7?Wdo zSv=0zpr{#lz5a@zzqCa=^G_og?dReag>5My>}`daHNS}bT&!J0oO0~H5b?zlqw&2a zexooN`|DJJpC{QT-jE0|((DZ}bqNt(4UmVtAx={mdB_`Lfy6ZOkY9<56-FNNYw@_k z$U}Z7-c}fS$nRATk9%p3{*c9Jj^4~-r01Wr80q;JF?}f!28E~Mw~@b!eOc@;k-w|; zF7uGL#QA44C(qGaqElfsM{kK9h0z@SQw%7K=IEc|kisYfd|Mn=7-fKOi>nh+uR!WS< z?$dt281)b?^lOP#vW_em(q2~>Sum`XfiPUpHyaT8bP9a^_Q)%{azEv(V5aY?DolTxeQqBsj+>ssxz3j3}; zy)drbsjyk7tIKOwuYFb3W%P_zKcwy%RksV{8(Q~vFR)F^_YiR>gIfiU%<76SaDU6?isljaloi^-M2p(q^c-OChsa zqkHbIT0FBC(}VQ%Y*PtQe$SML#}ehcxbyWe-7C%tQSFU2#80(OnRuM?J1)8`OZl>V zChjLR@o+ssRR+I~yDO%<%B2lC`nRK0dm>J7ZkXUd>!|i*F_qnre$ihS^-QO+=;GG} zG>Yd-X%y$N{!-fehZj{)FQ0?vy7*DHtcg=tKG`b2jMrGfSqqyOqPmD`CFS-Ql~dIO zsa6*+fzuEHZ;t-{wUV4)!np7oD-n`Ix_Q`2_#N#+dPerc06mF&2s7&!i+Nt8^|lr3 zX!QfuWEJeGi_h|mNIH#F6H@*`wAIBi%sB2}QI_!k9A$1*QIR3;##}p+=i=#}V0V7eD58B+H)yk0G9-7XU`+#nFUj$E``6SCH)G{b=IWJf{in z?_FBCHF4`HElIwu;r^KPrwCy1ik1`yy5~a9yNoTv+xD{lZfWzd`aHOkc6xDS%C^I2 z{A!K^ZuxIQLtR)rBQJU!IgYl&C66|);hgWKzoX}7%%Cpf>^~;P;*{MsahG%YI}wAT zgvK#M${bzuoNeVg@`&>}s=T+JvUeH1$?}?5%+X%LU$VvAluq^yH{8mRzXt0fzpZQ~ zYmf6g3mTQ{ z0E2kidAO=b%x2iea4Eyp3^y@MGQ15?6H7IM_i0VxD!}K$wcsUAq_{u23-EANuXtJ;Ur+`5o`!z#EU3Q(@Y>*Ez{`Wz0=`y#1K@9? zH{kie;i|hKd2QVn!M~*V62Kc{PXKNj_YB~?y6=h?wHbvkf`3xU%h1FJeU51_SHFrk zHTnwwBHqw$^SlN4!LdSnQ~OQK)W$2Bd*jHNwQcb!+CQ|GLejGSMguXm$F> z3vNXD?_+L5E4%JqZId`1_ssWc{^EzVDf-W99sw-y(pa{|pMZo=(X-lv;>$J9p~o5C z7f^nv`Z(ZI4XF>1XF_t1cnO;8OB+8dGc=a~@ zCks{c-6I4)c(ccuG3um-9@Se!s`i1(pYIcc#h@&-M)c5O? zN*>S$^-n~}N;cgT>c!yHw3hlubPZY+;rEaaSA9=^1JZt^-=u$~{AEA`R*G_MRJ*_U zHT^-@=S_VI^wGo={d?s;<2L14`zXHk^>oX{?g>REz9W&ar z57&RwI3JS#+c>75A9)Go!&Sco=R#QKe6~Ds{=s-&FR1z(U~SbqfcJ%;)i!A>>NW8q z>~ObuUjK7VvF8>2nz2=$r?pRvsr8Vrj`tkX9w?avxGi2Qx}XVh`f7{8v$AfEr&9m^ z_@#isGH3;vD?Ob&mSft1z!tGd`+fZto=w^~tkzB12fSB#_G@=mUFYf2s`0eBQ&bo9 zV!y2;oC$(nc*n!KRBh?``x?Il>n$56i4)5Z74WRu4|FKV+2pY_oE7Kwl8vkG7K zbfesh_qZqybhEU7=ogj$(bLbG^rM$e#)Bxsy9C|0w&|6Hey?VPOCsI}1>Ld+jP{0y zwW$8L@%TFjSQk~^N@H$AgI;G)FCWskhU>f^(mx(<0ki=FM!aD=X&v5+S+@tZ;@Cd#gW4~`H+U~o6q_Sb zLF``G{KnX0-eX!p><57D#jkij$~@Qci0%^?;tWNrV5WJ8YP)nCN$Z4!`?SA=9@Yl6 zlK6UaP>=|e?edb#O_G1LxzxBC_IX46h-2Nh zcn9>a2+r}`q|x2?G3~YLSG@ZXsWzkEuJ|41efnv2cboTVU&G715#$GtnGxjBuLFj} zp8#Y@p4eB^!4m4U z4#;U^xK$&WNiJu&JjmsvT)vIVpW^bP439D86^5Ela)d!J&ajT*T!w87w=zsJ%rG2e zc$DF73?F59jN!`+Ut#!jhQdSgHHHSmIKy!a=Q5nna4W+k!w!ZShLllt>*v4=^!z9BFhJy?*Wq2FIPcb~k@G*v(Nzx34;~2Iv zoX;@HFvD<=;ZcUSF?^KaF@`TQe1)O#v3(fE8P+kJ%dm~%R)!gdM;SiK@MVU=PZHt` z=Q7;N@MwVOk21WhU^mLYU>L_c7|;3UGF%WMdL~4iM;YG1lt;PzGD8ujT2Gib<6NH0 za4W+M!=nrzW%x2f5n-(uzRXY*GKJw>hFckC7(NQ`e$MwY!=vR?ew5+M3`GUEtt2>? z;Z}wjNf|@*tqfltOJz~b{0!$Z+{!S+@F>Ga8J6Nbzl+2najW<}R{J*XGVL!~ll~d~ z2|a978Z(UT#>K|1#+`=8Gut!Yv(9s)=Qhv%o(Db8d5~>;Px0>ZKJERn_f_woy#MgN z>-Cxi_~RH0@Xl11x!1fEhX}lbjI1|=oHv4%Ux>egP=q&4V))Aqr6P{ke#ap{9*?+} zKt9}z+DV8EGjKVzp|%b84)-=J0{naY9KiZIf>jj+@h${lym}?zt78d1U$Fu3g*d^d z0|eU(iRaU$RDL)@A#sJd4b3pH&Rs-sI+b4i>Eg;T(h_V{a zB?Tzgi!jRL0Cmg~y_?zqsN-*ML{UBk5Vw7pSG@BFsN>DdQj|{x)baZq@(w^<>=aEXcLC~x-tf`zw**>H?uJ)sq6bhHy*O)W!UDu^BVfkTe}K(&@g}ULi??7WUHlUk(($~<0?#{uOJV0vi?B9BpRW(-^NcmdWyW`m zjOWLmzj^w+U-16MTV>XpXPBN0y?d{tmGficJ_twg?9YAX2}bj2@(t;H+OKf;kl*$p zvkkWr`Lz4YS-9Pzzodj)QG9Cfsl_LbPaQt>=zSdgcRc*I0iOwoIj6u66Icrq@o9t~ zHsRBZPYXV+_)Nmun2gU9e5T?dE#2{BidJif8F~8@MrKjrhVP}B4|IsH@Z4w zPREul3%b&M-O2s)yOZhkl*wBrgF1W5mMK%Hv^dqjB$?hhXPZM9)_~c#0rBrh^>0C& z71myE!or4j;q)*~bue##A9`NamF}lDOdZzCbf?i&E}@HM$^KNje|^eMcUisjEjvYx zW$n<`BU7^?r_3PX%ai+9Wk!ZdkSsjPnM!Nf|0+9$e?ushOmp{BxN=xyNrg>kQQP&& z?ygQK@7R@zL)(lC?eb(-uPQnM)r2YPP$d+31H|Mw&PnZ8$WSX`Vy7r?ok6AC94hiGq7FB>s+~=> z@6U>09IC71b5q2kf!>a-Q^bma?(XEa?i7kk7xrQfYzJFucfw6N^N4L7G-J$r;Q(Bs zfB$@|r!NVAa<%Wb2&1Jz#NPgCQ{`}HZ9!r9xIi3D%c)Y!sbWDFcbv5MZ&kuz#cA)+ zkZRHO%;}@^po-Q81kD(oiEG=Jv`w8cGs}+Bs0vTtGE?k8I9a!L(JX3!>9sls;EH0w z!c_}bELgZ={-!O9mM&W;+V`jXQ$4LqSBgE!?t#>nEdm~z6g}w<%kJ*lhQ=KZ&wQ)9 zJH-Y_w=PcgrtGc`u^rRLJuU4NEBjKtYf{Nhu?&k!tn6(c=;%nL)7uBKD^0X@c8az% zFP2WxL2IT{wob3LlO3sry)^4!>4T`wh3SrDA7SaWsh&Q|PTF1F`CS0(#9b`BT2 z((c;P)tl@dt!6kqZ?hO)y=I_yII(@FwRcIXyKi{Sih-VODSJ45k=2cLKAgThxyu@f z+yyrniF+SK+_oL5rM=6$dIzx04QE={i+?bXJTujau+fw3?L^ogfe#}axx$IZx!q!z z_17kCxXSRp7g_KfcBA2SnCtB+dz8xg-Cfw1hBsQceLJnmJt_QZC$^Ry`-ihEN_KZ| zgQJhmfsJLGl|~pHp)t%Um(wcS+BX8jhSat-sS5{?PmIh!VThNLNM}n#%lUq;b|_88 z0kO{RI;X3*Q>;lL*Xl@#rD@tOR@xhOcJ-&)`-rr`Mv-HP=;}@PQ$XOr;##rXzZ+kW z+MXQf?st=Va|>K7mg(Dk{QHqC3fp!6K$_7d{r!C|l!mi#UspfZ(I~SBWGqcDPwwdI zK>SUKo@{BYwanU^vfGo}X*es%_t)-B_F@xO{!87fGzn9e+#z*X4zHzhkNRGd>aq5u z)+BpDLjzeLbzH%S$L+?uID~Sb67vyD;a7-^63@DJZ|5qqwaRQrxRcHxup-CCA&8@pIa*|e2rdUp7*GqvgFlvN=MtO257 zf%bRxq}J~5Lqgcw2?|;fMyZ^lI0GWH(r6)uiwh9wRdG2?$TTt>_7bOwGhne(C30dr zYKX9RwY@~_cE&keJ)7Rj+W}}=t`xz8u3A9noE0!)%8(M$XxTS zzWrPv6}Hn5*wN=BUA2I;A%^vA>)yY%s~;GtPy38?bSex&<@B^`=cnS)n=n~Ehx zE|(QXDlmcp!pAzL6&y;omK0comB|%J&J-M;1zk46lx6Q{0*$1X6r>jI$O1@d`LzJX zT8l~Ls%6P^zg*cwp_P?SfjapFhoy}(50*n2$+E6qWjQWw%ck2Yn<6|D;gj2lO=cZ} z+(>NLiPSTfO`tr~Hz<+Kn-eDF_GLz$My>-Fd1~IuVaEB%zWxCSB(oszrG462xM@kv zMMyS>3+?Ld=pN`yfuasoEJZeV5y?Wsh%zF$xU$;0XnpyT*QBskd!ZHuL*4`wj<(r4 zxv{`(ys%SZt-XI$(pF<}=Px{(JVK`{yPWted|xg{^L& zXCwxw#(CiOt_}(j?DuW~*g)#*@_`A(1 zGt}&C>&IVV*oNFhEJ$q|*s+7+TaK2urgLPOP%N^sYW7<8?p(#fef_CkI>+ZojtE+q zO4Z?&OM9VWPm&H&$?j3P7NpW0b{8Lzb0Tn}N!e(XUf-4Og7RyvT%8;(i$yM-+{dMK zuHMlN$wKEqM}MvYev!oa+fMG!(Nuuv?V`VHTNj=5a<$~j>(Z(AovH3_cti(Tbl!e| z9jL$oZ@}4ru<=NgDiGBr0-wTs%km!PUW!u)8X-~*;AUh`N{|6*cR=Pr`>f!=-0BV= zt*L$3&k))7t=um7s5);y*$lxR=L)f~x5MIsI+3UWwJLiP3&*z&NxPR2>~AAo35a#Q zkcq<(qGMA24UcRjQs`Ps71{^3rTMRX2y8K8Ih_L7AbcK>L4#>f92UduZ(y{&-|E}T zrM1=on!qmEn-+FqSeG_LCle6J*C`X=Ef)*WDa$;bvEI~PhbpHBBg{@eHSHrnbFwVe zy8}fYeR@L|ib(my06x~XU97Xb=i&@=WiM^1-C{+mpH@OHgApspp}Se4bIjq!S;Xqw zvY1l#SJ_U;B6S@(7v)7*4&K!|@mmJ9l5!a9!yytCQ@JlLpM(P2z7?9I&lrm=?C7oy=%t+4sXoQS(A{-lf$wm zwOw7jQ0nYl!U&o@4qqQbmIX-^C$l+9DqBZ0g@uiylWQ-@+Qm(i0gQva-Ia#%s3{^Q z+n&C+!`IeY9F1_-hZ1Q+CY3>yOGJ{ZCyTmlPtNQ{sRwK!HuEY??S96vfa#8aV-gdx zDJ)|brEKap*~eNs_Z_Ti7NM9bct)I=M5cM6n2$SeTg=}H(4OjnIxIq7jIaPzl#zt; zSFo&2?L&y+A|eh^q`CO;3~U=+X(>@M2D2ztRJUIWgAsB!&N2nYy@aaV&KEI|hl>Sh z>Gsa$$=>7+Nu=Y4ymni-2S+=3*s@i$9O%X6Ag**_(6+uVx(5R4?opBW@X_k75NdKL zC{dKls~f)iDjP_bK_8AEa*k<}zaUW&^XO#WyC-E6q7L3-3rpieFD6!W;sdj&D*?DX zZ#A$ArJktBq8QT_zLR3}$`aAQn%aTI*NZ!)ZZxChWGGE-G?Jl1?m7}-sdS|!rE-ZA zgN3#YqH`sV0~Begj?9F$(xD2Fzta8i3VENqpeu<}ej2eV&EB=v>Q8pJBW(3{rbS-( zTAo7u2XRP-LN>)xvfESko-Ql|G@@J;TR7chr0FJ?E>F{V@U;^tTii{c3#VKq&a>`Q zuJn_;ixu>CprrlPYO z%T9V3f;5-O`JFN*!@Y{R-dPBIZ_fdQ$temYT*B1wcakKZF=zUgE&V&Y(%Aj7*Hvj& z&yCB4>ZZ`x)QWbK)wyAWnhuwE&JEKP0Q-?lv7zAu`56#XRmjS&Ad1wjYf?J~x|8<8 zeNKj_mIy{AuYKAmP`GyfZ1dbkoz9Dy%5hc5YwyEZ$RVLKoIm7KOr(UANXYr%y+;;l zyOAZC4`8*>feUwFimaa22+MhHL(6aefNf(=u)t_96v@s`x*&5sY{6lPPDVqiV5H2J zQ)^tt_RHDI4xU$uv*2@7nwa6#PW6~J$4Bef;Zwt=%_5%x{x@pf3afXt>J7MPw)Upg zh;t&7&ct!jfeYR=29-?-6iyB&bDg}b$sy6zKwJ0Tn&P6ihLuC}nsPgiFn6h`#io}OKRVK5l z;+B5dnAAc4>X8M@a-rLEHN=R!BIo%9bGmUXgKXW>^a4DCg1+R#VnebE=_FPPQ4qPh zQ!8z?GzDGm<*-Fvwi{iG6Bn-Uv7@iU<3glxd+2_-mk4~fo+GFQZ@2A$FUxJj9g-*k zlvOke`JhEc7k=g85-<(wex&nizIgLLoO>>M$Ukd z!{D-Rm4(854BXYPdccyqYUAfEG*Gx9tD1Wcgl5@=ZOgtO!o4j)PJkyQeFOc1E;d#m zRylq{aZAvK$_3tbRA|EprGhI`dszxzQQ>cNMMbi&DsI8>h=eT=+a|)2OatXJQ>-TP ziLQO}B1M(etqDfMw?Fu%SS8DxL#oEvg_6eVpi$D-ZhV$Hu|TB`sO;)rGO%qJS!R1G zoaC61P&p6LhBcupzPu;T@(qskFhh8{d7aox07u;?4m|+2AW>k+r3}3_3lSR?<0$6 zUxdJPxsc8r9Xl@axNL+({zwm8a`?i1Nc1}TskwSIKy#`#oE&XoZ+gJSQKK)}0e$Jh zgEwYXUfPRCk2tcThHL;2IXY^q=&RqmV#_o zGC7YYR1<_u_tQ~UVknJz7)skdq#b(9DdB#c$`YYQ9*raprR^QUgEcE9_VM8GzM3YA z`|y6@Zjr*@plk))hmR;|!TWT!7{FVWTA-gxpiWtZHzUu%yKrmqcH%s|>9`W5c6`== zz6$>>L}`n{=K~YvtI#%ucRO)^iZ?$8@U9~DBT5(Hy+j-DGN#6gf-hhP+NAKdXftTr@b)Zef+P)mxOM@pgU8$fZ)p``;pp-#$d1EK)UPv#aWxj| zm+aAtejsIbPWO>@>w*O8nf!%3vQOzK47?Y71^%2HO#}W-0jTOY@is7zWP&)lwD5v3 z{rZ#z{!SL%uOxJXLc=G+4OdEm-%2)_Tu5oWz#WA1|gifZW%`}&eDv-(&Pw3XD|+GZh6I7GnzpP5}n|e^R@$Y(sclHA~hU& zk^gJ`NFw>qe#n-KaU?C>I?4WWBN-YH&OlgNhgZvGSZ&9AtwX?~@Hq#4IK9x=-AoJjlh0NV$@bZVUd zcP2)?6c&o(C42f_ht+`h6P0a9uPzQY&MJ0~Pi|&X3ktI25j1Z^C$FU-NuiE(C0`*Q zAxO6Fg*6HL-?fni3v{AKiVdWrw9DvYB8zo{Hy3J2o4wFV(xn~Kh;?09*A%oVj7l3i zThPd}^TBp@8`LrL?^dL zkZ%$90BZXfl7@Rg`=912Slz7i|khsmVntT6=QmaUw!q`jWYP zAxt4%fLLielsOfdoH8)#YR`KpO=C7(Kc7Y50wtNlMSt@I8h8jnsfsD+-(vren)eI2D;$CK!})I?gka15ggR zoB1iFbDT2g5DAQaBKpr-$xFdr)X~y(oXE+NDY)%G03mL1<{B)@Ui{~9<(!GEp9G!e znB3QKRaY-9^Du&u(@(iAQZOKACJDkK7o^^u+}pi94e#GM3B)n0(&`g2D{-U?6s{e~ zPCIE!TI|%{esGG3BPEYJ^yJ;Tqwx9DP$Tp`?Xoll&{UaXX`;u-eUIq_E1m?_LHi||r^9c^++f_q~Zr!PP&_tD7Vcb^w& zWxBOcqd8{@MkCLZLw$zqO{-xy+R=>sOKm5PriU{damR*jLplHLzD^|xy|7r$p8s0I z{4;BAJxYHgNt6nZZKXbxkjS}4%MET1A1O{aR{uAxHkdj^IqNCtcK9T?gBFF0rEn{m zSvegpXH!`0!njbw04Q^yoQiVc6uY-Gpf1$(fyd^BC$EQ`utCmCIRa%Dv@9s(IhiA6 za!!9vU_S-2Ec}WtZ9+0=(g@`6Y3I-Fy>g;x@zR7zC#S_s5@j%^D+?MuT{tB%f^Nv6 z(dI7zs-tkY4c`=eMz)u;C6irg%Q^*;wAC_zJDC9KK$dWH+QX7%5T&e&Y~0CqkQZQ1 z2H6iiDRf}V^I6bimk`EeT&P^2w(4HUp{!;O&iYAYh8N*_two%R^L!H)wA{|=JlTV` zWa~ND{5#dAu7%w-BH+jpm5zh9Kr0%D3{?21feKbY)?!G)#asbxB(g>n3imXl{qE7)zgIgtxYIF(;#xlz0cn`q5h&I<$295uT`)fu z3ifsjE}q+UMjn+r_sv-ax|Zggm5vy432LW1PUr-Y(WT0r%9$VBes0R`QO*^EvqVRe z@;>c)>d>*~?33$hg!!nWz#+38I-XLisrah}Ghx4eTu|U%H@ujwF0ZY`rd*~hb87dc zRx1`Q1*1t=R+N`e_}ZlwSQ^yaQl5l5_bobt(2oCGk|$v~I^iF|rSJ@liu{Oj#W^@h zoB_@9C%< z=jtiHQ#ygTPf|{F%lSN=NcQvbc|YZ$9q&(zT>CU4PX`ZyobF z&vM7U1pa2zWPI?KliEhgTb;X+p&3r@uqf}X=zyaYIEOA|1ZTN*9eu%!I@a0mul)#C zXnB7v)mEIjX)RW_a~h>RnKmoDwSj4&^o<TfH$GI|>xy`>Li*^z@4%!{vi2*{#g`@Q|bUDa==~jUJ#d%8T zBs6X(A8v;P@-XSfNO9U^iBcmP>u|p$yX8DHe^=zoy37s#@4O~=9AAh@$Ulw`T^8EH z(TtgM5&2-ueeEM3FuCr=yXdSm^pH+*)Y+4Ar)1i&=@Nw8kFG=dP@>BmXK%{6m*a%F z$XJJ|_}}eG@OwOT1vc_yY0bM4=QUwmfIpgcK6V7*rF}sdc&?(JhsZm6imh;sz#fd8 zPRC;Q&>Ukg0@7Z!qsVpJ%5J>_ryhELrwiYEsIMu~z2u>UuCC%xfR-(8Jsn%@f$Eu~__B%1n+<3LwTPGNA;e!S0uVwq#R5WfR8b>zq*EWo^tbFF)$nQbA-X>p z*Qt52@Iwt)LWiHm9@5Z9|C z)kZY)2L3T|JyJx1NUAWI)o*QdvpV`w6_+zXKT3+k)A5tCrGm;3QX%8PWUgMslN zs4wcJM)L%9Z^RF?P^C1@Sg%iuWir%vBnri3JJo{qiZI7z-nfVjY9TfpnJhNwh1O%o zV)Wq9V=a(Jn)rkk8w^)_(M@bH8XYY4V?<+7)IC8h)=~fg&fpFF%jh(S!AhE?v12^~ zQ^);Olcg|&ur`}KmNH3P9gS0q4mS9GMyxBAigf`;p$mVYQm1dSO9~bNkp;I9e{8S? z@*ytZ^G0G9!hE`q=c78}4eFR4#;PNc`Xa+9jb(1qYqXj?JCGgOg1Q+rz(_5?7KvbN znB}5k4gFMmV;8~%k!r7QVie?dfg(*g7%UWt9fW4FgK~stlIDZ68OaQWd?whTTjuiE zCf5H#A6XzexReLJJQAQ0WLMZ7FLNyh@o`!r>ToJpW92%VJ8V8@7b zf9Mw5SS>oX#L>4{{ z0&$U|nR{Rt@L^4a$wfQqzpyXB?fiZij#iW(;Yo|l3i`ZQ>F78%i@XPm9?JOPqe26>@ zY*@sA=!m~ilNrQ_(JdexO%DmUK7s-TnIEDhCgb4U{LN&tyIq|eBLznfqTs{(kR!Gw=PrH{biF(7)*}m4Oaqzig8oiL{(JCKULvq*CdmgIL^S=n8G) zzD;oOltBO^Fzf!5cjgTY5xn?Z+)LtqDejd_vKw76$R5D>Bt3HjU-|@RLk?^FwhzO7KZ^UqL@2GE9|8ByI51219Y`;nRsT z{&C;p#>P0!`|~DJv9ZF)0U6-zuGCkr*N#3mcI(~LrHSKj^!=C~-&4VS87&2Fwsy%VxYcu6WYsSI!t{jVwO$YOX+8I|V z9pFV=k29_gz1!%VkN_@D#-p-ZsU{3EJ&~$GMjMqUrDB2@t};1{g|kLyUP;#N0bH6T z8zrTF1B*7Qsb>!gqev&2Z7Aq(d#4c{DV^_XcYLQDpWO;_?cQEPeSRZ6{I{0*I~U`R z-K%PXx9?TS!+4lFh4(ux(+3y+TROI0%PVXo>TbdR$kxbvd+a~Bb%qGaKXvEm2+3Qj zE8*t45`EfE*a?j6n0yej>Lh@1>_iGd0=g6K&<>9KfLm^zkr$DwXkyb6Bhw%PXYi}y zSHZ80-?^m0CAK+tXPEn)5Q|5k91|de-wV@{ge(I-fTuvu$E?H5SqPeA&}BM5n1V2S z0GnHG&UPzV)lDe_4RK5Eq+1a$psD3%-BNg-Ov|-QbmGm47gI3`fSYkEKsdHr!mNuH zho?ziS?&y{Y%7u z(RK+ohzPS-%J`&7!TFReR0rn)KfCPSlt4j+k}yjH)+y;BDO-dpodS>`S~5ZwL>Ykc zUZ6dhLBVl03;}fv^q^3YLeLJNf(iEV0n`E55qt)+82}%X0HnipvkV(>gD-Ysh5+u$ zk^ak|6A&wBlTKnS!Wf=~unc)p6rL0vV5R{$Hh?1#M?`!&B0kOFVg}#ui*OYz+@qle zW3iwaDTuE7D#Q?juw?cpcMTUsYO#0f7?fhxs${LAdVn&?DWp{-xRTW9*{X}PL--|8 zWr-?FRN1Xa1%~HH8(hxxj2ICT(zte$+z2v{=|- z&q1lQrMe|tsbiL!p44-Z4a9Z5Xe^0n>>$?pspqTuH5mNR{^}WQwp@|Wsa5QW)7bS# zLxjGD(Ls$p!x~$0X{Zzyk?KAc{#eKU{J#9Cf(3WAn?i9o7JIiu4%iAGI^}H=;4`mSvs3|2 zv4bO&!gonFhci(?r{gf`Pj8B1DG**9rQS!0=P1d9$GNUC_>N+u(Q&x(9i+!)8`44O zzVo>1-2RiBXl<-E#?KQHYrb}2Y6$~yDoe_v5ZRio)$Bu%aVP}x*rPy@C@oS*^dZ_% zhbG(!D=98HKVbmE@QLt9S3X)7ZyW8?H>*lv`$YZ|X z;rnX7HkyJP)+lTX9|$04Vq!AZqXMWf=De zaPedNJbAf42e7#CYwV%9{q?uSiL;9hy=H9jmAujXh^JvTS*&Q5Jbce!Z^6?(Y|6~d zHkOy_C2zg%dlS#}qh?qP4B<6Gny_;KI_oe)u&@T>0mMXi*UG1(QZ0 zy427Ox+QPcHOy8r+H literal 0 HcmV?d00001 diff --git a/paket.dependencies b/paket.dependencies new file mode 100644 index 0000000..0d585cf --- /dev/null +++ b/paket.dependencies @@ -0,0 +1,8 @@ +source https://www.nuget.org/api/v2 + +nuget ExtCore 0.8.45 restriction: >= net45 +nuget FSharp.TypeProviders.StarterPack 1.1.3.88 +nuget Unquote 3.1.1 +nuget Xamarin.Android.Support.v4 23.1.1.0 restriction: >= monoandroid6.0 +nuget Xamarin.Android.Support.v7.AppCompat 23.1.1.0 restriction: >= monoandroid6.0 +nuget Xamarin.TestCloud.Agent 0.14.1 restriction: >= xamarinios \ No newline at end of file diff --git a/paket.lock b/paket.lock new file mode 100644 index 0000000..4edba5d --- /dev/null +++ b/paket.lock @@ -0,0 +1,9 @@ +NUGET + remote: https://www.nuget.org/api/v2 + ExtCore (0.8.45) - restriction: >= net45 + FSharp.TypeProviders.StarterPack (1.1.3.88) + Unquote (3.1.1) + Xamarin.Android.Support.v4 (23.1.1) - restriction: >= monoandroid6.0 + Xamarin.Android.Support.v7.AppCompat (23.1.1) - restriction: >= monoandroid6.0 + Xamarin.Android.Support.v4 (23.1.1) + Xamarin.TestCloud.Agent (0.14.1) - restriction: >= xamarinios diff --git a/samples/CocoaApp/paket.references b/samples/CocoaApp/paket.references new file mode 100644 index 0000000..e69de29 diff --git a/samples/iosDesignerUsage.sln b/samples/iosDesignerUsage.sln index 191b737..bbd9a1c 100644 --- a/samples/iosDesignerUsage.sln +++ b/samples/iosDesignerUsage.sln @@ -1,127 +1,132 @@ - -Microsoft Visual Studio Solution File, Format Version 12.00 -# Visual Studio 2012 -Project("{f2a71f9b-5d33-465a-a702-920d77279786}") = "SingleViewUniversal", "unified\SingleViewUniversal\SingleViewUniversal.fsproj", "{4A95C0B9-1453-47C0-B6A1-FEE6122BD11A}" -EndProject -Project("{f2a71f9b-5d33-465a-a702-920d77279786}") = "singleview_tvOS", "unified\singleview_tvOS\singleview_tvOS.fsproj", "{00BF2AD3-867C-4A12-8AE6-907D4F02380F}" -EndProject -Project("{f2a71f9b-5d33-465a-a702-920d77279786}") = "CocoaApp", "CocoaApp\CocoaApp.fsproj", "{7EF80A0C-9765-4E3B-A13B-0B1E77E9CCAA}" -EndProject -Project("{9344BDBB-3E7F-41FC-A0DD-8665D75EE146}") = "WatchkitTest", "unified\WatchkitTest\WatchkitTest.fsproj", "{7CB94428-22F3-41BD-8F5F-8BBF831AEFE1}" -EndProject -Project("{f2a71f9b-5d33-465a-a702-920d77279786}") = "fullTest", "unified\fullTest\fullTest.fsproj", "{A202739B-6E4E-4772-A2B6-2E427643FF15}" -EndProject -Project("{f2a71f9b-5d33-465a-a702-920d77279786}") = "fsharp_masterdetail", "unified\MasterDetail\fsharp_masterdetail.fsproj", "{14BE2E7C-3220-4128-A8B2-45DCB985B844}" -EndProject -Global - GlobalSection(SolutionConfigurationPlatforms) = preSolution - Debug|x86 = Debug|x86 - Release|x86 = Release|x86 - Debug|iPhoneSimulator = Debug|iPhoneSimulator - Release|iPhoneSimulator = Release|iPhoneSimulator - Debug|iPhone = Debug|iPhone - Release|iPhone = Release|iPhone - Ad-Hoc|iPhone = Ad-Hoc|iPhone - AppStore|iPhone = AppStore|iPhone - EndGlobalSection - GlobalSection(ProjectConfigurationPlatforms) = postSolution - {4A95C0B9-1453-47C0-B6A1-FEE6122BD11A}.Ad-Hoc|iPhone.ActiveCfg = Ad-Hoc|iPhone - {4A95C0B9-1453-47C0-B6A1-FEE6122BD11A}.Ad-Hoc|iPhone.Build.0 = Ad-Hoc|iPhone - {4A95C0B9-1453-47C0-B6A1-FEE6122BD11A}.AppStore|iPhone.ActiveCfg = AppStore|iPhone - {4A95C0B9-1453-47C0-B6A1-FEE6122BD11A}.AppStore|iPhone.Build.0 = AppStore|iPhone - {4A95C0B9-1453-47C0-B6A1-FEE6122BD11A}.Debug|iPhone.ActiveCfg = Debug|iPhone - {4A95C0B9-1453-47C0-B6A1-FEE6122BD11A}.Debug|iPhone.Build.0 = Debug|iPhone - {4A95C0B9-1453-47C0-B6A1-FEE6122BD11A}.Debug|iPhoneSimulator.ActiveCfg = Debug|iPhoneSimulator - {4A95C0B9-1453-47C0-B6A1-FEE6122BD11A}.Debug|iPhoneSimulator.Build.0 = Debug|iPhoneSimulator - {4A95C0B9-1453-47C0-B6A1-FEE6122BD11A}.Debug|x86.ActiveCfg = Debug|iPhoneSimulator - {4A95C0B9-1453-47C0-B6A1-FEE6122BD11A}.Debug|x86.Build.0 = Debug|iPhoneSimulator - {4A95C0B9-1453-47C0-B6A1-FEE6122BD11A}.Release|iPhone.ActiveCfg = Release|iPhone - {4A95C0B9-1453-47C0-B6A1-FEE6122BD11A}.Release|iPhone.Build.0 = Release|iPhone - {4A95C0B9-1453-47C0-B6A1-FEE6122BD11A}.Release|iPhoneSimulator.ActiveCfg = Release|iPhoneSimulator - {4A95C0B9-1453-47C0-B6A1-FEE6122BD11A}.Release|iPhoneSimulator.Build.0 = Release|iPhoneSimulator - {4A95C0B9-1453-47C0-B6A1-FEE6122BD11A}.Release|x86.ActiveCfg = Debug|iPhoneSimulator - {4A95C0B9-1453-47C0-B6A1-FEE6122BD11A}.Release|x86.Build.0 = Debug|iPhoneSimulator - {00BF2AD3-867C-4A12-8AE6-907D4F02380F}.Debug|x86.ActiveCfg = Debug|iPhoneSimulator - {00BF2AD3-867C-4A12-8AE6-907D4F02380F}.Debug|x86.Build.0 = Debug|iPhoneSimulator - {00BF2AD3-867C-4A12-8AE6-907D4F02380F}.Release|x86.ActiveCfg = Debug|iPhoneSimulator - {00BF2AD3-867C-4A12-8AE6-907D4F02380F}.Release|x86.Build.0 = Debug|iPhoneSimulator - {00BF2AD3-867C-4A12-8AE6-907D4F02380F}.Debug|iPhoneSimulator.ActiveCfg = Debug|iPhoneSimulator - {00BF2AD3-867C-4A12-8AE6-907D4F02380F}.Debug|iPhoneSimulator.Build.0 = Debug|iPhoneSimulator - {00BF2AD3-867C-4A12-8AE6-907D4F02380F}.Release|iPhoneSimulator.ActiveCfg = Release|iPhoneSimulator - {00BF2AD3-867C-4A12-8AE6-907D4F02380F}.Release|iPhoneSimulator.Build.0 = Release|iPhoneSimulator - {00BF2AD3-867C-4A12-8AE6-907D4F02380F}.Debug|iPhone.ActiveCfg = Debug|iPhone - {00BF2AD3-867C-4A12-8AE6-907D4F02380F}.Debug|iPhone.Build.0 = Debug|iPhone - {00BF2AD3-867C-4A12-8AE6-907D4F02380F}.Release|iPhone.ActiveCfg = Release|iPhone - {00BF2AD3-867C-4A12-8AE6-907D4F02380F}.Release|iPhone.Build.0 = Release|iPhone - {00BF2AD3-867C-4A12-8AE6-907D4F02380F}.Ad-Hoc|iPhone.ActiveCfg = Release|iPhone - {00BF2AD3-867C-4A12-8AE6-907D4F02380F}.Ad-Hoc|iPhone.Build.0 = Release|iPhone - {00BF2AD3-867C-4A12-8AE6-907D4F02380F}.AppStore|iPhone.ActiveCfg = Release|iPhone - {00BF2AD3-867C-4A12-8AE6-907D4F02380F}.AppStore|iPhone.Build.0 = Release|iPhone - {7EF80A0C-9765-4E3B-A13B-0B1E77E9CCAA}.Debug|x86.ActiveCfg = Debug|iPhone - {7EF80A0C-9765-4E3B-A13B-0B1E77E9CCAA}.Debug|x86.Build.0 = Debug|iPhone - {7EF80A0C-9765-4E3B-A13B-0B1E77E9CCAA}.Release|x86.ActiveCfg = Release|iPhone - {7EF80A0C-9765-4E3B-A13B-0B1E77E9CCAA}.Release|x86.Build.0 = Release|iPhone - {7EF80A0C-9765-4E3B-A13B-0B1E77E9CCAA}.Debug|iPhoneSimulator.ActiveCfg = Debug|iPhone - {7EF80A0C-9765-4E3B-A13B-0B1E77E9CCAA}.Debug|iPhoneSimulator.Build.0 = Debug|iPhone - {7EF80A0C-9765-4E3B-A13B-0B1E77E9CCAA}.Release|iPhoneSimulator.ActiveCfg = Release|iPhone - {7EF80A0C-9765-4E3B-A13B-0B1E77E9CCAA}.Release|iPhoneSimulator.Build.0 = Release|iPhone - {7EF80A0C-9765-4E3B-A13B-0B1E77E9CCAA}.Debug|iPhone.ActiveCfg = Debug|iPhone - {7EF80A0C-9765-4E3B-A13B-0B1E77E9CCAA}.Debug|iPhone.Build.0 = Debug|iPhone - {7EF80A0C-9765-4E3B-A13B-0B1E77E9CCAA}.Release|iPhone.ActiveCfg = Release|iPhone - {7EF80A0C-9765-4E3B-A13B-0B1E77E9CCAA}.Release|iPhone.Build.0 = Release|iPhone - {7EF80A0C-9765-4E3B-A13B-0B1E77E9CCAA}.Ad-Hoc|iPhone.ActiveCfg = Release|iPhone - {7EF80A0C-9765-4E3B-A13B-0B1E77E9CCAA}.Ad-Hoc|iPhone.Build.0 = Release|iPhone - {7EF80A0C-9765-4E3B-A13B-0B1E77E9CCAA}.AppStore|iPhone.ActiveCfg = Release|iPhone - {7EF80A0C-9765-4E3B-A13B-0B1E77E9CCAA}.AppStore|iPhone.Build.0 = Release|iPhone - {7CB94428-22F3-41BD-8F5F-8BBF831AEFE1}.Debug|x86.ActiveCfg = Debug|iPhoneSimulator - {7CB94428-22F3-41BD-8F5F-8BBF831AEFE1}.Debug|x86.Build.0 = Debug|iPhoneSimulator - {7CB94428-22F3-41BD-8F5F-8BBF831AEFE1}.Release|x86.ActiveCfg = Debug|iPhoneSimulator - {7CB94428-22F3-41BD-8F5F-8BBF831AEFE1}.Release|x86.Build.0 = Debug|iPhoneSimulator - {7CB94428-22F3-41BD-8F5F-8BBF831AEFE1}.Debug|iPhoneSimulator.ActiveCfg = Debug|iPhoneSimulator - {7CB94428-22F3-41BD-8F5F-8BBF831AEFE1}.Debug|iPhoneSimulator.Build.0 = Debug|iPhoneSimulator - {7CB94428-22F3-41BD-8F5F-8BBF831AEFE1}.Release|iPhoneSimulator.ActiveCfg = Release|iPhoneSimulator - {7CB94428-22F3-41BD-8F5F-8BBF831AEFE1}.Release|iPhoneSimulator.Build.0 = Release|iPhoneSimulator - {7CB94428-22F3-41BD-8F5F-8BBF831AEFE1}.Debug|iPhone.ActiveCfg = Debug|iPhone - {7CB94428-22F3-41BD-8F5F-8BBF831AEFE1}.Debug|iPhone.Build.0 = Debug|iPhone - {7CB94428-22F3-41BD-8F5F-8BBF831AEFE1}.Release|iPhone.ActiveCfg = Release|iPhone - {7CB94428-22F3-41BD-8F5F-8BBF831AEFE1}.Release|iPhone.Build.0 = Release|iPhone - {7CB94428-22F3-41BD-8F5F-8BBF831AEFE1}.Ad-Hoc|iPhone.ActiveCfg = Release|iPhone - {7CB94428-22F3-41BD-8F5F-8BBF831AEFE1}.Ad-Hoc|iPhone.Build.0 = Release|iPhone - {7CB94428-22F3-41BD-8F5F-8BBF831AEFE1}.AppStore|iPhone.ActiveCfg = Release|iPhone - {7CB94428-22F3-41BD-8F5F-8BBF831AEFE1}.AppStore|iPhone.Build.0 = Release|iPhone - {A202739B-6E4E-4772-A2B6-2E427643FF15}.Debug|x86.ActiveCfg = Debug|iPhoneSimulator - {A202739B-6E4E-4772-A2B6-2E427643FF15}.Debug|x86.Build.0 = Debug|iPhoneSimulator - {A202739B-6E4E-4772-A2B6-2E427643FF15}.Release|x86.ActiveCfg = Debug|iPhoneSimulator - {A202739B-6E4E-4772-A2B6-2E427643FF15}.Release|x86.Build.0 = Debug|iPhoneSimulator - {A202739B-6E4E-4772-A2B6-2E427643FF15}.Debug|iPhoneSimulator.ActiveCfg = Debug|iPhoneSimulator - {A202739B-6E4E-4772-A2B6-2E427643FF15}.Debug|iPhoneSimulator.Build.0 = Debug|iPhoneSimulator - {A202739B-6E4E-4772-A2B6-2E427643FF15}.Release|iPhoneSimulator.ActiveCfg = Release|iPhoneSimulator - {A202739B-6E4E-4772-A2B6-2E427643FF15}.Release|iPhoneSimulator.Build.0 = Release|iPhoneSimulator - {A202739B-6E4E-4772-A2B6-2E427643FF15}.Debug|iPhone.ActiveCfg = Debug|iPhone - {A202739B-6E4E-4772-A2B6-2E427643FF15}.Debug|iPhone.Build.0 = Debug|iPhone - {A202739B-6E4E-4772-A2B6-2E427643FF15}.Release|iPhone.ActiveCfg = Release|iPhone - {A202739B-6E4E-4772-A2B6-2E427643FF15}.Release|iPhone.Build.0 = Release|iPhone - {A202739B-6E4E-4772-A2B6-2E427643FF15}.Ad-Hoc|iPhone.ActiveCfg = Ad-Hoc|iPhone - {A202739B-6E4E-4772-A2B6-2E427643FF15}.Ad-Hoc|iPhone.Build.0 = Ad-Hoc|iPhone - {A202739B-6E4E-4772-A2B6-2E427643FF15}.AppStore|iPhone.ActiveCfg = AppStore|iPhone - {A202739B-6E4E-4772-A2B6-2E427643FF15}.AppStore|iPhone.Build.0 = AppStore|iPhone - {14BE2E7C-3220-4128-A8B2-45DCB985B844}.Debug|x86.ActiveCfg = Debug|iPhoneSimulator - {14BE2E7C-3220-4128-A8B2-45DCB985B844}.Debug|x86.Build.0 = Debug|iPhoneSimulator - {14BE2E7C-3220-4128-A8B2-45DCB985B844}.Release|x86.ActiveCfg = Debug|iPhoneSimulator - {14BE2E7C-3220-4128-A8B2-45DCB985B844}.Release|x86.Build.0 = Debug|iPhoneSimulator - {14BE2E7C-3220-4128-A8B2-45DCB985B844}.Debug|iPhoneSimulator.ActiveCfg = Debug|iPhoneSimulator - {14BE2E7C-3220-4128-A8B2-45DCB985B844}.Debug|iPhoneSimulator.Build.0 = Debug|iPhoneSimulator - {14BE2E7C-3220-4128-A8B2-45DCB985B844}.Release|iPhoneSimulator.ActiveCfg = Release|iPhoneSimulator - {14BE2E7C-3220-4128-A8B2-45DCB985B844}.Release|iPhoneSimulator.Build.0 = Release|iPhoneSimulator - {14BE2E7C-3220-4128-A8B2-45DCB985B844}.Debug|iPhone.ActiveCfg = Debug|iPhone - {14BE2E7C-3220-4128-A8B2-45DCB985B844}.Debug|iPhone.Build.0 = Debug|iPhone - {14BE2E7C-3220-4128-A8B2-45DCB985B844}.Release|iPhone.ActiveCfg = Release|iPhone - {14BE2E7C-3220-4128-A8B2-45DCB985B844}.Release|iPhone.Build.0 = Release|iPhone - {14BE2E7C-3220-4128-A8B2-45DCB985B844}.Ad-Hoc|iPhone.ActiveCfg = Ad-Hoc|iPhone - {14BE2E7C-3220-4128-A8B2-45DCB985B844}.Ad-Hoc|iPhone.Build.0 = Ad-Hoc|iPhone - {14BE2E7C-3220-4128-A8B2-45DCB985B844}.AppStore|iPhone.ActiveCfg = AppStore|iPhone - {14BE2E7C-3220-4128-A8B2-45DCB985B844}.AppStore|iPhone.Build.0 = AppStore|iPhone - EndGlobalSection - GlobalSection(NestedProjects) = preSolution - EndGlobalSection -EndGlobal + +Microsoft Visual Studio Solution File, Format Version 12.00 +# Visual Studio 2012 +Project("{2150E333-8FDC-42A3-9474-1A3956D46DE8}") = ".paket", ".paket", "{EA864239-4932-4E63-A509-A88427DEE871}" + ProjectSection(SolutionItems) = preProject + ..\paket.dependencies = ..\paket.dependencies + EndProjectSection +EndProject +Project("{f2a71f9b-5d33-465a-a702-920d77279786}") = "SingleViewUniversal", "unified\SingleViewUniversal\SingleViewUniversal.fsproj", "{4A95C0B9-1453-47C0-B6A1-FEE6122BD11A}" +EndProject +Project("{f2a71f9b-5d33-465a-a702-920d77279786}") = "singleview_tvOS", "unified\singleview_tvOS\singleview_tvOS.fsproj", "{00BF2AD3-867C-4A12-8AE6-907D4F02380F}" +EndProject +Project("{f2a71f9b-5d33-465a-a702-920d77279786}") = "CocoaApp", "CocoaApp\CocoaApp.fsproj", "{7EF80A0C-9765-4E3B-A13B-0B1E77E9CCAA}" +EndProject +Project("{9344BDBB-3E7F-41FC-A0DD-8665D75EE146}") = "WatchkitTest", "unified\WatchkitTest\WatchkitTest.fsproj", "{7CB94428-22F3-41BD-8F5F-8BBF831AEFE1}" +EndProject +Project("{f2a71f9b-5d33-465a-a702-920d77279786}") = "fullTest", "unified\fullTest\fullTest.fsproj", "{A202739B-6E4E-4772-A2B6-2E427643FF15}" +EndProject +Project("{f2a71f9b-5d33-465a-a702-920d77279786}") = "fsharp_masterdetail", "unified\MasterDetail\fsharp_masterdetail.fsproj", "{14BE2E7C-3220-4128-A8B2-45DCB985B844}" +EndProject +Global + GlobalSection(SolutionConfigurationPlatforms) = preSolution + Debug|x86 = Debug|x86 + Release|x86 = Release|x86 + Debug|iPhoneSimulator = Debug|iPhoneSimulator + Release|iPhoneSimulator = Release|iPhoneSimulator + Debug|iPhone = Debug|iPhone + Release|iPhone = Release|iPhone + Ad-Hoc|iPhone = Ad-Hoc|iPhone + AppStore|iPhone = AppStore|iPhone + EndGlobalSection + GlobalSection(ProjectConfigurationPlatforms) = postSolution + {4A95C0B9-1453-47C0-B6A1-FEE6122BD11A}.Ad-Hoc|iPhone.ActiveCfg = Ad-Hoc|iPhone + {4A95C0B9-1453-47C0-B6A1-FEE6122BD11A}.Ad-Hoc|iPhone.Build.0 = Ad-Hoc|iPhone + {4A95C0B9-1453-47C0-B6A1-FEE6122BD11A}.AppStore|iPhone.ActiveCfg = AppStore|iPhone + {4A95C0B9-1453-47C0-B6A1-FEE6122BD11A}.AppStore|iPhone.Build.0 = AppStore|iPhone + {4A95C0B9-1453-47C0-B6A1-FEE6122BD11A}.Debug|iPhone.ActiveCfg = Debug|iPhone + {4A95C0B9-1453-47C0-B6A1-FEE6122BD11A}.Debug|iPhone.Build.0 = Debug|iPhone + {4A95C0B9-1453-47C0-B6A1-FEE6122BD11A}.Debug|iPhoneSimulator.ActiveCfg = Debug|iPhoneSimulator + {4A95C0B9-1453-47C0-B6A1-FEE6122BD11A}.Debug|iPhoneSimulator.Build.0 = Debug|iPhoneSimulator + {4A95C0B9-1453-47C0-B6A1-FEE6122BD11A}.Debug|x86.ActiveCfg = Debug|iPhoneSimulator + {4A95C0B9-1453-47C0-B6A1-FEE6122BD11A}.Debug|x86.Build.0 = Debug|iPhoneSimulator + {4A95C0B9-1453-47C0-B6A1-FEE6122BD11A}.Release|iPhone.ActiveCfg = Release|iPhone + {4A95C0B9-1453-47C0-B6A1-FEE6122BD11A}.Release|iPhone.Build.0 = Release|iPhone + {4A95C0B9-1453-47C0-B6A1-FEE6122BD11A}.Release|iPhoneSimulator.ActiveCfg = Release|iPhoneSimulator + {4A95C0B9-1453-47C0-B6A1-FEE6122BD11A}.Release|iPhoneSimulator.Build.0 = Release|iPhoneSimulator + {4A95C0B9-1453-47C0-B6A1-FEE6122BD11A}.Release|x86.ActiveCfg = Debug|iPhoneSimulator + {4A95C0B9-1453-47C0-B6A1-FEE6122BD11A}.Release|x86.Build.0 = Debug|iPhoneSimulator + {00BF2AD3-867C-4A12-8AE6-907D4F02380F}.Debug|x86.ActiveCfg = Debug|iPhoneSimulator + {00BF2AD3-867C-4A12-8AE6-907D4F02380F}.Debug|x86.Build.0 = Debug|iPhoneSimulator + {00BF2AD3-867C-4A12-8AE6-907D4F02380F}.Release|x86.ActiveCfg = Debug|iPhoneSimulator + {00BF2AD3-867C-4A12-8AE6-907D4F02380F}.Release|x86.Build.0 = Debug|iPhoneSimulator + {00BF2AD3-867C-4A12-8AE6-907D4F02380F}.Debug|iPhoneSimulator.ActiveCfg = Debug|iPhoneSimulator + {00BF2AD3-867C-4A12-8AE6-907D4F02380F}.Debug|iPhoneSimulator.Build.0 = Debug|iPhoneSimulator + {00BF2AD3-867C-4A12-8AE6-907D4F02380F}.Release|iPhoneSimulator.ActiveCfg = Release|iPhoneSimulator + {00BF2AD3-867C-4A12-8AE6-907D4F02380F}.Release|iPhoneSimulator.Build.0 = Release|iPhoneSimulator + {00BF2AD3-867C-4A12-8AE6-907D4F02380F}.Debug|iPhone.ActiveCfg = Debug|iPhone + {00BF2AD3-867C-4A12-8AE6-907D4F02380F}.Debug|iPhone.Build.0 = Debug|iPhone + {00BF2AD3-867C-4A12-8AE6-907D4F02380F}.Release|iPhone.ActiveCfg = Release|iPhone + {00BF2AD3-867C-4A12-8AE6-907D4F02380F}.Release|iPhone.Build.0 = Release|iPhone + {00BF2AD3-867C-4A12-8AE6-907D4F02380F}.Ad-Hoc|iPhone.ActiveCfg = Release|iPhone + {00BF2AD3-867C-4A12-8AE6-907D4F02380F}.Ad-Hoc|iPhone.Build.0 = Release|iPhone + {00BF2AD3-867C-4A12-8AE6-907D4F02380F}.AppStore|iPhone.ActiveCfg = Release|iPhone + {00BF2AD3-867C-4A12-8AE6-907D4F02380F}.AppStore|iPhone.Build.0 = Release|iPhone + {7EF80A0C-9765-4E3B-A13B-0B1E77E9CCAA}.Debug|x86.ActiveCfg = Debug|iPhone + {7EF80A0C-9765-4E3B-A13B-0B1E77E9CCAA}.Debug|x86.Build.0 = Debug|iPhone + {7EF80A0C-9765-4E3B-A13B-0B1E77E9CCAA}.Release|x86.ActiveCfg = Release|iPhone + {7EF80A0C-9765-4E3B-A13B-0B1E77E9CCAA}.Release|x86.Build.0 = Release|iPhone + {7EF80A0C-9765-4E3B-A13B-0B1E77E9CCAA}.Debug|iPhoneSimulator.ActiveCfg = Debug|iPhone + {7EF80A0C-9765-4E3B-A13B-0B1E77E9CCAA}.Debug|iPhoneSimulator.Build.0 = Debug|iPhone + {7EF80A0C-9765-4E3B-A13B-0B1E77E9CCAA}.Release|iPhoneSimulator.ActiveCfg = Release|iPhone + {7EF80A0C-9765-4E3B-A13B-0B1E77E9CCAA}.Release|iPhoneSimulator.Build.0 = Release|iPhone + {7EF80A0C-9765-4E3B-A13B-0B1E77E9CCAA}.Debug|iPhone.ActiveCfg = Debug|iPhone + {7EF80A0C-9765-4E3B-A13B-0B1E77E9CCAA}.Debug|iPhone.Build.0 = Debug|iPhone + {7EF80A0C-9765-4E3B-A13B-0B1E77E9CCAA}.Release|iPhone.ActiveCfg = Release|iPhone + {7EF80A0C-9765-4E3B-A13B-0B1E77E9CCAA}.Release|iPhone.Build.0 = Release|iPhone + {7EF80A0C-9765-4E3B-A13B-0B1E77E9CCAA}.Ad-Hoc|iPhone.ActiveCfg = Release|iPhone + {7EF80A0C-9765-4E3B-A13B-0B1E77E9CCAA}.Ad-Hoc|iPhone.Build.0 = Release|iPhone + {7EF80A0C-9765-4E3B-A13B-0B1E77E9CCAA}.AppStore|iPhone.ActiveCfg = Release|iPhone + {7EF80A0C-9765-4E3B-A13B-0B1E77E9CCAA}.AppStore|iPhone.Build.0 = Release|iPhone + {7CB94428-22F3-41BD-8F5F-8BBF831AEFE1}.Debug|x86.ActiveCfg = Debug|iPhoneSimulator + {7CB94428-22F3-41BD-8F5F-8BBF831AEFE1}.Debug|x86.Build.0 = Debug|iPhoneSimulator + {7CB94428-22F3-41BD-8F5F-8BBF831AEFE1}.Release|x86.ActiveCfg = Debug|iPhoneSimulator + {7CB94428-22F3-41BD-8F5F-8BBF831AEFE1}.Release|x86.Build.0 = Debug|iPhoneSimulator + {7CB94428-22F3-41BD-8F5F-8BBF831AEFE1}.Debug|iPhoneSimulator.ActiveCfg = Debug|iPhoneSimulator + {7CB94428-22F3-41BD-8F5F-8BBF831AEFE1}.Debug|iPhoneSimulator.Build.0 = Debug|iPhoneSimulator + {7CB94428-22F3-41BD-8F5F-8BBF831AEFE1}.Release|iPhoneSimulator.ActiveCfg = Release|iPhoneSimulator + {7CB94428-22F3-41BD-8F5F-8BBF831AEFE1}.Release|iPhoneSimulator.Build.0 = Release|iPhoneSimulator + {7CB94428-22F3-41BD-8F5F-8BBF831AEFE1}.Debug|iPhone.ActiveCfg = Debug|iPhone + {7CB94428-22F3-41BD-8F5F-8BBF831AEFE1}.Debug|iPhone.Build.0 = Debug|iPhone + {7CB94428-22F3-41BD-8F5F-8BBF831AEFE1}.Release|iPhone.ActiveCfg = Release|iPhone + {7CB94428-22F3-41BD-8F5F-8BBF831AEFE1}.Release|iPhone.Build.0 = Release|iPhone + {7CB94428-22F3-41BD-8F5F-8BBF831AEFE1}.Ad-Hoc|iPhone.ActiveCfg = Release|iPhone + {7CB94428-22F3-41BD-8F5F-8BBF831AEFE1}.Ad-Hoc|iPhone.Build.0 = Release|iPhone + {7CB94428-22F3-41BD-8F5F-8BBF831AEFE1}.AppStore|iPhone.ActiveCfg = Release|iPhone + {7CB94428-22F3-41BD-8F5F-8BBF831AEFE1}.AppStore|iPhone.Build.0 = Release|iPhone + {A202739B-6E4E-4772-A2B6-2E427643FF15}.Debug|x86.ActiveCfg = Debug|iPhoneSimulator + {A202739B-6E4E-4772-A2B6-2E427643FF15}.Debug|x86.Build.0 = Debug|iPhoneSimulator + {A202739B-6E4E-4772-A2B6-2E427643FF15}.Release|x86.ActiveCfg = Debug|iPhoneSimulator + {A202739B-6E4E-4772-A2B6-2E427643FF15}.Release|x86.Build.0 = Debug|iPhoneSimulator + {A202739B-6E4E-4772-A2B6-2E427643FF15}.Debug|iPhoneSimulator.ActiveCfg = Debug|iPhoneSimulator + {A202739B-6E4E-4772-A2B6-2E427643FF15}.Debug|iPhoneSimulator.Build.0 = Debug|iPhoneSimulator + {A202739B-6E4E-4772-A2B6-2E427643FF15}.Release|iPhoneSimulator.ActiveCfg = Release|iPhoneSimulator + {A202739B-6E4E-4772-A2B6-2E427643FF15}.Release|iPhoneSimulator.Build.0 = Release|iPhoneSimulator + {A202739B-6E4E-4772-A2B6-2E427643FF15}.Debug|iPhone.ActiveCfg = Debug|iPhone + {A202739B-6E4E-4772-A2B6-2E427643FF15}.Debug|iPhone.Build.0 = Debug|iPhone + {A202739B-6E4E-4772-A2B6-2E427643FF15}.Release|iPhone.ActiveCfg = Release|iPhone + {A202739B-6E4E-4772-A2B6-2E427643FF15}.Release|iPhone.Build.0 = Release|iPhone + {A202739B-6E4E-4772-A2B6-2E427643FF15}.Ad-Hoc|iPhone.ActiveCfg = Ad-Hoc|iPhone + {A202739B-6E4E-4772-A2B6-2E427643FF15}.Ad-Hoc|iPhone.Build.0 = Ad-Hoc|iPhone + {A202739B-6E4E-4772-A2B6-2E427643FF15}.AppStore|iPhone.ActiveCfg = AppStore|iPhone + {A202739B-6E4E-4772-A2B6-2E427643FF15}.AppStore|iPhone.Build.0 = AppStore|iPhone + {14BE2E7C-3220-4128-A8B2-45DCB985B844}.Debug|x86.ActiveCfg = Debug|iPhoneSimulator + {14BE2E7C-3220-4128-A8B2-45DCB985B844}.Debug|x86.Build.0 = Debug|iPhoneSimulator + {14BE2E7C-3220-4128-A8B2-45DCB985B844}.Release|x86.ActiveCfg = Debug|iPhoneSimulator + {14BE2E7C-3220-4128-A8B2-45DCB985B844}.Release|x86.Build.0 = Debug|iPhoneSimulator + {14BE2E7C-3220-4128-A8B2-45DCB985B844}.Debug|iPhoneSimulator.ActiveCfg = Debug|iPhoneSimulator + {14BE2E7C-3220-4128-A8B2-45DCB985B844}.Debug|iPhoneSimulator.Build.0 = Debug|iPhoneSimulator + {14BE2E7C-3220-4128-A8B2-45DCB985B844}.Release|iPhoneSimulator.ActiveCfg = Release|iPhoneSimulator + {14BE2E7C-3220-4128-A8B2-45DCB985B844}.Release|iPhoneSimulator.Build.0 = Release|iPhoneSimulator + {14BE2E7C-3220-4128-A8B2-45DCB985B844}.Debug|iPhone.ActiveCfg = Debug|iPhone + {14BE2E7C-3220-4128-A8B2-45DCB985B844}.Debug|iPhone.Build.0 = Debug|iPhone + {14BE2E7C-3220-4128-A8B2-45DCB985B844}.Release|iPhone.ActiveCfg = Release|iPhone + {14BE2E7C-3220-4128-A8B2-45DCB985B844}.Release|iPhone.Build.0 = Release|iPhone + {14BE2E7C-3220-4128-A8B2-45DCB985B844}.Ad-Hoc|iPhone.ActiveCfg = Ad-Hoc|iPhone + {14BE2E7C-3220-4128-A8B2-45DCB985B844}.Ad-Hoc|iPhone.Build.0 = Ad-Hoc|iPhone + {14BE2E7C-3220-4128-A8B2-45DCB985B844}.AppStore|iPhone.ActiveCfg = AppStore|iPhone + {14BE2E7C-3220-4128-A8B2-45DCB985B844}.AppStore|iPhone.Build.0 = AppStore|iPhone + EndGlobalSection + GlobalSection(NestedProjects) = preSolution + EndGlobalSection +EndGlobal diff --git a/samples/unified/MasterDetail/paket.references b/samples/unified/MasterDetail/paket.references new file mode 100644 index 0000000..e69de29 diff --git a/samples/unified/SingleViewUniversal/paket.references b/samples/unified/SingleViewUniversal/paket.references new file mode 100644 index 0000000..e69de29 diff --git a/samples/unified/WatchkitTest/WatchkitTest.fsproj b/samples/unified/WatchkitTest/WatchkitTest.fsproj index 59e91af..a1bf72b 100644 --- a/samples/unified/WatchkitTest/WatchkitTest.fsproj +++ b/samples/unified/WatchkitTest/WatchkitTest.fsproj @@ -1,4 +1,4 @@ - + Debug @@ -97,7 +97,7 @@ - + @@ -105,4 +105,15 @@ + + + + + ..\..\..\packages\Xamarin.TestCloud.Agent\lib\Xamarin.iOS10\Calabash.dll + True + True + + + + \ No newline at end of file diff --git a/samples/unified/WatchkitTest/packages.config b/samples/unified/WatchkitTest/packages.config deleted file mode 100644 index e820753..0000000 --- a/samples/unified/WatchkitTest/packages.config +++ /dev/null @@ -1,4 +0,0 @@ - - - - \ No newline at end of file diff --git a/samples/unified/WatchkitTest/paket.references b/samples/unified/WatchkitTest/paket.references new file mode 100644 index 0000000..b077b8e --- /dev/null +++ b/samples/unified/WatchkitTest/paket.references @@ -0,0 +1 @@ +Xamarin.TestCloud.Agent \ No newline at end of file diff --git a/samples/unified/fullTest/fullTest.sln b/samples/unified/fullTest/fullTest.sln index 1e78fee..3f6570c 100644 --- a/samples/unified/fullTest/fullTest.sln +++ b/samples/unified/fullTest/fullTest.sln @@ -1,6 +1,11 @@  Microsoft Visual Studio Solution File, Format Version 11.00 # Visual Studio 2010 +Project("{2150E333-8FDC-42A3-9474-1A3956D46DE8}") = ".paket", ".paket", "{CA719849-C680-4F03-A1F7-C6390FD74148}" + ProjectSection(SolutionItems) = preProject + ..\..\..\paket.dependencies = ..\..\..\paket.dependencies + EndProjectSection +EndProject Project("{f2a71f9b-5d33-465a-a702-920d77279786}") = "fullTest", "fullTest.fsproj", "{A202739B-6E4E-4772-A2B6-2E427643FF15}" EndProject Global diff --git a/samples/unified/fullTest/paket.references b/samples/unified/fullTest/paket.references new file mode 100644 index 0000000..e69de29 diff --git a/samples/unified/singleview_tvOS/paket.references b/samples/unified/singleview_tvOS/paket.references new file mode 100644 index 0000000..e69de29 diff --git a/src/Testing/DisposalIssue/DisposalIssue.fsproj b/src/Testing/DisposalIssue/DisposalIssue.fsproj index 2f8514b..4d4c9ab 100644 --- a/src/Testing/DisposalIssue/DisposalIssue.fsproj +++ b/src/Testing/DisposalIssue/DisposalIssue.fsproj @@ -1,62 +1,88 @@ - - - - Debug - AnyCPU - {03D202B0-123E-4397-BCA9-36129CBA8518} - Library - DisposalIssue - DisposalIssue - - - true - full - false - bin\Debug - DEBUG - prompt - false - false - - - true - - - - - - - - true - pdbonly - true - bin\Release - prompt - - - false - true - - - - - - - - - - ..\packages\Unquote.2.2.2\lib\net40\Unquote.dll - - - - - - - - - - - - - + + + + Debug + AnyCPU + {03D202B0-123E-4397-BCA9-36129CBA8518} + Library + DisposalIssue + DisposalIssue + + + true + full + false + bin\Debug + DEBUG + prompt + false + false + + + true + + + + + + + + true + pdbonly + true + bin\Release + prompt + + + false + true + + + + + + + + + + + + + + + + + + + + + + + + + ..\..\..\packages\Unquote\lib\net40\Unquote.dll + True + True + + + + + + + ..\..\..\packages\Unquote\lib\net45\Unquote.dll + True + True + + + + + + + ..\..\..\packages\Unquote\lib\portable-net45+netcore45+wpa81+wp8+MonoAndroid1+MonoTouch1\Unquote.dll + True + True + + + + \ No newline at end of file diff --git a/src/Testing/DisposalIssue/packages.config b/src/Testing/DisposalIssue/packages.config deleted file mode 100644 index e3f4831..0000000 --- a/src/Testing/DisposalIssue/packages.config +++ /dev/null @@ -1,4 +0,0 @@ - - - - \ No newline at end of file diff --git a/src/Testing/DisposalIssue/paket.references b/src/Testing/DisposalIssue/paket.references new file mode 100644 index 0000000..bd6b144 --- /dev/null +++ b/src/Testing/DisposalIssue/paket.references @@ -0,0 +1 @@ +Unquote \ No newline at end of file diff --git a/src/XAmarin.UIProvider.iOSRuntime/paket.references b/src/XAmarin.UIProvider.iOSRuntime/paket.references new file mode 100644 index 0000000..e69de29 diff --git a/src/Xamarin.Android.DesignerTest/DesignerTest.sln b/src/Xamarin.Android.DesignerTest/DesignerTest.sln index fe81d4e..4805877 100644 --- a/src/Xamarin.Android.DesignerTest/DesignerTest.sln +++ b/src/Xamarin.Android.DesignerTest/DesignerTest.sln @@ -1,6 +1,11 @@ Microsoft Visual Studio Solution File, Format Version 12.00 # Visual Studio 2012 +Project("{2150E333-8FDC-42A3-9474-1A3956D46DE8}") = ".paket", ".paket", "{3E91C654-B9C4-4920-8C70-9E6254AB131D}" + ProjectSection(SolutionItems) = preProject + ..\..\paket.dependencies = ..\..\paket.dependencies + EndProjectSection +EndProject Project("{f2a71f9b-5d33-465a-a702-920d77279786}") = "DesignerTest", "DesignerTest\DesignerTest.fsproj", "{444D009C-7FF9-41A9-B92E-697A001F85C4}" EndProject Project("{FAE04EC0-301F-11D3-BF4B-00C04F79EFBC}") = "cs_test", "cs_test\cs_test.csproj", "{22BC1B43-F146-466A-8116-9972A2420EC4}" diff --git a/src/Xamarin.Android.DesignerTest/DesignerTest/paket.references b/src/Xamarin.Android.DesignerTest/DesignerTest/paket.references new file mode 100644 index 0000000..e69de29 diff --git a/src/Xamarin.Android.DesignerTest/cs_test/cs_test.csproj b/src/Xamarin.Android.DesignerTest/cs_test/cs_test.csproj index 576328d..def5ca6 100644 --- a/src/Xamarin.Android.DesignerTest/cs_test/cs_test.csproj +++ b/src/Xamarin.Android.DesignerTest/cs_test/cs_test.csproj @@ -1,4 +1,4 @@ - + Debug @@ -41,12 +41,6 @@ - - ..\packages\Xamarin.Android.Support.v4.23.1.1.0\lib\MonoAndroid403\Xamarin.Android.Support.v4.dll - - - ..\packages\Xamarin.Android.Support.v7.AppCompat.23.1.1.0\lib\MonoAndroid403\Xamarin.Android.Support.v7.AppCompat.dll - @@ -58,7 +52,7 @@ - + @@ -74,4 +68,26 @@ + + + + + ..\..\..\packages\Xamarin.Android.Support.v4\lib\MonoAndroid403\Xamarin.Android.Support.v4.dll + True + True + + + + + + + + + ..\..\..\packages\Xamarin.Android.Support.v7.AppCompat\lib\MonoAndroid403\Xamarin.Android.Support.v7.AppCompat.dll + True + True + + + + \ No newline at end of file diff --git a/src/Xamarin.Android.DesignerTest/cs_test/packages.config b/src/Xamarin.Android.DesignerTest/cs_test/packages.config deleted file mode 100644 index bcac260..0000000 --- a/src/Xamarin.Android.DesignerTest/cs_test/packages.config +++ /dev/null @@ -1,5 +0,0 @@ - - - - - \ No newline at end of file diff --git a/src/Xamarin.Android.DesignerTest/cs_test/paket.references b/src/Xamarin.Android.DesignerTest/cs_test/paket.references new file mode 100644 index 0000000..6820170 --- /dev/null +++ b/src/Xamarin.Android.DesignerTest/cs_test/paket.references @@ -0,0 +1,2 @@ +Xamarin.Android.Support.v4 +Xamarin.Android.Support.v7.AppCompat \ No newline at end of file diff --git a/src/Xamarin.Android.UIPRovider.sln b/src/Xamarin.Android.UIPRovider.sln index a42f144..60337a7 100644 --- a/src/Xamarin.Android.UIPRovider.sln +++ b/src/Xamarin.Android.UIPRovider.sln @@ -1,6 +1,11 @@ Microsoft Visual Studio Solution File, Format Version 12.00 # Visual Studio 2012 +Project("{2150E333-8FDC-42A3-9474-1A3956D46DE8}") = ".paket", ".paket", "{8076FAE0-3716-40F3-97DD-279AE3BC3226}" + ProjectSection(SolutionItems) = preProject + ..\paket.dependencies = ..\paket.dependencies + EndProjectSection +EndProject Project("{f2a71f9b-5d33-465a-a702-920d77279786}") = "Xamarin.Android.UIPRovider", "Xamarin.Android.UIPRovider\Xamarin.Android.UIPRovider.fsproj", "{BDF5D89F-10DD-4232-9C5D-D1488FC3EDF8}" EndProject Project("{f2a71f9b-5d33-465a-a702-920d77279786}") = "Xamarin.Android.UIProvider.Runtime", "Xamarin.Android.UIProvider.Runtime\Xamarin.Android.UIProvider.Runtime.fsproj", "{3AAE14BD-F10D-44C0-A09C-685C95B52646}" diff --git a/src/Xamarin.Android.UIPRovider/ProvidedTypes.fs b/src/Xamarin.Android.UIPRovider/ProvidedTypes.fs index 8c69de5..c6e67cf 100644 --- a/src/Xamarin.Android.UIPRovider/ProvidedTypes.fs +++ b/src/Xamarin.Android.UIPRovider/ProvidedTypes.fs @@ -1,2743 +1,2736 @@ -#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 = 2) - 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(message : string, isError) = obsoleteMessage <- Some (message,isError) - member __.HasParamArray with get() = hasParamArray and set(v) = hasParamArray <- v - member __.AddXmlDocComputed xmlDocFunction = xmlDocAlwaysRecomputed <- Some xmlDocFunction - member __.AddXmlDocDelayed xmlDocFunction = xmlDocDelayed <- Some xmlDocFunction - member __.AddXmlDoc xmlDoc = xmlDocDelayed <- Some (fun () -> xmlDoc) - 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 xmlDocFunction = customAttributesImpl.AddXmlDocDelayed xmlDocFunction - member __.AddXmlDocComputed xmlDocFunction = customAttributesImpl.AddXmlDocComputed xmlDocFunction - member __.AddXmlDoc xmlDoc = customAttributesImpl.AddXmlDoc xmlDoc - - 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 __.IsParamArray with get() = customAttributesImpl.HasParamArray and set(v) = customAttributesImpl.HasParamArray <- v - override __.Name = name - override __.ParameterType = parameterType - override __.Attributes = (base.Attributes ||| (if isOut then ParameterAttributes.Out else enum 0) - ||| (match optionalValue with None -> enum 0 | Some _ -> ParameterAttributes.Optional ||| ParameterAttributes.HasDefault)) - override __.RawDefaultValue = defaultArg optionalValue null - member __.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 isStatic() = ctorAttributes.HasFlag(MethodAttributes.Static) - - let customAttributesImpl = CustomAttributesImpl() - member __.IsTypeInitializer - with get() = isStatic() && ctorAttributes.HasFlag(MethodAttributes.Private) - and set(v) = - let typeInitializerAttributes = MethodAttributes.Static ||| MethodAttributes.Private - ctorAttributes <- if v then ctorAttributes ||| typeInitializerAttributes else ctorAttributes &&& ~~~typeInitializerAttributes - - member __.AddXmlDocComputed xmlDocFunction = customAttributesImpl.AddXmlDocComputed xmlDocFunction - member __.AddXmlDocDelayed xmlDocFunction = customAttributesImpl.AddXmlDocDelayed xmlDocFunction - member __.AddXmlDoc xmlDoc = customAttributesImpl.AddXmlDoc xmlDoc - member __.AddObsoleteAttribute (message,?isError) = customAttributesImpl.AddObsolete (message,defaultArg isError false) - member __.AddDefinitionLocation(line,column,filePath) = customAttributesImpl.AddDefinitionLocation(line, column, filePath) - member __.GetCustomAttributesDataImpl() = customAttributesImpl.GetCustomAttributesData() -#if FX_NO_CUSTOMATTRIBUTEDATA -#else - override __.GetCustomAttributesData() = customAttributesImpl.GetCustomAttributesData() -#endif - - member __.DeclaringTypeImpl - with set x = - if declaringType<>null then failwith (sprintf "ProvidedConstructor: declaringType already set on '%s'" (nameText())); - declaringType <- x - - member __.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 __.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 __.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 || isStatic() then [] else ["this"]) - |> Array.ofList - transQuotationToCode isGenerated f paramNames - | None -> failwith (sprintf "ProvidedConstructor: no invoker for '%s'" (nameText())) - - member __.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 __.IsImplicitCtor with get() = isImplicitCtor and set v = isImplicitCtor <- v - - // Implement overloads - override __.GetParameters() = parameters |> List.toArray - override __.Attributes = ctorAttributes - override __.Name = if isStatic() then ".cctor" else ".ctor" - override __.DeclaringType = declaringType |> nonNull "ProvidedConstructor.DeclaringType" - override __.IsDefined(_attributeType, _inherit) = true - - override __.Invoke(_invokeAttr, _binder, _parameters, _culture) = notRequired "Invoke" (nameText()) - override __.Invoke(_obj, _invokeAttr, _binder, _parameters, _culture) = notRequired "Invoke" (nameText()) - override __.ReflectedType = notRequired "ReflectedType" (nameText()) - override __.GetMethodImplementationFlags() = notRequired "GetMethodImplementationFlags" (nameText()) - override __.MethodHandle = notRequired "MethodHandle" (nameText()) - override __.GetCustomAttributes(_inherit) = notRequired "GetCustomAttributes" (nameText()) - override __.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 mutable staticParams = [ ] - let mutable staticParamsApply = None - let isStatic() = methodAttrs.HasFlag(MethodAttributes.Static) - let customAttributesImpl = CustomAttributesImpl() - - member __.AddXmlDocComputed xmlDocFunction = customAttributesImpl.AddXmlDocComputed xmlDocFunction - member __.AddXmlDocDelayed xmlDocFunction = customAttributesImpl.AddXmlDocDelayed xmlDocFunction - member __.AddXmlDoc xmlDoc = customAttributesImpl.AddXmlDoc xmlDoc - member __.AddObsoleteAttribute (message,?isError) = customAttributesImpl.AddObsolete (message,defaultArg isError false) - member __.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 __.GetCustomAttributesData() = customAttributesImpl.GetCustomAttributesData() -#endif - - member __.SetMethodAttrs m = methodAttrs <- m - member __.AddMethodAttrs m = methodAttrs <- methodAttrs ||| m - member __.DeclaringTypeImpl with set x = declaringType <- x // check: not set twice - member __.IsStaticMethod - with get() = isStatic() - and set x = if x then methodAttrs <- methodAttrs ||| MethodAttributes.Static - else methodAttrs <- methodAttrs &&& (~~~ MethodAttributes.Static) - - member __.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" methodName (if declaringType=null then "" else declaringType.FullName)) - - - /// Abstract a type to a parametric-type. Requires "formal parameters" and "instantiation function". - member __.DefineStaticParameters(staticParameters : list, apply : (string -> obj[] -> ProvidedMethod)) = - staticParams <- staticParameters - staticParamsApply <- Some apply - - /// Get ParameterInfo[] for the parametric type parameters (//s GetGenericParameters) - member __.GetStaticParameters() = [| for p in staticParams -> p :> ParameterInfo |] - - /// Instantiate parametrics type - member __.ApplyStaticArguments(mangledName: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 method %s" staticParams.Length args.Length methodName) - match staticParamsApply with - | None -> failwith "ProvidedTypeDefinition: DefineStaticParameters was not called" - | Some f -> f mangledName args - else - failwith (sprintf "ProvidedTypeDefinition: static parameters supplied but not expected for method %s" methodName) - - member __.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 isStatic() then [] else ["this"]) - |> Array.ofList - transQuotationToCode isGenerated f paramNames - | None -> failwith (sprintf "ProvidedMethod: no invoker for %s on type %s" methodName (if declaringType=null then "" else declaringType.FullName)) - - // Implement overloads - override __.GetParameters() = argParams |> Array.ofList - override __.Attributes = methodAttrs - override __.Name = methodName - override __.DeclaringType = declaringType |> nonNull "ProvidedMethod.DeclaringType" - override __.IsDefined(_attributeType, _inherit) : bool = true - override __.MemberType = MemberTypes.Method - override __.CallingConvention = - let cc = CallingConventions.Standard - let cc = if not (isStatic()) then cc ||| CallingConventions.HasThis else cc - cc - override __.ReturnType = returnType - override __.ReturnParameter = null // REVIEW: Give it a name and type? - override __.ToString() = "Method " + methodName - - // 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 __.MetadataToken = hash declaringType + hash methodName - override __.MethodHandle = RuntimeMethodHandle() - - override __.ReturnTypeCustomAttributes = notRequired "ReturnTypeCustomAttributes" methodName - override __.GetBaseDefinition() = notRequired "GetBaseDefinition" methodName - override __.GetMethodImplementationFlags() = notRequired "GetMethodImplementationFlags" methodName - override __.Invoke(_obj, _invokeAttr, _binder, _parameters, _culture) = notRequired "Invoke" methodName - override __.ReflectedType = notRequired "ReflectedType" methodName - override __.GetCustomAttributes(_inherit) = notRequired "GetCustomAttributes" methodName - override __.GetCustomAttributes(_attributeType, _inherit) = notRequired "GetCustomAttributes" methodName - - -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 __.AddXmlDocComputed xmlDocFunction = customAttributesImpl.AddXmlDocComputed xmlDocFunction - member __.AddXmlDocDelayed xmlDocFunction = customAttributesImpl.AddXmlDocDelayed xmlDocFunction - member __.AddXmlDoc xmlDoc = customAttributesImpl.AddXmlDoc xmlDoc - member __.AddObsoleteAttribute (message,?isError) = customAttributesImpl.AddObsolete (message,defaultArg isError false) - member __.AddDefinitionLocation(line,column,filePath) = customAttributesImpl.AddDefinitionLocation(line, column, filePath) - member __.GetCustomAttributesDataImpl() = customAttributesImpl.GetCustomAttributesData() - member __.AddCustomAttribute attribute = customAttributesImpl.AddCustomAttribute attribute -#if FX_NO_CUSTOMATTRIBUTEDATA -#else - override __.GetCustomAttributesData() = customAttributesImpl.GetCustomAttributesData() -#endif - - member __.DeclaringTypeImpl with set x = declaringType <- x // check: not set twice - - member __.IsStatic - with get() = isStatic - and set x = isStatic <- x - - member __.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 __.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 __.PropertyType = propertyType - override __.SetValue(_obj, _value, _invokeAttr, _binder, _index, _culture) = notRequired "SetValue" propertyName - override __.GetAccessors _nonPublic = notRequired "nonPublic" propertyName - override __.GetGetMethod _nonPublic = if hasGetter() then getter.Force() :> MethodInfo else null - override __.GetSetMethod _nonPublic = if hasSetter() then setter.Force() :> MethodInfo else null - override __.GetIndexParameters() = [| for p in parameters -> upcast p |] - override __.Attributes = PropertyAttributes.None - override __.CanRead = hasGetter() - override __.CanWrite = hasSetter() - override __.GetValue(_obj, _invokeAttr, _binder, _index, _culture) : obj = notRequired "GetValue" propertyName - override __.Name = propertyName - override __.DeclaringType = declaringType |> nonNull "ProvidedProperty.DeclaringType" - override __.MemberType : MemberTypes = MemberTypes.Property - - override __.ReflectedType = notRequired "ReflectedType" propertyName - override __.GetCustomAttributes(_inherit) = notRequired "GetCustomAttributes" propertyName - override __.GetCustomAttributes(_attributeType, _inherit) = notRequired "GetCustomAttributes" propertyName - override __.IsDefined(_attributeType, _inherit) = notRequired "IsDefined" propertyName - -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 __.AddXmlDocComputed xmlDocFunction = customAttributesImpl.AddXmlDocComputed xmlDocFunction - member __.AddXmlDocDelayed xmlDocFunction = customAttributesImpl.AddXmlDocDelayed xmlDocFunction - member __.AddXmlDoc xmlDoc = customAttributesImpl.AddXmlDoc xmlDoc - member __.AddDefinitionLocation(line,column,filePath) = customAttributesImpl.AddDefinitionLocation(line, column, filePath) - member __.GetCustomAttributesDataImpl() = customAttributesImpl.GetCustomAttributesData() -#if FX_NO_CUSTOMATTRIBUTEDATA -#else - override __.GetCustomAttributesData() = customAttributesImpl.GetCustomAttributesData() -#endif - - member __.DeclaringTypeImpl with set x = declaringType <- x // check: not set twice - member __.IsStatic - with get() = isStatic - and set x = isStatic <- x - - member __.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 __.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 __.EventHandlerType = eventHandlerType - override __.GetAddMethod _nonPublic = adder.Force() :> MethodInfo - override __.GetRemoveMethod _nonPublic = remover.Force() :> MethodInfo - override __.Attributes = EventAttributes.None - override __.Name = eventName - override __.DeclaringType = declaringType |> nonNull "ProvidedEvent.DeclaringType" - override __.MemberType : MemberTypes = MemberTypes.Event - - override __.GetRaiseMethod _nonPublic = notRequired "GetRaiseMethod" eventName - override __.ReflectedType = notRequired "ReflectedType" eventName - override __.GetCustomAttributes(_inherit) = notRequired "GetCustomAttributes" eventName - override __.GetCustomAttributes(_attributeType, _inherit) = notRequired "GetCustomAttributes" eventName - override __.IsDefined(_attributeType, _inherit) = notRequired "IsDefined" eventName - -type ProvidedLiteralField(fieldName:string,fieldType:Type,literalValue:obj) = - inherit System.Reflection.FieldInfo() - // State - - let mutable declaringType = null - - let customAttributesImpl = CustomAttributesImpl() - member __.AddXmlDocComputed xmlDocFunction = customAttributesImpl.AddXmlDocComputed xmlDocFunction - member __.AddXmlDocDelayed xmlDocFunction = customAttributesImpl.AddXmlDocDelayed xmlDocFunction - member __.AddXmlDoc xmlDoc = customAttributesImpl.AddXmlDoc xmlDoc - member __.AddObsoleteAttribute (message,?isError) = customAttributesImpl.AddObsolete (message,defaultArg isError false) - member __.AddDefinitionLocation(line,column,filePath) = customAttributesImpl.AddDefinitionLocation(line, column, filePath) - member __.GetCustomAttributesDataImpl() = customAttributesImpl.GetCustomAttributesData() -#if FX_NO_CUSTOMATTRIBUTEDATA -#else - override __.GetCustomAttributesData() = customAttributesImpl.GetCustomAttributesData() -#endif - - member __.DeclaringTypeImpl with set x = declaringType <- x // check: not set twice - - - // Implement overloads - override __.FieldType = fieldType - override __.GetRawConstantValue() = literalValue - override __.Attributes = FieldAttributes.Static ||| FieldAttributes.Literal ||| FieldAttributes.Public - override __.Name = fieldName - override __.DeclaringType = declaringType |> nonNull "ProvidedLiteralField.DeclaringType" - override __.MemberType : MemberTypes = MemberTypes.Field - - override __.ReflectedType = notRequired "ReflectedType" fieldName - override __.GetCustomAttributes(_inherit) = notRequired "GetCustomAttributes" fieldName - override __.GetCustomAttributes(_attributeType, _inherit) = notRequired "GetCustomAttributes" fieldName - override __.IsDefined(_attributeType, _inherit) = notRequired "IsDefined" fieldName - - override __.SetValue(_obj, _value, _invokeAttr, _binder, _culture) = notRequired "SetValue" fieldName - override __.GetValue(_obj) : obj = notRequired "GetValue" fieldName - override __.FieldHandle = notRequired "FieldHandle" fieldName - -type ProvidedField(fieldName:string,fieldType:Type) = - inherit System.Reflection.FieldInfo() - // State - - let mutable declaringType = null - - let customAttributesImpl = CustomAttributesImpl() - let mutable fieldAttrs = FieldAttributes.Private - member __.AddXmlDocComputed xmlDocFunction = customAttributesImpl.AddXmlDocComputed xmlDocFunction - member __.AddXmlDocDelayed xmlDocFunction = customAttributesImpl.AddXmlDocDelayed xmlDocFunction - member __.AddXmlDoc xmlDoc = customAttributesImpl.AddXmlDoc xmlDoc - member __.AddObsoleteAttribute (message,?isError) = customAttributesImpl.AddObsolete (message,defaultArg isError false) - member __.AddDefinitionLocation(line,column,filePath) = customAttributesImpl.AddDefinitionLocation(line, column, filePath) - member __.GetCustomAttributesDataImpl() = customAttributesImpl.GetCustomAttributesData() - member __.AddCustomAttribute attribute = customAttributesImpl.AddCustomAttribute attribute -#if FX_NO_CUSTOMATTRIBUTEDATA -#else - override __.GetCustomAttributesData() = customAttributesImpl.GetCustomAttributesData() -#endif - - member __.DeclaringTypeImpl with set x = declaringType <- x // check: not set twice - - member __.SetFieldAttributes attrs = fieldAttrs <- attrs - // Implement overloads - override __.FieldType = fieldType - override __.GetRawConstantValue() = null - override __.Attributes = fieldAttrs - override __.Name = fieldName - override __.DeclaringType = declaringType |> nonNull "ProvidedField.DeclaringType" - override __.MemberType : MemberTypes = MemberTypes.Field - - override __.ReflectedType = notRequired "ReflectedType" fieldName - override __.GetCustomAttributes(_inherit) = notRequired "GetCustomAttributes" fieldName - override __.GetCustomAttributes(_attributeType, _inherit) = notRequired "GetCustomAttributes" fieldName - override __.IsDefined(_attributeType, _inherit) = notRequired "IsDefined" fieldName - - override __.SetValue(_obj, _value, _invokeAttr, _binder, _culture) = notRequired "SetValue" fieldName - override __.GetValue(_obj) : obj = notRequired "GetValue" fieldName - override __.FieldHandle = notRequired "FieldHandle" fieldName - -/// 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 - - let nameText() = - 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" - - 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 __.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 __.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 __.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 __.Name = nameText() - - override __.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 __.GetArrayRank() = (match kind with SymbolKind.Array n -> n | SymbolKind.SDArray -> 1 | _ -> invalidOp "non-array type") - override __.IsArrayImpl() = (match kind with SymbolKind.Array _ | SymbolKind.SDArray -> true | _ -> false) - override __.IsByRefImpl() = (match kind with SymbolKind.ByRef _ -> true | _ -> false) - override __.IsPointerImpl() = (match kind with SymbolKind.Pointer _ -> true | _ -> false) - override __.IsPrimitiveImpl() = false - override __.IsGenericType = (match kind with SymbolKind.Generic _ -> true | _ -> false) - override __.GetGenericArguments() = (match kind with SymbolKind.Generic _ -> args |> List.toArray | _ -> invalidOp "non-generic type") - override __.GetGenericTypeDefinition() = (match kind with SymbolKind.Generic e -> e | _ -> invalidOp "non-generic type") - override __.IsCOMObjectImpl() = false - override __.HasElementTypeImpl() = (match kind with SymbolKind.Generic _ -> false | _ -> true) - override __.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 __.Assembly = - match kind with - | SymbolKind.FSharpTypeAbbreviation (assembly,_nsp,_path) -> assembly - | SymbolKind.Generic gty -> gty.Assembly - | _ -> notRequired "Assembly" (nameText()) - - override __.Namespace = - match kind with - | SymbolKind.FSharpTypeAbbreviation (_assembly,nsp,_path) -> nsp - | _ -> notRequired "Namespace" (nameText()) - - override __.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 __.Equals(other: obj) = - match other with - | :? ProvidedSymbolType as otherTy -> (kind, args) = (otherTy.Kind, otherTy.Args) - | _ -> false - - member __.Kind = kind - member __.Args = args - - override __.Module : Module = notRequired "Module" (nameText()) - override __.GetConstructors _bindingAttr = notRequired "GetConstructors" (nameText()) - override __.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" (nameText()) - override __.GetMembers _bindingAttr = notRequired "GetMembers" (nameText()) - override __.GetMethods _bindingAttr = notRequired "GetMethods" (nameText()) - override __.GetField(_name, _bindingAttr) = notRequired "GetField" (nameText()) - override __.GetFields _bindingAttr = notRequired "GetFields" (nameText()) - override __.GetInterface(_name, _ignoreCase) = notRequired "GetInterface" (nameText()) - override __.GetInterfaces() = notRequired "GetInterfaces" (nameText()) - override __.GetEvent(_name, _bindingAttr) = notRequired "GetEvent" (nameText()) - override __.GetEvents _bindingAttr = notRequired "GetEvents" (nameText()) - override __.GetProperties _bindingAttr = notRequired "GetProperties" (nameText()) - override __.GetPropertyImpl(_name, _bindingAttr, _binder, _returnType, _types, _modifiers) = notRequired "GetPropertyImpl" (nameText()) - override __.GetNestedTypes _bindingAttr = notRequired "GetNestedTypes" (nameText()) - override __.GetNestedType(_name, _bindingAttr) = notRequired "GetNestedType" (nameText()) - override __.GetAttributeFlagsImpl() = notRequired "GetAttributeFlagsImpl" (nameText()) - override this.UnderlyingSystemType = - match kind with - | SymbolKind.SDArray - | SymbolKind.Array _ - | SymbolKind.Pointer - | SymbolKind.FSharpTypeAbbreviation _ - | SymbolKind.ByRef -> upcast this - | SymbolKind.Generic gty -> gty.UnderlyingSystemType -#if FX_NO_CUSTOMATTRIBUTEDATA -#else - override __.GetCustomAttributesData() = ([| |] :> IList<_>) -#endif - override __.MemberType = notRequired "MemberType" (nameText()) - override __.GetMember(_name,_mt,_bindingAttr) = notRequired "GetMember" (nameText()) - override __.GUID = notRequired "GUID" (nameText()) - override __.InvokeMember(_name, _invokeAttr, _binder, _target, _args, _modifiers, _culture, _namedParameters) = notRequired "InvokeMember" (nameText()) - override __.AssemblyQualifiedName = notRequired "AssemblyQualifiedName" (nameText()) - override __.GetConstructorImpl(_bindingAttr, _binder, _callConvention, _types, _modifiers) = notRequired "GetConstructorImpl" (nameText()) - override __.GetCustomAttributes(_inherit) = [| |] - override __.GetCustomAttributes(_attributeType, _inherit) = [| |] - override __.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 __.Name = p.Name - override __.ParameterType = ProvidedSymbolType.convType parameters p.ParameterType - override __.Attributes = p.Attributes - override __.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 __.GetGenericMethodDefinition() = genericMethodDefinition - - override __.DeclaringType = ProvidedSymbolType.convType parameters genericMethodDefinition.DeclaringType - override __.ToString() = "Method " + genericMethodDefinition.Name - override __.Name = genericMethodDefinition.Name - override __.MetadataToken = genericMethodDefinition.MetadataToken - override __.Attributes = genericMethodDefinition.Attributes - override __.CallingConvention = genericMethodDefinition.CallingConvention - override __.MemberType = genericMethodDefinition.MemberType - - override __.IsDefined(_attributeType, _inherit) : bool = notRequired "IsDefined" genericMethodDefinition.Name - override __.ReturnType = ProvidedSymbolType.convType parameters genericMethodDefinition.ReturnType - override __.GetParameters() = genericMethodDefinition.GetParameters() |> Array.map convParam - override __.ReturnParameter = genericMethodDefinition.ReturnParameter |> convParam - override __.ReturnTypeCustomAttributes = notRequired "ReturnTypeCustomAttributes" genericMethodDefinition.Name - override __.GetBaseDefinition() = notRequired "GetBaseDefinition" genericMethodDefinition.Name - override __.GetMethodImplementationFlags() = notRequired "GetMethodImplementationFlags" genericMethodDefinition.Name - override __.MethodHandle = notRequired "MethodHandle" genericMethodDefinition.Name - override __.Invoke(_obj, _invokeAttr, _binder, _parameters, _culture) = notRequired "Invoke" genericMethodDefinition.Name - override __.ReflectedType = notRequired "ReflectedType" genericMethodDefinition.Name - override __.GetCustomAttributes(_inherit) = notRequired "GetCustomAttributes" genericMethodDefinition.Name - override __.GetCustomAttributes(_attributeType, _inherit) = notRequired "GetCustomAttributes" genericMethodDefinition.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 FSharp.Compiler.Service - // 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 __.One = typeof - member __.Product (m1,m2) = typedefof>.MakeGenericType [| m1;m2 |] - member __.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 __.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 __.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" className) - - 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" className) - - 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" className) - - 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" className) - - 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 __.AddXmlDocComputed xmlDocFunction = customAttributesImpl.AddXmlDocComputed xmlDocFunction - member __.AddXmlDocDelayed xmlDocFunction = customAttributesImpl.AddXmlDocDelayed xmlDocFunction - member __.AddXmlDoc xmlDoc = customAttributesImpl.AddXmlDoc xmlDoc - member __.AddObsoleteAttribute (message,?isError) = customAttributesImpl.AddObsolete (message,defaultArg isError false) - member __.AddDefinitionLocation(line,column,filePath) = customAttributesImpl.AddDefinitionLocation(line, column, filePath) - member __.HideObjectMethods with set v = customAttributesImpl.HideObjectMethods <- v - member __.NonNullable with set v = customAttributesImpl.NonNullable <- v - member __.GetCustomAttributesDataImpl() = customAttributesImpl.GetCustomAttributesData() - member __.AddCustomAttribute attribute = customAttributesImpl.AddCustomAttribute attribute -#if FX_NO_CUSTOMATTRIBUTEDATA -#else - override __.GetCustomAttributesData() = customAttributesImpl.GetCustomAttributesData() -#endif - - member __.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 __.UnderlyingSystemType = typeof - - member __.SetEnumUnderlyingType(ty) = enumUnderlyingType <- ty - - override __.GetEnumUnderlyingType() = if this.IsEnum then enumUnderlyingType else invalidOp "not enum type" - - member __.SetBaseType t = baseType <- lazy Some t - - member __.SetBaseTypeDelayed baseTypeFunction = baseType <- lazy (Some (baseTypeFunction())) - - member __.SetAttributes x = attributes <- x - - // Add MemberInfos - member __.AddMembersDelayed(membersFunction : unit -> list<#MemberInfo>) = - membersQueue.Add (fun () -> membersFunction() |> List.map (fun x -> patchUpAddedMemberInfo this x; x :> MemberInfo )) - - member __.AddMembers(memberInfos:list<#MemberInfo>) = (* strict *) - memberInfos |> List.iter (patchUpAddedMemberInfo this) // strict: patch up now - membersQueue.Add (fun () -> memberInfos |> List.map (fun x -> x :> MemberInfo)) - - member __.AddMember(memberInfo:MemberInfo) = - this.AddMembers [memberInfo] - - member __.AddMemberDelayed(memberFunction : unit -> #MemberInfo) = - this.AddMembersDelayed(fun () -> [memberFunction()]) - - member __.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 __.DefineStaticParameters(staticParameters : list, apply : (string -> obj[] -> ProvidedTypeDefinition)) = - staticParams <- staticParameters - staticParamsApply <- Some apply - - /// Get ParameterInfo[] for the parametric type parameters (//s GetGenericParameters) - member __.GetStaticParameters() = [| for p in staticParams -> p :> ParameterInfo |] - - /// Instantiate parametrics type - member __.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 __.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 __.Assembly = theAssembly.Force() - - member __.SetAssembly assembly = theAssembly <- lazy assembly - - member __.SetAssemblyLazy assembly = theAssembly <- assembly - - override __.FullName = fullName.Force() - - override __.Namespace = rootNamespace.Force() - - override __.BaseType = match baseType.Value with Some ty -> ty | None -> null - - // Constructors - override __.GetConstructors bindingAttr = - [| for m in this.GetMembers bindingAttr do - if m.MemberType = MemberTypes.Constructor then - yield (m :?> ConstructorInfo) |] - // Methods - override __.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 __.GetMethods bindingAttr = - this.GetMembers bindingAttr - |> Array.filter (fun m -> m.MemberType.HasFlag(MemberTypes.Method)) - |> Array.map (fun m -> m :?> MethodInfo) - - // Fields - override __.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 __.GetFields bindingAttr = - [| for m in this.GetMembers bindingAttr do if m.MemberType.HasFlag(MemberTypes.Field) then yield m :?> FieldInfo |] - - override __.GetInterface(_name, _ignoreCase) = notRequired "GetInterface" this.Name - - override __.GetInterfaces() = - [| yield! getInterfaces() |] - - member __.GetInterfaceImplementations() = - [| yield! getInterfaces() |] - - member __.AddInterfaceImplementation ityp = interfaceImpls.Add ityp - - member __.AddInterfaceImplementationsDelayed itypf = interfaceImplsDelayed.Add itypf - - member __.GetMethodOverrides() = - [| yield! methodOverrides |] - - member __.DefineMethodOverride (bodyMethInfo,declMethInfo) = methodOverrides.Add (bodyMethInfo, declMethInfo) - - // Events - override __.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 __.GetEvents bindingAttr = - [| for m in this.GetMembers bindingAttr do if m.MemberType.HasFlag(MemberTypes.Event) then yield downcast m |] - - // Properties - override __.GetProperties bindingAttr = - [| for m in this.GetMembers bindingAttr do if m.MemberType.HasFlag(MemberTypes.Property) then yield downcast m |] - - override __.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 __.MakeArrayType() = ProvidedSymbolType(SymbolKind.SDArray, [this]) :> Type - override __.MakeArrayType arg = ProvidedSymbolType(SymbolKind.Array arg, [this]) :> Type - override __.MakePointerType() = ProvidedSymbolType(SymbolKind.Pointer, [this]) :> Type - override __.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 __.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 __.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 __.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 __.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 __.GetAttributeFlagsImpl() = adjustTypeAttributes attributes this.IsNested - override __.IsArrayImpl() = false - override __.IsByRefImpl() = false - override __.IsPointerImpl() = false - override __.IsPrimitiveImpl() = false - override __.IsCOMObjectImpl() = false - override __.HasElementTypeImpl() = false - override __.Name = className - override __.DeclaringType = declaringType.Force() - override __.MemberType = if this.IsNested then MemberTypes.NestedType else MemberTypes.TypeInfo - override __.GetHashCode() = rootNamespace.GetHashCode() ^^^ className.GetHashCode() - override __.Equals(that:obj) = - match that with - | null -> false - | :? ProvidedTypeDefinition as ti -> System.Object.ReferenceEquals(this,ti) - | _ -> false - - override __.GetGenericArguments() = [||] - override __.ToString() = this.Name - - - override __.Module : Module = notRequired "Module" this.Name - override __.GUID = Guid.Empty - override __.GetConstructorImpl(_bindingAttr, _binder, _callConvention, _types, _modifiers) = null - override __.GetCustomAttributes(_inherit) = [| |] - override __.GetCustomAttributes(_attributeType, _inherit) = [| |] - override __.IsDefined(_attributeType: Type, _inherit) = false - - override __.GetElementType() = notRequired "Module" this.Name - override __.InvokeMember(_name, _invokeAttr, _binder, _target, _args, _modifiers, _culture, _namedParameters) = notRequired "Module" this.Name - override __.AssemblyQualifiedName = notRequired "Module" this.Name - member __.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 __.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 - let fieldType = - if plf.DeclaringType.IsEnum then field.FieldType.GetEnumUnderlyingType() - else field.FieldType - emit expectedState (Quotations.Expr.Value(field.GetRawConstantValue(), fieldType)) - | _ -> - 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 - | :? ProvidedLiteralField as plf when fieldMap.ContainsKey plf -> fieldMap.[plf] :> 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 - | Quotations.Patterns.DefaultValue(typ) as n -> - if typ.IsClass then ilg.Emit(OpCodes.Ldnull) - else failwith (sprintf "unknown expression '%A' in generated method" n) - | 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 - } - - -#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 __.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 __.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 __.RegisterProbingFolder (folder) = - // use GetFullPath to ensure that folder is valid - ignore(IO.Path.GetFullPath folder) - probingFolders.Add folder - - member __.RegisterRuntimeAssemblyLocationAsProbingFolder (config : TypeProviderConfig) = - config.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 this.Invalidate() = invalidateE.Trigger(this,EventArgs()) - - member __.GetStaticParametersForMethod(mb: MethodBase) = - printfn "In GetStaticParametersForMethod" - match mb with - | :? ProvidedMethod as t -> t.GetStaticParameters() - | _ -> [| |] - - member __.ApplyStaticArgumentsForMethod(mb: MethodBase, mangledName, objs) = - printfn "In ApplyStaticArgumentsForMethod" - match mb with - | :? ProvidedMethod as t -> t.ApplyStaticArguments(mangledName, objs) :> MethodBase - | _ -> failwith (sprintf "ApplyStaticArguments: static parameters for method %s are unexpected" mb.Name) - - interface ITypeProvider with - - [] - override __.Invalidate = invalidateE.Publish - - override __.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 __.GetStaticParameters(ty) = - match ty with - | :? ProvidedTypeDefinition as t -> - if ty.Name = t.Name (* REVIEW: use equality? *) then - t.GetStaticParameters() - else - [| |] - | _ -> [| |] - - override __.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 __.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 __.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 +#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 = 2) + 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(message : string, isError) = obsoleteMessage <- Some (message,isError) + member __.HasParamArray with get() = hasParamArray and set(v) = hasParamArray <- v + member __.AddXmlDocComputed xmlDocFunction = xmlDocAlwaysRecomputed <- Some xmlDocFunction + member __.AddXmlDocDelayed xmlDocFunction = xmlDocDelayed <- Some xmlDocFunction + member __.AddXmlDoc xmlDoc = xmlDocDelayed <- Some (fun () -> xmlDoc) + 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 xmlDocFunction = customAttributesImpl.AddXmlDocDelayed xmlDocFunction + member __.AddXmlDocComputed xmlDocFunction = customAttributesImpl.AddXmlDocComputed xmlDocFunction + member __.AddXmlDoc xmlDoc = customAttributesImpl.AddXmlDoc xmlDoc + + 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 __.IsParamArray with get() = customAttributesImpl.HasParamArray and set(v) = customAttributesImpl.HasParamArray <- v + override __.Name = name + override __.ParameterType = parameterType + override __.Attributes = (base.Attributes ||| (if isOut then ParameterAttributes.Out else enum 0) + ||| (match optionalValue with None -> enum 0 | Some _ -> ParameterAttributes.Optional ||| ParameterAttributes.HasDefault)) + override __.RawDefaultValue = defaultArg optionalValue null + member __.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 isStatic() = ctorAttributes.HasFlag(MethodAttributes.Static) + + let customAttributesImpl = CustomAttributesImpl() + member __.IsTypeInitializer + with get() = isStatic() && ctorAttributes.HasFlag(MethodAttributes.Private) + and set(v) = + let typeInitializerAttributes = MethodAttributes.Static ||| MethodAttributes.Private + ctorAttributes <- if v then ctorAttributes ||| typeInitializerAttributes else ctorAttributes &&& ~~~typeInitializerAttributes + + member __.AddXmlDocComputed xmlDocFunction = customAttributesImpl.AddXmlDocComputed xmlDocFunction + member __.AddXmlDocDelayed xmlDocFunction = customAttributesImpl.AddXmlDocDelayed xmlDocFunction + member __.AddXmlDoc xmlDoc = customAttributesImpl.AddXmlDoc xmlDoc + member __.AddObsoleteAttribute (message,?isError) = customAttributesImpl.AddObsolete (message,defaultArg isError false) + member __.AddDefinitionLocation(line,column,filePath) = customAttributesImpl.AddDefinitionLocation(line, column, filePath) + member __.GetCustomAttributesDataImpl() = customAttributesImpl.GetCustomAttributesData() +#if FX_NO_CUSTOMATTRIBUTEDATA +#else + override __.GetCustomAttributesData() = customAttributesImpl.GetCustomAttributesData() +#endif + + member __.DeclaringTypeImpl + with set x = + if declaringType<>null then failwith (sprintf "ProvidedConstructor: declaringType already set on '%s'" (nameText())); + declaringType <- x + + member __.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 __.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 __.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 || isStatic() then [] else ["this"]) + |> Array.ofList + transQuotationToCode isGenerated f paramNames + | None -> failwith (sprintf "ProvidedConstructor: no invoker for '%s'" (nameText())) + + member __.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 __.IsImplicitCtor with get() = isImplicitCtor and set v = isImplicitCtor <- v + + // Implement overloads + override __.GetParameters() = parameters |> List.toArray + override __.Attributes = ctorAttributes + override __.Name = if isStatic() then ".cctor" else ".ctor" + override __.DeclaringType = declaringType |> nonNull "ProvidedConstructor.DeclaringType" + override __.IsDefined(_attributeType, _inherit) = true + + override __.Invoke(_invokeAttr, _binder, _parameters, _culture) = notRequired "Invoke" (nameText()) + override __.Invoke(_obj, _invokeAttr, _binder, _parameters, _culture) = notRequired "Invoke" (nameText()) + override __.ReflectedType = notRequired "ReflectedType" (nameText()) + override __.GetMethodImplementationFlags() = notRequired "GetMethodImplementationFlags" (nameText()) + override __.MethodHandle = notRequired "MethodHandle" (nameText()) + override __.GetCustomAttributes(_inherit) = notRequired "GetCustomAttributes" (nameText()) + override __.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 mutable staticParams = [ ] + let mutable staticParamsApply = None + let isStatic() = methodAttrs.HasFlag(MethodAttributes.Static) + let customAttributesImpl = CustomAttributesImpl() + + member __.AddXmlDocComputed xmlDocFunction = customAttributesImpl.AddXmlDocComputed xmlDocFunction + member __.AddXmlDocDelayed xmlDocFunction = customAttributesImpl.AddXmlDocDelayed xmlDocFunction + member __.AddXmlDoc xmlDoc = customAttributesImpl.AddXmlDoc xmlDoc + member __.AddObsoleteAttribute (message,?isError) = customAttributesImpl.AddObsolete (message,defaultArg isError false) + member __.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 __.GetCustomAttributesData() = customAttributesImpl.GetCustomAttributesData() +#endif + + member __.SetMethodAttrs m = methodAttrs <- m + member __.AddMethodAttrs m = methodAttrs <- methodAttrs ||| m + member __.DeclaringTypeImpl with set x = declaringType <- x // check: not set twice + member __.IsStaticMethod + with get() = isStatic() + and set x = if x then methodAttrs <- methodAttrs ||| MethodAttributes.Static + else methodAttrs <- methodAttrs &&& (~~~ MethodAttributes.Static) + + member __.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" methodName (if declaringType=null then "" else declaringType.FullName)) + + + /// Abstract a type to a parametric-type. Requires "formal parameters" and "instantiation function". + member __.DefineStaticParameters(staticParameters : list, apply : (string -> obj[] -> ProvidedMethod)) = + staticParams <- staticParameters + staticParamsApply <- Some apply + + /// Get ParameterInfo[] for the parametric type parameters (//s GetGenericParameters) + member __.GetStaticParameters() = [| for p in staticParams -> p :> ParameterInfo |] + + /// Instantiate parametrics type + member __.ApplyStaticArguments(mangledName: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 method %s" staticParams.Length args.Length methodName) + match staticParamsApply with + | None -> failwith "ProvidedTypeDefinition: DefineStaticParameters was not called" + | Some f -> f mangledName args + else + failwith (sprintf "ProvidedTypeDefinition: static parameters supplied but not expected for method %s" methodName) + + member __.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 isStatic() then [] else ["this"]) + |> Array.ofList + transQuotationToCode isGenerated f paramNames + | None -> failwith (sprintf "ProvidedMethod: no invoker for %s on type %s" methodName (if declaringType=null then "" else declaringType.FullName)) + + // Implement overloads + override __.GetParameters() = argParams |> Array.ofList + override __.Attributes = methodAttrs + override __.Name = methodName + override __.DeclaringType = declaringType |> nonNull "ProvidedMethod.DeclaringType" + override __.IsDefined(_attributeType, _inherit) : bool = true + override __.MemberType = MemberTypes.Method + override __.CallingConvention = + let cc = CallingConventions.Standard + let cc = if not (isStatic()) then cc ||| CallingConventions.HasThis else cc + cc + override __.ReturnType = returnType + override __.ReturnParameter = null // REVIEW: Give it a name and type? + override __.ToString() = "Method " + methodName + + // 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 __.MetadataToken = hash declaringType + hash methodName + override __.MethodHandle = RuntimeMethodHandle() + + override __.ReturnTypeCustomAttributes = notRequired "ReturnTypeCustomAttributes" methodName + override __.GetBaseDefinition() = notRequired "GetBaseDefinition" methodName + override __.GetMethodImplementationFlags() = notRequired "GetMethodImplementationFlags" methodName + override __.Invoke(_obj, _invokeAttr, _binder, _parameters, _culture) = notRequired "Invoke" methodName + override __.ReflectedType = notRequired "ReflectedType" methodName + override __.GetCustomAttributes(_inherit) = notRequired "GetCustomAttributes" methodName + override __.GetCustomAttributes(_attributeType, _inherit) = notRequired "GetCustomAttributes" methodName + + +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 __.AddXmlDocComputed xmlDocFunction = customAttributesImpl.AddXmlDocComputed xmlDocFunction + member __.AddXmlDocDelayed xmlDocFunction = customAttributesImpl.AddXmlDocDelayed xmlDocFunction + member __.AddXmlDoc xmlDoc = customAttributesImpl.AddXmlDoc xmlDoc + member __.AddObsoleteAttribute (message,?isError) = customAttributesImpl.AddObsolete (message,defaultArg isError false) + member __.AddDefinitionLocation(line,column,filePath) = customAttributesImpl.AddDefinitionLocation(line, column, filePath) + member __.GetCustomAttributesDataImpl() = customAttributesImpl.GetCustomAttributesData() + member __.AddCustomAttribute attribute = customAttributesImpl.AddCustomAttribute attribute +#if FX_NO_CUSTOMATTRIBUTEDATA +#else + override __.GetCustomAttributesData() = customAttributesImpl.GetCustomAttributesData() +#endif + + member __.DeclaringTypeImpl with set x = declaringType <- x // check: not set twice + + member __.IsStatic + with get() = isStatic + and set x = isStatic <- x + + member __.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 __.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 __.PropertyType = propertyType + override __.SetValue(_obj, _value, _invokeAttr, _binder, _index, _culture) = notRequired "SetValue" propertyName + override __.GetAccessors _nonPublic = notRequired "nonPublic" propertyName + override __.GetGetMethod _nonPublic = if hasGetter() then getter.Force() :> MethodInfo else null + override __.GetSetMethod _nonPublic = if hasSetter() then setter.Force() :> MethodInfo else null + override __.GetIndexParameters() = [| for p in parameters -> upcast p |] + override __.Attributes = PropertyAttributes.None + override __.CanRead = hasGetter() + override __.CanWrite = hasSetter() + override __.GetValue(_obj, _invokeAttr, _binder, _index, _culture) : obj = notRequired "GetValue" propertyName + override __.Name = propertyName + override __.DeclaringType = declaringType |> nonNull "ProvidedProperty.DeclaringType" + override __.MemberType : MemberTypes = MemberTypes.Property + + override __.ReflectedType = notRequired "ReflectedType" propertyName + override __.GetCustomAttributes(_inherit) = notRequired "GetCustomAttributes" propertyName + override __.GetCustomAttributes(_attributeType, _inherit) = notRequired "GetCustomAttributes" propertyName + override __.IsDefined(_attributeType, _inherit) = notRequired "IsDefined" propertyName + +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 __.AddXmlDocComputed xmlDocFunction = customAttributesImpl.AddXmlDocComputed xmlDocFunction + member __.AddXmlDocDelayed xmlDocFunction = customAttributesImpl.AddXmlDocDelayed xmlDocFunction + member __.AddXmlDoc xmlDoc = customAttributesImpl.AddXmlDoc xmlDoc + member __.AddDefinitionLocation(line,column,filePath) = customAttributesImpl.AddDefinitionLocation(line, column, filePath) + member __.GetCustomAttributesDataImpl() = customAttributesImpl.GetCustomAttributesData() +#if FX_NO_CUSTOMATTRIBUTEDATA +#else + override __.GetCustomAttributesData() = customAttributesImpl.GetCustomAttributesData() +#endif + + member __.DeclaringTypeImpl with set x = declaringType <- x // check: not set twice + member __.IsStatic + with get() = isStatic + and set x = isStatic <- x + + member __.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 __.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 __.EventHandlerType = eventHandlerType + override __.GetAddMethod _nonPublic = adder.Force() :> MethodInfo + override __.GetRemoveMethod _nonPublic = remover.Force() :> MethodInfo + override __.Attributes = EventAttributes.None + override __.Name = eventName + override __.DeclaringType = declaringType |> nonNull "ProvidedEvent.DeclaringType" + override __.MemberType : MemberTypes = MemberTypes.Event + + override __.GetRaiseMethod _nonPublic = notRequired "GetRaiseMethod" eventName + override __.ReflectedType = notRequired "ReflectedType" eventName + override __.GetCustomAttributes(_inherit) = notRequired "GetCustomAttributes" eventName + override __.GetCustomAttributes(_attributeType, _inherit) = notRequired "GetCustomAttributes" eventName + override __.IsDefined(_attributeType, _inherit) = notRequired "IsDefined" eventName + +type ProvidedLiteralField(fieldName:string,fieldType:Type,literalValue:obj) = + inherit System.Reflection.FieldInfo() + // State + + let mutable declaringType = null + + let customAttributesImpl = CustomAttributesImpl() + member __.AddXmlDocComputed xmlDocFunction = customAttributesImpl.AddXmlDocComputed xmlDocFunction + member __.AddXmlDocDelayed xmlDocFunction = customAttributesImpl.AddXmlDocDelayed xmlDocFunction + member __.AddXmlDoc xmlDoc = customAttributesImpl.AddXmlDoc xmlDoc + member __.AddObsoleteAttribute (message,?isError) = customAttributesImpl.AddObsolete (message,defaultArg isError false) + member __.AddDefinitionLocation(line,column,filePath) = customAttributesImpl.AddDefinitionLocation(line, column, filePath) + member __.GetCustomAttributesDataImpl() = customAttributesImpl.GetCustomAttributesData() +#if FX_NO_CUSTOMATTRIBUTEDATA +#else + override __.GetCustomAttributesData() = customAttributesImpl.GetCustomAttributesData() +#endif + + member __.DeclaringTypeImpl with set x = declaringType <- x // check: not set twice + + + // Implement overloads + override __.FieldType = fieldType + override __.GetRawConstantValue() = literalValue + override __.Attributes = FieldAttributes.Static ||| FieldAttributes.Literal ||| FieldAttributes.Public + override __.Name = fieldName + override __.DeclaringType = declaringType |> nonNull "ProvidedLiteralField.DeclaringType" + override __.MemberType : MemberTypes = MemberTypes.Field + + override __.ReflectedType = notRequired "ReflectedType" fieldName + override __.GetCustomAttributes(_inherit) = notRequired "GetCustomAttributes" fieldName + override __.GetCustomAttributes(_attributeType, _inherit) = notRequired "GetCustomAttributes" fieldName + override __.IsDefined(_attributeType, _inherit) = notRequired "IsDefined" fieldName + + override __.SetValue(_obj, _value, _invokeAttr, _binder, _culture) = notRequired "SetValue" fieldName + override __.GetValue(_obj) : obj = notRequired "GetValue" fieldName + override __.FieldHandle = notRequired "FieldHandle" fieldName + +type ProvidedField(fieldName:string,fieldType:Type) = + inherit System.Reflection.FieldInfo() + // State + + let mutable declaringType = null + + let customAttributesImpl = CustomAttributesImpl() + let mutable fieldAttrs = FieldAttributes.Private + member __.AddXmlDocComputed xmlDocFunction = customAttributesImpl.AddXmlDocComputed xmlDocFunction + member __.AddXmlDocDelayed xmlDocFunction = customAttributesImpl.AddXmlDocDelayed xmlDocFunction + member __.AddXmlDoc xmlDoc = customAttributesImpl.AddXmlDoc xmlDoc + member __.AddObsoleteAttribute (message,?isError) = customAttributesImpl.AddObsolete (message,defaultArg isError false) + member __.AddDefinitionLocation(line,column,filePath) = customAttributesImpl.AddDefinitionLocation(line, column, filePath) + member __.GetCustomAttributesDataImpl() = customAttributesImpl.GetCustomAttributesData() +#if FX_NO_CUSTOMATTRIBUTEDATA +#else + override __.GetCustomAttributesData() = customAttributesImpl.GetCustomAttributesData() +#endif + + member __.DeclaringTypeImpl with set x = declaringType <- x // check: not set twice + + member __.SetFieldAttributes attrs = fieldAttrs <- attrs + // Implement overloads + override __.FieldType = fieldType + override __.GetRawConstantValue() = null + override __.Attributes = fieldAttrs + override __.Name = fieldName + override __.DeclaringType = declaringType |> nonNull "ProvidedField.DeclaringType" + override __.MemberType : MemberTypes = MemberTypes.Field + + override __.ReflectedType = notRequired "ReflectedType" fieldName + override __.GetCustomAttributes(_inherit) = notRequired "GetCustomAttributes" fieldName + override __.GetCustomAttributes(_attributeType, _inherit) = notRequired "GetCustomAttributes" fieldName + override __.IsDefined(_attributeType, _inherit) = notRequired "IsDefined" fieldName + + override __.SetValue(_obj, _value, _invokeAttr, _binder, _culture) = notRequired "SetValue" fieldName + override __.GetValue(_obj) : obj = notRequired "GetValue" fieldName + override __.FieldHandle = notRequired "FieldHandle" fieldName + +/// 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 + + let nameText() = + 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" + + 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 __.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 __.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 __.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 __.Name = nameText() + + override __.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 __.GetArrayRank() = (match kind with SymbolKind.Array n -> n | SymbolKind.SDArray -> 1 | _ -> invalidOp "non-array type") + override __.IsArrayImpl() = (match kind with SymbolKind.Array _ | SymbolKind.SDArray -> true | _ -> false) + override __.IsByRefImpl() = (match kind with SymbolKind.ByRef _ -> true | _ -> false) + override __.IsPointerImpl() = (match kind with SymbolKind.Pointer _ -> true | _ -> false) + override __.IsPrimitiveImpl() = false + override __.IsGenericType = (match kind with SymbolKind.Generic _ -> true | _ -> false) + override __.GetGenericArguments() = (match kind with SymbolKind.Generic _ -> args |> List.toArray | _ -> invalidOp "non-generic type") + override __.GetGenericTypeDefinition() = (match kind with SymbolKind.Generic e -> e | _ -> invalidOp "non-generic type") + override __.IsCOMObjectImpl() = false + override __.HasElementTypeImpl() = (match kind with SymbolKind.Generic _ -> false | _ -> true) + override __.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 __.Assembly = + match kind with + | SymbolKind.FSharpTypeAbbreviation (assembly,_nsp,_path) -> assembly + | SymbolKind.Generic gty -> gty.Assembly + | _ -> notRequired "Assembly" (nameText()) + + override __.Namespace = + match kind with + | SymbolKind.FSharpTypeAbbreviation (_assembly,nsp,_path) -> nsp + | _ -> notRequired "Namespace" (nameText()) + + override __.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 __.Equals(other: obj) = + match other with + | :? ProvidedSymbolType as otherTy -> (kind, args) = (otherTy.Kind, otherTy.Args) + | _ -> false + + member __.Kind = kind + member __.Args = args + + override __.Module : Module = notRequired "Module" (nameText()) + override __.GetConstructors _bindingAttr = notRequired "GetConstructors" (nameText()) + override __.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" (nameText()) + override __.GetMembers _bindingAttr = notRequired "GetMembers" (nameText()) + override __.GetMethods _bindingAttr = notRequired "GetMethods" (nameText()) + override __.GetField(_name, _bindingAttr) = notRequired "GetField" (nameText()) + override __.GetFields _bindingAttr = notRequired "GetFields" (nameText()) + override __.GetInterface(_name, _ignoreCase) = notRequired "GetInterface" (nameText()) + override __.GetInterfaces() = notRequired "GetInterfaces" (nameText()) + override __.GetEvent(_name, _bindingAttr) = notRequired "GetEvent" (nameText()) + override __.GetEvents _bindingAttr = notRequired "GetEvents" (nameText()) + override __.GetProperties _bindingAttr = notRequired "GetProperties" (nameText()) + override __.GetPropertyImpl(_name, _bindingAttr, _binder, _returnType, _types, _modifiers) = notRequired "GetPropertyImpl" (nameText()) + override __.GetNestedTypes _bindingAttr = notRequired "GetNestedTypes" (nameText()) + override __.GetNestedType(_name, _bindingAttr) = notRequired "GetNestedType" (nameText()) + override __.GetAttributeFlagsImpl() = notRequired "GetAttributeFlagsImpl" (nameText()) + override this.UnderlyingSystemType = + match kind with + | SymbolKind.SDArray + | SymbolKind.Array _ + | SymbolKind.Pointer + | SymbolKind.FSharpTypeAbbreviation _ + | SymbolKind.ByRef -> upcast this + | SymbolKind.Generic gty -> gty.UnderlyingSystemType +#if FX_NO_CUSTOMATTRIBUTEDATA +#else + override __.GetCustomAttributesData() = ([| |] :> IList<_>) +#endif + override __.MemberType = notRequired "MemberType" (nameText()) + override __.GetMember(_name,_mt,_bindingAttr) = notRequired "GetMember" (nameText()) + override __.GUID = notRequired "GUID" (nameText()) + override __.InvokeMember(_name, _invokeAttr, _binder, _target, _args, _modifiers, _culture, _namedParameters) = notRequired "InvokeMember" (nameText()) + override __.AssemblyQualifiedName = notRequired "AssemblyQualifiedName" (nameText()) + override __.GetConstructorImpl(_bindingAttr, _binder, _callConvention, _types, _modifiers) = notRequired "GetConstructorImpl" (nameText()) + override __.GetCustomAttributes(_inherit) = [| |] + override __.GetCustomAttributes(_attributeType, _inherit) = [| |] + override __.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 __.Name = p.Name + override __.ParameterType = ProvidedSymbolType.convType parameters p.ParameterType + override __.Attributes = p.Attributes + override __.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 __.GetGenericMethodDefinition() = genericMethodDefinition + + override __.DeclaringType = ProvidedSymbolType.convType parameters genericMethodDefinition.DeclaringType + override __.ToString() = "Method " + genericMethodDefinition.Name + override __.Name = genericMethodDefinition.Name + override __.MetadataToken = genericMethodDefinition.MetadataToken + override __.Attributes = genericMethodDefinition.Attributes + override __.CallingConvention = genericMethodDefinition.CallingConvention + override __.MemberType = genericMethodDefinition.MemberType + + override __.IsDefined(_attributeType, _inherit) : bool = notRequired "IsDefined" genericMethodDefinition.Name + override __.ReturnType = ProvidedSymbolType.convType parameters genericMethodDefinition.ReturnType + override __.GetParameters() = genericMethodDefinition.GetParameters() |> Array.map convParam + override __.ReturnParameter = genericMethodDefinition.ReturnParameter |> convParam + override __.ReturnTypeCustomAttributes = notRequired "ReturnTypeCustomAttributes" genericMethodDefinition.Name + override __.GetBaseDefinition() = notRequired "GetBaseDefinition" genericMethodDefinition.Name + override __.GetMethodImplementationFlags() = notRequired "GetMethodImplementationFlags" genericMethodDefinition.Name + override __.MethodHandle = notRequired "MethodHandle" genericMethodDefinition.Name + override __.Invoke(_obj, _invokeAttr, _binder, _parameters, _culture) = notRequired "Invoke" genericMethodDefinition.Name + override __.ReflectedType = notRequired "ReflectedType" genericMethodDefinition.Name + override __.GetCustomAttributes(_inherit) = notRequired "GetCustomAttributes" genericMethodDefinition.Name + override __.GetCustomAttributes(_attributeType, _inherit) = notRequired "GetCustomAttributes" genericMethodDefinition.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 FSharp.Compiler.Service + // 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 __.One = typeof + member __.Product (m1,m2) = typedefof>.MakeGenericType [| m1;m2 |] + member __.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 __.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 __.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" className) + + 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" className) + + 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" className) + + 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" className) + + 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 __.AddXmlDocComputed xmlDocFunction = customAttributesImpl.AddXmlDocComputed xmlDocFunction + member __.AddXmlDocDelayed xmlDocFunction = customAttributesImpl.AddXmlDocDelayed xmlDocFunction + member __.AddXmlDoc xmlDoc = customAttributesImpl.AddXmlDoc xmlDoc + member __.AddObsoleteAttribute (message,?isError) = customAttributesImpl.AddObsolete (message,defaultArg isError false) + member __.AddDefinitionLocation(line,column,filePath) = customAttributesImpl.AddDefinitionLocation(line, column, filePath) + member __.HideObjectMethods with set v = customAttributesImpl.HideObjectMethods <- v + member __.NonNullable with set v = customAttributesImpl.NonNullable <- v + member __.GetCustomAttributesDataImpl() = customAttributesImpl.GetCustomAttributesData() + member __.AddCustomAttribute attribute = customAttributesImpl.AddCustomAttribute attribute +#if FX_NO_CUSTOMATTRIBUTEDATA +#else + override __.GetCustomAttributesData() = customAttributesImpl.GetCustomAttributesData() +#endif + + member __.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 __.UnderlyingSystemType = typeof + + member __.SetEnumUnderlyingType(ty) = enumUnderlyingType <- ty + + override __.GetEnumUnderlyingType() = if this.IsEnum then enumUnderlyingType else invalidOp "not enum type" + + member __.SetBaseType t = baseType <- lazy Some t + + member __.SetBaseTypeDelayed baseTypeFunction = baseType <- lazy (Some (baseTypeFunction())) + + member __.SetAttributes x = attributes <- x + + // Add MemberInfos + member __.AddMembersDelayed(membersFunction : unit -> list<#MemberInfo>) = + membersQueue.Add (fun () -> membersFunction() |> List.map (fun x -> patchUpAddedMemberInfo this x; x :> MemberInfo )) + + member __.AddMembers(memberInfos:list<#MemberInfo>) = (* strict *) + memberInfos |> List.iter (patchUpAddedMemberInfo this) // strict: patch up now + membersQueue.Add (fun () -> memberInfos |> List.map (fun x -> x :> MemberInfo)) + + member __.AddMember(memberInfo:MemberInfo) = + this.AddMembers [memberInfo] + + member __.AddMemberDelayed(memberFunction : unit -> #MemberInfo) = + this.AddMembersDelayed(fun () -> [memberFunction()]) + + member __.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 __.DefineStaticParameters(staticParameters : list, apply : (string -> obj[] -> ProvidedTypeDefinition)) = + staticParams <- staticParameters + staticParamsApply <- Some apply + + /// Get ParameterInfo[] for the parametric type parameters (//s GetGenericParameters) + member __.GetStaticParameters() = [| for p in staticParams -> p :> ParameterInfo |] + + /// Instantiate parametrics type + member __.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 __.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 __.Assembly = theAssembly.Force() + + member __.SetAssembly assembly = theAssembly <- lazy assembly + + member __.SetAssemblyLazy assembly = theAssembly <- assembly + + override __.FullName = fullName.Force() + + override __.Namespace = rootNamespace.Force() + + override __.BaseType = match baseType.Value with Some ty -> ty | None -> null + + // Constructors + override __.GetConstructors bindingAttr = + [| for m in this.GetMembers bindingAttr do + if m.MemberType = MemberTypes.Constructor then + yield (m :?> ConstructorInfo) |] + // Methods + override __.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 __.GetMethods bindingAttr = + this.GetMembers bindingAttr + |> Array.filter (fun m -> m.MemberType.HasFlag(MemberTypes.Method)) + |> Array.map (fun m -> m :?> MethodInfo) + + // Fields + override __.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 __.GetFields bindingAttr = + [| for m in this.GetMembers bindingAttr do if m.MemberType.HasFlag(MemberTypes.Field) then yield m :?> FieldInfo |] + + override __.GetInterface(_name, _ignoreCase) = notRequired "GetInterface" this.Name + + override __.GetInterfaces() = + [| yield! getInterfaces() |] + + member __.GetInterfaceImplementations() = + [| yield! getInterfaces() |] + + member __.AddInterfaceImplementation ityp = interfaceImpls.Add ityp + + member __.AddInterfaceImplementationsDelayed itypf = interfaceImplsDelayed.Add itypf + + member __.GetMethodOverrides() = + [| yield! methodOverrides |] + + member __.DefineMethodOverride (bodyMethInfo,declMethInfo) = methodOverrides.Add (bodyMethInfo, declMethInfo) + + // Events + override __.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 __.GetEvents bindingAttr = + [| for m in this.GetMembers bindingAttr do if m.MemberType.HasFlag(MemberTypes.Event) then yield downcast m |] + + // Properties + override __.GetProperties bindingAttr = + [| for m in this.GetMembers bindingAttr do if m.MemberType.HasFlag(MemberTypes.Property) then yield downcast m |] + + override __.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 __.MakeArrayType() = ProvidedSymbolType(SymbolKind.SDArray, [this]) :> Type + override __.MakeArrayType arg = ProvidedSymbolType(SymbolKind.Array arg, [this]) :> Type + override __.MakePointerType() = ProvidedSymbolType(SymbolKind.Pointer, [this]) :> Type + override __.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 __.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 __.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 __.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 __.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 __.GetAttributeFlagsImpl() = adjustTypeAttributes attributes this.IsNested + override __.IsArrayImpl() = false + override __.IsByRefImpl() = false + override __.IsPointerImpl() = false + override __.IsPrimitiveImpl() = false + override __.IsCOMObjectImpl() = false + override __.HasElementTypeImpl() = false + override __.Name = className + override __.DeclaringType = declaringType.Force() + override __.MemberType = if this.IsNested then MemberTypes.NestedType else MemberTypes.TypeInfo + override __.GetHashCode() = rootNamespace.GetHashCode() ^^^ className.GetHashCode() + override __.Equals(that:obj) = + match that with + | null -> false + | :? ProvidedTypeDefinition as ti -> System.Object.ReferenceEquals(this,ti) + | _ -> false + + override __.GetGenericArguments() = [||] + override __.ToString() = this.Name + + + override __.Module : Module = notRequired "Module" this.Name + override __.GUID = Guid.Empty + override __.GetConstructorImpl(_bindingAttr, _binder, _callConvention, _types, _modifiers) = null + override __.GetCustomAttributes(_inherit) = [| |] + override __.GetCustomAttributes(_attributeType, _inherit) = [| |] + override __.IsDefined(_attributeType: Type, _inherit) = false + + override __.GetElementType() = notRequired "Module" this.Name + override __.InvokeMember(_name, _invokeAttr, _binder, _target, _args, _modifiers, _culture, _namedParameters) = notRequired "Module" this.Name + override __.AssemblyQualifiedName = notRequired "Module" this.Name + member __.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 __.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 + } + + +#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 __.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 __.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 __.RegisterProbingFolder (folder) = + // use GetFullPath to ensure that folder is valid + ignore(IO.Path.GetFullPath folder) + probingFolders.Add folder + + member __.RegisterRuntimeAssemblyLocationAsProbingFolder (config : TypeProviderConfig) = + config.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 this.Invalidate() = invalidateE.Trigger(this,EventArgs()) + + member __.GetStaticParametersForMethod(mb: MethodBase) = + printfn "In GetStaticParametersForMethod" + match mb with + | :? ProvidedMethod as t -> t.GetStaticParameters() + | _ -> [| |] + + member __.ApplyStaticArgumentsForMethod(mb: MethodBase, mangledName, objs) = + printfn "In ApplyStaticArgumentsForMethod" + match mb with + | :? ProvidedMethod as t -> t.ApplyStaticArguments(mangledName, objs) :> MethodBase + | _ -> failwith (sprintf "ApplyStaticArguments: static parameters for method %s are unexpected" mb.Name) + + interface ITypeProvider with + + [] + override __.Invalidate = invalidateE.Publish + + override __.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 __.GetStaticParameters(ty) = + match ty with + | :? ProvidedTypeDefinition as t -> + if ty.Name = t.Name (* REVIEW: use equality? *) then + t.GetStaticParameters() + else + [| |] + | _ -> [| |] + + override __.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 __.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 __.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/src/Xamarin.Android.UIPRovider/ProvidedTypes.fsi b/src/Xamarin.Android.UIPRovider/ProvidedTypes.fsi index c737473..3eb5025 100644 --- a/src/Xamarin.Android.UIPRovider/ProvidedTypes.fsi +++ b/src/Xamarin.Android.UIPRovider/ProvidedTypes.fsi @@ -225,9 +225,6 @@ type ProvidedField = member AddDefinitionLocation : line:int * column:int * filePath:string -> unit member SetFieldAttributes : attributes : FieldAttributes -> unit - - /// Add a custom attribute to the provided property definition. - member AddCustomAttribute : CustomAttributeData -> unit /// Represents the type constructor in a provided symbol type. [] diff --git a/src/Xamarin.Android.UIPRovider/Xamarin.Android.UIPRovider.fsproj b/src/Xamarin.Android.UIPRovider/Xamarin.Android.UIPRovider.fsproj index 11482cb..35310db 100644 --- a/src/Xamarin.Android.UIPRovider/Xamarin.Android.UIPRovider.fsproj +++ b/src/Xamarin.Android.UIPRovider/Xamarin.Android.UIPRovider.fsproj @@ -1,4 +1,4 @@ - + Debug AnyCPU @@ -17,7 +17,8 @@ prompt false None - + + @@ -27,11 +28,13 @@ true ..\build\Release - + + prompt false true - + + @@ -44,19 +47,33 @@ ..\..\..\..\..\Library\Frameworks\Xamarin.Android.framework\Versions\6.1.99-76\lib\xbuild-frameworks\MonoAndroid\v1.0\Java.Interop.dll - - ..\packages\ExtCore.0.8.45\lib\net45\ExtCore.dll - - - - + + True + + + True + + + True + - + + + + + + ..\..\packages\ExtCore\lib\net45\ExtCore.dll + True + True + + + + \ No newline at end of file diff --git a/src/Xamarin.Android.UIPRovider/Xamarin.Android.UIPRovider.sln b/src/Xamarin.Android.UIPRovider/Xamarin.Android.UIPRovider.sln index 457f6bf..c780ed0 100644 --- a/src/Xamarin.Android.UIPRovider/Xamarin.Android.UIPRovider.sln +++ b/src/Xamarin.Android.UIPRovider/Xamarin.Android.UIPRovider.sln @@ -1,6 +1,11 @@ Microsoft Visual Studio Solution File, Format Version 12.00 # Visual Studio 2012 +Project("{2150E333-8FDC-42A3-9474-1A3956D46DE8}") = ".paket", ".paket", "{D61A1AF4-6CA9-44F7-962D-6F855A57F620}" + ProjectSection(SolutionItems) = preProject + ..\..\paket.dependencies = ..\..\paket.dependencies + EndProjectSection +EndProject Project("{f2a71f9b-5d33-465a-a702-920d77279786}") = "Xamarin.Android.UIPRovider", "Xamarin.Android.UIPRovider.fsproj", "{BDF5D89F-10DD-4232-9C5D-D1488FC3EDF8}" EndProject Global diff --git a/src/Xamarin.Android.UIPRovider/packages.config b/src/Xamarin.Android.UIPRovider/packages.config deleted file mode 100644 index ecb345a..0000000 --- a/src/Xamarin.Android.UIPRovider/packages.config +++ /dev/null @@ -1,5 +0,0 @@ - - - - - \ No newline at end of file diff --git a/src/Xamarin.Android.UIPRovider/paket.references b/src/Xamarin.Android.UIPRovider/paket.references new file mode 100644 index 0000000..2afac44 --- /dev/null +++ b/src/Xamarin.Android.UIPRovider/paket.references @@ -0,0 +1,2 @@ +ExtCore +FSharp.TypeProviders.StarterPack \ No newline at end of file diff --git a/src/Xamarin.Android.UIProvider.Runtime/paket.references b/src/Xamarin.Android.UIProvider.Runtime/paket.references new file mode 100644 index 0000000..e69de29 diff --git a/src/Xamarin.UIProvider.OSXRuntime/paket.references b/src/Xamarin.UIProvider.OSXRuntime/paket.references new file mode 100644 index 0000000..e69de29 diff --git a/src/Xamarin.UIProvider.TVOSRuntime/paket.references b/src/Xamarin.UIProvider.TVOSRuntime/paket.references new file mode 100644 index 0000000..e69de29 diff --git a/src/Xamarin.iOSProviders.sln b/src/Xamarin.iOSProviders.sln index 8d6af0e..f4aced0 100644 --- a/src/Xamarin.iOSProviders.sln +++ b/src/Xamarin.iOSProviders.sln @@ -1,106 +1,111 @@ - -Microsoft Visual Studio Solution File, Format Version 12.00 -# Visual Studio 2012 -Project("{f2a71f9b-5d33-465a-a702-920d77279786}") = "Xamarin.UIProviders.DesignTime", "Xamarin.iOSProviders\Xamarin.UIProviders.DesignTime.fsproj", "{DD17E7B0-6EE1-4862-80F8-E0CAB67D6137}" -EndProject -Project("{f2a71f9b-5d33-465a-a702-920d77279786}") = "Xamarin.UIProvider.TVOSRuntime", "Xamarin.UIProvider.TVOSRuntime\Xamarin.UIProvider.TVOSRuntime.fsproj", "{4F84B7DD-A5E0-4BC3-9C9F-565988030202}" -EndProject -Project("{f2a71f9b-5d33-465a-a702-920d77279786}") = "Xamarin.UIProvider.iOSRuntime", "Xamarin.UIProvider.iOSRuntime\Xamarin.UIProvider.iOSRuntime.fsproj", "{90F944F1-593E-4960-B374-0F1367C1D0ED}" -EndProject -Project("{f2a71f9b-5d33-465a-a702-920d77279786}") = "Xamarin.UIProvider.OSXRuntime", "Xamarin.UIProvider.OSXRuntime\Xamarin.UIProvider.OSXRuntime.fsproj", "{8C2B961B-7314-487B-8C91-9C4A4B7A91D2}" -EndProject -Global - GlobalSection(SolutionConfigurationPlatforms) = preSolution - Debug|iPhoneSimulator = Debug|iPhoneSimulator - Release|iPhoneSimulator = Release|iPhoneSimulator - Debug|iPhone = Debug|iPhone - Release|iPhone = Release|iPhone - Ad-Hoc|iPhone = Ad-Hoc|iPhone - AppStore|iPhone = AppStore|iPhone - Debug|Any CPU = Debug|Any CPU - EndGlobalSection - GlobalSection(ProjectConfigurationPlatforms) = postSolution - {DD17E7B0-6EE1-4862-80F8-E0CAB67D6137}.Ad-Hoc|iPhone.ActiveCfg = Release|Any CPU - {DD17E7B0-6EE1-4862-80F8-E0CAB67D6137}.Ad-Hoc|iPhone.Build.0 = Release|Any CPU - {DD17E7B0-6EE1-4862-80F8-E0CAB67D6137}.AppStore|iPhone.ActiveCfg = Release|Any CPU - {DD17E7B0-6EE1-4862-80F8-E0CAB67D6137}.AppStore|iPhone.Build.0 = Release|Any CPU - {DD17E7B0-6EE1-4862-80F8-E0CAB67D6137}.Debug|Any CPU.ActiveCfg = Debug|Any CPU - {DD17E7B0-6EE1-4862-80F8-E0CAB67D6137}.Debug|Any CPU.Build.0 = Debug|Any CPU - {DD17E7B0-6EE1-4862-80F8-E0CAB67D6137}.Debug|iPhone.ActiveCfg = Debug|Any CPU - {DD17E7B0-6EE1-4862-80F8-E0CAB67D6137}.Debug|iPhone.Build.0 = Debug|Any CPU - {DD17E7B0-6EE1-4862-80F8-E0CAB67D6137}.Debug|iPhoneSimulator.ActiveCfg = Debug|Any CPU - {DD17E7B0-6EE1-4862-80F8-E0CAB67D6137}.Debug|iPhoneSimulator.Build.0 = Debug|Any CPU - {DD17E7B0-6EE1-4862-80F8-E0CAB67D6137}.Release|iPhone.ActiveCfg = Release|Any CPU - {DD17E7B0-6EE1-4862-80F8-E0CAB67D6137}.Release|iPhone.Build.0 = Release|Any CPU - {DD17E7B0-6EE1-4862-80F8-E0CAB67D6137}.Release|iPhoneSimulator.ActiveCfg = Release|Any CPU - {DD17E7B0-6EE1-4862-80F8-E0CAB67D6137}.Release|iPhoneSimulator.Build.0 = Release|Any CPU - {6EBFDE55-9687-40A9-8C1A-6E204ECB117F}.Ad-Hoc|iPhone.ActiveCfg = Release|Any CPU - {6EBFDE55-9687-40A9-8C1A-6E204ECB117F}.Ad-Hoc|iPhone.Build.0 = Release|Any CPU - {6EBFDE55-9687-40A9-8C1A-6E204ECB117F}.AppStore|iPhone.ActiveCfg = Release|Any CPU - {6EBFDE55-9687-40A9-8C1A-6E204ECB117F}.AppStore|iPhone.Build.0 = Release|Any CPU - {6EBFDE55-9687-40A9-8C1A-6E204ECB117F}.Debug|iPhone.ActiveCfg = Debug|Any CPU - {6EBFDE55-9687-40A9-8C1A-6E204ECB117F}.Debug|iPhone.Build.0 = Debug|Any CPU - {6EBFDE55-9687-40A9-8C1A-6E204ECB117F}.Debug|iPhoneSimulator.ActiveCfg = Debug|Any CPU - {6EBFDE55-9687-40A9-8C1A-6E204ECB117F}.Debug|iPhoneSimulator.Build.0 = Debug|Any CPU - {6EBFDE55-9687-40A9-8C1A-6E204ECB117F}.Release|iPhone.ActiveCfg = Release|Any CPU - {6EBFDE55-9687-40A9-8C1A-6E204ECB117F}.Release|iPhone.Build.0 = Release|Any CPU - {6EBFDE55-9687-40A9-8C1A-6E204ECB117F}.Release|iPhoneSimulator.ActiveCfg = Release|Any CPU - {6EBFDE55-9687-40A9-8C1A-6E204ECB117F}.Release|iPhoneSimulator.Build.0 = Release|Any CPU - {B85F245B-3FB9-4253-8251-16F98F05B6EC}.Ad-Hoc|iPhone.ActiveCfg = Release|Any CPU - {B85F245B-3FB9-4253-8251-16F98F05B6EC}.Ad-Hoc|iPhone.Build.0 = Release|Any CPU - {B85F245B-3FB9-4253-8251-16F98F05B6EC}.AppStore|iPhone.ActiveCfg = Release|Any CPU - {B85F245B-3FB9-4253-8251-16F98F05B6EC}.AppStore|iPhone.Build.0 = Release|Any CPU - {B85F245B-3FB9-4253-8251-16F98F05B6EC}.Debug|iPhone.ActiveCfg = Debug|Any CPU - {B85F245B-3FB9-4253-8251-16F98F05B6EC}.Debug|iPhone.Build.0 = Debug|Any CPU - {B85F245B-3FB9-4253-8251-16F98F05B6EC}.Debug|iPhoneSimulator.ActiveCfg = Debug|Any CPU - {B85F245B-3FB9-4253-8251-16F98F05B6EC}.Debug|iPhoneSimulator.Build.0 = Debug|Any CPU - {B85F245B-3FB9-4253-8251-16F98F05B6EC}.Release|iPhone.ActiveCfg = Release|Any CPU - {B85F245B-3FB9-4253-8251-16F98F05B6EC}.Release|iPhone.Build.0 = Release|Any CPU - {B85F245B-3FB9-4253-8251-16F98F05B6EC}.Release|iPhoneSimulator.ActiveCfg = Release|Any CPU - {B85F245B-3FB9-4253-8251-16F98F05B6EC}.Release|iPhoneSimulator.Build.0 = Release|Any CPU - {4F84B7DD-A5E0-4BC3-9C9F-565988030202}.Debug|iPhoneSimulator.ActiveCfg = Debug|Any CPU - {4F84B7DD-A5E0-4BC3-9C9F-565988030202}.Debug|iPhoneSimulator.Build.0 = Debug|Any CPU - {4F84B7DD-A5E0-4BC3-9C9F-565988030202}.Release|iPhoneSimulator.ActiveCfg = Release|Any CPU - {4F84B7DD-A5E0-4BC3-9C9F-565988030202}.Release|iPhoneSimulator.Build.0 = Release|Any CPU - {4F84B7DD-A5E0-4BC3-9C9F-565988030202}.Debug|iPhone.ActiveCfg = Debug|Any CPU - {4F84B7DD-A5E0-4BC3-9C9F-565988030202}.Debug|iPhone.Build.0 = Debug|Any CPU - {4F84B7DD-A5E0-4BC3-9C9F-565988030202}.Release|iPhone.ActiveCfg = Release|Any CPU - {4F84B7DD-A5E0-4BC3-9C9F-565988030202}.Release|iPhone.Build.0 = Release|Any CPU - {4F84B7DD-A5E0-4BC3-9C9F-565988030202}.Ad-Hoc|iPhone.ActiveCfg = Release|Any CPU - {4F84B7DD-A5E0-4BC3-9C9F-565988030202}.Ad-Hoc|iPhone.Build.0 = Release|Any CPU - {4F84B7DD-A5E0-4BC3-9C9F-565988030202}.AppStore|iPhone.ActiveCfg = Release|Any CPU - {4F84B7DD-A5E0-4BC3-9C9F-565988030202}.AppStore|iPhone.Build.0 = Release|Any CPU - {4F84B7DD-A5E0-4BC3-9C9F-565988030202}.Debug|Any CPU.ActiveCfg = Debug|Any CPU - {4F84B7DD-A5E0-4BC3-9C9F-565988030202}.Debug|Any CPU.Build.0 = Debug|Any CPU - {90F944F1-593E-4960-B374-0F1367C1D0ED}.Debug|iPhoneSimulator.ActiveCfg = Debug|Any CPU - {90F944F1-593E-4960-B374-0F1367C1D0ED}.Debug|iPhoneSimulator.Build.0 = Debug|Any CPU - {90F944F1-593E-4960-B374-0F1367C1D0ED}.Release|iPhoneSimulator.ActiveCfg = Release|Any CPU - {90F944F1-593E-4960-B374-0F1367C1D0ED}.Release|iPhoneSimulator.Build.0 = Release|Any CPU - {90F944F1-593E-4960-B374-0F1367C1D0ED}.Debug|iPhone.ActiveCfg = Debug|Any CPU - {90F944F1-593E-4960-B374-0F1367C1D0ED}.Debug|iPhone.Build.0 = Debug|Any CPU - {90F944F1-593E-4960-B374-0F1367C1D0ED}.Release|iPhone.ActiveCfg = Release|Any CPU - {90F944F1-593E-4960-B374-0F1367C1D0ED}.Release|iPhone.Build.0 = Release|Any CPU - {90F944F1-593E-4960-B374-0F1367C1D0ED}.Ad-Hoc|iPhone.ActiveCfg = Release|Any CPU - {90F944F1-593E-4960-B374-0F1367C1D0ED}.Ad-Hoc|iPhone.Build.0 = Release|Any CPU - {90F944F1-593E-4960-B374-0F1367C1D0ED}.AppStore|iPhone.ActiveCfg = Release|Any CPU - {90F944F1-593E-4960-B374-0F1367C1D0ED}.AppStore|iPhone.Build.0 = Release|Any CPU - {90F944F1-593E-4960-B374-0F1367C1D0ED}.Debug|Any CPU.ActiveCfg = Debug|Any CPU - {90F944F1-593E-4960-B374-0F1367C1D0ED}.Debug|Any CPU.Build.0 = Debug|Any CPU - {8C2B961B-7314-487B-8C91-9C4A4B7A91D2}.Debug|iPhoneSimulator.ActiveCfg = Debug|Any CPU - {8C2B961B-7314-487B-8C91-9C4A4B7A91D2}.Debug|iPhoneSimulator.Build.0 = Debug|Any CPU - {8C2B961B-7314-487B-8C91-9C4A4B7A91D2}.Release|iPhoneSimulator.ActiveCfg = Release|Any CPU - {8C2B961B-7314-487B-8C91-9C4A4B7A91D2}.Release|iPhoneSimulator.Build.0 = Release|Any CPU - {8C2B961B-7314-487B-8C91-9C4A4B7A91D2}.Debug|iPhone.ActiveCfg = Debug|Any CPU - {8C2B961B-7314-487B-8C91-9C4A4B7A91D2}.Debug|iPhone.Build.0 = Debug|Any CPU - {8C2B961B-7314-487B-8C91-9C4A4B7A91D2}.Release|iPhone.ActiveCfg = Release|Any CPU - {8C2B961B-7314-487B-8C91-9C4A4B7A91D2}.Release|iPhone.Build.0 = Release|Any CPU - {8C2B961B-7314-487B-8C91-9C4A4B7A91D2}.Ad-Hoc|iPhone.ActiveCfg = Release|Any CPU - {8C2B961B-7314-487B-8C91-9C4A4B7A91D2}.Ad-Hoc|iPhone.Build.0 = Release|Any CPU - {8C2B961B-7314-487B-8C91-9C4A4B7A91D2}.AppStore|iPhone.ActiveCfg = Release|Any CPU - {8C2B961B-7314-487B-8C91-9C4A4B7A91D2}.AppStore|iPhone.Build.0 = Release|Any CPU - {8C2B961B-7314-487B-8C91-9C4A4B7A91D2}.Debug|Any CPU.ActiveCfg = Debug|Any CPU - {8C2B961B-7314-487B-8C91-9C4A4B7A91D2}.Debug|Any CPU.Build.0 = Debug|Any CPU - EndGlobalSection - GlobalSection(NestedProjects) = preSolution - EndGlobalSection -EndGlobal + +Microsoft Visual Studio Solution File, Format Version 12.00 +# Visual Studio 2012 +Project("{2150E333-8FDC-42A3-9474-1A3956D46DE8}") = ".paket", ".paket", "{5A197B75-5EEA-4726-8D3C-08A5BBC40008}" + ProjectSection(SolutionItems) = preProject + ..\paket.dependencies = ..\paket.dependencies + EndProjectSection +EndProject +Project("{f2a71f9b-5d33-465a-a702-920d77279786}") = "Xamarin.UIProviders.DesignTime", "Xamarin.iOSProviders\Xamarin.UIProviders.DesignTime.fsproj", "{DD17E7B0-6EE1-4862-80F8-E0CAB67D6137}" +EndProject +Project("{f2a71f9b-5d33-465a-a702-920d77279786}") = "Xamarin.UIProvider.TVOSRuntime", "Xamarin.UIProvider.TVOSRuntime\Xamarin.UIProvider.TVOSRuntime.fsproj", "{4F84B7DD-A5E0-4BC3-9C9F-565988030202}" +EndProject +Project("{f2a71f9b-5d33-465a-a702-920d77279786}") = "Xamarin.UIProvider.iOSRuntime", "Xamarin.UIProvider.iOSRuntime\Xamarin.UIProvider.iOSRuntime.fsproj", "{90F944F1-593E-4960-B374-0F1367C1D0ED}" +EndProject +Project("{f2a71f9b-5d33-465a-a702-920d77279786}") = "Xamarin.UIProvider.OSXRuntime", "Xamarin.UIProvider.OSXRuntime\Xamarin.UIProvider.OSXRuntime.fsproj", "{8C2B961B-7314-487B-8C91-9C4A4B7A91D2}" +EndProject +Global + GlobalSection(SolutionConfigurationPlatforms) = preSolution + Debug|iPhoneSimulator = Debug|iPhoneSimulator + Release|iPhoneSimulator = Release|iPhoneSimulator + Debug|iPhone = Debug|iPhone + Release|iPhone = Release|iPhone + Ad-Hoc|iPhone = Ad-Hoc|iPhone + AppStore|iPhone = AppStore|iPhone + Debug|Any CPU = Debug|Any CPU + EndGlobalSection + GlobalSection(ProjectConfigurationPlatforms) = postSolution + {DD17E7B0-6EE1-4862-80F8-E0CAB67D6137}.Ad-Hoc|iPhone.ActiveCfg = Release|Any CPU + {DD17E7B0-6EE1-4862-80F8-E0CAB67D6137}.Ad-Hoc|iPhone.Build.0 = Release|Any CPU + {DD17E7B0-6EE1-4862-80F8-E0CAB67D6137}.AppStore|iPhone.ActiveCfg = Release|Any CPU + {DD17E7B0-6EE1-4862-80F8-E0CAB67D6137}.AppStore|iPhone.Build.0 = Release|Any CPU + {DD17E7B0-6EE1-4862-80F8-E0CAB67D6137}.Debug|Any CPU.ActiveCfg = Debug|Any CPU + {DD17E7B0-6EE1-4862-80F8-E0CAB67D6137}.Debug|Any CPU.Build.0 = Debug|Any CPU + {DD17E7B0-6EE1-4862-80F8-E0CAB67D6137}.Debug|iPhone.ActiveCfg = Debug|Any CPU + {DD17E7B0-6EE1-4862-80F8-E0CAB67D6137}.Debug|iPhone.Build.0 = Debug|Any CPU + {DD17E7B0-6EE1-4862-80F8-E0CAB67D6137}.Debug|iPhoneSimulator.ActiveCfg = Debug|Any CPU + {DD17E7B0-6EE1-4862-80F8-E0CAB67D6137}.Debug|iPhoneSimulator.Build.0 = Debug|Any CPU + {DD17E7B0-6EE1-4862-80F8-E0CAB67D6137}.Release|iPhone.ActiveCfg = Release|Any CPU + {DD17E7B0-6EE1-4862-80F8-E0CAB67D6137}.Release|iPhone.Build.0 = Release|Any CPU + {DD17E7B0-6EE1-4862-80F8-E0CAB67D6137}.Release|iPhoneSimulator.ActiveCfg = Release|Any CPU + {DD17E7B0-6EE1-4862-80F8-E0CAB67D6137}.Release|iPhoneSimulator.Build.0 = Release|Any CPU + {6EBFDE55-9687-40A9-8C1A-6E204ECB117F}.Ad-Hoc|iPhone.ActiveCfg = Release|Any CPU + {6EBFDE55-9687-40A9-8C1A-6E204ECB117F}.Ad-Hoc|iPhone.Build.0 = Release|Any CPU + {6EBFDE55-9687-40A9-8C1A-6E204ECB117F}.AppStore|iPhone.ActiveCfg = Release|Any CPU + {6EBFDE55-9687-40A9-8C1A-6E204ECB117F}.AppStore|iPhone.Build.0 = Release|Any CPU + {6EBFDE55-9687-40A9-8C1A-6E204ECB117F}.Debug|iPhone.ActiveCfg = Debug|Any CPU + {6EBFDE55-9687-40A9-8C1A-6E204ECB117F}.Debug|iPhone.Build.0 = Debug|Any CPU + {6EBFDE55-9687-40A9-8C1A-6E204ECB117F}.Debug|iPhoneSimulator.ActiveCfg = Debug|Any CPU + {6EBFDE55-9687-40A9-8C1A-6E204ECB117F}.Debug|iPhoneSimulator.Build.0 = Debug|Any CPU + {6EBFDE55-9687-40A9-8C1A-6E204ECB117F}.Release|iPhone.ActiveCfg = Release|Any CPU + {6EBFDE55-9687-40A9-8C1A-6E204ECB117F}.Release|iPhone.Build.0 = Release|Any CPU + {6EBFDE55-9687-40A9-8C1A-6E204ECB117F}.Release|iPhoneSimulator.ActiveCfg = Release|Any CPU + {6EBFDE55-9687-40A9-8C1A-6E204ECB117F}.Release|iPhoneSimulator.Build.0 = Release|Any CPU + {B85F245B-3FB9-4253-8251-16F98F05B6EC}.Ad-Hoc|iPhone.ActiveCfg = Release|Any CPU + {B85F245B-3FB9-4253-8251-16F98F05B6EC}.Ad-Hoc|iPhone.Build.0 = Release|Any CPU + {B85F245B-3FB9-4253-8251-16F98F05B6EC}.AppStore|iPhone.ActiveCfg = Release|Any CPU + {B85F245B-3FB9-4253-8251-16F98F05B6EC}.AppStore|iPhone.Build.0 = Release|Any CPU + {B85F245B-3FB9-4253-8251-16F98F05B6EC}.Debug|iPhone.ActiveCfg = Debug|Any CPU + {B85F245B-3FB9-4253-8251-16F98F05B6EC}.Debug|iPhone.Build.0 = Debug|Any CPU + {B85F245B-3FB9-4253-8251-16F98F05B6EC}.Debug|iPhoneSimulator.ActiveCfg = Debug|Any CPU + {B85F245B-3FB9-4253-8251-16F98F05B6EC}.Debug|iPhoneSimulator.Build.0 = Debug|Any CPU + {B85F245B-3FB9-4253-8251-16F98F05B6EC}.Release|iPhone.ActiveCfg = Release|Any CPU + {B85F245B-3FB9-4253-8251-16F98F05B6EC}.Release|iPhone.Build.0 = Release|Any CPU + {B85F245B-3FB9-4253-8251-16F98F05B6EC}.Release|iPhoneSimulator.ActiveCfg = Release|Any CPU + {B85F245B-3FB9-4253-8251-16F98F05B6EC}.Release|iPhoneSimulator.Build.0 = Release|Any CPU + {4F84B7DD-A5E0-4BC3-9C9F-565988030202}.Debug|iPhoneSimulator.ActiveCfg = Debug|Any CPU + {4F84B7DD-A5E0-4BC3-9C9F-565988030202}.Debug|iPhoneSimulator.Build.0 = Debug|Any CPU + {4F84B7DD-A5E0-4BC3-9C9F-565988030202}.Release|iPhoneSimulator.ActiveCfg = Release|Any CPU + {4F84B7DD-A5E0-4BC3-9C9F-565988030202}.Release|iPhoneSimulator.Build.0 = Release|Any CPU + {4F84B7DD-A5E0-4BC3-9C9F-565988030202}.Debug|iPhone.ActiveCfg = Debug|Any CPU + {4F84B7DD-A5E0-4BC3-9C9F-565988030202}.Debug|iPhone.Build.0 = Debug|Any CPU + {4F84B7DD-A5E0-4BC3-9C9F-565988030202}.Release|iPhone.ActiveCfg = Release|Any CPU + {4F84B7DD-A5E0-4BC3-9C9F-565988030202}.Release|iPhone.Build.0 = Release|Any CPU + {4F84B7DD-A5E0-4BC3-9C9F-565988030202}.Ad-Hoc|iPhone.ActiveCfg = Release|Any CPU + {4F84B7DD-A5E0-4BC3-9C9F-565988030202}.Ad-Hoc|iPhone.Build.0 = Release|Any CPU + {4F84B7DD-A5E0-4BC3-9C9F-565988030202}.AppStore|iPhone.ActiveCfg = Release|Any CPU + {4F84B7DD-A5E0-4BC3-9C9F-565988030202}.AppStore|iPhone.Build.0 = Release|Any CPU + {4F84B7DD-A5E0-4BC3-9C9F-565988030202}.Debug|Any CPU.ActiveCfg = Debug|Any CPU + {4F84B7DD-A5E0-4BC3-9C9F-565988030202}.Debug|Any CPU.Build.0 = Debug|Any CPU + {90F944F1-593E-4960-B374-0F1367C1D0ED}.Debug|iPhoneSimulator.ActiveCfg = Debug|Any CPU + {90F944F1-593E-4960-B374-0F1367C1D0ED}.Debug|iPhoneSimulator.Build.0 = Debug|Any CPU + {90F944F1-593E-4960-B374-0F1367C1D0ED}.Release|iPhoneSimulator.ActiveCfg = Release|Any CPU + {90F944F1-593E-4960-B374-0F1367C1D0ED}.Release|iPhoneSimulator.Build.0 = Release|Any CPU + {90F944F1-593E-4960-B374-0F1367C1D0ED}.Debug|iPhone.ActiveCfg = Debug|Any CPU + {90F944F1-593E-4960-B374-0F1367C1D0ED}.Debug|iPhone.Build.0 = Debug|Any CPU + {90F944F1-593E-4960-B374-0F1367C1D0ED}.Release|iPhone.ActiveCfg = Release|Any CPU + {90F944F1-593E-4960-B374-0F1367C1D0ED}.Release|iPhone.Build.0 = Release|Any CPU + {90F944F1-593E-4960-B374-0F1367C1D0ED}.Ad-Hoc|iPhone.ActiveCfg = Release|Any CPU + {90F944F1-593E-4960-B374-0F1367C1D0ED}.Ad-Hoc|iPhone.Build.0 = Release|Any CPU + {90F944F1-593E-4960-B374-0F1367C1D0ED}.AppStore|iPhone.ActiveCfg = Release|Any CPU + {90F944F1-593E-4960-B374-0F1367C1D0ED}.AppStore|iPhone.Build.0 = Release|Any CPU + {90F944F1-593E-4960-B374-0F1367C1D0ED}.Debug|Any CPU.ActiveCfg = Debug|Any CPU + {90F944F1-593E-4960-B374-0F1367C1D0ED}.Debug|Any CPU.Build.0 = Debug|Any CPU + {8C2B961B-7314-487B-8C91-9C4A4B7A91D2}.Debug|iPhoneSimulator.ActiveCfg = Debug|Any CPU + {8C2B961B-7314-487B-8C91-9C4A4B7A91D2}.Debug|iPhoneSimulator.Build.0 = Debug|Any CPU + {8C2B961B-7314-487B-8C91-9C4A4B7A91D2}.Release|iPhoneSimulator.ActiveCfg = Release|Any CPU + {8C2B961B-7314-487B-8C91-9C4A4B7A91D2}.Release|iPhoneSimulator.Build.0 = Release|Any CPU + {8C2B961B-7314-487B-8C91-9C4A4B7A91D2}.Debug|iPhone.ActiveCfg = Debug|Any CPU + {8C2B961B-7314-487B-8C91-9C4A4B7A91D2}.Debug|iPhone.Build.0 = Debug|Any CPU + {8C2B961B-7314-487B-8C91-9C4A4B7A91D2}.Release|iPhone.ActiveCfg = Release|Any CPU + {8C2B961B-7314-487B-8C91-9C4A4B7A91D2}.Release|iPhone.Build.0 = Release|Any CPU + {8C2B961B-7314-487B-8C91-9C4A4B7A91D2}.Ad-Hoc|iPhone.ActiveCfg = Release|Any CPU + {8C2B961B-7314-487B-8C91-9C4A4B7A91D2}.Ad-Hoc|iPhone.Build.0 = Release|Any CPU + {8C2B961B-7314-487B-8C91-9C4A4B7A91D2}.AppStore|iPhone.ActiveCfg = Release|Any CPU + {8C2B961B-7314-487B-8C91-9C4A4B7A91D2}.AppStore|iPhone.Build.0 = Release|Any CPU + {8C2B961B-7314-487B-8C91-9C4A4B7A91D2}.Debug|Any CPU.ActiveCfg = Debug|Any CPU + {8C2B961B-7314-487B-8C91-9C4A4B7A91D2}.Debug|Any CPU.Build.0 = Debug|Any CPU + EndGlobalSection + GlobalSection(NestedProjects) = preSolution + EndGlobalSection +EndGlobal diff --git a/src/Xamarin.iOSProviders/ProvidedTypes.fs b/src/Xamarin.iOSProviders/ProvidedTypes.fs index 53e5180..c6e67cf 100644 --- a/src/Xamarin.iOSProviders/ProvidedTypes.fs +++ b/src/Xamarin.iOSProviders/ProvidedTypes.fs @@ -1,2736 +1,2736 @@ -#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 = 2) - 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(message : string, isError) = obsoleteMessage <- Some (message,isError) - member __.HasParamArray with get() = hasParamArray and set(v) = hasParamArray <- v - member __.AddXmlDocComputed xmlDocFunction = xmlDocAlwaysRecomputed <- Some xmlDocFunction - member __.AddXmlDocDelayed xmlDocFunction = xmlDocDelayed <- Some xmlDocFunction - member __.AddXmlDoc xmlDoc = xmlDocDelayed <- Some (fun () -> xmlDoc) - 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 xmlDocFunction = customAttributesImpl.AddXmlDocDelayed xmlDocFunction - member __.AddXmlDocComputed xmlDocFunction = customAttributesImpl.AddXmlDocComputed xmlDocFunction - member __.AddXmlDoc xmlDoc = customAttributesImpl.AddXmlDoc xmlDoc - - 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 __.IsParamArray with get() = customAttributesImpl.HasParamArray and set(v) = customAttributesImpl.HasParamArray <- v - override __.Name = name - override __.ParameterType = parameterType - override __.Attributes = (base.Attributes ||| (if isOut then ParameterAttributes.Out else enum 0) - ||| (match optionalValue with None -> enum 0 | Some _ -> ParameterAttributes.Optional ||| ParameterAttributes.HasDefault)) - override __.RawDefaultValue = defaultArg optionalValue null - member __.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 isStatic() = ctorAttributes.HasFlag(MethodAttributes.Static) - - let customAttributesImpl = CustomAttributesImpl() - member __.IsTypeInitializer - with get() = isStatic() && ctorAttributes.HasFlag(MethodAttributes.Private) - and set(v) = - let typeInitializerAttributes = MethodAttributes.Static ||| MethodAttributes.Private - ctorAttributes <- if v then ctorAttributes ||| typeInitializerAttributes else ctorAttributes &&& ~~~typeInitializerAttributes - - member __.AddXmlDocComputed xmlDocFunction = customAttributesImpl.AddXmlDocComputed xmlDocFunction - member __.AddXmlDocDelayed xmlDocFunction = customAttributesImpl.AddXmlDocDelayed xmlDocFunction - member __.AddXmlDoc xmlDoc = customAttributesImpl.AddXmlDoc xmlDoc - member __.AddObsoleteAttribute (message,?isError) = customAttributesImpl.AddObsolete (message,defaultArg isError false) - member __.AddDefinitionLocation(line,column,filePath) = customAttributesImpl.AddDefinitionLocation(line, column, filePath) - member __.GetCustomAttributesDataImpl() = customAttributesImpl.GetCustomAttributesData() -#if FX_NO_CUSTOMATTRIBUTEDATA -#else - override __.GetCustomAttributesData() = customAttributesImpl.GetCustomAttributesData() -#endif - - member __.DeclaringTypeImpl - with set x = - if declaringType<>null then failwith (sprintf "ProvidedConstructor: declaringType already set on '%s'" (nameText())); - declaringType <- x - - member __.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 __.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 __.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 || isStatic() then [] else ["this"]) - |> Array.ofList - transQuotationToCode isGenerated f paramNames - | None -> failwith (sprintf "ProvidedConstructor: no invoker for '%s'" (nameText())) - - member __.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 __.IsImplicitCtor with get() = isImplicitCtor and set v = isImplicitCtor <- v - - // Implement overloads - override __.GetParameters() = parameters |> List.toArray - override __.Attributes = ctorAttributes - override __.Name = if isStatic() then ".cctor" else ".ctor" - override __.DeclaringType = declaringType |> nonNull "ProvidedConstructor.DeclaringType" - override __.IsDefined(_attributeType, _inherit) = true - - override __.Invoke(_invokeAttr, _binder, _parameters, _culture) = notRequired "Invoke" (nameText()) - override __.Invoke(_obj, _invokeAttr, _binder, _parameters, _culture) = notRequired "Invoke" (nameText()) - override __.ReflectedType = notRequired "ReflectedType" (nameText()) - override __.GetMethodImplementationFlags() = notRequired "GetMethodImplementationFlags" (nameText()) - override __.MethodHandle = notRequired "MethodHandle" (nameText()) - override __.GetCustomAttributes(_inherit) = notRequired "GetCustomAttributes" (nameText()) - override __.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 mutable staticParams = [ ] - let mutable staticParamsApply = None - let isStatic() = methodAttrs.HasFlag(MethodAttributes.Static) - let customAttributesImpl = CustomAttributesImpl() - - member __.AddXmlDocComputed xmlDocFunction = customAttributesImpl.AddXmlDocComputed xmlDocFunction - member __.AddXmlDocDelayed xmlDocFunction = customAttributesImpl.AddXmlDocDelayed xmlDocFunction - member __.AddXmlDoc xmlDoc = customAttributesImpl.AddXmlDoc xmlDoc - member __.AddObsoleteAttribute (message,?isError) = customAttributesImpl.AddObsolete (message,defaultArg isError false) - member __.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 __.GetCustomAttributesData() = customAttributesImpl.GetCustomAttributesData() -#endif - - member __.SetMethodAttrs m = methodAttrs <- m - member __.AddMethodAttrs m = methodAttrs <- methodAttrs ||| m - member __.DeclaringTypeImpl with set x = declaringType <- x // check: not set twice - member __.IsStaticMethod - with get() = isStatic() - and set x = if x then methodAttrs <- methodAttrs ||| MethodAttributes.Static - else methodAttrs <- methodAttrs &&& (~~~ MethodAttributes.Static) - - member __.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" methodName (if declaringType=null then "" else declaringType.FullName)) - - - /// Abstract a type to a parametric-type. Requires "formal parameters" and "instantiation function". - member __.DefineStaticParameters(staticParameters : list, apply : (string -> obj[] -> ProvidedMethod)) = - staticParams <- staticParameters - staticParamsApply <- Some apply - - /// Get ParameterInfo[] for the parametric type parameters (//s GetGenericParameters) - member __.GetStaticParameters() = [| for p in staticParams -> p :> ParameterInfo |] - - /// Instantiate parametrics type - member __.ApplyStaticArguments(mangledName: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 method %s" staticParams.Length args.Length methodName) - match staticParamsApply with - | None -> failwith "ProvidedTypeDefinition: DefineStaticParameters was not called" - | Some f -> f mangledName args - else - failwith (sprintf "ProvidedTypeDefinition: static parameters supplied but not expected for method %s" methodName) - - member __.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 isStatic() then [] else ["this"]) - |> Array.ofList - transQuotationToCode isGenerated f paramNames - | None -> failwith (sprintf "ProvidedMethod: no invoker for %s on type %s" methodName (if declaringType=null then "" else declaringType.FullName)) - - // Implement overloads - override __.GetParameters() = argParams |> Array.ofList - override __.Attributes = methodAttrs - override __.Name = methodName - override __.DeclaringType = declaringType |> nonNull "ProvidedMethod.DeclaringType" - override __.IsDefined(_attributeType, _inherit) : bool = true - override __.MemberType = MemberTypes.Method - override __.CallingConvention = - let cc = CallingConventions.Standard - let cc = if not (isStatic()) then cc ||| CallingConventions.HasThis else cc - cc - override __.ReturnType = returnType - override __.ReturnParameter = null // REVIEW: Give it a name and type? - override __.ToString() = "Method " + methodName - - // 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 __.MetadataToken = hash declaringType + hash methodName - override __.MethodHandle = RuntimeMethodHandle() - - override __.ReturnTypeCustomAttributes = notRequired "ReturnTypeCustomAttributes" methodName - override __.GetBaseDefinition() = notRequired "GetBaseDefinition" methodName - override __.GetMethodImplementationFlags() = notRequired "GetMethodImplementationFlags" methodName - override __.Invoke(_obj, _invokeAttr, _binder, _parameters, _culture) = notRequired "Invoke" methodName - override __.ReflectedType = notRequired "ReflectedType" methodName - override __.GetCustomAttributes(_inherit) = notRequired "GetCustomAttributes" methodName - override __.GetCustomAttributes(_attributeType, _inherit) = notRequired "GetCustomAttributes" methodName - - -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 __.AddXmlDocComputed xmlDocFunction = customAttributesImpl.AddXmlDocComputed xmlDocFunction - member __.AddXmlDocDelayed xmlDocFunction = customAttributesImpl.AddXmlDocDelayed xmlDocFunction - member __.AddXmlDoc xmlDoc = customAttributesImpl.AddXmlDoc xmlDoc - member __.AddObsoleteAttribute (message,?isError) = customAttributesImpl.AddObsolete (message,defaultArg isError false) - member __.AddDefinitionLocation(line,column,filePath) = customAttributesImpl.AddDefinitionLocation(line, column, filePath) - member __.GetCustomAttributesDataImpl() = customAttributesImpl.GetCustomAttributesData() - member __.AddCustomAttribute attribute = customAttributesImpl.AddCustomAttribute attribute -#if FX_NO_CUSTOMATTRIBUTEDATA -#else - override __.GetCustomAttributesData() = customAttributesImpl.GetCustomAttributesData() -#endif - - member __.DeclaringTypeImpl with set x = declaringType <- x // check: not set twice - - member __.IsStatic - with get() = isStatic - and set x = isStatic <- x - - member __.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 __.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 __.PropertyType = propertyType - override __.SetValue(_obj, _value, _invokeAttr, _binder, _index, _culture) = notRequired "SetValue" propertyName - override __.GetAccessors _nonPublic = notRequired "nonPublic" propertyName - override __.GetGetMethod _nonPublic = if hasGetter() then getter.Force() :> MethodInfo else null - override __.GetSetMethod _nonPublic = if hasSetter() then setter.Force() :> MethodInfo else null - override __.GetIndexParameters() = [| for p in parameters -> upcast p |] - override __.Attributes = PropertyAttributes.None - override __.CanRead = hasGetter() - override __.CanWrite = hasSetter() - override __.GetValue(_obj, _invokeAttr, _binder, _index, _culture) : obj = notRequired "GetValue" propertyName - override __.Name = propertyName - override __.DeclaringType = declaringType |> nonNull "ProvidedProperty.DeclaringType" - override __.MemberType : MemberTypes = MemberTypes.Property - - override __.ReflectedType = notRequired "ReflectedType" propertyName - override __.GetCustomAttributes(_inherit) = notRequired "GetCustomAttributes" propertyName - override __.GetCustomAttributes(_attributeType, _inherit) = notRequired "GetCustomAttributes" propertyName - override __.IsDefined(_attributeType, _inherit) = notRequired "IsDefined" propertyName - -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 __.AddXmlDocComputed xmlDocFunction = customAttributesImpl.AddXmlDocComputed xmlDocFunction - member __.AddXmlDocDelayed xmlDocFunction = customAttributesImpl.AddXmlDocDelayed xmlDocFunction - member __.AddXmlDoc xmlDoc = customAttributesImpl.AddXmlDoc xmlDoc - member __.AddDefinitionLocation(line,column,filePath) = customAttributesImpl.AddDefinitionLocation(line, column, filePath) - member __.GetCustomAttributesDataImpl() = customAttributesImpl.GetCustomAttributesData() -#if FX_NO_CUSTOMATTRIBUTEDATA -#else - override __.GetCustomAttributesData() = customAttributesImpl.GetCustomAttributesData() -#endif - - member __.DeclaringTypeImpl with set x = declaringType <- x // check: not set twice - member __.IsStatic - with get() = isStatic - and set x = isStatic <- x - - member __.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 __.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 __.EventHandlerType = eventHandlerType - override __.GetAddMethod _nonPublic = adder.Force() :> MethodInfo - override __.GetRemoveMethod _nonPublic = remover.Force() :> MethodInfo - override __.Attributes = EventAttributes.None - override __.Name = eventName - override __.DeclaringType = declaringType |> nonNull "ProvidedEvent.DeclaringType" - override __.MemberType : MemberTypes = MemberTypes.Event - - override __.GetRaiseMethod _nonPublic = notRequired "GetRaiseMethod" eventName - override __.ReflectedType = notRequired "ReflectedType" eventName - override __.GetCustomAttributes(_inherit) = notRequired "GetCustomAttributes" eventName - override __.GetCustomAttributes(_attributeType, _inherit) = notRequired "GetCustomAttributes" eventName - override __.IsDefined(_attributeType, _inherit) = notRequired "IsDefined" eventName - -type ProvidedLiteralField(fieldName:string,fieldType:Type,literalValue:obj) = - inherit System.Reflection.FieldInfo() - // State - - let mutable declaringType = null - - let customAttributesImpl = CustomAttributesImpl() - member __.AddXmlDocComputed xmlDocFunction = customAttributesImpl.AddXmlDocComputed xmlDocFunction - member __.AddXmlDocDelayed xmlDocFunction = customAttributesImpl.AddXmlDocDelayed xmlDocFunction - member __.AddXmlDoc xmlDoc = customAttributesImpl.AddXmlDoc xmlDoc - member __.AddObsoleteAttribute (message,?isError) = customAttributesImpl.AddObsolete (message,defaultArg isError false) - member __.AddDefinitionLocation(line,column,filePath) = customAttributesImpl.AddDefinitionLocation(line, column, filePath) - member __.GetCustomAttributesDataImpl() = customAttributesImpl.GetCustomAttributesData() -#if FX_NO_CUSTOMATTRIBUTEDATA -#else - override __.GetCustomAttributesData() = customAttributesImpl.GetCustomAttributesData() -#endif - - member __.DeclaringTypeImpl with set x = declaringType <- x // check: not set twice - - - // Implement overloads - override __.FieldType = fieldType - override __.GetRawConstantValue() = literalValue - override __.Attributes = FieldAttributes.Static ||| FieldAttributes.Literal ||| FieldAttributes.Public - override __.Name = fieldName - override __.DeclaringType = declaringType |> nonNull "ProvidedLiteralField.DeclaringType" - override __.MemberType : MemberTypes = MemberTypes.Field - - override __.ReflectedType = notRequired "ReflectedType" fieldName - override __.GetCustomAttributes(_inherit) = notRequired "GetCustomAttributes" fieldName - override __.GetCustomAttributes(_attributeType, _inherit) = notRequired "GetCustomAttributes" fieldName - override __.IsDefined(_attributeType, _inherit) = notRequired "IsDefined" fieldName - - override __.SetValue(_obj, _value, _invokeAttr, _binder, _culture) = notRequired "SetValue" fieldName - override __.GetValue(_obj) : obj = notRequired "GetValue" fieldName - override __.FieldHandle = notRequired "FieldHandle" fieldName - -type ProvidedField(fieldName:string,fieldType:Type) = - inherit System.Reflection.FieldInfo() - // State - - let mutable declaringType = null - - let customAttributesImpl = CustomAttributesImpl() - let mutable fieldAttrs = FieldAttributes.Private - member __.AddXmlDocComputed xmlDocFunction = customAttributesImpl.AddXmlDocComputed xmlDocFunction - member __.AddXmlDocDelayed xmlDocFunction = customAttributesImpl.AddXmlDocDelayed xmlDocFunction - member __.AddXmlDoc xmlDoc = customAttributesImpl.AddXmlDoc xmlDoc - member __.AddObsoleteAttribute (message,?isError) = customAttributesImpl.AddObsolete (message,defaultArg isError false) - member __.AddDefinitionLocation(line,column,filePath) = customAttributesImpl.AddDefinitionLocation(line, column, filePath) - member __.GetCustomAttributesDataImpl() = customAttributesImpl.GetCustomAttributesData() -#if FX_NO_CUSTOMATTRIBUTEDATA -#else - override __.GetCustomAttributesData() = customAttributesImpl.GetCustomAttributesData() -#endif - - member __.DeclaringTypeImpl with set x = declaringType <- x // check: not set twice - - member __.SetFieldAttributes attrs = fieldAttrs <- attrs - // Implement overloads - override __.FieldType = fieldType - override __.GetRawConstantValue() = null - override __.Attributes = fieldAttrs - override __.Name = fieldName - override __.DeclaringType = declaringType |> nonNull "ProvidedField.DeclaringType" - override __.MemberType : MemberTypes = MemberTypes.Field - - override __.ReflectedType = notRequired "ReflectedType" fieldName - override __.GetCustomAttributes(_inherit) = notRequired "GetCustomAttributes" fieldName - override __.GetCustomAttributes(_attributeType, _inherit) = notRequired "GetCustomAttributes" fieldName - override __.IsDefined(_attributeType, _inherit) = notRequired "IsDefined" fieldName - - override __.SetValue(_obj, _value, _invokeAttr, _binder, _culture) = notRequired "SetValue" fieldName - override __.GetValue(_obj) : obj = notRequired "GetValue" fieldName - override __.FieldHandle = notRequired "FieldHandle" fieldName - -/// 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 - - let nameText() = - 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" - - 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 __.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 __.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 __.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 __.Name = nameText() - - override __.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 __.GetArrayRank() = (match kind with SymbolKind.Array n -> n | SymbolKind.SDArray -> 1 | _ -> invalidOp "non-array type") - override __.IsArrayImpl() = (match kind with SymbolKind.Array _ | SymbolKind.SDArray -> true | _ -> false) - override __.IsByRefImpl() = (match kind with SymbolKind.ByRef _ -> true | _ -> false) - override __.IsPointerImpl() = (match kind with SymbolKind.Pointer _ -> true | _ -> false) - override __.IsPrimitiveImpl() = false - override __.IsGenericType = (match kind with SymbolKind.Generic _ -> true | _ -> false) - override __.GetGenericArguments() = (match kind with SymbolKind.Generic _ -> args |> List.toArray | _ -> invalidOp "non-generic type") - override __.GetGenericTypeDefinition() = (match kind with SymbolKind.Generic e -> e | _ -> invalidOp "non-generic type") - override __.IsCOMObjectImpl() = false - override __.HasElementTypeImpl() = (match kind with SymbolKind.Generic _ -> false | _ -> true) - override __.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 __.Assembly = - match kind with - | SymbolKind.FSharpTypeAbbreviation (assembly,_nsp,_path) -> assembly - | SymbolKind.Generic gty -> gty.Assembly - | _ -> notRequired "Assembly" (nameText()) - - override __.Namespace = - match kind with - | SymbolKind.FSharpTypeAbbreviation (_assembly,nsp,_path) -> nsp - | _ -> notRequired "Namespace" (nameText()) - - override __.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 __.Equals(other: obj) = - match other with - | :? ProvidedSymbolType as otherTy -> (kind, args) = (otherTy.Kind, otherTy.Args) - | _ -> false - - member __.Kind = kind - member __.Args = args - - override __.Module : Module = notRequired "Module" (nameText()) - override __.GetConstructors _bindingAttr = notRequired "GetConstructors" (nameText()) - override __.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" (nameText()) - override __.GetMembers _bindingAttr = notRequired "GetMembers" (nameText()) - override __.GetMethods _bindingAttr = notRequired "GetMethods" (nameText()) - override __.GetField(_name, _bindingAttr) = notRequired "GetField" (nameText()) - override __.GetFields _bindingAttr = notRequired "GetFields" (nameText()) - override __.GetInterface(_name, _ignoreCase) = notRequired "GetInterface" (nameText()) - override __.GetInterfaces() = notRequired "GetInterfaces" (nameText()) - override __.GetEvent(_name, _bindingAttr) = notRequired "GetEvent" (nameText()) - override __.GetEvents _bindingAttr = notRequired "GetEvents" (nameText()) - override __.GetProperties _bindingAttr = notRequired "GetProperties" (nameText()) - override __.GetPropertyImpl(_name, _bindingAttr, _binder, _returnType, _types, _modifiers) = notRequired "GetPropertyImpl" (nameText()) - override __.GetNestedTypes _bindingAttr = notRequired "GetNestedTypes" (nameText()) - override __.GetNestedType(_name, _bindingAttr) = notRequired "GetNestedType" (nameText()) - override __.GetAttributeFlagsImpl() = notRequired "GetAttributeFlagsImpl" (nameText()) - override this.UnderlyingSystemType = - match kind with - | SymbolKind.SDArray - | SymbolKind.Array _ - | SymbolKind.Pointer - | SymbolKind.FSharpTypeAbbreviation _ - | SymbolKind.ByRef -> upcast this - | SymbolKind.Generic gty -> gty.UnderlyingSystemType -#if FX_NO_CUSTOMATTRIBUTEDATA -#else - override __.GetCustomAttributesData() = ([| |] :> IList<_>) -#endif - override __.MemberType = notRequired "MemberType" (nameText()) - override __.GetMember(_name,_mt,_bindingAttr) = notRequired "GetMember" (nameText()) - override __.GUID = notRequired "GUID" (nameText()) - override __.InvokeMember(_name, _invokeAttr, _binder, _target, _args, _modifiers, _culture, _namedParameters) = notRequired "InvokeMember" (nameText()) - override __.AssemblyQualifiedName = notRequired "AssemblyQualifiedName" (nameText()) - override __.GetConstructorImpl(_bindingAttr, _binder, _callConvention, _types, _modifiers) = notRequired "GetConstructorImpl" (nameText()) - override __.GetCustomAttributes(_inherit) = [| |] - override __.GetCustomAttributes(_attributeType, _inherit) = [| |] - override __.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 __.Name = p.Name - override __.ParameterType = ProvidedSymbolType.convType parameters p.ParameterType - override __.Attributes = p.Attributes - override __.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 __.GetGenericMethodDefinition() = genericMethodDefinition - - override __.DeclaringType = ProvidedSymbolType.convType parameters genericMethodDefinition.DeclaringType - override __.ToString() = "Method " + genericMethodDefinition.Name - override __.Name = genericMethodDefinition.Name - override __.MetadataToken = genericMethodDefinition.MetadataToken - override __.Attributes = genericMethodDefinition.Attributes - override __.CallingConvention = genericMethodDefinition.CallingConvention - override __.MemberType = genericMethodDefinition.MemberType - - override __.IsDefined(_attributeType, _inherit) : bool = notRequired "IsDefined" genericMethodDefinition.Name - override __.ReturnType = ProvidedSymbolType.convType parameters genericMethodDefinition.ReturnType - override __.GetParameters() = genericMethodDefinition.GetParameters() |> Array.map convParam - override __.ReturnParameter = genericMethodDefinition.ReturnParameter |> convParam - override __.ReturnTypeCustomAttributes = notRequired "ReturnTypeCustomAttributes" genericMethodDefinition.Name - override __.GetBaseDefinition() = notRequired "GetBaseDefinition" genericMethodDefinition.Name - override __.GetMethodImplementationFlags() = notRequired "GetMethodImplementationFlags" genericMethodDefinition.Name - override __.MethodHandle = notRequired "MethodHandle" genericMethodDefinition.Name - override __.Invoke(_obj, _invokeAttr, _binder, _parameters, _culture) = notRequired "Invoke" genericMethodDefinition.Name - override __.ReflectedType = notRequired "ReflectedType" genericMethodDefinition.Name - override __.GetCustomAttributes(_inherit) = notRequired "GetCustomAttributes" genericMethodDefinition.Name - override __.GetCustomAttributes(_attributeType, _inherit) = notRequired "GetCustomAttributes" genericMethodDefinition.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 FSharp.Compiler.Service - // 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 __.One = typeof - member __.Product (m1,m2) = typedefof>.MakeGenericType [| m1;m2 |] - member __.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 __.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 __.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" className) - - 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" className) - - 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" className) - - 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" className) - - 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 __.AddXmlDocComputed xmlDocFunction = customAttributesImpl.AddXmlDocComputed xmlDocFunction - member __.AddXmlDocDelayed xmlDocFunction = customAttributesImpl.AddXmlDocDelayed xmlDocFunction - member __.AddXmlDoc xmlDoc = customAttributesImpl.AddXmlDoc xmlDoc - member __.AddObsoleteAttribute (message,?isError) = customAttributesImpl.AddObsolete (message,defaultArg isError false) - member __.AddDefinitionLocation(line,column,filePath) = customAttributesImpl.AddDefinitionLocation(line, column, filePath) - member __.HideObjectMethods with set v = customAttributesImpl.HideObjectMethods <- v - member __.NonNullable with set v = customAttributesImpl.NonNullable <- v - member __.GetCustomAttributesDataImpl() = customAttributesImpl.GetCustomAttributesData() - member __.AddCustomAttribute attribute = customAttributesImpl.AddCustomAttribute attribute -#if FX_NO_CUSTOMATTRIBUTEDATA -#else - override __.GetCustomAttributesData() = customAttributesImpl.GetCustomAttributesData() -#endif - - member __.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 __.UnderlyingSystemType = typeof - - member __.SetEnumUnderlyingType(ty) = enumUnderlyingType <- ty - - override __.GetEnumUnderlyingType() = if this.IsEnum then enumUnderlyingType else invalidOp "not enum type" - - member __.SetBaseType t = baseType <- lazy Some t - - member __.SetBaseTypeDelayed baseTypeFunction = baseType <- lazy (Some (baseTypeFunction())) - - member __.SetAttributes x = attributes <- x - - // Add MemberInfos - member __.AddMembersDelayed(membersFunction : unit -> list<#MemberInfo>) = - membersQueue.Add (fun () -> membersFunction() |> List.map (fun x -> patchUpAddedMemberInfo this x; x :> MemberInfo )) - - member __.AddMembers(memberInfos:list<#MemberInfo>) = (* strict *) - memberInfos |> List.iter (patchUpAddedMemberInfo this) // strict: patch up now - membersQueue.Add (fun () -> memberInfos |> List.map (fun x -> x :> MemberInfo)) - - member __.AddMember(memberInfo:MemberInfo) = - this.AddMembers [memberInfo] - - member __.AddMemberDelayed(memberFunction : unit -> #MemberInfo) = - this.AddMembersDelayed(fun () -> [memberFunction()]) - - member __.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 __.DefineStaticParameters(staticParameters : list, apply : (string -> obj[] -> ProvidedTypeDefinition)) = - staticParams <- staticParameters - staticParamsApply <- Some apply - - /// Get ParameterInfo[] for the parametric type parameters (//s GetGenericParameters) - member __.GetStaticParameters() = [| for p in staticParams -> p :> ParameterInfo |] - - /// Instantiate parametrics type - member __.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 __.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 __.Assembly = theAssembly.Force() - - member __.SetAssembly assembly = theAssembly <- lazy assembly - - member __.SetAssemblyLazy assembly = theAssembly <- assembly - - override __.FullName = fullName.Force() - - override __.Namespace = rootNamespace.Force() - - override __.BaseType = match baseType.Value with Some ty -> ty | None -> null - - // Constructors - override __.GetConstructors bindingAttr = - [| for m in this.GetMembers bindingAttr do - if m.MemberType = MemberTypes.Constructor then - yield (m :?> ConstructorInfo) |] - // Methods - override __.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 __.GetMethods bindingAttr = - this.GetMembers bindingAttr - |> Array.filter (fun m -> m.MemberType.HasFlag(MemberTypes.Method)) - |> Array.map (fun m -> m :?> MethodInfo) - - // Fields - override __.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 __.GetFields bindingAttr = - [| for m in this.GetMembers bindingAttr do if m.MemberType.HasFlag(MemberTypes.Field) then yield m :?> FieldInfo |] - - override __.GetInterface(_name, _ignoreCase) = notRequired "GetInterface" this.Name - - override __.GetInterfaces() = - [| yield! getInterfaces() |] - - member __.GetInterfaceImplementations() = - [| yield! getInterfaces() |] - - member __.AddInterfaceImplementation ityp = interfaceImpls.Add ityp - - member __.AddInterfaceImplementationsDelayed itypf = interfaceImplsDelayed.Add itypf - - member __.GetMethodOverrides() = - [| yield! methodOverrides |] - - member __.DefineMethodOverride (bodyMethInfo,declMethInfo) = methodOverrides.Add (bodyMethInfo, declMethInfo) - - // Events - override __.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 __.GetEvents bindingAttr = - [| for m in this.GetMembers bindingAttr do if m.MemberType.HasFlag(MemberTypes.Event) then yield downcast m |] - - // Properties - override __.GetProperties bindingAttr = - [| for m in this.GetMembers bindingAttr do if m.MemberType.HasFlag(MemberTypes.Property) then yield downcast m |] - - override __.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 __.MakeArrayType() = ProvidedSymbolType(SymbolKind.SDArray, [this]) :> Type - override __.MakeArrayType arg = ProvidedSymbolType(SymbolKind.Array arg, [this]) :> Type - override __.MakePointerType() = ProvidedSymbolType(SymbolKind.Pointer, [this]) :> Type - override __.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 __.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 __.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 __.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 __.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 __.GetAttributeFlagsImpl() = adjustTypeAttributes attributes this.IsNested - override __.IsArrayImpl() = false - override __.IsByRefImpl() = false - override __.IsPointerImpl() = false - override __.IsPrimitiveImpl() = false - override __.IsCOMObjectImpl() = false - override __.HasElementTypeImpl() = false - override __.Name = className - override __.DeclaringType = declaringType.Force() - override __.MemberType = if this.IsNested then MemberTypes.NestedType else MemberTypes.TypeInfo - override __.GetHashCode() = rootNamespace.GetHashCode() ^^^ className.GetHashCode() - override __.Equals(that:obj) = - match that with - | null -> false - | :? ProvidedTypeDefinition as ti -> System.Object.ReferenceEquals(this,ti) - | _ -> false - - override __.GetGenericArguments() = [||] - override __.ToString() = this.Name - - - override __.Module : Module = notRequired "Module" this.Name - override __.GUID = Guid.Empty - override __.GetConstructorImpl(_bindingAttr, _binder, _callConvention, _types, _modifiers) = null - override __.GetCustomAttributes(_inherit) = [| |] - override __.GetCustomAttributes(_attributeType, _inherit) = [| |] - override __.IsDefined(_attributeType: Type, _inherit) = false - - override __.GetElementType() = notRequired "Module" this.Name - override __.InvokeMember(_name, _invokeAttr, _binder, _target, _args, _modifiers, _culture, _namedParameters) = notRequired "Module" this.Name - override __.AssemblyQualifiedName = notRequired "Module" this.Name - member __.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 __.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 - } - - -#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 __.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 __.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 __.RegisterProbingFolder (folder) = - // use GetFullPath to ensure that folder is valid - ignore(IO.Path.GetFullPath folder) - probingFolders.Add folder - - member __.RegisterRuntimeAssemblyLocationAsProbingFolder (config : TypeProviderConfig) = - config.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 this.Invalidate() = invalidateE.Trigger(this,EventArgs()) - - member __.GetStaticParametersForMethod(mb: MethodBase) = - printfn "In GetStaticParametersForMethod" - match mb with - | :? ProvidedMethod as t -> t.GetStaticParameters() - | _ -> [| |] - - member __.ApplyStaticArgumentsForMethod(mb: MethodBase, mangledName, objs) = - printfn "In ApplyStaticArgumentsForMethod" - match mb with - | :? ProvidedMethod as t -> t.ApplyStaticArguments(mangledName, objs) :> MethodBase - | _ -> failwith (sprintf "ApplyStaticArguments: static parameters for method %s are unexpected" mb.Name) - - interface ITypeProvider with - - [] - override __.Invalidate = invalidateE.Publish - - override __.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 __.GetStaticParameters(ty) = - match ty with - | :? ProvidedTypeDefinition as t -> - if ty.Name = t.Name (* REVIEW: use equality? *) then - t.GetStaticParameters() - else - [| |] - | _ -> [| |] - - override __.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 __.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 __.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 +#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 = 2) + 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(message : string, isError) = obsoleteMessage <- Some (message,isError) + member __.HasParamArray with get() = hasParamArray and set(v) = hasParamArray <- v + member __.AddXmlDocComputed xmlDocFunction = xmlDocAlwaysRecomputed <- Some xmlDocFunction + member __.AddXmlDocDelayed xmlDocFunction = xmlDocDelayed <- Some xmlDocFunction + member __.AddXmlDoc xmlDoc = xmlDocDelayed <- Some (fun () -> xmlDoc) + 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 xmlDocFunction = customAttributesImpl.AddXmlDocDelayed xmlDocFunction + member __.AddXmlDocComputed xmlDocFunction = customAttributesImpl.AddXmlDocComputed xmlDocFunction + member __.AddXmlDoc xmlDoc = customAttributesImpl.AddXmlDoc xmlDoc + + 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 __.IsParamArray with get() = customAttributesImpl.HasParamArray and set(v) = customAttributesImpl.HasParamArray <- v + override __.Name = name + override __.ParameterType = parameterType + override __.Attributes = (base.Attributes ||| (if isOut then ParameterAttributes.Out else enum 0) + ||| (match optionalValue with None -> enum 0 | Some _ -> ParameterAttributes.Optional ||| ParameterAttributes.HasDefault)) + override __.RawDefaultValue = defaultArg optionalValue null + member __.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 isStatic() = ctorAttributes.HasFlag(MethodAttributes.Static) + + let customAttributesImpl = CustomAttributesImpl() + member __.IsTypeInitializer + with get() = isStatic() && ctorAttributes.HasFlag(MethodAttributes.Private) + and set(v) = + let typeInitializerAttributes = MethodAttributes.Static ||| MethodAttributes.Private + ctorAttributes <- if v then ctorAttributes ||| typeInitializerAttributes else ctorAttributes &&& ~~~typeInitializerAttributes + + member __.AddXmlDocComputed xmlDocFunction = customAttributesImpl.AddXmlDocComputed xmlDocFunction + member __.AddXmlDocDelayed xmlDocFunction = customAttributesImpl.AddXmlDocDelayed xmlDocFunction + member __.AddXmlDoc xmlDoc = customAttributesImpl.AddXmlDoc xmlDoc + member __.AddObsoleteAttribute (message,?isError) = customAttributesImpl.AddObsolete (message,defaultArg isError false) + member __.AddDefinitionLocation(line,column,filePath) = customAttributesImpl.AddDefinitionLocation(line, column, filePath) + member __.GetCustomAttributesDataImpl() = customAttributesImpl.GetCustomAttributesData() +#if FX_NO_CUSTOMATTRIBUTEDATA +#else + override __.GetCustomAttributesData() = customAttributesImpl.GetCustomAttributesData() +#endif + + member __.DeclaringTypeImpl + with set x = + if declaringType<>null then failwith (sprintf "ProvidedConstructor: declaringType already set on '%s'" (nameText())); + declaringType <- x + + member __.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 __.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 __.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 || isStatic() then [] else ["this"]) + |> Array.ofList + transQuotationToCode isGenerated f paramNames + | None -> failwith (sprintf "ProvidedConstructor: no invoker for '%s'" (nameText())) + + member __.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 __.IsImplicitCtor with get() = isImplicitCtor and set v = isImplicitCtor <- v + + // Implement overloads + override __.GetParameters() = parameters |> List.toArray + override __.Attributes = ctorAttributes + override __.Name = if isStatic() then ".cctor" else ".ctor" + override __.DeclaringType = declaringType |> nonNull "ProvidedConstructor.DeclaringType" + override __.IsDefined(_attributeType, _inherit) = true + + override __.Invoke(_invokeAttr, _binder, _parameters, _culture) = notRequired "Invoke" (nameText()) + override __.Invoke(_obj, _invokeAttr, _binder, _parameters, _culture) = notRequired "Invoke" (nameText()) + override __.ReflectedType = notRequired "ReflectedType" (nameText()) + override __.GetMethodImplementationFlags() = notRequired "GetMethodImplementationFlags" (nameText()) + override __.MethodHandle = notRequired "MethodHandle" (nameText()) + override __.GetCustomAttributes(_inherit) = notRequired "GetCustomAttributes" (nameText()) + override __.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 mutable staticParams = [ ] + let mutable staticParamsApply = None + let isStatic() = methodAttrs.HasFlag(MethodAttributes.Static) + let customAttributesImpl = CustomAttributesImpl() + + member __.AddXmlDocComputed xmlDocFunction = customAttributesImpl.AddXmlDocComputed xmlDocFunction + member __.AddXmlDocDelayed xmlDocFunction = customAttributesImpl.AddXmlDocDelayed xmlDocFunction + member __.AddXmlDoc xmlDoc = customAttributesImpl.AddXmlDoc xmlDoc + member __.AddObsoleteAttribute (message,?isError) = customAttributesImpl.AddObsolete (message,defaultArg isError false) + member __.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 __.GetCustomAttributesData() = customAttributesImpl.GetCustomAttributesData() +#endif + + member __.SetMethodAttrs m = methodAttrs <- m + member __.AddMethodAttrs m = methodAttrs <- methodAttrs ||| m + member __.DeclaringTypeImpl with set x = declaringType <- x // check: not set twice + member __.IsStaticMethod + with get() = isStatic() + and set x = if x then methodAttrs <- methodAttrs ||| MethodAttributes.Static + else methodAttrs <- methodAttrs &&& (~~~ MethodAttributes.Static) + + member __.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" methodName (if declaringType=null then "" else declaringType.FullName)) + + + /// Abstract a type to a parametric-type. Requires "formal parameters" and "instantiation function". + member __.DefineStaticParameters(staticParameters : list, apply : (string -> obj[] -> ProvidedMethod)) = + staticParams <- staticParameters + staticParamsApply <- Some apply + + /// Get ParameterInfo[] for the parametric type parameters (//s GetGenericParameters) + member __.GetStaticParameters() = [| for p in staticParams -> p :> ParameterInfo |] + + /// Instantiate parametrics type + member __.ApplyStaticArguments(mangledName: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 method %s" staticParams.Length args.Length methodName) + match staticParamsApply with + | None -> failwith "ProvidedTypeDefinition: DefineStaticParameters was not called" + | Some f -> f mangledName args + else + failwith (sprintf "ProvidedTypeDefinition: static parameters supplied but not expected for method %s" methodName) + + member __.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 isStatic() then [] else ["this"]) + |> Array.ofList + transQuotationToCode isGenerated f paramNames + | None -> failwith (sprintf "ProvidedMethod: no invoker for %s on type %s" methodName (if declaringType=null then "" else declaringType.FullName)) + + // Implement overloads + override __.GetParameters() = argParams |> Array.ofList + override __.Attributes = methodAttrs + override __.Name = methodName + override __.DeclaringType = declaringType |> nonNull "ProvidedMethod.DeclaringType" + override __.IsDefined(_attributeType, _inherit) : bool = true + override __.MemberType = MemberTypes.Method + override __.CallingConvention = + let cc = CallingConventions.Standard + let cc = if not (isStatic()) then cc ||| CallingConventions.HasThis else cc + cc + override __.ReturnType = returnType + override __.ReturnParameter = null // REVIEW: Give it a name and type? + override __.ToString() = "Method " + methodName + + // 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 __.MetadataToken = hash declaringType + hash methodName + override __.MethodHandle = RuntimeMethodHandle() + + override __.ReturnTypeCustomAttributes = notRequired "ReturnTypeCustomAttributes" methodName + override __.GetBaseDefinition() = notRequired "GetBaseDefinition" methodName + override __.GetMethodImplementationFlags() = notRequired "GetMethodImplementationFlags" methodName + override __.Invoke(_obj, _invokeAttr, _binder, _parameters, _culture) = notRequired "Invoke" methodName + override __.ReflectedType = notRequired "ReflectedType" methodName + override __.GetCustomAttributes(_inherit) = notRequired "GetCustomAttributes" methodName + override __.GetCustomAttributes(_attributeType, _inherit) = notRequired "GetCustomAttributes" methodName + + +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 __.AddXmlDocComputed xmlDocFunction = customAttributesImpl.AddXmlDocComputed xmlDocFunction + member __.AddXmlDocDelayed xmlDocFunction = customAttributesImpl.AddXmlDocDelayed xmlDocFunction + member __.AddXmlDoc xmlDoc = customAttributesImpl.AddXmlDoc xmlDoc + member __.AddObsoleteAttribute (message,?isError) = customAttributesImpl.AddObsolete (message,defaultArg isError false) + member __.AddDefinitionLocation(line,column,filePath) = customAttributesImpl.AddDefinitionLocation(line, column, filePath) + member __.GetCustomAttributesDataImpl() = customAttributesImpl.GetCustomAttributesData() + member __.AddCustomAttribute attribute = customAttributesImpl.AddCustomAttribute attribute +#if FX_NO_CUSTOMATTRIBUTEDATA +#else + override __.GetCustomAttributesData() = customAttributesImpl.GetCustomAttributesData() +#endif + + member __.DeclaringTypeImpl with set x = declaringType <- x // check: not set twice + + member __.IsStatic + with get() = isStatic + and set x = isStatic <- x + + member __.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 __.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 __.PropertyType = propertyType + override __.SetValue(_obj, _value, _invokeAttr, _binder, _index, _culture) = notRequired "SetValue" propertyName + override __.GetAccessors _nonPublic = notRequired "nonPublic" propertyName + override __.GetGetMethod _nonPublic = if hasGetter() then getter.Force() :> MethodInfo else null + override __.GetSetMethod _nonPublic = if hasSetter() then setter.Force() :> MethodInfo else null + override __.GetIndexParameters() = [| for p in parameters -> upcast p |] + override __.Attributes = PropertyAttributes.None + override __.CanRead = hasGetter() + override __.CanWrite = hasSetter() + override __.GetValue(_obj, _invokeAttr, _binder, _index, _culture) : obj = notRequired "GetValue" propertyName + override __.Name = propertyName + override __.DeclaringType = declaringType |> nonNull "ProvidedProperty.DeclaringType" + override __.MemberType : MemberTypes = MemberTypes.Property + + override __.ReflectedType = notRequired "ReflectedType" propertyName + override __.GetCustomAttributes(_inherit) = notRequired "GetCustomAttributes" propertyName + override __.GetCustomAttributes(_attributeType, _inherit) = notRequired "GetCustomAttributes" propertyName + override __.IsDefined(_attributeType, _inherit) = notRequired "IsDefined" propertyName + +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 __.AddXmlDocComputed xmlDocFunction = customAttributesImpl.AddXmlDocComputed xmlDocFunction + member __.AddXmlDocDelayed xmlDocFunction = customAttributesImpl.AddXmlDocDelayed xmlDocFunction + member __.AddXmlDoc xmlDoc = customAttributesImpl.AddXmlDoc xmlDoc + member __.AddDefinitionLocation(line,column,filePath) = customAttributesImpl.AddDefinitionLocation(line, column, filePath) + member __.GetCustomAttributesDataImpl() = customAttributesImpl.GetCustomAttributesData() +#if FX_NO_CUSTOMATTRIBUTEDATA +#else + override __.GetCustomAttributesData() = customAttributesImpl.GetCustomAttributesData() +#endif + + member __.DeclaringTypeImpl with set x = declaringType <- x // check: not set twice + member __.IsStatic + with get() = isStatic + and set x = isStatic <- x + + member __.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 __.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 __.EventHandlerType = eventHandlerType + override __.GetAddMethod _nonPublic = adder.Force() :> MethodInfo + override __.GetRemoveMethod _nonPublic = remover.Force() :> MethodInfo + override __.Attributes = EventAttributes.None + override __.Name = eventName + override __.DeclaringType = declaringType |> nonNull "ProvidedEvent.DeclaringType" + override __.MemberType : MemberTypes = MemberTypes.Event + + override __.GetRaiseMethod _nonPublic = notRequired "GetRaiseMethod" eventName + override __.ReflectedType = notRequired "ReflectedType" eventName + override __.GetCustomAttributes(_inherit) = notRequired "GetCustomAttributes" eventName + override __.GetCustomAttributes(_attributeType, _inherit) = notRequired "GetCustomAttributes" eventName + override __.IsDefined(_attributeType, _inherit) = notRequired "IsDefined" eventName + +type ProvidedLiteralField(fieldName:string,fieldType:Type,literalValue:obj) = + inherit System.Reflection.FieldInfo() + // State + + let mutable declaringType = null + + let customAttributesImpl = CustomAttributesImpl() + member __.AddXmlDocComputed xmlDocFunction = customAttributesImpl.AddXmlDocComputed xmlDocFunction + member __.AddXmlDocDelayed xmlDocFunction = customAttributesImpl.AddXmlDocDelayed xmlDocFunction + member __.AddXmlDoc xmlDoc = customAttributesImpl.AddXmlDoc xmlDoc + member __.AddObsoleteAttribute (message,?isError) = customAttributesImpl.AddObsolete (message,defaultArg isError false) + member __.AddDefinitionLocation(line,column,filePath) = customAttributesImpl.AddDefinitionLocation(line, column, filePath) + member __.GetCustomAttributesDataImpl() = customAttributesImpl.GetCustomAttributesData() +#if FX_NO_CUSTOMATTRIBUTEDATA +#else + override __.GetCustomAttributesData() = customAttributesImpl.GetCustomAttributesData() +#endif + + member __.DeclaringTypeImpl with set x = declaringType <- x // check: not set twice + + + // Implement overloads + override __.FieldType = fieldType + override __.GetRawConstantValue() = literalValue + override __.Attributes = FieldAttributes.Static ||| FieldAttributes.Literal ||| FieldAttributes.Public + override __.Name = fieldName + override __.DeclaringType = declaringType |> nonNull "ProvidedLiteralField.DeclaringType" + override __.MemberType : MemberTypes = MemberTypes.Field + + override __.ReflectedType = notRequired "ReflectedType" fieldName + override __.GetCustomAttributes(_inherit) = notRequired "GetCustomAttributes" fieldName + override __.GetCustomAttributes(_attributeType, _inherit) = notRequired "GetCustomAttributes" fieldName + override __.IsDefined(_attributeType, _inherit) = notRequired "IsDefined" fieldName + + override __.SetValue(_obj, _value, _invokeAttr, _binder, _culture) = notRequired "SetValue" fieldName + override __.GetValue(_obj) : obj = notRequired "GetValue" fieldName + override __.FieldHandle = notRequired "FieldHandle" fieldName + +type ProvidedField(fieldName:string,fieldType:Type) = + inherit System.Reflection.FieldInfo() + // State + + let mutable declaringType = null + + let customAttributesImpl = CustomAttributesImpl() + let mutable fieldAttrs = FieldAttributes.Private + member __.AddXmlDocComputed xmlDocFunction = customAttributesImpl.AddXmlDocComputed xmlDocFunction + member __.AddXmlDocDelayed xmlDocFunction = customAttributesImpl.AddXmlDocDelayed xmlDocFunction + member __.AddXmlDoc xmlDoc = customAttributesImpl.AddXmlDoc xmlDoc + member __.AddObsoleteAttribute (message,?isError) = customAttributesImpl.AddObsolete (message,defaultArg isError false) + member __.AddDefinitionLocation(line,column,filePath) = customAttributesImpl.AddDefinitionLocation(line, column, filePath) + member __.GetCustomAttributesDataImpl() = customAttributesImpl.GetCustomAttributesData() +#if FX_NO_CUSTOMATTRIBUTEDATA +#else + override __.GetCustomAttributesData() = customAttributesImpl.GetCustomAttributesData() +#endif + + member __.DeclaringTypeImpl with set x = declaringType <- x // check: not set twice + + member __.SetFieldAttributes attrs = fieldAttrs <- attrs + // Implement overloads + override __.FieldType = fieldType + override __.GetRawConstantValue() = null + override __.Attributes = fieldAttrs + override __.Name = fieldName + override __.DeclaringType = declaringType |> nonNull "ProvidedField.DeclaringType" + override __.MemberType : MemberTypes = MemberTypes.Field + + override __.ReflectedType = notRequired "ReflectedType" fieldName + override __.GetCustomAttributes(_inherit) = notRequired "GetCustomAttributes" fieldName + override __.GetCustomAttributes(_attributeType, _inherit) = notRequired "GetCustomAttributes" fieldName + override __.IsDefined(_attributeType, _inherit) = notRequired "IsDefined" fieldName + + override __.SetValue(_obj, _value, _invokeAttr, _binder, _culture) = notRequired "SetValue" fieldName + override __.GetValue(_obj) : obj = notRequired "GetValue" fieldName + override __.FieldHandle = notRequired "FieldHandle" fieldName + +/// 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 + + let nameText() = + 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" + + 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 __.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 __.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 __.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 __.Name = nameText() + + override __.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 __.GetArrayRank() = (match kind with SymbolKind.Array n -> n | SymbolKind.SDArray -> 1 | _ -> invalidOp "non-array type") + override __.IsArrayImpl() = (match kind with SymbolKind.Array _ | SymbolKind.SDArray -> true | _ -> false) + override __.IsByRefImpl() = (match kind with SymbolKind.ByRef _ -> true | _ -> false) + override __.IsPointerImpl() = (match kind with SymbolKind.Pointer _ -> true | _ -> false) + override __.IsPrimitiveImpl() = false + override __.IsGenericType = (match kind with SymbolKind.Generic _ -> true | _ -> false) + override __.GetGenericArguments() = (match kind with SymbolKind.Generic _ -> args |> List.toArray | _ -> invalidOp "non-generic type") + override __.GetGenericTypeDefinition() = (match kind with SymbolKind.Generic e -> e | _ -> invalidOp "non-generic type") + override __.IsCOMObjectImpl() = false + override __.HasElementTypeImpl() = (match kind with SymbolKind.Generic _ -> false | _ -> true) + override __.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 __.Assembly = + match kind with + | SymbolKind.FSharpTypeAbbreviation (assembly,_nsp,_path) -> assembly + | SymbolKind.Generic gty -> gty.Assembly + | _ -> notRequired "Assembly" (nameText()) + + override __.Namespace = + match kind with + | SymbolKind.FSharpTypeAbbreviation (_assembly,nsp,_path) -> nsp + | _ -> notRequired "Namespace" (nameText()) + + override __.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 __.Equals(other: obj) = + match other with + | :? ProvidedSymbolType as otherTy -> (kind, args) = (otherTy.Kind, otherTy.Args) + | _ -> false + + member __.Kind = kind + member __.Args = args + + override __.Module : Module = notRequired "Module" (nameText()) + override __.GetConstructors _bindingAttr = notRequired "GetConstructors" (nameText()) + override __.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" (nameText()) + override __.GetMembers _bindingAttr = notRequired "GetMembers" (nameText()) + override __.GetMethods _bindingAttr = notRequired "GetMethods" (nameText()) + override __.GetField(_name, _bindingAttr) = notRequired "GetField" (nameText()) + override __.GetFields _bindingAttr = notRequired "GetFields" (nameText()) + override __.GetInterface(_name, _ignoreCase) = notRequired "GetInterface" (nameText()) + override __.GetInterfaces() = notRequired "GetInterfaces" (nameText()) + override __.GetEvent(_name, _bindingAttr) = notRequired "GetEvent" (nameText()) + override __.GetEvents _bindingAttr = notRequired "GetEvents" (nameText()) + override __.GetProperties _bindingAttr = notRequired "GetProperties" (nameText()) + override __.GetPropertyImpl(_name, _bindingAttr, _binder, _returnType, _types, _modifiers) = notRequired "GetPropertyImpl" (nameText()) + override __.GetNestedTypes _bindingAttr = notRequired "GetNestedTypes" (nameText()) + override __.GetNestedType(_name, _bindingAttr) = notRequired "GetNestedType" (nameText()) + override __.GetAttributeFlagsImpl() = notRequired "GetAttributeFlagsImpl" (nameText()) + override this.UnderlyingSystemType = + match kind with + | SymbolKind.SDArray + | SymbolKind.Array _ + | SymbolKind.Pointer + | SymbolKind.FSharpTypeAbbreviation _ + | SymbolKind.ByRef -> upcast this + | SymbolKind.Generic gty -> gty.UnderlyingSystemType +#if FX_NO_CUSTOMATTRIBUTEDATA +#else + override __.GetCustomAttributesData() = ([| |] :> IList<_>) +#endif + override __.MemberType = notRequired "MemberType" (nameText()) + override __.GetMember(_name,_mt,_bindingAttr) = notRequired "GetMember" (nameText()) + override __.GUID = notRequired "GUID" (nameText()) + override __.InvokeMember(_name, _invokeAttr, _binder, _target, _args, _modifiers, _culture, _namedParameters) = notRequired "InvokeMember" (nameText()) + override __.AssemblyQualifiedName = notRequired "AssemblyQualifiedName" (nameText()) + override __.GetConstructorImpl(_bindingAttr, _binder, _callConvention, _types, _modifiers) = notRequired "GetConstructorImpl" (nameText()) + override __.GetCustomAttributes(_inherit) = [| |] + override __.GetCustomAttributes(_attributeType, _inherit) = [| |] + override __.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 __.Name = p.Name + override __.ParameterType = ProvidedSymbolType.convType parameters p.ParameterType + override __.Attributes = p.Attributes + override __.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 __.GetGenericMethodDefinition() = genericMethodDefinition + + override __.DeclaringType = ProvidedSymbolType.convType parameters genericMethodDefinition.DeclaringType + override __.ToString() = "Method " + genericMethodDefinition.Name + override __.Name = genericMethodDefinition.Name + override __.MetadataToken = genericMethodDefinition.MetadataToken + override __.Attributes = genericMethodDefinition.Attributes + override __.CallingConvention = genericMethodDefinition.CallingConvention + override __.MemberType = genericMethodDefinition.MemberType + + override __.IsDefined(_attributeType, _inherit) : bool = notRequired "IsDefined" genericMethodDefinition.Name + override __.ReturnType = ProvidedSymbolType.convType parameters genericMethodDefinition.ReturnType + override __.GetParameters() = genericMethodDefinition.GetParameters() |> Array.map convParam + override __.ReturnParameter = genericMethodDefinition.ReturnParameter |> convParam + override __.ReturnTypeCustomAttributes = notRequired "ReturnTypeCustomAttributes" genericMethodDefinition.Name + override __.GetBaseDefinition() = notRequired "GetBaseDefinition" genericMethodDefinition.Name + override __.GetMethodImplementationFlags() = notRequired "GetMethodImplementationFlags" genericMethodDefinition.Name + override __.MethodHandle = notRequired "MethodHandle" genericMethodDefinition.Name + override __.Invoke(_obj, _invokeAttr, _binder, _parameters, _culture) = notRequired "Invoke" genericMethodDefinition.Name + override __.ReflectedType = notRequired "ReflectedType" genericMethodDefinition.Name + override __.GetCustomAttributes(_inherit) = notRequired "GetCustomAttributes" genericMethodDefinition.Name + override __.GetCustomAttributes(_attributeType, _inherit) = notRequired "GetCustomAttributes" genericMethodDefinition.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 FSharp.Compiler.Service + // 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 __.One = typeof + member __.Product (m1,m2) = typedefof>.MakeGenericType [| m1;m2 |] + member __.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 __.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 __.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" className) + + 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" className) + + 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" className) + + 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" className) + + 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 __.AddXmlDocComputed xmlDocFunction = customAttributesImpl.AddXmlDocComputed xmlDocFunction + member __.AddXmlDocDelayed xmlDocFunction = customAttributesImpl.AddXmlDocDelayed xmlDocFunction + member __.AddXmlDoc xmlDoc = customAttributesImpl.AddXmlDoc xmlDoc + member __.AddObsoleteAttribute (message,?isError) = customAttributesImpl.AddObsolete (message,defaultArg isError false) + member __.AddDefinitionLocation(line,column,filePath) = customAttributesImpl.AddDefinitionLocation(line, column, filePath) + member __.HideObjectMethods with set v = customAttributesImpl.HideObjectMethods <- v + member __.NonNullable with set v = customAttributesImpl.NonNullable <- v + member __.GetCustomAttributesDataImpl() = customAttributesImpl.GetCustomAttributesData() + member __.AddCustomAttribute attribute = customAttributesImpl.AddCustomAttribute attribute +#if FX_NO_CUSTOMATTRIBUTEDATA +#else + override __.GetCustomAttributesData() = customAttributesImpl.GetCustomAttributesData() +#endif + + member __.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 __.UnderlyingSystemType = typeof + + member __.SetEnumUnderlyingType(ty) = enumUnderlyingType <- ty + + override __.GetEnumUnderlyingType() = if this.IsEnum then enumUnderlyingType else invalidOp "not enum type" + + member __.SetBaseType t = baseType <- lazy Some t + + member __.SetBaseTypeDelayed baseTypeFunction = baseType <- lazy (Some (baseTypeFunction())) + + member __.SetAttributes x = attributes <- x + + // Add MemberInfos + member __.AddMembersDelayed(membersFunction : unit -> list<#MemberInfo>) = + membersQueue.Add (fun () -> membersFunction() |> List.map (fun x -> patchUpAddedMemberInfo this x; x :> MemberInfo )) + + member __.AddMembers(memberInfos:list<#MemberInfo>) = (* strict *) + memberInfos |> List.iter (patchUpAddedMemberInfo this) // strict: patch up now + membersQueue.Add (fun () -> memberInfos |> List.map (fun x -> x :> MemberInfo)) + + member __.AddMember(memberInfo:MemberInfo) = + this.AddMembers [memberInfo] + + member __.AddMemberDelayed(memberFunction : unit -> #MemberInfo) = + this.AddMembersDelayed(fun () -> [memberFunction()]) + + member __.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 __.DefineStaticParameters(staticParameters : list, apply : (string -> obj[] -> ProvidedTypeDefinition)) = + staticParams <- staticParameters + staticParamsApply <- Some apply + + /// Get ParameterInfo[] for the parametric type parameters (//s GetGenericParameters) + member __.GetStaticParameters() = [| for p in staticParams -> p :> ParameterInfo |] + + /// Instantiate parametrics type + member __.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 __.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 __.Assembly = theAssembly.Force() + + member __.SetAssembly assembly = theAssembly <- lazy assembly + + member __.SetAssemblyLazy assembly = theAssembly <- assembly + + override __.FullName = fullName.Force() + + override __.Namespace = rootNamespace.Force() + + override __.BaseType = match baseType.Value with Some ty -> ty | None -> null + + // Constructors + override __.GetConstructors bindingAttr = + [| for m in this.GetMembers bindingAttr do + if m.MemberType = MemberTypes.Constructor then + yield (m :?> ConstructorInfo) |] + // Methods + override __.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 __.GetMethods bindingAttr = + this.GetMembers bindingAttr + |> Array.filter (fun m -> m.MemberType.HasFlag(MemberTypes.Method)) + |> Array.map (fun m -> m :?> MethodInfo) + + // Fields + override __.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 __.GetFields bindingAttr = + [| for m in this.GetMembers bindingAttr do if m.MemberType.HasFlag(MemberTypes.Field) then yield m :?> FieldInfo |] + + override __.GetInterface(_name, _ignoreCase) = notRequired "GetInterface" this.Name + + override __.GetInterfaces() = + [| yield! getInterfaces() |] + + member __.GetInterfaceImplementations() = + [| yield! getInterfaces() |] + + member __.AddInterfaceImplementation ityp = interfaceImpls.Add ityp + + member __.AddInterfaceImplementationsDelayed itypf = interfaceImplsDelayed.Add itypf + + member __.GetMethodOverrides() = + [| yield! methodOverrides |] + + member __.DefineMethodOverride (bodyMethInfo,declMethInfo) = methodOverrides.Add (bodyMethInfo, declMethInfo) + + // Events + override __.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 __.GetEvents bindingAttr = + [| for m in this.GetMembers bindingAttr do if m.MemberType.HasFlag(MemberTypes.Event) then yield downcast m |] + + // Properties + override __.GetProperties bindingAttr = + [| for m in this.GetMembers bindingAttr do if m.MemberType.HasFlag(MemberTypes.Property) then yield downcast m |] + + override __.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 __.MakeArrayType() = ProvidedSymbolType(SymbolKind.SDArray, [this]) :> Type + override __.MakeArrayType arg = ProvidedSymbolType(SymbolKind.Array arg, [this]) :> Type + override __.MakePointerType() = ProvidedSymbolType(SymbolKind.Pointer, [this]) :> Type + override __.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 __.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 __.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 __.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 __.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 __.GetAttributeFlagsImpl() = adjustTypeAttributes attributes this.IsNested + override __.IsArrayImpl() = false + override __.IsByRefImpl() = false + override __.IsPointerImpl() = false + override __.IsPrimitiveImpl() = false + override __.IsCOMObjectImpl() = false + override __.HasElementTypeImpl() = false + override __.Name = className + override __.DeclaringType = declaringType.Force() + override __.MemberType = if this.IsNested then MemberTypes.NestedType else MemberTypes.TypeInfo + override __.GetHashCode() = rootNamespace.GetHashCode() ^^^ className.GetHashCode() + override __.Equals(that:obj) = + match that with + | null -> false + | :? ProvidedTypeDefinition as ti -> System.Object.ReferenceEquals(this,ti) + | _ -> false + + override __.GetGenericArguments() = [||] + override __.ToString() = this.Name + + + override __.Module : Module = notRequired "Module" this.Name + override __.GUID = Guid.Empty + override __.GetConstructorImpl(_bindingAttr, _binder, _callConvention, _types, _modifiers) = null + override __.GetCustomAttributes(_inherit) = [| |] + override __.GetCustomAttributes(_attributeType, _inherit) = [| |] + override __.IsDefined(_attributeType: Type, _inherit) = false + + override __.GetElementType() = notRequired "Module" this.Name + override __.InvokeMember(_name, _invokeAttr, _binder, _target, _args, _modifiers, _culture, _namedParameters) = notRequired "Module" this.Name + override __.AssemblyQualifiedName = notRequired "Module" this.Name + member __.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 __.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 + } + + +#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 __.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 __.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 __.RegisterProbingFolder (folder) = + // use GetFullPath to ensure that folder is valid + ignore(IO.Path.GetFullPath folder) + probingFolders.Add folder + + member __.RegisterRuntimeAssemblyLocationAsProbingFolder (config : TypeProviderConfig) = + config.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 this.Invalidate() = invalidateE.Trigger(this,EventArgs()) + + member __.GetStaticParametersForMethod(mb: MethodBase) = + printfn "In GetStaticParametersForMethod" + match mb with + | :? ProvidedMethod as t -> t.GetStaticParameters() + | _ -> [| |] + + member __.ApplyStaticArgumentsForMethod(mb: MethodBase, mangledName, objs) = + printfn "In ApplyStaticArgumentsForMethod" + match mb with + | :? ProvidedMethod as t -> t.ApplyStaticArguments(mangledName, objs) :> MethodBase + | _ -> failwith (sprintf "ApplyStaticArguments: static parameters for method %s are unexpected" mb.Name) + + interface ITypeProvider with + + [] + override __.Invalidate = invalidateE.Publish + + override __.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 __.GetStaticParameters(ty) = + match ty with + | :? ProvidedTypeDefinition as t -> + if ty.Name = t.Name (* REVIEW: use equality? *) then + t.GetStaticParameters() + else + [| |] + | _ -> [| |] + + override __.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 __.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 __.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/src/Xamarin.iOSProviders/Xamarin.UIProviders.DesignTime.fsproj b/src/Xamarin.iOSProviders/Xamarin.UIProviders.DesignTime.fsproj index 504e3b1..6acab2a 100644 --- a/src/Xamarin.iOSProviders/Xamarin.UIProviders.DesignTime.fsproj +++ b/src/Xamarin.iOSProviders/Xamarin.UIProviders.DesignTime.fsproj @@ -1,4 +1,4 @@ - + Debug AnyCPU @@ -14,7 +14,8 @@ ..\Build\Debug DEBUG prompt - + + true false false @@ -25,10 +26,12 @@ true ..\Build\Release prompt - + + false true - + + Program @@ -50,12 +53,6 @@ /Applications/Visual Studio.app/Contents/Resources/lib/monodevelop/AddIns/MonoDevelop.IPhone/MonoTouch.Design.Client.dll - - ..\packages\ExtCore.0.8.45\lib\net45\ExtCore.dll - - - ..\packages\Unquote.3.1.1\lib\net45\Unquote.dll - /Applications/Visual Studio.app/Contents/Resources/lib/monodevelop/AddIns/MonoDevelop.MacDev/MonoDevelop.MacDev.dll @@ -66,12 +63,18 @@ - - + + True + + + True + - + + True + @@ -79,8 +82,48 @@ - + + + + + + ..\..\packages\ExtCore\lib\net45\ExtCore.dll + True + True + + + + + + + + + ..\..\packages\Unquote\lib\net40\Unquote.dll + True + True + + + + + + + ..\..\packages\Unquote\lib\net45\Unquote.dll + True + True + + + + + + + ..\..\packages\Unquote\lib\portable-net45+netcore45+wpa81+wp8+MonoAndroid1+MonoTouch1\Unquote.dll + True + True + + + + \ No newline at end of file diff --git a/src/Xamarin.iOSProviders/Xamarin.iOSProviders.sln b/src/Xamarin.iOSProviders/Xamarin.iOSProviders.sln index e9c7c7d..3406e3c 100644 --- a/src/Xamarin.iOSProviders/Xamarin.iOSProviders.sln +++ b/src/Xamarin.iOSProviders/Xamarin.iOSProviders.sln @@ -1,6 +1,11 @@  Microsoft Visual Studio Solution File, Format Version 11.00 # Visual Studio 2010 +Project("{2150E333-8FDC-42A3-9474-1A3956D46DE8}") = ".paket", ".paket", "{89B3BDAF-823A-4D54-835B-D11E27BB07CE}" + ProjectSection(SolutionItems) = preProject + ..\..\paket.dependencies = ..\..\paket.dependencies + EndProjectSection +EndProject Project("{f2a71f9b-5d33-465a-a702-920d77279786}") = "Xamarin.iOSProviders", "Xamarin.iOSProviders.fsproj", "{DD17E7B0-6EE1-4862-80F8-E0CAB67D6137}" EndProject Global diff --git a/src/Xamarin.iOSProviders/packages.config b/src/Xamarin.iOSProviders/packages.config deleted file mode 100644 index a58e883..0000000 --- a/src/Xamarin.iOSProviders/packages.config +++ /dev/null @@ -1,6 +0,0 @@ - - - - - - \ No newline at end of file diff --git a/src/Xamarin.iOSProviders/paket.references b/src/Xamarin.iOSProviders/paket.references new file mode 100644 index 0000000..7323c9c --- /dev/null +++ b/src/Xamarin.iOSProviders/paket.references @@ -0,0 +1,3 @@ +ExtCore +FSharp.TypeProviders.StarterPack +Unquote \ No newline at end of file From c4678779f5d560af40d1e5ab1960ddff4653fbe2 Mon Sep 17 00:00:00 2001 From: Dave Thomas Date: Mon, 26 Jun 2017 20:25:40 +0100 Subject: [PATCH 03/10] Update then kill unnecessary files --- src/XAmarin.UIProvider.iOSRuntime/AssemblyInfo.fs | 11 ++++------- src/XAmarin.UIProvider.iOSRuntime/Component1.fs | 5 ----- src/Xamarin.UIProvider.OSXRuntime/AssemblyInfo.fs | 11 ++++------- src/Xamarin.UIProvider.OSXRuntime/Component1.fs | 5 ----- src/Xamarin.UIProvider.TVOSRuntime/AssemblyInfo.fs | 10 ++++------ src/Xamarin.UIProvider.TVOSRuntime/Component1.fs | 5 ----- 6 files changed, 12 insertions(+), 35 deletions(-) delete mode 100644 src/XAmarin.UIProvider.iOSRuntime/Component1.fs delete mode 100644 src/Xamarin.UIProvider.OSXRuntime/Component1.fs delete mode 100644 src/Xamarin.UIProvider.TVOSRuntime/Component1.fs diff --git a/src/XAmarin.UIProvider.iOSRuntime/AssemblyInfo.fs b/src/XAmarin.UIProvider.iOSRuntime/AssemblyInfo.fs index ffcdc14..e157d9d 100644 --- a/src/XAmarin.UIProvider.iOSRuntime/AssemblyInfo.fs +++ b/src/XAmarin.UIProvider.iOSRuntime/AssemblyInfo.fs @@ -1,20 +1,17 @@ namespace Xamarin.UIProvider.iOSRuntime open System.Reflection +open Microsoft.FSharp.Core.CompilerServices open System.Runtime.CompilerServices [] [] [] -[] +[] [] -[] +[] [] - -// The assembly version has the format {Major}.{Minor}.{Build}.{Revision} - [] - +[] //[] //[] - () diff --git a/src/XAmarin.UIProvider.iOSRuntime/Component1.fs b/src/XAmarin.UIProvider.iOSRuntime/Component1.fs deleted file mode 100644 index e4d2bd2..0000000 --- a/src/XAmarin.UIProvider.iOSRuntime/Component1.fs +++ /dev/null @@ -1,5 +0,0 @@ -namespace global -open Microsoft.FSharp.Core.CompilerServices - -[] -() \ No newline at end of file diff --git a/src/Xamarin.UIProvider.OSXRuntime/AssemblyInfo.fs b/src/Xamarin.UIProvider.OSXRuntime/AssemblyInfo.fs index 8ea4e59..5a2ddc7 100644 --- a/src/Xamarin.UIProvider.OSXRuntime/AssemblyInfo.fs +++ b/src/Xamarin.UIProvider.OSXRuntime/AssemblyInfo.fs @@ -1,20 +1,17 @@ namespace Xamarin.UIProvider.OSXRuntime open System.Reflection +open Microsoft.FSharp.Core.CompilerServices open System.Runtime.CompilerServices [] [] [] -[] +[] [] -[] +[] [] - -// The assembly version has the format {Major}.{Minor}.{Build}.{Revision} - [] - +[] //[] //[] - () diff --git a/src/Xamarin.UIProvider.OSXRuntime/Component1.fs b/src/Xamarin.UIProvider.OSXRuntime/Component1.fs deleted file mode 100644 index e4d2bd2..0000000 --- a/src/Xamarin.UIProvider.OSXRuntime/Component1.fs +++ /dev/null @@ -1,5 +0,0 @@ -namespace global -open Microsoft.FSharp.Core.CompilerServices - -[] -() \ No newline at end of file diff --git a/src/Xamarin.UIProvider.TVOSRuntime/AssemblyInfo.fs b/src/Xamarin.UIProvider.TVOSRuntime/AssemblyInfo.fs index 342e071..384c2d5 100644 --- a/src/Xamarin.UIProvider.TVOSRuntime/AssemblyInfo.fs +++ b/src/Xamarin.UIProvider.TVOSRuntime/AssemblyInfo.fs @@ -1,19 +1,17 @@ namespace Xamarin.UIProvider.TVOSRuntime open System.Reflection +open Microsoft.FSharp.Core.CompilerServices open System.Runtime.CompilerServices [] [] [] -[] +[] [] -[] +[] [] - -// The assembly version has the format {Major}.{Minor}.{Build}.{Revision} - [] - +[] //[] //[] diff --git a/src/Xamarin.UIProvider.TVOSRuntime/Component1.fs b/src/Xamarin.UIProvider.TVOSRuntime/Component1.fs deleted file mode 100644 index e4d2bd2..0000000 --- a/src/Xamarin.UIProvider.TVOSRuntime/Component1.fs +++ /dev/null @@ -1,5 +0,0 @@ -namespace global -open Microsoft.FSharp.Core.CompilerServices - -[] -() \ No newline at end of file From f3cc170dbeba297b890c99268b071098e634eead Mon Sep 17 00:00:00 2001 From: Dave Thomas Date: Mon, 26 Jun 2017 20:29:10 +0100 Subject: [PATCH 04/10] Update provided types to latest --- src/Xamarin.iOSProviders/ProvidedTypes.fs | 5780 +++++++++++--------- src/Xamarin.iOSProviders/ProvidedTypes.fsi | 109 +- 2 files changed, 3128 insertions(+), 2761 deletions(-) diff --git a/src/Xamarin.iOSProviders/ProvidedTypes.fs b/src/Xamarin.iOSProviders/ProvidedTypes.fs index c6e67cf..0f7d8c3 100644 --- a/src/Xamarin.iOSProviders/ProvidedTypes.fs +++ b/src/Xamarin.iOSProviders/ProvidedTypes.fs @@ -1,2736 +1,3044 @@ -#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 = 2) - 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(message : string, isError) = obsoleteMessage <- Some (message,isError) - member __.HasParamArray with get() = hasParamArray and set(v) = hasParamArray <- v - member __.AddXmlDocComputed xmlDocFunction = xmlDocAlwaysRecomputed <- Some xmlDocFunction - member __.AddXmlDocDelayed xmlDocFunction = xmlDocDelayed <- Some xmlDocFunction - member __.AddXmlDoc xmlDoc = xmlDocDelayed <- Some (fun () -> xmlDoc) - 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 xmlDocFunction = customAttributesImpl.AddXmlDocDelayed xmlDocFunction - member __.AddXmlDocComputed xmlDocFunction = customAttributesImpl.AddXmlDocComputed xmlDocFunction - member __.AddXmlDoc xmlDoc = customAttributesImpl.AddXmlDoc xmlDoc - - 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 __.IsParamArray with get() = customAttributesImpl.HasParamArray and set(v) = customAttributesImpl.HasParamArray <- v - override __.Name = name - override __.ParameterType = parameterType - override __.Attributes = (base.Attributes ||| (if isOut then ParameterAttributes.Out else enum 0) - ||| (match optionalValue with None -> enum 0 | Some _ -> ParameterAttributes.Optional ||| ParameterAttributes.HasDefault)) - override __.RawDefaultValue = defaultArg optionalValue null - member __.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 isStatic() = ctorAttributes.HasFlag(MethodAttributes.Static) - - let customAttributesImpl = CustomAttributesImpl() - member __.IsTypeInitializer - with get() = isStatic() && ctorAttributes.HasFlag(MethodAttributes.Private) - and set(v) = - let typeInitializerAttributes = MethodAttributes.Static ||| MethodAttributes.Private - ctorAttributes <- if v then ctorAttributes ||| typeInitializerAttributes else ctorAttributes &&& ~~~typeInitializerAttributes - - member __.AddXmlDocComputed xmlDocFunction = customAttributesImpl.AddXmlDocComputed xmlDocFunction - member __.AddXmlDocDelayed xmlDocFunction = customAttributesImpl.AddXmlDocDelayed xmlDocFunction - member __.AddXmlDoc xmlDoc = customAttributesImpl.AddXmlDoc xmlDoc - member __.AddObsoleteAttribute (message,?isError) = customAttributesImpl.AddObsolete (message,defaultArg isError false) - member __.AddDefinitionLocation(line,column,filePath) = customAttributesImpl.AddDefinitionLocation(line, column, filePath) - member __.GetCustomAttributesDataImpl() = customAttributesImpl.GetCustomAttributesData() -#if FX_NO_CUSTOMATTRIBUTEDATA -#else - override __.GetCustomAttributesData() = customAttributesImpl.GetCustomAttributesData() -#endif - - member __.DeclaringTypeImpl - with set x = - if declaringType<>null then failwith (sprintf "ProvidedConstructor: declaringType already set on '%s'" (nameText())); - declaringType <- x - - member __.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 __.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 __.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 || isStatic() then [] else ["this"]) - |> Array.ofList - transQuotationToCode isGenerated f paramNames - | None -> failwith (sprintf "ProvidedConstructor: no invoker for '%s'" (nameText())) - - member __.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 __.IsImplicitCtor with get() = isImplicitCtor and set v = isImplicitCtor <- v - - // Implement overloads - override __.GetParameters() = parameters |> List.toArray - override __.Attributes = ctorAttributes - override __.Name = if isStatic() then ".cctor" else ".ctor" - override __.DeclaringType = declaringType |> nonNull "ProvidedConstructor.DeclaringType" - override __.IsDefined(_attributeType, _inherit) = true - - override __.Invoke(_invokeAttr, _binder, _parameters, _culture) = notRequired "Invoke" (nameText()) - override __.Invoke(_obj, _invokeAttr, _binder, _parameters, _culture) = notRequired "Invoke" (nameText()) - override __.ReflectedType = notRequired "ReflectedType" (nameText()) - override __.GetMethodImplementationFlags() = notRequired "GetMethodImplementationFlags" (nameText()) - override __.MethodHandle = notRequired "MethodHandle" (nameText()) - override __.GetCustomAttributes(_inherit) = notRequired "GetCustomAttributes" (nameText()) - override __.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 mutable staticParams = [ ] - let mutable staticParamsApply = None - let isStatic() = methodAttrs.HasFlag(MethodAttributes.Static) - let customAttributesImpl = CustomAttributesImpl() - - member __.AddXmlDocComputed xmlDocFunction = customAttributesImpl.AddXmlDocComputed xmlDocFunction - member __.AddXmlDocDelayed xmlDocFunction = customAttributesImpl.AddXmlDocDelayed xmlDocFunction - member __.AddXmlDoc xmlDoc = customAttributesImpl.AddXmlDoc xmlDoc - member __.AddObsoleteAttribute (message,?isError) = customAttributesImpl.AddObsolete (message,defaultArg isError false) - member __.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 __.GetCustomAttributesData() = customAttributesImpl.GetCustomAttributesData() -#endif - - member __.SetMethodAttrs m = methodAttrs <- m - member __.AddMethodAttrs m = methodAttrs <- methodAttrs ||| m - member __.DeclaringTypeImpl with set x = declaringType <- x // check: not set twice - member __.IsStaticMethod - with get() = isStatic() - and set x = if x then methodAttrs <- methodAttrs ||| MethodAttributes.Static - else methodAttrs <- methodAttrs &&& (~~~ MethodAttributes.Static) - - member __.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" methodName (if declaringType=null then "" else declaringType.FullName)) - - - /// Abstract a type to a parametric-type. Requires "formal parameters" and "instantiation function". - member __.DefineStaticParameters(staticParameters : list, apply : (string -> obj[] -> ProvidedMethod)) = - staticParams <- staticParameters - staticParamsApply <- Some apply - - /// Get ParameterInfo[] for the parametric type parameters (//s GetGenericParameters) - member __.GetStaticParameters() = [| for p in staticParams -> p :> ParameterInfo |] - - /// Instantiate parametrics type - member __.ApplyStaticArguments(mangledName: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 method %s" staticParams.Length args.Length methodName) - match staticParamsApply with - | None -> failwith "ProvidedTypeDefinition: DefineStaticParameters was not called" - | Some f -> f mangledName args - else - failwith (sprintf "ProvidedTypeDefinition: static parameters supplied but not expected for method %s" methodName) - - member __.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 isStatic() then [] else ["this"]) - |> Array.ofList - transQuotationToCode isGenerated f paramNames - | None -> failwith (sprintf "ProvidedMethod: no invoker for %s on type %s" methodName (if declaringType=null then "" else declaringType.FullName)) - - // Implement overloads - override __.GetParameters() = argParams |> Array.ofList - override __.Attributes = methodAttrs - override __.Name = methodName - override __.DeclaringType = declaringType |> nonNull "ProvidedMethod.DeclaringType" - override __.IsDefined(_attributeType, _inherit) : bool = true - override __.MemberType = MemberTypes.Method - override __.CallingConvention = - let cc = CallingConventions.Standard - let cc = if not (isStatic()) then cc ||| CallingConventions.HasThis else cc - cc - override __.ReturnType = returnType - override __.ReturnParameter = null // REVIEW: Give it a name and type? - override __.ToString() = "Method " + methodName - - // 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 __.MetadataToken = hash declaringType + hash methodName - override __.MethodHandle = RuntimeMethodHandle() - - override __.ReturnTypeCustomAttributes = notRequired "ReturnTypeCustomAttributes" methodName - override __.GetBaseDefinition() = notRequired "GetBaseDefinition" methodName - override __.GetMethodImplementationFlags() = notRequired "GetMethodImplementationFlags" methodName - override __.Invoke(_obj, _invokeAttr, _binder, _parameters, _culture) = notRequired "Invoke" methodName - override __.ReflectedType = notRequired "ReflectedType" methodName - override __.GetCustomAttributes(_inherit) = notRequired "GetCustomAttributes" methodName - override __.GetCustomAttributes(_attributeType, _inherit) = notRequired "GetCustomAttributes" methodName - - -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 __.AddXmlDocComputed xmlDocFunction = customAttributesImpl.AddXmlDocComputed xmlDocFunction - member __.AddXmlDocDelayed xmlDocFunction = customAttributesImpl.AddXmlDocDelayed xmlDocFunction - member __.AddXmlDoc xmlDoc = customAttributesImpl.AddXmlDoc xmlDoc - member __.AddObsoleteAttribute (message,?isError) = customAttributesImpl.AddObsolete (message,defaultArg isError false) - member __.AddDefinitionLocation(line,column,filePath) = customAttributesImpl.AddDefinitionLocation(line, column, filePath) - member __.GetCustomAttributesDataImpl() = customAttributesImpl.GetCustomAttributesData() - member __.AddCustomAttribute attribute = customAttributesImpl.AddCustomAttribute attribute -#if FX_NO_CUSTOMATTRIBUTEDATA -#else - override __.GetCustomAttributesData() = customAttributesImpl.GetCustomAttributesData() -#endif - - member __.DeclaringTypeImpl with set x = declaringType <- x // check: not set twice - - member __.IsStatic - with get() = isStatic - and set x = isStatic <- x - - member __.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 __.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 __.PropertyType = propertyType - override __.SetValue(_obj, _value, _invokeAttr, _binder, _index, _culture) = notRequired "SetValue" propertyName - override __.GetAccessors _nonPublic = notRequired "nonPublic" propertyName - override __.GetGetMethod _nonPublic = if hasGetter() then getter.Force() :> MethodInfo else null - override __.GetSetMethod _nonPublic = if hasSetter() then setter.Force() :> MethodInfo else null - override __.GetIndexParameters() = [| for p in parameters -> upcast p |] - override __.Attributes = PropertyAttributes.None - override __.CanRead = hasGetter() - override __.CanWrite = hasSetter() - override __.GetValue(_obj, _invokeAttr, _binder, _index, _culture) : obj = notRequired "GetValue" propertyName - override __.Name = propertyName - override __.DeclaringType = declaringType |> nonNull "ProvidedProperty.DeclaringType" - override __.MemberType : MemberTypes = MemberTypes.Property - - override __.ReflectedType = notRequired "ReflectedType" propertyName - override __.GetCustomAttributes(_inherit) = notRequired "GetCustomAttributes" propertyName - override __.GetCustomAttributes(_attributeType, _inherit) = notRequired "GetCustomAttributes" propertyName - override __.IsDefined(_attributeType, _inherit) = notRequired "IsDefined" propertyName - -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 __.AddXmlDocComputed xmlDocFunction = customAttributesImpl.AddXmlDocComputed xmlDocFunction - member __.AddXmlDocDelayed xmlDocFunction = customAttributesImpl.AddXmlDocDelayed xmlDocFunction - member __.AddXmlDoc xmlDoc = customAttributesImpl.AddXmlDoc xmlDoc - member __.AddDefinitionLocation(line,column,filePath) = customAttributesImpl.AddDefinitionLocation(line, column, filePath) - member __.GetCustomAttributesDataImpl() = customAttributesImpl.GetCustomAttributesData() -#if FX_NO_CUSTOMATTRIBUTEDATA -#else - override __.GetCustomAttributesData() = customAttributesImpl.GetCustomAttributesData() -#endif - - member __.DeclaringTypeImpl with set x = declaringType <- x // check: not set twice - member __.IsStatic - with get() = isStatic - and set x = isStatic <- x - - member __.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 __.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 __.EventHandlerType = eventHandlerType - override __.GetAddMethod _nonPublic = adder.Force() :> MethodInfo - override __.GetRemoveMethod _nonPublic = remover.Force() :> MethodInfo - override __.Attributes = EventAttributes.None - override __.Name = eventName - override __.DeclaringType = declaringType |> nonNull "ProvidedEvent.DeclaringType" - override __.MemberType : MemberTypes = MemberTypes.Event - - override __.GetRaiseMethod _nonPublic = notRequired "GetRaiseMethod" eventName - override __.ReflectedType = notRequired "ReflectedType" eventName - override __.GetCustomAttributes(_inherit) = notRequired "GetCustomAttributes" eventName - override __.GetCustomAttributes(_attributeType, _inherit) = notRequired "GetCustomAttributes" eventName - override __.IsDefined(_attributeType, _inherit) = notRequired "IsDefined" eventName - -type ProvidedLiteralField(fieldName:string,fieldType:Type,literalValue:obj) = - inherit System.Reflection.FieldInfo() - // State - - let mutable declaringType = null - - let customAttributesImpl = CustomAttributesImpl() - member __.AddXmlDocComputed xmlDocFunction = customAttributesImpl.AddXmlDocComputed xmlDocFunction - member __.AddXmlDocDelayed xmlDocFunction = customAttributesImpl.AddXmlDocDelayed xmlDocFunction - member __.AddXmlDoc xmlDoc = customAttributesImpl.AddXmlDoc xmlDoc - member __.AddObsoleteAttribute (message,?isError) = customAttributesImpl.AddObsolete (message,defaultArg isError false) - member __.AddDefinitionLocation(line,column,filePath) = customAttributesImpl.AddDefinitionLocation(line, column, filePath) - member __.GetCustomAttributesDataImpl() = customAttributesImpl.GetCustomAttributesData() -#if FX_NO_CUSTOMATTRIBUTEDATA -#else - override __.GetCustomAttributesData() = customAttributesImpl.GetCustomAttributesData() -#endif - - member __.DeclaringTypeImpl with set x = declaringType <- x // check: not set twice - - - // Implement overloads - override __.FieldType = fieldType - override __.GetRawConstantValue() = literalValue - override __.Attributes = FieldAttributes.Static ||| FieldAttributes.Literal ||| FieldAttributes.Public - override __.Name = fieldName - override __.DeclaringType = declaringType |> nonNull "ProvidedLiteralField.DeclaringType" - override __.MemberType : MemberTypes = MemberTypes.Field - - override __.ReflectedType = notRequired "ReflectedType" fieldName - override __.GetCustomAttributes(_inherit) = notRequired "GetCustomAttributes" fieldName - override __.GetCustomAttributes(_attributeType, _inherit) = notRequired "GetCustomAttributes" fieldName - override __.IsDefined(_attributeType, _inherit) = notRequired "IsDefined" fieldName - - override __.SetValue(_obj, _value, _invokeAttr, _binder, _culture) = notRequired "SetValue" fieldName - override __.GetValue(_obj) : obj = notRequired "GetValue" fieldName - override __.FieldHandle = notRequired "FieldHandle" fieldName - -type ProvidedField(fieldName:string,fieldType:Type) = - inherit System.Reflection.FieldInfo() - // State - - let mutable declaringType = null - - let customAttributesImpl = CustomAttributesImpl() - let mutable fieldAttrs = FieldAttributes.Private - member __.AddXmlDocComputed xmlDocFunction = customAttributesImpl.AddXmlDocComputed xmlDocFunction - member __.AddXmlDocDelayed xmlDocFunction = customAttributesImpl.AddXmlDocDelayed xmlDocFunction - member __.AddXmlDoc xmlDoc = customAttributesImpl.AddXmlDoc xmlDoc - member __.AddObsoleteAttribute (message,?isError) = customAttributesImpl.AddObsolete (message,defaultArg isError false) - member __.AddDefinitionLocation(line,column,filePath) = customAttributesImpl.AddDefinitionLocation(line, column, filePath) - member __.GetCustomAttributesDataImpl() = customAttributesImpl.GetCustomAttributesData() -#if FX_NO_CUSTOMATTRIBUTEDATA -#else - override __.GetCustomAttributesData() = customAttributesImpl.GetCustomAttributesData() -#endif - - member __.DeclaringTypeImpl with set x = declaringType <- x // check: not set twice - - member __.SetFieldAttributes attrs = fieldAttrs <- attrs - // Implement overloads - override __.FieldType = fieldType - override __.GetRawConstantValue() = null - override __.Attributes = fieldAttrs - override __.Name = fieldName - override __.DeclaringType = declaringType |> nonNull "ProvidedField.DeclaringType" - override __.MemberType : MemberTypes = MemberTypes.Field - - override __.ReflectedType = notRequired "ReflectedType" fieldName - override __.GetCustomAttributes(_inherit) = notRequired "GetCustomAttributes" fieldName - override __.GetCustomAttributes(_attributeType, _inherit) = notRequired "GetCustomAttributes" fieldName - override __.IsDefined(_attributeType, _inherit) = notRequired "IsDefined" fieldName - - override __.SetValue(_obj, _value, _invokeAttr, _binder, _culture) = notRequired "SetValue" fieldName - override __.GetValue(_obj) : obj = notRequired "GetValue" fieldName - override __.FieldHandle = notRequired "FieldHandle" fieldName - -/// 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 - - let nameText() = - 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" - - 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 __.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 __.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 __.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 __.Name = nameText() - - override __.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 __.GetArrayRank() = (match kind with SymbolKind.Array n -> n | SymbolKind.SDArray -> 1 | _ -> invalidOp "non-array type") - override __.IsArrayImpl() = (match kind with SymbolKind.Array _ | SymbolKind.SDArray -> true | _ -> false) - override __.IsByRefImpl() = (match kind with SymbolKind.ByRef _ -> true | _ -> false) - override __.IsPointerImpl() = (match kind with SymbolKind.Pointer _ -> true | _ -> false) - override __.IsPrimitiveImpl() = false - override __.IsGenericType = (match kind with SymbolKind.Generic _ -> true | _ -> false) - override __.GetGenericArguments() = (match kind with SymbolKind.Generic _ -> args |> List.toArray | _ -> invalidOp "non-generic type") - override __.GetGenericTypeDefinition() = (match kind with SymbolKind.Generic e -> e | _ -> invalidOp "non-generic type") - override __.IsCOMObjectImpl() = false - override __.HasElementTypeImpl() = (match kind with SymbolKind.Generic _ -> false | _ -> true) - override __.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 __.Assembly = - match kind with - | SymbolKind.FSharpTypeAbbreviation (assembly,_nsp,_path) -> assembly - | SymbolKind.Generic gty -> gty.Assembly - | _ -> notRequired "Assembly" (nameText()) - - override __.Namespace = - match kind with - | SymbolKind.FSharpTypeAbbreviation (_assembly,nsp,_path) -> nsp - | _ -> notRequired "Namespace" (nameText()) - - override __.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 __.Equals(other: obj) = - match other with - | :? ProvidedSymbolType as otherTy -> (kind, args) = (otherTy.Kind, otherTy.Args) - | _ -> false - - member __.Kind = kind - member __.Args = args - - override __.Module : Module = notRequired "Module" (nameText()) - override __.GetConstructors _bindingAttr = notRequired "GetConstructors" (nameText()) - override __.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" (nameText()) - override __.GetMembers _bindingAttr = notRequired "GetMembers" (nameText()) - override __.GetMethods _bindingAttr = notRequired "GetMethods" (nameText()) - override __.GetField(_name, _bindingAttr) = notRequired "GetField" (nameText()) - override __.GetFields _bindingAttr = notRequired "GetFields" (nameText()) - override __.GetInterface(_name, _ignoreCase) = notRequired "GetInterface" (nameText()) - override __.GetInterfaces() = notRequired "GetInterfaces" (nameText()) - override __.GetEvent(_name, _bindingAttr) = notRequired "GetEvent" (nameText()) - override __.GetEvents _bindingAttr = notRequired "GetEvents" (nameText()) - override __.GetProperties _bindingAttr = notRequired "GetProperties" (nameText()) - override __.GetPropertyImpl(_name, _bindingAttr, _binder, _returnType, _types, _modifiers) = notRequired "GetPropertyImpl" (nameText()) - override __.GetNestedTypes _bindingAttr = notRequired "GetNestedTypes" (nameText()) - override __.GetNestedType(_name, _bindingAttr) = notRequired "GetNestedType" (nameText()) - override __.GetAttributeFlagsImpl() = notRequired "GetAttributeFlagsImpl" (nameText()) - override this.UnderlyingSystemType = - match kind with - | SymbolKind.SDArray - | SymbolKind.Array _ - | SymbolKind.Pointer - | SymbolKind.FSharpTypeAbbreviation _ - | SymbolKind.ByRef -> upcast this - | SymbolKind.Generic gty -> gty.UnderlyingSystemType -#if FX_NO_CUSTOMATTRIBUTEDATA -#else - override __.GetCustomAttributesData() = ([| |] :> IList<_>) -#endif - override __.MemberType = notRequired "MemberType" (nameText()) - override __.GetMember(_name,_mt,_bindingAttr) = notRequired "GetMember" (nameText()) - override __.GUID = notRequired "GUID" (nameText()) - override __.InvokeMember(_name, _invokeAttr, _binder, _target, _args, _modifiers, _culture, _namedParameters) = notRequired "InvokeMember" (nameText()) - override __.AssemblyQualifiedName = notRequired "AssemblyQualifiedName" (nameText()) - override __.GetConstructorImpl(_bindingAttr, _binder, _callConvention, _types, _modifiers) = notRequired "GetConstructorImpl" (nameText()) - override __.GetCustomAttributes(_inherit) = [| |] - override __.GetCustomAttributes(_attributeType, _inherit) = [| |] - override __.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 __.Name = p.Name - override __.ParameterType = ProvidedSymbolType.convType parameters p.ParameterType - override __.Attributes = p.Attributes - override __.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 __.GetGenericMethodDefinition() = genericMethodDefinition - - override __.DeclaringType = ProvidedSymbolType.convType parameters genericMethodDefinition.DeclaringType - override __.ToString() = "Method " + genericMethodDefinition.Name - override __.Name = genericMethodDefinition.Name - override __.MetadataToken = genericMethodDefinition.MetadataToken - override __.Attributes = genericMethodDefinition.Attributes - override __.CallingConvention = genericMethodDefinition.CallingConvention - override __.MemberType = genericMethodDefinition.MemberType - - override __.IsDefined(_attributeType, _inherit) : bool = notRequired "IsDefined" genericMethodDefinition.Name - override __.ReturnType = ProvidedSymbolType.convType parameters genericMethodDefinition.ReturnType - override __.GetParameters() = genericMethodDefinition.GetParameters() |> Array.map convParam - override __.ReturnParameter = genericMethodDefinition.ReturnParameter |> convParam - override __.ReturnTypeCustomAttributes = notRequired "ReturnTypeCustomAttributes" genericMethodDefinition.Name - override __.GetBaseDefinition() = notRequired "GetBaseDefinition" genericMethodDefinition.Name - override __.GetMethodImplementationFlags() = notRequired "GetMethodImplementationFlags" genericMethodDefinition.Name - override __.MethodHandle = notRequired "MethodHandle" genericMethodDefinition.Name - override __.Invoke(_obj, _invokeAttr, _binder, _parameters, _culture) = notRequired "Invoke" genericMethodDefinition.Name - override __.ReflectedType = notRequired "ReflectedType" genericMethodDefinition.Name - override __.GetCustomAttributes(_inherit) = notRequired "GetCustomAttributes" genericMethodDefinition.Name - override __.GetCustomAttributes(_attributeType, _inherit) = notRequired "GetCustomAttributes" genericMethodDefinition.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 FSharp.Compiler.Service - // 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 __.One = typeof - member __.Product (m1,m2) = typedefof>.MakeGenericType [| m1;m2 |] - member __.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 __.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 __.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" className) - - 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" className) - - 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" className) - - 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" className) - - 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 __.AddXmlDocComputed xmlDocFunction = customAttributesImpl.AddXmlDocComputed xmlDocFunction - member __.AddXmlDocDelayed xmlDocFunction = customAttributesImpl.AddXmlDocDelayed xmlDocFunction - member __.AddXmlDoc xmlDoc = customAttributesImpl.AddXmlDoc xmlDoc - member __.AddObsoleteAttribute (message,?isError) = customAttributesImpl.AddObsolete (message,defaultArg isError false) - member __.AddDefinitionLocation(line,column,filePath) = customAttributesImpl.AddDefinitionLocation(line, column, filePath) - member __.HideObjectMethods with set v = customAttributesImpl.HideObjectMethods <- v - member __.NonNullable with set v = customAttributesImpl.NonNullable <- v - member __.GetCustomAttributesDataImpl() = customAttributesImpl.GetCustomAttributesData() - member __.AddCustomAttribute attribute = customAttributesImpl.AddCustomAttribute attribute -#if FX_NO_CUSTOMATTRIBUTEDATA -#else - override __.GetCustomAttributesData() = customAttributesImpl.GetCustomAttributesData() -#endif - - member __.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 __.UnderlyingSystemType = typeof - - member __.SetEnumUnderlyingType(ty) = enumUnderlyingType <- ty - - override __.GetEnumUnderlyingType() = if this.IsEnum then enumUnderlyingType else invalidOp "not enum type" - - member __.SetBaseType t = baseType <- lazy Some t - - member __.SetBaseTypeDelayed baseTypeFunction = baseType <- lazy (Some (baseTypeFunction())) - - member __.SetAttributes x = attributes <- x - - // Add MemberInfos - member __.AddMembersDelayed(membersFunction : unit -> list<#MemberInfo>) = - membersQueue.Add (fun () -> membersFunction() |> List.map (fun x -> patchUpAddedMemberInfo this x; x :> MemberInfo )) - - member __.AddMembers(memberInfos:list<#MemberInfo>) = (* strict *) - memberInfos |> List.iter (patchUpAddedMemberInfo this) // strict: patch up now - membersQueue.Add (fun () -> memberInfos |> List.map (fun x -> x :> MemberInfo)) - - member __.AddMember(memberInfo:MemberInfo) = - this.AddMembers [memberInfo] - - member __.AddMemberDelayed(memberFunction : unit -> #MemberInfo) = - this.AddMembersDelayed(fun () -> [memberFunction()]) - - member __.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 __.DefineStaticParameters(staticParameters : list, apply : (string -> obj[] -> ProvidedTypeDefinition)) = - staticParams <- staticParameters - staticParamsApply <- Some apply - - /// Get ParameterInfo[] for the parametric type parameters (//s GetGenericParameters) - member __.GetStaticParameters() = [| for p in staticParams -> p :> ParameterInfo |] - - /// Instantiate parametrics type - member __.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 __.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 __.Assembly = theAssembly.Force() - - member __.SetAssembly assembly = theAssembly <- lazy assembly - - member __.SetAssemblyLazy assembly = theAssembly <- assembly - - override __.FullName = fullName.Force() - - override __.Namespace = rootNamespace.Force() - - override __.BaseType = match baseType.Value with Some ty -> ty | None -> null - - // Constructors - override __.GetConstructors bindingAttr = - [| for m in this.GetMembers bindingAttr do - if m.MemberType = MemberTypes.Constructor then - yield (m :?> ConstructorInfo) |] - // Methods - override __.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 __.GetMethods bindingAttr = - this.GetMembers bindingAttr - |> Array.filter (fun m -> m.MemberType.HasFlag(MemberTypes.Method)) - |> Array.map (fun m -> m :?> MethodInfo) - - // Fields - override __.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 __.GetFields bindingAttr = - [| for m in this.GetMembers bindingAttr do if m.MemberType.HasFlag(MemberTypes.Field) then yield m :?> FieldInfo |] - - override __.GetInterface(_name, _ignoreCase) = notRequired "GetInterface" this.Name - - override __.GetInterfaces() = - [| yield! getInterfaces() |] - - member __.GetInterfaceImplementations() = - [| yield! getInterfaces() |] - - member __.AddInterfaceImplementation ityp = interfaceImpls.Add ityp - - member __.AddInterfaceImplementationsDelayed itypf = interfaceImplsDelayed.Add itypf - - member __.GetMethodOverrides() = - [| yield! methodOverrides |] - - member __.DefineMethodOverride (bodyMethInfo,declMethInfo) = methodOverrides.Add (bodyMethInfo, declMethInfo) - - // Events - override __.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 __.GetEvents bindingAttr = - [| for m in this.GetMembers bindingAttr do if m.MemberType.HasFlag(MemberTypes.Event) then yield downcast m |] - - // Properties - override __.GetProperties bindingAttr = - [| for m in this.GetMembers bindingAttr do if m.MemberType.HasFlag(MemberTypes.Property) then yield downcast m |] - - override __.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 __.MakeArrayType() = ProvidedSymbolType(SymbolKind.SDArray, [this]) :> Type - override __.MakeArrayType arg = ProvidedSymbolType(SymbolKind.Array arg, [this]) :> Type - override __.MakePointerType() = ProvidedSymbolType(SymbolKind.Pointer, [this]) :> Type - override __.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 __.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 __.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 __.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 __.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 __.GetAttributeFlagsImpl() = adjustTypeAttributes attributes this.IsNested - override __.IsArrayImpl() = false - override __.IsByRefImpl() = false - override __.IsPointerImpl() = false - override __.IsPrimitiveImpl() = false - override __.IsCOMObjectImpl() = false - override __.HasElementTypeImpl() = false - override __.Name = className - override __.DeclaringType = declaringType.Force() - override __.MemberType = if this.IsNested then MemberTypes.NestedType else MemberTypes.TypeInfo - override __.GetHashCode() = rootNamespace.GetHashCode() ^^^ className.GetHashCode() - override __.Equals(that:obj) = - match that with - | null -> false - | :? ProvidedTypeDefinition as ti -> System.Object.ReferenceEquals(this,ti) - | _ -> false - - override __.GetGenericArguments() = [||] - override __.ToString() = this.Name - - - override __.Module : Module = notRequired "Module" this.Name - override __.GUID = Guid.Empty - override __.GetConstructorImpl(_bindingAttr, _binder, _callConvention, _types, _modifiers) = null - override __.GetCustomAttributes(_inherit) = [| |] - override __.GetCustomAttributes(_attributeType, _inherit) = [| |] - override __.IsDefined(_attributeType: Type, _inherit) = false - - override __.GetElementType() = notRequired "Module" this.Name - override __.InvokeMember(_name, _invokeAttr, _binder, _target, _args, _modifiers, _culture, _namedParameters) = notRequired "Module" this.Name - override __.AssemblyQualifiedName = notRequired "Module" this.Name - member __.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 __.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 - } - - -#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 __.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 __.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 __.RegisterProbingFolder (folder) = - // use GetFullPath to ensure that folder is valid - ignore(IO.Path.GetFullPath folder) - probingFolders.Add folder - - member __.RegisterRuntimeAssemblyLocationAsProbingFolder (config : TypeProviderConfig) = - config.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 this.Invalidate() = invalidateE.Trigger(this,EventArgs()) - - member __.GetStaticParametersForMethod(mb: MethodBase) = - printfn "In GetStaticParametersForMethod" - match mb with - | :? ProvidedMethod as t -> t.GetStaticParameters() - | _ -> [| |] - - member __.ApplyStaticArgumentsForMethod(mb: MethodBase, mangledName, objs) = - printfn "In ApplyStaticArgumentsForMethod" - match mb with - | :? ProvidedMethod as t -> t.ApplyStaticArguments(mangledName, objs) :> MethodBase - | _ -> failwith (sprintf "ApplyStaticArguments: static parameters for method %s are unexpected" mb.Name) - - interface ITypeProvider with - - [] - override __.Invalidate = invalidateE.Publish - - override __.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 __.GetStaticParameters(ty) = - match ty with - | :? ProvidedTypeDefinition as t -> - if ty.Name = t.Name (* REVIEW: use equality? *) then - t.GetStaticParameters() - else - [| |] - | _ -> [| |] - - override __.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 __.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 __.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 +// 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-4.0 releases + +namespace ProviderImplementation.ProvidedTypes + +open System +open System.Text +open System.IO +open System.Reflection +open System.Linq.Expressions +open System.Collections.Generic +open Microsoft.FSharp.Quotations +open Microsoft.FSharp.Quotations.Patterns +open Microsoft.FSharp.Quotations.DerivedPatterns +open Microsoft.FSharp.Core.CompilerServices + +#if NO_GENERATIVE +#else +open System.Reflection.Emit +#endif + +//-------------------------------------------------------------------------------- +// UncheckedQuotations + +// The FSharp.Core 2.0 - 4.0 (4.0.0.0 - 4.4.0.0) quotations implementation is overly strict in that it doesn't allow +// generation of quotations for cross-targeted FSharp.Core. Below we define a series of Unchecked methods +// implemented via reflection hacks to allow creation of various nodes when using a cross-targets FSharp.Core and +// mscorlib.dll. +// +// - Most importantly, these cross-targeted quotations can be provided to the F# compiler by a type provider. +// They are generally produced via the AssemblyReplacer.fs component through a process of rewriting design-time quotations that +// are not cross-targeted. +// +// - However, these quotation values are a bit fragile. Using existing FSharp.Core.Quotations.Patterns +// active patterns on these quotation nodes will generally work correctly. But using ExprShape.RebuildShapeCombination +// on these new nodes will not succed, nor will operations that build new quotations such as Expr.Call. +// Instead, use the replacement provided in this module. +// +// - Likewise, some operations in these quotation values like "expr.Type" may be a bit fragile, possibly returning non cross-targeted types in +// the result. However those operations are not used by the F# compiler. +[] +module internal UncheckedQuotations = + + let qTy = typeof.Assembly.GetType("Microsoft.FSharp.Quotations.ExprConstInfo") + assert (qTy <> null) + let pTy = typeof.Assembly.GetType("Microsoft.FSharp.Quotations.PatternsModule") + assert (pTy<> null) + + // These are handles to the internal functions that create quotation nodes of different sizes. Although internal, + // these function names have been stable since F# 2.0. + let mkFE0 = pTy.GetMethod("mkFE0", BindingFlags.Static ||| BindingFlags.Public ||| BindingFlags.NonPublic) + assert (mkFE0 <> null) + let mkFE1 = pTy.GetMethod("mkFE1", BindingFlags.Static ||| BindingFlags.Public ||| BindingFlags.NonPublic) + assert (mkFE1 <> null) + let mkFE2 = pTy.GetMethod("mkFE2", BindingFlags.Static ||| BindingFlags.Public ||| BindingFlags.NonPublic) + assert (mkFE2 <> null) + let mkFEN = pTy.GetMethod("mkFEN", BindingFlags.Static ||| BindingFlags.Public ||| BindingFlags.NonPublic) + assert (mkFEN <> null) + + // These are handles to the internal tags attached to quotation nodes of different sizes. Although internal, + // these function names have been stable since F# 2.0. + let newDelegateOp = qTy.GetMethod("NewNewDelegateOp", BindingFlags.Static ||| BindingFlags.Public ||| BindingFlags.NonPublic) + assert (newDelegateOp <> null) + let instanceCallOp = qTy.GetMethod("NewInstanceMethodCallOp", BindingFlags.Static ||| BindingFlags.Public ||| BindingFlags.NonPublic) + assert (instanceCallOp <> null) + let staticCallOp = qTy.GetMethod("NewStaticMethodCallOp", BindingFlags.Static ||| BindingFlags.Public ||| BindingFlags.NonPublic) + assert (staticCallOp <> null) + let newObjectOp = qTy.GetMethod("NewNewObjectOp", BindingFlags.Static ||| BindingFlags.Public ||| BindingFlags.NonPublic) + assert (newObjectOp <> null) + let newArrayOp = qTy.GetMethod("NewNewArrayOp", BindingFlags.Static ||| BindingFlags.Public ||| BindingFlags.NonPublic) + assert (newArrayOp <> null) + let appOp = qTy.GetMethod("get_AppOp", BindingFlags.Static ||| BindingFlags.Public ||| BindingFlags.NonPublic) + assert (appOp <> null) + let instancePropGetOp = qTy.GetMethod("NewInstancePropGetOp", BindingFlags.Static ||| BindingFlags.Public ||| BindingFlags.NonPublic) + assert (instancePropGetOp <> null) + let staticPropGetOp = qTy.GetMethod("NewStaticPropGetOp", BindingFlags.Static ||| BindingFlags.Public ||| BindingFlags.NonPublic) + assert (staticPropGetOp <> null) + let instancePropSetOp = qTy.GetMethod("NewInstancePropSetOp", BindingFlags.Static ||| BindingFlags.Public ||| BindingFlags.NonPublic) + assert (instancePropSetOp <> null) + let staticPropSetOp = qTy.GetMethod("NewStaticPropSetOp", BindingFlags.Static ||| BindingFlags.Public ||| BindingFlags.NonPublic) + assert (staticPropSetOp <> null) + let instanceFieldGetOp = qTy.GetMethod("NewInstanceFieldGetOp", BindingFlags.Static ||| BindingFlags.Public ||| BindingFlags.NonPublic) + assert (instanceFieldGetOp <> null) + let staticFieldGetOp = qTy.GetMethod("NewStaticFieldGetOp", BindingFlags.Static ||| BindingFlags.Public ||| BindingFlags.NonPublic) + assert (staticFieldGetOp <> null) + let instanceFieldSetOp = qTy.GetMethod("NewInstanceFieldSetOp", BindingFlags.Static ||| BindingFlags.Public ||| BindingFlags.NonPublic) + assert (instanceFieldSetOp <> null) + let staticFieldSetOp = qTy.GetMethod("NewStaticFieldSetOp", BindingFlags.Static ||| BindingFlags.Public ||| BindingFlags.NonPublic) + assert (staticFieldSetOp <> null) + let tupleGetOp = qTy.GetMethod("NewTupleGetOp", BindingFlags.Static ||| BindingFlags.Public ||| BindingFlags.NonPublic) + assert (tupleGetOp <> null) + let letOp = qTy.GetMethod("get_LetOp", BindingFlags.Static ||| BindingFlags.Public ||| BindingFlags.NonPublic) + assert (letOp <> null) + + type Microsoft.FSharp.Quotations.Expr with + + static member NewDelegateUnchecked (ty: Type, vs: Var list, body: Expr) = + let e = List.foldBack (fun v acc -> Expr.Lambda(v,acc)) vs body + let op = newDelegateOp.Invoke(null, [| box ty |]) + mkFE1.Invoke(null, [| box op; box e |]) :?> Expr + + static member NewObjectUnchecked (cinfo: ConstructorInfo, args : Expr list) = + let op = newObjectOp.Invoke(null, [| box cinfo |]) + mkFEN.Invoke(null, [| box op; box args |]) :?> Expr + + static member NewArrayUnchecked (elementType: Type, elements : Expr list) = + let op = newArrayOp.Invoke(null, [| box elementType |]) + mkFEN.Invoke(null, [| box op; box elements |]) :?> Expr + + static member CallUnchecked (minfo: MethodInfo, args : Expr list) = + let op = staticCallOp.Invoke(null, [| box minfo |]) + mkFEN.Invoke(null, [| box op; box args |]) :?> Expr + + static member CallUnchecked (obj: Expr, minfo: MethodInfo, args : Expr list) = + let op = instanceCallOp.Invoke(null, [| box minfo |]) + mkFEN.Invoke(null, [| box op; box (obj::args) |]) :?> Expr + + static member ApplicationUnchecked (f: Expr, x: Expr) = + let op = appOp.Invoke(null, [| |]) + mkFE2.Invoke(null, [| box op; box f; box x |]) :?> Expr + + static member PropertyGetUnchecked (pinfo: PropertyInfo, args : Expr list) = + let op = staticPropGetOp.Invoke(null, [| box pinfo |]) + mkFEN.Invoke(null, [| box op; box args |]) :?> Expr + + static member PropertyGetUnchecked (obj: Expr, pinfo: PropertyInfo, ?args : Expr list) = + let args = defaultArg args [] + let op = instancePropGetOp.Invoke(null, [| box pinfo |]) + mkFEN.Invoke(null, [| box op; box (obj::args) |]) :?> Expr + + static member PropertySetUnchecked (pinfo: PropertyInfo, value: Expr, ?args : Expr list) = + let args = defaultArg args [] + let op = staticPropSetOp.Invoke(null, [| box pinfo |]) + mkFEN.Invoke(null, [| box op; box (args@[value]) |]) :?> Expr + + static member PropertySetUnchecked (obj: Expr, pinfo: PropertyInfo, value: Expr, args : Expr list) = + let op = instancePropSetOp.Invoke(null, [| box pinfo |]) + mkFEN.Invoke(null, [| box op; box (obj::(args@[value])) |]) :?> Expr + + static member FieldGetUnchecked (pinfo: FieldInfo) = + let op = staticFieldGetOp.Invoke(null, [| box pinfo |]) + mkFE0.Invoke(null, [| box op; |]) :?> Expr + + static member FieldGetUnchecked (obj: Expr, pinfo: FieldInfo) = + let op = instanceFieldGetOp.Invoke(null, [| box pinfo |]) + mkFE1.Invoke(null, [| box op; box obj |]) :?> Expr + + static member FieldSetUnchecked (pinfo: FieldInfo, value: Expr) = + let op = staticFieldSetOp.Invoke(null, [| box pinfo |]) + mkFE1.Invoke(null, [| box op; box value |]) :?> Expr + + static member FieldSetUnchecked (obj: Expr, pinfo: FieldInfo, value: Expr) = + let op = instanceFieldSetOp.Invoke(null, [| box pinfo |]) + mkFE2.Invoke(null, [| box op; box obj; box value |]) :?> Expr + + static member TupleGetUnchecked (e: Expr, n:int) = + let op = tupleGetOp.Invoke(null, [| box e.Type; box n |]) + mkFE1.Invoke(null, [| box op; box e |]) :?> Expr + + static member LetUnchecked (v:Var, e: Expr, body:Expr) = + let lam = Expr.Lambda(v,body) + let op = letOp.Invoke(null, [| |]) + mkFE2.Invoke(null, [| box op; box e; box lam |]) :?> Expr + + type Shape = Shape of (Expr list -> Expr) + + let (|ShapeCombinationUnchecked|ShapeVarUnchecked|ShapeLambdaUnchecked|) e = + match e with + | NewObject (cinfo, args) -> + ShapeCombinationUnchecked (Shape (function args -> Expr.NewObjectUnchecked (cinfo, args)), args) + | NewArray (ty, args) -> + ShapeCombinationUnchecked (Shape (function args -> Expr.NewArrayUnchecked (ty, args)), args) + | NewDelegate (t, vars, expr) -> + ShapeCombinationUnchecked (Shape (function [expr] -> Expr.NewDelegateUnchecked (t, vars, expr) | _ -> invalidArg "expr" "invalid shape"), [expr]) + | TupleGet (expr, n) -> + ShapeCombinationUnchecked (Shape (function [expr] -> Expr.TupleGetUnchecked (expr, n) | _ -> invalidArg "expr" "invalid shape"), [expr]) + | Application (f, x) -> + ShapeCombinationUnchecked (Shape (function [f; x] -> Expr.ApplicationUnchecked (f, x) | _ -> invalidArg "expr" "invalid shape"), [f; x]) + | Call (objOpt, minfo, args) -> + match objOpt with + | None -> ShapeCombinationUnchecked (Shape (function args -> Expr.CallUnchecked (minfo, args)), args) + | Some obj -> ShapeCombinationUnchecked (Shape (function (obj::args) -> Expr.CallUnchecked (obj, minfo, args) | _ -> invalidArg "expr" "invalid shape"), obj::args) + | PropertyGet (objOpt, pinfo, args) -> + match objOpt with + | None -> ShapeCombinationUnchecked (Shape (function args -> Expr.PropertyGetUnchecked (pinfo, args)), args) + | Some obj -> ShapeCombinationUnchecked (Shape (function (obj::args) -> Expr.PropertyGetUnchecked (obj, pinfo, args) | _ -> invalidArg "expr" "invalid shape"), obj::args) + | PropertySet (objOpt, pinfo, args, value) -> + match objOpt with + | None -> ShapeCombinationUnchecked (Shape (function (value::args) -> Expr.PropertySetUnchecked (pinfo, value, args) | _ -> invalidArg "expr" "invalid shape"), value::args) + | Some obj -> ShapeCombinationUnchecked (Shape (function (obj::value::args) -> Expr.PropertySetUnchecked (obj, pinfo, value, args) | _ -> invalidArg "expr" "invalid shape"), obj::value::args) + | FieldGet (objOpt, pinfo) -> + match objOpt with + | None -> ShapeCombinationUnchecked (Shape (function _ -> Expr.FieldGetUnchecked (pinfo)), []) + | Some obj -> ShapeCombinationUnchecked (Shape (function [obj] -> Expr.FieldGetUnchecked (obj, pinfo) | _ -> invalidArg "expr" "invalid shape"), [obj]) + | FieldSet (objOpt, pinfo, value) -> + match objOpt with + | None -> ShapeCombinationUnchecked (Shape (function [value] -> Expr.FieldSetUnchecked (pinfo, value) | _ -> invalidArg "expr" "invalid shape"), [value]) + | Some obj -> ShapeCombinationUnchecked (Shape (function [obj;value] -> Expr.FieldSetUnchecked (obj, pinfo, value) | _ -> invalidArg "expr" "invalid shape"), [obj; value]) + | Let (var, value, body) -> + ShapeCombinationUnchecked (Shape (function [value;Lambda(var, body)] -> Expr.LetUnchecked(var, value, body) | _ -> invalidArg "expr" "invalid shape"), [value; Expr.Lambda(var, body)]) + | TupleGet (expr, i) -> + ShapeCombinationUnchecked (Shape (function [expr] -> Expr.TupleGetUnchecked (expr, i) | _ -> invalidArg "expr" "invalid shape"), [expr]) + | ExprShape.ShapeCombination (comb,args) -> + ShapeCombinationUnchecked (Shape (fun args -> ExprShape.RebuildShapeCombination(comb, args)), args) + | ExprShape.ShapeVar v -> ShapeVarUnchecked v + | ExprShape.ShapeLambda (v, e) -> ShapeLambdaUnchecked (v,e) + + let RebuildShapeCombinationUnchecked (Shape comb,args) = comb args + +//-------------------------------------------------------------------------------- +// The quotation simplifier +// +// This is invoked for each quotation specified by the type provider, just before it is +// handed to the F# compiler, allowing a broader range of +// quotations to be accepted. Specifically accept: +// +// - NewTuple nodes (for generative type providers) +// - TupleGet nodes (for generative type providers) +// - array and list values as constants +// - PropertyGet and PropertySet nodes +// - Application, NewUnionCase, NewRecord, UnionCaseTest nodes +// - Let nodes (defining "byref" values) +// - LetRecursive nodes +// +// Additionally, a set of code optimizations are applied to generated code: +// - inlineRightPipe +// - optimizeCurriedApplications +// - inlineValueBindings + +type QuotationSimplifier(isGenerated: bool) = + + let rec transExpr q = + match q with + // convert NewTuple to the call to the constructor of the Tuple type (only for generated types) + | NewTuple(items) when isGenerated -> + let rec mkCtor args ty = + let ctor, restTyOpt = Reflection.FSharpValue.PreComputeTupleConstructorInfo ty + match restTyOpt with + | None -> Expr.NewObject(ctor, List.map transExpr args) + | Some restTy -> + let curr = [for a in Seq.take 7 args -> transExpr a] + let rest = List.ofSeq (Seq.skip 7 args) + Expr.NewObject(ctor, curr @ [mkCtor rest restTy]) + let tys = [| for e in items -> e.Type |] + let tupleTy = Reflection.FSharpType.MakeTupleType tys + transExpr (mkCtor items tupleTy) + // convert TupleGet to the chain of PropertyGet calls (only for generated types) + | TupleGet(e, i) when isGenerated -> + let rec mkGet ty i (e : Expr) = + let pi, restOpt = Reflection.FSharpValue.PreComputeTuplePropertyInfo(ty, i) + let propGet = Expr.PropertyGet(e, pi) + match restOpt with + | None -> propGet + | Some (restTy, restI) -> mkGet restTy restI propGet + transExpr (mkGet e.Type i (transExpr e)) + | Value(value, ty) -> + if value <> null then + let tyOfValue = value.GetType() + transValue(value, tyOfValue, ty) + else q + // Eliminate F# property gets to method calls + | PropertyGet(obj,propInfo,args) -> + match obj with + | None -> transExpr (Expr.CallUnchecked(propInfo.GetGetMethod(),args)) + | Some o -> transExpr (Expr.CallUnchecked(transExpr o,propInfo.GetGetMethod(),args)) + // Eliminate F# property sets to method calls + | PropertySet(obj,propInfo,args,v) -> + match obj with + | None -> transExpr (Expr.CallUnchecked(propInfo.GetSetMethod(),args@[v])) + | Some o -> transExpr (Expr.CallUnchecked(transExpr o,propInfo.GetSetMethod(),args@[v])) + // Eliminate F# function applications to FSharpFunc<_,_>.Invoke calls + | Application(f,e) -> + transExpr (Expr.CallUnchecked(transExpr f, f.Type.GetMethod "Invoke", [ e ]) ) + | NewUnionCase(ci, es) -> + transExpr (Expr.CallUnchecked(Reflection.FSharpValue.PreComputeUnionConstructorInfo ci, es) ) + | NewRecord(ci, es) -> + transExpr (Expr.NewObjectUnchecked(Reflection.FSharpValue.PreComputeRecordConstructorInfo ci, es) ) + | UnionCaseTest(e,uc) -> + let tagInfo = Reflection.FSharpValue.PreComputeUnionTagMemberInfo uc.DeclaringType + let tagExpr = + match tagInfo with + | :? PropertyInfo as tagProp -> + transExpr (Expr.PropertyGet(e,tagProp) ) + | :? MethodInfo as tagMeth -> + if tagMeth.IsStatic then transExpr (Expr.Call(tagMeth, [e])) + else transExpr (Expr.Call(e,tagMeth,[])) + | _ -> failwith "unreachable: unexpected result from PreComputeUnionTagMemberInfo" + let tagNumber = uc.Tag + transExpr <@@ (%%(tagExpr) : int) = tagNumber @@> + + // Explicitly handle weird byref variables in lets (used to populate out parameters), since the generic handlers can't deal with byrefs. + // + // 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 + | Let(v,vexpr,bexpr) when v.Type.IsByRef -> transLetOfByref v vexpr bexpr + + // Eliminate recursive let bindings (which are unsupported by the type provider API) to regular let bindings + | LetRecursive(bindings, expr) -> transLetRec bindings expr + + // Handle the generic cases + | ShapeLambdaUnchecked(v,body) -> Expr.Lambda(v, transExpr body) + | ShapeCombinationUnchecked(comb,args) -> RebuildShapeCombinationUnchecked(comb,List.map transExpr args) + | ShapeVarUnchecked _ -> q + + and transLetRec 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 Call(None, r, [_]) -> r | _ -> failwith "Extracting MethodInfo from <@ 1 @> failed" + let d = match <@ Unchecked.defaultof<_> @> with Call(None, d, []) -> d | _ -> failwith "Extracting MethodInfo from <@ Unchecked.defaultof<_> @> failed" + Expr.Call(r.GetGenericMethodDefinition().MakeGenericMethod(t), [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 Call(None, m, [_]) -> m | _ -> failwith "Extracting MethodInfo from <@ !(ref 1) @> failed" + let tyArgs = v.Type.GetGenericArguments() + Expr.Call(m.GetGenericMethodDefinition().MakeGenericMethod(tyArgs), [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 Call(None, m, [_;_]) -> m | _ -> failwith "Extracting MethodInfo from <@ (ref 1) := 2 @> failed" + Expr.Call(m.GetGenericMethodDefinition().MakeGenericMethod(v.Type), [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) -> 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 -> Expr.LetUnchecked(varDict.[v], init v.Type, b)) body + |> transExpr + + + and transLetOfByref v vexpr bexpr = + match vexpr with + | Sequential(e',vexpr') -> + (* let v = (e'; vexpr') in bexpr => e'; let v = vexpr' in bexpr *) + Expr.Sequential(e', transLetOfByref v vexpr' bexpr) + |> transExpr + | 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 *) + // + // Note, this duplicates "bexpr" + Expr.IfThenElse(c, transLetOfByref v b1 bexpr, transLetOfByref v b2 bexpr) + |> transExpr + | Var _ -> + (* let v = v1 in bexpr => bexpr[v/v1] *) + bexpr.Substitute(fun v' -> if v = v' then Some vexpr else None) + |> transExpr + | _ -> + failwith (sprintf "Unexpected byref binding: %A = %A" v vexpr) + + and transValueArray (o : Array, ty : Type) = + let elemTy = ty.GetElementType() + let converter = getValueConverterForType elemTy + let elements = [ for el in o -> converter el ] + Expr.NewArrayUnchecked(elemTy, elements) + + and transValueList(o, ty : Type, nil, cons) = + let converter = getValueConverterForType (ty.GetGenericArguments().[0]) + o + |> Seq.cast + |> List.ofSeq + |> fun l -> List.foldBack(fun o s -> Expr.NewUnionCase(cons, [ converter(o); s ])) l (Expr.NewUnionCase(nil, [])) + |> transExpr + + and getValueConverterForType (ty : Type) = + if ty.IsArray then + fun (v : obj) -> transValueArray(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 -> transValueList (v :?> System.Collections.IEnumerable, ty, nil, cons) + else + fun v -> Expr.Value(v, ty) + + and transValue (v : obj, tyOfValue : Type, expectedTy : Type) = + let converter = getValueConverterForType tyOfValue + let r = converter v + if tyOfValue <> expectedTy then Expr.Coerce(r, expectedTy) + else r + +#if NO_GENERATIVE +#else + // TODO: this works over FSharp.Core 4.4.0.0 types. These types need to be retargeted to the target runtime. + 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 (===) a b = LanguagePrimitives.PhysicalEquality a b + + let traverse f = + let rec fallback e = + match e with + | Let(v, value, body) -> + let fixedValue = f fallback value + let fixedBody = f fallback body + if fixedValue === value && fixedBody === body then + e + else + Expr.Let(v, fixedValue, fixedBody) + | ShapeVarUnchecked _ -> e + | ShapeLambdaUnchecked(v, body) -> + let fixedBody = f fallback body + if fixedBody === body then + e + else + Expr.Lambda(v, fixedBody) + | ShapeCombinationUnchecked(shape, exprs) -> + let exprs1 = List.map (f fallback) exprs + if List.forall2 (===) exprs exprs1 then + e + else + RebuildShapeCombinationUnchecked(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 + | SpecificCall RightPipe (None, _, [operand; applicable]) -> + let fixedOperand = loop operand + match loop applicable with + | Lambda(arg, body) -> + let v = Quotations.Var("__temp", operand.Type) + let ev = Expr.Var v + + let fixedBody = loop body + Expr.Let(v, fixedOperand, fixedBody.Substitute(fun v1 -> if v1 = arg then Some ev else None)) + | fixedApplicable -> Expr.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 + | Let(id, (Value(_) as v), body) when not id.IsMutable -> + map.[id] <- v + let fixedBody = loop body + map.Remove(id) |> ignore + fixedBody + | ShapeVarUnchecked 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 + | 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 + | Application(e, arg) -> + let e1 = tryPeelApplications e ((loop arg)::args) + if e1 === e then + orig + else + e1 + | Let(id, applicable, (Lambda(_) as body)) when n > 0 -> + let numberOfApplication = countPeelableApplications body id 0 + if numberOfApplication = 0 then orig + elif n = 1 then Expr.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.toArray + |> (fun arr -> arr.[n - 1]) + + let adaptMethod = getFastFuncType args resultType + let adapted = Expr.Call(adaptMethod, [loop applicable]) + let invoke = adapted.Type.GetMethod("Invoke", [| for arg in args -> arg.Type |]) + Expr.Call(adapted, invoke, args) + else + (applicable, args) ||> List.fold (fun e a -> Expr.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 + | Lambda(arg, Let(v1, Application(Var f, Var arg1), rest)) when v = f && arg = arg1 -> countPeelableApplications rest v1 (n + 1) + // \arg -> (f arg) ==> f + | Lambda(arg, Application(Var f, Var arg1)) when v = f && arg = arg1 -> n + | _ -> n + loop expr +#endif + + member __.TranslateExpression q = transExpr q + + member __.TranslateQuotationToCode qexprf (paramNames: string[]) (argExprs: Expr[]) = + // Use the real variable names instead of indices, to improve output of Debug.fs + // 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 -> Expr.Var v]) + + let pairs = Array.zip argExprs vars + let expr = Array.foldBack (fun (arg, var) e -> Expr.LetUnchecked(var, arg, e)) pairs expr +#if NO_GENERATIVE +#else + let expr = + if isGenerated then + let e1 = inlineRightPipe expr + let e2 = optimizeCurriedApplications e1 + let e3 = inlineValueBindings e2 + e3 + else + expr +#endif + + transExpr expr + +//------------------------------------------------------------------------------------------------- +// Generate IL code from quotations + + +#if NO_GENERATIVE +#else + +type (*internal*) ExpectedStackState = + | Empty = 1 + | Address = 2 + | Value = 3 + +type CodeGenerator(assemblyMainModule: ModuleBuilder, uniqueLambdaTypeName, + implicitCtorArgsAsFields: FieldBuilder list, + transType: Type -> Type, + transField: FieldInfo -> FieldInfo, + transMethod: MethodInfo -> MethodInfo, + transCtor: ConstructorInfo -> ConstructorInfo, + isLiteralEnumField: FieldInfo -> bool, + ilg: ILGenerator, locals:Dictionary, parameterVars) = + + // TypeBuilderInstantiation should really be a public type, since we + // have to use alternative means for various Method/Field/Constructor lookups on this kind of type. + // Also, on Mono 3.x and 4.x this type had a different name. + let TypeBuilderInstantiationType = + let runningOnMono = try System.Type.GetType("Mono.Runtime") <> null with e-> false + let ty = + if runningOnMono then + let ty = Type.GetType("System.Reflection.MonoGenericClass") + match ty with + | null -> Type.GetType("System.Reflection.Emit.TypeBuilderInstantiation") + | _ -> ty + else + Type.GetType("System.Reflection.Emit.TypeBuilderInstantiation") + + ty + + // TODO: this works over FSharp.Core 4.4.0.0 types and methods. These types need to be retargeted to the target runtime. + + 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 rec emitLambda(callSiteIlg : ILGenerator, v : Quotations.Var, body : 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 lambdaLocals = 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) + lambdaLocals.[v] <- l + + let expectedState = if (invoke.ReturnType = typeof) then ExpectedStackState.Empty else ExpectedStackState.Value + let lambadParamVars = [| Quotations.Var("this", lambda); v|] + let codeGen = CodeGenerator(assemblyMainModule, uniqueLambdaTypeName, implicitCtorArgsAsFields, transType, transField, transMethod, transCtor, isLiteralEnumField, ilg, lambdaLocals, lambadParamVars) + codeGen.EmitExpr (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 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 + match expr with + | 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(transType loopVar.Type) + locals.Add(loopVar, lb) + lb + + // loopVar = first + emitExpr ExpectedStackState.Value first + ilg.Emit(OpCodes.Stloc, lb) + + let before = ilg.DefineLabel() + let after = ilg.DefineLabel() + + ilg.MarkLabel before + ilg.Emit(OpCodes.Ldloc, lb) + + emitExpr ExpectedStackState.Value last + ilg.Emit(OpCodes.Bgt, after) + + emitExpr 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) + + | NewArray(elementTy, elements) -> + ilg.Emit(OpCodes.Ldc_I4, List.length elements) + ilg.Emit(OpCodes.Newarr, transType elementTy) + + elements + |> List.iteri (fun i el -> + ilg.Emit(OpCodes.Dup) + ilg.Emit(OpCodes.Ldc_I4, i) + emitExpr ExpectedStackState.Value el + ilg.Emit(OpCodes.Stelem, transType elementTy)) + + popIfEmptyExpected expectedState + + | WhileLoop(cond, body) -> + let before = ilg.DefineLabel() + let after = ilg.DefineLabel() + + ilg.MarkLabel before + emitExpr ExpectedStackState.Value cond + ilg.Emit(OpCodes.Brfalse, after) + emitExpr ExpectedStackState.Empty body + ilg.Emit(OpCodes.Br, before) + + ilg.MarkLabel after + + | Var v -> + if isEmpty expectedState then () else + + // Try to interpret this as a method parameter + 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 -> + + // Try to interpret this as an implicit field in a class + 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 -> + + // Try to interpret this as a local + 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" + + | Coerce (arg,ty) -> + // castClass may lead to observable side-effects - InvalidCastException + emitExpr ExpectedStackState.Value arg + let argTy = transType arg.Type + let targetTy = transType 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 && (TypeBuilderInstantiationType.Equals(targetTy.GetType()) || not (targetTy.IsAssignableFrom(argTy))) then + ilg.Emit(OpCodes.Castclass, targetTy) + + popIfEmptyExpected expectedState + + | SpecificCall <@ (-) @>(None, [t1; t2; _], [a1; a2]) -> + assert(t1 = t2) + emitExpr ExpectedStackState.Value a1 + emitExpr ExpectedStackState.Value a2 + if t1 = typeof then + ilg.Emit(OpCodes.Call, typeof.GetMethod "op_Subtraction") + else + ilg.Emit(OpCodes.Sub) + emitConvIfNecessary t1 + + popIfEmptyExpected expectedState + + | SpecificCall <@ (/) @> (None, [t1; t2; _], [a1; a2]) -> + assert (t1 = t2) + emitExpr ExpectedStackState.Value a1 + emitExpr 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 + + | SpecificCall <@ int @>(None, [sourceTy], [v]) -> + emitExpr ExpectedStackState.Value v + match Type.GetTypeCode(sourceTy) with + | TypeCode.String -> + ilg.Emit(OpCodes.Call, 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" + + | SpecificCall <@ LanguagePrimitives.IntrinsicFunctions.GetArray @> (None, [ty], [arr; index]) -> + // observable side-effect - IndexOutOfRangeException + emitExpr ExpectedStackState.Value arr + emitExpr ExpectedStackState.Value index + if isAddress expectedState then + ilg.Emit(OpCodes.Readonly) + ilg.Emit(OpCodes.Ldelema, transType ty) + else + ilg.Emit(OpCodes.Ldelem, transType ty) + + popIfEmptyExpected expectedState + + | SpecificCall <@ LanguagePrimitives.IntrinsicFunctions.GetArray2D @> (None, _ty, arr::indices) + | SpecificCall <@ LanguagePrimitives.IntrinsicFunctions.GetArray3D @> (None, _ty, arr::indices) + | 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 + emitExpr ExpectedStackState.Value arr + for index in indices do + emitExpr ExpectedStackState.Value index + + if isAddress expectedState then + ilg.Emit(OpCodes.Readonly) + + ilg.Emit(OpCodes.Call, meth) + + popIfEmptyExpected expectedState + + + | FieldGet (None,field) when isLiteralEnumField field -> + if expectedState <> ExpectedStackState.Empty then + emitExpr expectedState (Expr.Value(field.GetRawConstantValue(), field.FieldType.GetEnumUnderlyingType())) + + | FieldGet (objOpt,field) -> + objOpt |> Option.iter (fun e -> + let s = if e.Type.IsValueType then ExpectedStackState.Address else ExpectedStackState.Value + emitExpr s e) + let field = transField field + if field.IsStatic then + ilg.Emit(OpCodes.Ldsfld, field) + else + ilg.Emit(OpCodes.Ldfld, field) + + | FieldSet (objOpt,field,v) -> + objOpt |> Option.iter (fun e -> + let s = if e.Type.IsValueType then ExpectedStackState.Address else ExpectedStackState.Value + emitExpr s e) + emitExpr ExpectedStackState.Value v + let field = transField field + if field.IsStatic then + ilg.Emit(OpCodes.Stsfld, field) + else + ilg.Emit(OpCodes.Stfld, field) + + | Call (objOpt,meth,args) -> + objOpt |> Option.iter (fun e -> + let s = if e.Type.IsValueType then ExpectedStackState.Address else ExpectedStackState.Value + emitExpr s e) + + for pe in args do + emitExpr ExpectedStackState.Value pe + + // 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 transType + let gmd = meth.GetGenericMethodDefinition() |> transMethod + gmd.GetGenericMethodDefinition().MakeGenericMethod args + elif meth.DeclaringType.IsGenericType then + let gdty = transType (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 transType meth.DeclaringType with + | :? TypeBuilder as dty -> TypeBuilder.GetMethod(dty, gdtym) + | dty -> MethodBase.GetMethodFromHandle(meth.MethodHandle, dty.TypeHandle) :?> _ + + assert (dtym <> null) + dtym + else + transMethod meth + match objOpt with + | Some obj when mappedMeth.IsAbstract || mappedMeth.IsVirtual -> + if obj.Type.IsValueType then ilg.Emit(OpCodes.Constrained, transType 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) + | _ -> () + + | NewObject (ctor,args) -> + for pe in args do + emitExpr ExpectedStackState.Value pe + let meth = transCtor ctor + ilg.Emit(OpCodes.Newobj, meth) + + popIfEmptyExpected expectedState + + | 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, transType ty) + ilg.Emit(OpCodes.Call, 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, DecimalConstructor()) + | :? DateTime as x -> + ilg.Emit(OpCodes.Ldc_I8, x.Ticks) + ilg.Emit(OpCodes.Ldc_I4, int x.Kind) + ilg.Emit(OpCodes.Newobj, DateTimeConstructor()) + | :? DateTimeOffset as x -> + ilg.Emit(OpCodes.Ldc_I8, x.Ticks) + ilg.Emit(OpCodes.Ldc_I8, x.Offset.Ticks) + ilg.Emit(OpCodes.Newobj, TimeSpanConstructor()) + ilg.Emit(OpCodes.Newobj, DateTimeOffsetConstructor()) + | null -> ilg.Emit(OpCodes.Ldnull) + | _ -> failwithf "unknown constant '%A' in generated method" v + if isEmpty expectedState then () + else emitC obj + + | Let(v,e,b) -> + let lb = ilg.DeclareLocal (transType v.Type) + locals.Add (v, lb) + emitExpr ExpectedStackState.Value e + ilg.Emit(OpCodes.Stloc, lb.LocalIndex) + emitExpr expectedState b + + | Sequential(e1, e2) -> + emitExpr ExpectedStackState.Empty e1 + emitExpr expectedState e2 + + | IfThenElse(cond, ifTrue, ifFalse) -> + let ifFalseLabel = ilg.DefineLabel() + let endLabel = ilg.DefineLabel() + + emitExpr ExpectedStackState.Value cond + + ilg.Emit(OpCodes.Brfalse, ifFalseLabel) + + emitExpr expectedState ifTrue + ilg.Emit(OpCodes.Br, endLabel) + + ilg.MarkLabel(ifFalseLabel) + emitExpr expectedState ifFalse + + ilg.Emit(OpCodes.Nop) + ilg.MarkLabel(endLabel) + + | TryWith(body, _filterVar, _filterBody, catchVar, catchBody) -> + + let stres, ldres = + if isEmpty expectedState then ignore, ignore + else + let local = ilg.DeclareLocal (transType body.Type) + let stres = fun () -> ilg.Emit(OpCodes.Stloc, local) + let ldres = fun () -> ilg.Emit(OpCodes.Ldloc, local) + stres, ldres + + let exceptionVar = ilg.DeclareLocal(transType catchVar.Type) + locals.Add(catchVar, exceptionVar) + + let _exnBlock = ilg.BeginExceptionBlock() + + emitExpr expectedState body + stres() + + ilg.BeginCatchBlock(transType catchVar.Type) + ilg.Emit(OpCodes.Stloc, exceptionVar) + emitExpr expectedState catchBody + stres() + ilg.EndExceptionBlock() + + ldres() + + | VarSet(v,e) -> + emitExpr 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" + | Lambda(v, body) -> + emitLambda(ilg, v, body, expr.GetFreeVars(), locals, parameterVars) + popIfEmptyExpected expectedState + | n -> + failwith (sprintf "unknown expression '%A' in generated method" n) + + member __.EmitExpr (expectedState, expr) = emitExpr expectedState expr + +#endif + +[] +module internal Misc = + + + 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 = 2) + member __.ConstructorArguments = upcast [|CustomAttributeTypedArgument(typeof, message) ; CustomAttributeTypedArgument(typeof, isError) |] + member __.NamedArguments = upcast [| |] } + + let mkReflectedDefinitionCustomAttributeData() = +#if FX_NO_CUSTOMATTRIBUTEDATA + { new IProvidedCustomAttributeData with +#else + { new CustomAttributeData() with +#endif + member __.Constructor = typeof.GetConstructors().[0] + member __.ConstructorArguments = upcast [| |] + 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 + let mutable hasReflectedDefinition = 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() + if hasReflectedDefinition then yield mkReflectedDefinitionCustomAttributeData() + yield! customAttributes |] + + member __.AddDefinitionLocation(line:int,column:int,filePath:string) = customAttributes.Add(mkDefinitionLocationAttributeCustomAttributeData(line, column, filePath)) + member __.AddObsolete(message : string, isError) = obsoleteMessage <- Some (message,isError) + member __.HasParamArray with get() = hasParamArray and set(v) = hasParamArray <- v + member __.HasReflectedDefinition with get() = hasReflectedDefinition and set(v) = hasReflectedDefinition <- v + member __.AddXmlDocComputed xmlDocFunction = xmlDocAlwaysRecomputed <- Some xmlDocFunction + member __.AddXmlDocDelayed xmlDocFunction = xmlDocDelayed <- Some xmlDocFunction + member __.AddXmlDoc xmlDoc = xmlDocDelayed <- Some (fun () -> xmlDoc) + 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() + // Recomputed XML doc is evaluated on every call to GetCustomAttributesData() + match xmlDocAlwaysRecomputed with None -> () | Some f -> yield mkXmlDocCustomAttributeData (f()) |] + :> IList<_> + + + 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 xmlDocFunction = customAttributesImpl.AddXmlDocDelayed xmlDocFunction + member __.AddXmlDocComputed xmlDocFunction = customAttributesImpl.AddXmlDocComputed xmlDocFunction + member __.AddXmlDoc xmlDoc = customAttributesImpl.AddXmlDoc xmlDoc + + 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 __.IsParamArray with get() = customAttributesImpl.HasParamArray and set(v) = customAttributesImpl.HasParamArray <- v + member __.IsReflectedDefinition with get() = customAttributesImpl.HasReflectedDefinition and set(v) = customAttributesImpl.HasReflectedDefinition <- v + override __.Name = name + override __.ParameterType = parameterType + override __.Attributes = (base.Attributes ||| (if isOut then ParameterAttributes.Out else enum 0) + ||| (match optionalValue with None -> enum 0 | Some _ -> ParameterAttributes.Optional ||| ParameterAttributes.HasDefault)) + override __.RawDefaultValue = defaultArg optionalValue null + member __.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 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 isStatic() = ctorAttributes.HasFlag(MethodAttributes.Static) + + let customAttributesImpl = CustomAttributesImpl() + member __.IsTypeInitializer + with get() = isStatic() && ctorAttributes.HasFlag(MethodAttributes.Private) + and set(v) = + let typeInitializerAttributes = MethodAttributes.Static ||| MethodAttributes.Private + ctorAttributes <- if v then ctorAttributes ||| typeInitializerAttributes else ctorAttributes &&& ~~~typeInitializerAttributes + + member __.AddXmlDocComputed xmlDocFunction = customAttributesImpl.AddXmlDocComputed xmlDocFunction + member __.AddXmlDocDelayed xmlDocFunction = customAttributesImpl.AddXmlDocDelayed xmlDocFunction + member __.AddXmlDoc xmlDoc = customAttributesImpl.AddXmlDoc xmlDoc + member __.AddObsoleteAttribute (message,?isError) = customAttributesImpl.AddObsolete (message,defaultArg isError false) + member __.AddDefinitionLocation(line,column,filePath) = customAttributesImpl.AddDefinitionLocation(line, column, filePath) + member __.GetCustomAttributesDataImpl() = customAttributesImpl.GetCustomAttributesData() +#if FX_NO_CUSTOMATTRIBUTEDATA +#else + override __.GetCustomAttributesData() = customAttributesImpl.GetCustomAttributesData() +#endif + + member __.DeclaringTypeImpl + with set x = + if declaringType<>null then failwith (sprintf "ProvidedConstructor: declaringType already set on '%s'" (nameText())); + declaringType <- x + + member __.InvokeCode + with set (q:Expr list -> Expr) = + match invokeCode with + | None -> invokeCode <- Some q + | Some _ -> failwith (sprintf "ProvidedConstructor: code already given for '%s'" (nameText())) + + member __.BaseConstructorCall + with set (d:Expr list -> (ConstructorInfo * Expr list)) = + match baseCall with + | None -> baseCall <- Some d + | Some _ -> failwith (sprintf "ProvidedConstructor: base call already given for '%s'" (nameText())) + + member __.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 || isStatic() then [] else ["this"]) + |> Array.ofList + QuotationSimplifier(isGenerated).TranslateQuotationToCode f paramNames + | None -> failwith (sprintf "ProvidedConstructor: no invoker for '%s'" (nameText())) + + member __.GetBaseConstructorCallInternal isGenerated = + match baseCall with + | Some f -> Some(fun ctorArgs -> let c,baseCtorArgExprs = f ctorArgs in c, List.map (QuotationSimplifier(isGenerated).TranslateExpression) baseCtorArgExprs) + | None -> None + + member __.IsImplicitCtor with get() = isImplicitCtor and set v = isImplicitCtor <- v + + // Implement overloads + override __.GetParameters() = parameters |> List.toArray + override __.Attributes = ctorAttributes + override __.Name = if isStatic() then ".cctor" else ".ctor" + override __.DeclaringType = declaringType |> nonNull "ProvidedConstructor.DeclaringType" + override __.IsDefined(_attributeType, _inherit) = true + + override __.Invoke(_invokeAttr, _binder, _parameters, _culture) = notRequired "Invoke" (nameText()) + override __.Invoke(_obj, _invokeAttr, _binder, _parameters, _culture) = notRequired "Invoke" (nameText()) + override __.ReflectedType = notRequired "ReflectedType" (nameText()) + override __.GetMethodImplementationFlags() = notRequired "GetMethodImplementationFlags" (nameText()) + override __.MethodHandle = notRequired "MethodHandle" (nameText()) + override __.GetCustomAttributes(_inherit) = notRequired "GetCustomAttributes" (nameText()) + override __.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 Expr> + let mutable staticParams = [ ] + let mutable staticParamsApply = None + let isStatic() = methodAttrs.HasFlag(MethodAttributes.Static) + let customAttributesImpl = CustomAttributesImpl() + + member __.AddXmlDocComputed xmlDocFunction = customAttributesImpl.AddXmlDocComputed xmlDocFunction + member __.AddXmlDocDelayed xmlDocFunction = customAttributesImpl.AddXmlDocDelayed xmlDocFunction + member __.AddXmlDoc xmlDoc = customAttributesImpl.AddXmlDoc xmlDoc + member __.AddObsoleteAttribute (message,?isError) = customAttributesImpl.AddObsolete (message,defaultArg isError false) + member __.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 __.GetCustomAttributesData() = customAttributesImpl.GetCustomAttributesData() +#endif + + member __.SetMethodAttrs m = methodAttrs <- m + member __.AddMethodAttrs m = methodAttrs <- methodAttrs ||| m + member __.DeclaringTypeImpl with set x = declaringType <- x // check: not set twice + member __.IsStaticMethod + with get() = isStatic() + and set x = if x then methodAttrs <- methodAttrs ||| MethodAttributes.Static + else methodAttrs <- methodAttrs &&& (~~~ MethodAttributes.Static) + + member __.InvokeCode + with set (q:Expr list -> Expr) = + match invokeCode with + | None -> invokeCode <- Some q + | Some _ -> failwith (sprintf "ProvidedConstructor: code already given for %s on type %s" methodName (if declaringType=null then "" else declaringType.FullName)) + + + /// Abstract a type to a parametric-type. Requires "formal parameters" and "instantiation function". + member __.DefineStaticParameters(staticParameters : list, apply : (string -> obj[] -> ProvidedMethod)) = + staticParams <- staticParameters + staticParamsApply <- Some apply + + /// Get ParameterInfo[] for the parametric type parameters (//s GetGenericParameters) + member __.GetStaticParameters() = [| for p in staticParams -> p :> ParameterInfo |] + + /// Instantiate parametrics type + member __.ApplyStaticArguments(mangledName: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 method %s" staticParams.Length args.Length methodName) + match staticParamsApply with + | None -> failwith "ProvidedTypeDefinition: DefineStaticParameters was not called" + | Some f -> f mangledName args + else + failwith (sprintf "ProvidedTypeDefinition: static parameters supplied but not expected for method %s" methodName) + + member __.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 isStatic() then [] else ["this"]) + |> Array.ofList + QuotationSimplifier(isGenerated).TranslateQuotationToCode f paramNames + | None -> failwith (sprintf "ProvidedMethod: no invoker for %s on type %s" methodName (if declaringType=null then "" else declaringType.FullName)) + + // Implement overloads + override __.GetParameters() = argParams |> Array.ofList + override __.Attributes = methodAttrs + override __.Name = methodName + override __.DeclaringType = declaringType |> nonNull "ProvidedMethod.DeclaringType" + override __.IsDefined(_attributeType, _inherit) : bool = true + override __.MemberType = MemberTypes.Method + override __.CallingConvention = + let cc = CallingConventions.Standard + let cc = if not (isStatic()) then cc ||| CallingConventions.HasThis else cc + cc + override __.ReturnType = returnType + override __.ReturnParameter = null // REVIEW: Give it a name and type? + override __.ToString() = "Method " + methodName + + // 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 __.MetadataToken = hash declaringType + hash methodName + override __.MethodHandle = RuntimeMethodHandle() + + override __.ReturnTypeCustomAttributes = notRequired "ReturnTypeCustomAttributes" methodName + override __.GetBaseDefinition() = notRequired "GetBaseDefinition" methodName + override __.GetMethodImplementationFlags() = notRequired "GetMethodImplementationFlags" methodName + override __.Invoke(_obj, _invokeAttr, _binder, _parameters, _culture) = notRequired "Invoke" methodName + override __.ReflectedType = notRequired "ReflectedType" methodName + override __.GetCustomAttributes(_inherit) = notRequired "GetCustomAttributes" methodName + override __.GetCustomAttributes(_attributeType, _inherit) = notRequired "GetCustomAttributes" methodName + + +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 Expr> + let mutable setterCode = None : option 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 __.AddXmlDocComputed xmlDocFunction = customAttributesImpl.AddXmlDocComputed xmlDocFunction + member __.AddXmlDocDelayed xmlDocFunction = customAttributesImpl.AddXmlDocDelayed xmlDocFunction + member __.AddXmlDoc xmlDoc = customAttributesImpl.AddXmlDoc xmlDoc + member __.AddObsoleteAttribute (message,?isError) = customAttributesImpl.AddObsolete (message,defaultArg isError false) + member __.AddDefinitionLocation(line,column,filePath) = customAttributesImpl.AddDefinitionLocation(line, column, filePath) + member __.GetCustomAttributesDataImpl() = customAttributesImpl.GetCustomAttributesData() + member __.AddCustomAttribute attribute = customAttributesImpl.AddCustomAttribute attribute +#if FX_NO_CUSTOMATTRIBUTEDATA +#else + override __.GetCustomAttributesData() = customAttributesImpl.GetCustomAttributesData() +#endif + + member __.DeclaringTypeImpl with set x = declaringType <- x // check: not set twice + + member __.IsStatic + with get() = isStatic + and set x = isStatic <- x + + member __.GetterCode + with set (q:Expr list -> Expr) = + if not getter.IsValueCreated then getterCode <- Some q else failwith "ProvidedProperty: getter MethodInfo has already been created" + + member __.SetterCode + with set (q:Expr list -> Expr) = + if not (setter.IsValueCreated) then setterCode <- Some q else failwith "ProvidedProperty: setter MethodInfo has already been created" + + // Implement overloads + override __.PropertyType = propertyType + override __.SetValue(_obj, _value, _invokeAttr, _binder, _index, _culture) = notRequired "SetValue" propertyName + override __.GetAccessors _nonPublic = notRequired "nonPublic" propertyName + override __.GetGetMethod _nonPublic = if hasGetter() then getter.Force() :> MethodInfo else null + override __.GetSetMethod _nonPublic = if hasSetter() then setter.Force() :> MethodInfo else null + override __.GetIndexParameters() = [| for p in parameters -> upcast p |] + override __.Attributes = PropertyAttributes.None + override __.CanRead = hasGetter() + override __.CanWrite = hasSetter() + override __.GetValue(_obj, _invokeAttr, _binder, _index, _culture) : obj = notRequired "GetValue" propertyName + override __.Name = propertyName + override __.DeclaringType = declaringType |> nonNull "ProvidedProperty.DeclaringType" + override __.MemberType : MemberTypes = MemberTypes.Property + + override __.ReflectedType = notRequired "ReflectedType" propertyName + override __.GetCustomAttributes(_inherit) = notRequired "GetCustomAttributes" propertyName + override __.GetCustomAttributes(_attributeType, _inherit) = notRequired "GetCustomAttributes" propertyName + override __.IsDefined(_attributeType, _inherit) = notRequired "IsDefined" propertyName + +type ProvidedEvent(eventName:string,eventHandlerType:Type) = + inherit System.Reflection.EventInfo() + // State + + let mutable declaringType = null + let mutable isStatic = false + let mutable adderCode = None : option Expr> + let mutable removerCode = None : option 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 __.AddXmlDocComputed xmlDocFunction = customAttributesImpl.AddXmlDocComputed xmlDocFunction + member __.AddXmlDocDelayed xmlDocFunction = customAttributesImpl.AddXmlDocDelayed xmlDocFunction + member __.AddXmlDoc xmlDoc = customAttributesImpl.AddXmlDoc xmlDoc + member __.AddDefinitionLocation(line,column,filePath) = customAttributesImpl.AddDefinitionLocation(line, column, filePath) + member __.GetCustomAttributesDataImpl() = customAttributesImpl.GetCustomAttributesData() +#if FX_NO_CUSTOMATTRIBUTEDATA +#else + override __.GetCustomAttributesData() = customAttributesImpl.GetCustomAttributesData() +#endif + + member __.DeclaringTypeImpl with set x = declaringType <- x // check: not set twice + member __.IsStatic + with get() = isStatic + and set x = isStatic <- x + + member __.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 __.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 __.EventHandlerType = eventHandlerType + override __.GetAddMethod _nonPublic = adder.Force() :> MethodInfo + override __.GetRemoveMethod _nonPublic = remover.Force() :> MethodInfo + override __.Attributes = EventAttributes.None + override __.Name = eventName + override __.DeclaringType = declaringType |> nonNull "ProvidedEvent.DeclaringType" + override __.MemberType : MemberTypes = MemberTypes.Event + + override __.GetRaiseMethod _nonPublic = notRequired "GetRaiseMethod" eventName + override __.ReflectedType = notRequired "ReflectedType" eventName + override __.GetCustomAttributes(_inherit) = notRequired "GetCustomAttributes" eventName + override __.GetCustomAttributes(_attributeType, _inherit) = notRequired "GetCustomAttributes" eventName + override __.IsDefined(_attributeType, _inherit) = notRequired "IsDefined" eventName + +type ProvidedLiteralField(fieldName:string,fieldType:Type,literalValue:obj) = + inherit System.Reflection.FieldInfo() + // State + + let mutable declaringType = null + + let customAttributesImpl = CustomAttributesImpl() + member __.AddXmlDocComputed xmlDocFunction = customAttributesImpl.AddXmlDocComputed xmlDocFunction + member __.AddXmlDocDelayed xmlDocFunction = customAttributesImpl.AddXmlDocDelayed xmlDocFunction + member __.AddXmlDoc xmlDoc = customAttributesImpl.AddXmlDoc xmlDoc + member __.AddObsoleteAttribute (message,?isError) = customAttributesImpl.AddObsolete (message,defaultArg isError false) + member __.AddDefinitionLocation(line,column,filePath) = customAttributesImpl.AddDefinitionLocation(line, column, filePath) + member __.GetCustomAttributesDataImpl() = customAttributesImpl.GetCustomAttributesData() +#if FX_NO_CUSTOMATTRIBUTEDATA +#else + override __.GetCustomAttributesData() = customAttributesImpl.GetCustomAttributesData() +#endif + + member __.DeclaringTypeImpl with set x = declaringType <- x // check: not set twice + + + // Implement overloads + override __.FieldType = fieldType + override __.GetRawConstantValue() = literalValue + override __.Attributes = FieldAttributes.Static ||| FieldAttributes.Literal ||| FieldAttributes.Public + override __.Name = fieldName + override __.DeclaringType = declaringType |> nonNull "ProvidedLiteralField.DeclaringType" + override __.MemberType : MemberTypes = MemberTypes.Field + + override __.ReflectedType = notRequired "ReflectedType" fieldName + override __.GetCustomAttributes(_inherit) = notRequired "GetCustomAttributes" fieldName + override __.GetCustomAttributes(_attributeType, _inherit) = notRequired "GetCustomAttributes" fieldName + override __.IsDefined(_attributeType, _inherit) = notRequired "IsDefined" fieldName + + override __.SetValue(_obj, _value, _invokeAttr, _binder, _culture) = notRequired "SetValue" fieldName + override __.GetValue(_obj) : obj = notRequired "GetValue" fieldName + override __.FieldHandle = notRequired "FieldHandle" fieldName + +type ProvidedField(fieldName:string,fieldType:Type) = + inherit System.Reflection.FieldInfo() + // State + + let mutable declaringType = null + + let customAttributesImpl = CustomAttributesImpl() + let mutable fieldAttrs = FieldAttributes.Private + member __.AddXmlDocComputed xmlDocFunction = customAttributesImpl.AddXmlDocComputed xmlDocFunction + member __.AddXmlDocDelayed xmlDocFunction = customAttributesImpl.AddXmlDocDelayed xmlDocFunction + member __.AddXmlDoc xmlDoc = customAttributesImpl.AddXmlDoc xmlDoc + member __.AddObsoleteAttribute (message,?isError) = customAttributesImpl.AddObsolete (message,defaultArg isError false) + member __.AddDefinitionLocation(line,column,filePath) = customAttributesImpl.AddDefinitionLocation(line, column, filePath) + member __.GetCustomAttributesDataImpl() = customAttributesImpl.GetCustomAttributesData() +#if FX_NO_CUSTOMATTRIBUTEDATA +#else + override __.GetCustomAttributesData() = customAttributesImpl.GetCustomAttributesData() +#endif + + member __.DeclaringTypeImpl with set x = declaringType <- x // check: not set twice + + member __.SetFieldAttributes attrs = fieldAttrs <- attrs + // Implement overloads + override __.FieldType = fieldType + override __.GetRawConstantValue() = null + override __.Attributes = fieldAttrs + override __.Name = fieldName + override __.DeclaringType = declaringType |> nonNull "ProvidedField.DeclaringType" + override __.MemberType : MemberTypes = MemberTypes.Field + + override __.ReflectedType = notRequired "ReflectedType" fieldName + override __.GetCustomAttributes(_inherit) = notRequired "GetCustomAttributes" fieldName + override __.GetCustomAttributes(_attributeType, _inherit) = notRequired "GetCustomAttributes" fieldName + override __.IsDefined(_attributeType, _inherit) = notRequired "IsDefined" fieldName + + override __.SetValue(_obj, _value, _invokeAttr, _binder, _culture) = notRequired "SetValue" fieldName + override __.GetValue(_obj) : obj = notRequired "GetValue" fieldName + override __.FieldHandle = notRequired "FieldHandle" fieldName + +/// Represents the type constructor in a provided symbol type. +[] +type ProvidedSymbolKind = + | 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: ProvidedSymbolKind, args: Type list, convToTgt: Type -> Type) = + 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 + | ProvidedSymbolKind.SDArray, [ty] | ProvidedSymbolKind.Array _, [ty] when otherTy.IsArray-> ty.Equals(otherTy.GetElementType()) + | ProvidedSymbolKind.ByRef, [ty] when otherTy.IsByRef -> ty.Equals(otherTy.GetElementType()) + | ProvidedSymbolKind.Pointer, [ty] when otherTy.IsPointer -> ty.Equals(otherTy.GetElementType()) + | ProvidedSymbolKind.Generic baseTy, args -> otherTy.IsGenericType && isEquivalentTo baseTy (otherTy.GetGenericTypeDefinition()) && Seq.forall2 isEquivalentTo args (otherTy.GetGenericArguments()) + | _ -> false + | a, b -> a.Equals b + + let nameText() = + match kind,args with + | ProvidedSymbolKind.SDArray,[arg] -> arg.Name + "[]" + | ProvidedSymbolKind.Array _,[arg] -> arg.Name + "[*]" + | ProvidedSymbolKind.Pointer,[arg] -> arg.Name + "*" + | ProvidedSymbolKind.ByRef,[arg] -> arg.Name + "&" + | ProvidedSymbolKind.Generic gty, args -> gty.Name + (sprintf "%A" args) + | ProvidedSymbolKind.FSharpTypeAbbreviation (_,_,path),_ -> path.[path.Length-1] + | _ -> failwith "unreachable" + + /// Substitute types for type variables. + 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()) + ty.GetGenericTypeDefinition().MakeGenericType(args) + elif ty.HasElementType then + let ety = ProvidedSymbolType.convType parameters (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 + elif ty.IsGenericParameter then + if ty.GenericParameterPosition <= parameters.Length - 1 then + parameters.[ty.GenericParameterPosition] + else + ty + else ty + + override __.FullName = + match kind,args with + | ProvidedSymbolKind.SDArray,[arg] -> arg.FullName + "[]" + | ProvidedSymbolKind.Array _,[arg] -> arg.FullName + "[*]" + | ProvidedSymbolKind.Pointer,[arg] -> arg.FullName + "*" + | ProvidedSymbolKind.ByRef,[arg] -> arg.FullName + "&" + | ProvidedSymbolKind.Generic gty, args -> gty.FullName + "[" + (args |> List.map (fun arg -> arg.ToString()) |> String.concat ",") + "]" + | ProvidedSymbolKind.FSharpTypeAbbreviation (_,nsp,path),args -> String.concat "." (Array.append [| nsp |] path) + (match args with [] -> "" | _ -> 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 __.DeclaringType = + match kind,args with + | ProvidedSymbolKind.SDArray,[arg] -> arg + | ProvidedSymbolKind.Array _,[arg] -> arg + | ProvidedSymbolKind.Pointer,[arg] -> arg + | ProvidedSymbolKind.ByRef,[arg] -> arg + | ProvidedSymbolKind.Generic gty,_ -> gty + | ProvidedSymbolKind.FSharpTypeAbbreviation _,_ -> null + | _ -> failwith "unreachable" + + override __.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 __.Name = nameText() + + override __.BaseType = + match kind with + | ProvidedSymbolKind.SDArray -> convToTgt typeof + | ProvidedSymbolKind.Array _ -> convToTgt typeof + | ProvidedSymbolKind.Pointer -> convToTgt typeof + | ProvidedSymbolKind.ByRef -> convToTgt typeof + | ProvidedSymbolKind.Generic gty -> + if gty.BaseType = null then null else + ProvidedSymbolType.convType args gty.BaseType + | ProvidedSymbolKind.FSharpTypeAbbreviation _ -> convToTgt typeof + + override __.GetArrayRank() = (match kind with ProvidedSymbolKind.Array n -> n | ProvidedSymbolKind.SDArray -> 1 | _ -> invalidOp "non-array type") + override __.IsValueTypeImpl() = (match kind with ProvidedSymbolKind.Generic gtd -> gtd.IsValueType | _ -> false) + override __.IsArrayImpl() = (match kind with ProvidedSymbolKind.Array _ | ProvidedSymbolKind.SDArray -> true | _ -> false) + override __.IsByRefImpl() = (match kind with ProvidedSymbolKind.ByRef _ -> true | _ -> false) + override __.IsPointerImpl() = (match kind with ProvidedSymbolKind.Pointer _ -> true | _ -> false) + override __.IsPrimitiveImpl() = false + override __.IsGenericType = (match kind with ProvidedSymbolKind.Generic _ -> true | _ -> false) + override __.GetGenericArguments() = (match kind with ProvidedSymbolKind.Generic _ -> args |> List.toArray | _ -> invalidOp "non-generic type") + override __.GetGenericTypeDefinition() = (match kind with ProvidedSymbolKind.Generic e -> e | _ -> invalidOp "non-generic type") + override __.IsCOMObjectImpl() = false + override __.HasElementTypeImpl() = (match kind with ProvidedSymbolKind.Generic _ -> false | _ -> true) + override __.GetElementType() = (match kind,args with (ProvidedSymbolKind.Array _ | ProvidedSymbolKind.SDArray | ProvidedSymbolKind.ByRef | ProvidedSymbolKind.Pointer),[e] -> e | _ -> invalidOp "not an array, pointer or byref type") + override this.ToString() = this.FullName + + override __.Assembly = + match kind with + | ProvidedSymbolKind.FSharpTypeAbbreviation (assembly,_nsp,_path) -> assembly + | ProvidedSymbolKind.Generic gty -> gty.Assembly + | _ -> notRequired "Assembly" (nameText()) + + override __.Namespace = + match kind with + | ProvidedSymbolKind.FSharpTypeAbbreviation (_assembly,nsp,_path) -> nsp + | _ -> notRequired "Namespace" (nameText()) + + override __.GetHashCode() = + match kind,args with + | ProvidedSymbolKind.SDArray,[arg] -> 10 + hash arg + | ProvidedSymbolKind.Array _,[arg] -> 163 + hash arg + | ProvidedSymbolKind.Pointer,[arg] -> 283 + hash arg + | ProvidedSymbolKind.ByRef,[arg] -> 43904 + hash arg + | ProvidedSymbolKind.Generic gty,_ -> 9797 + hash gty + List.sumBy hash args + | ProvidedSymbolKind.FSharpTypeAbbreviation _,_ -> 3092 + | _ -> failwith "unreachable" + + override __.Equals(other: obj) = + match other with + | :? ProvidedSymbolType as otherTy -> (kind, args) = (otherTy.Kind, otherTy.Args) + | _ -> false + + member __.Kind = kind + member __.Args = args + + member __.IsFSharpTypeAbbreviation = match kind with FSharpTypeAbbreviation _ -> true | _ -> false + // For example, int + member __.IsFSharpUnitAnnotated = match kind with ProvidedSymbolKind.Generic gtd -> not gtd.IsGenericTypeDefinition | _ -> false + + override __.Module : Module = notRequired "Module" (nameText()) + override __.GetConstructors _bindingAttr = notRequired "GetConstructors" (nameText()) + override __.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" (nameText()) + override __.GetMembers _bindingAttr = notRequired "GetMembers" (nameText()) + override __.GetMethods _bindingAttr = notRequired "GetMethods" (nameText()) + override __.GetField(_name, _bindingAttr) = notRequired "GetField" (nameText()) + override __.GetFields _bindingAttr = notRequired "GetFields" (nameText()) + override __.GetInterface(_name, _ignoreCase) = notRequired "GetInterface" (nameText()) + override __.GetInterfaces() = notRequired "GetInterfaces" (nameText()) + override __.GetEvent(_name, _bindingAttr) = notRequired "GetEvent" (nameText()) + override __.GetEvents _bindingAttr = notRequired "GetEvents" (nameText()) + override __.GetProperties _bindingAttr = notRequired "GetProperties" (nameText()) + override __.GetPropertyImpl(_name, _bindingAttr, _binder, _returnType, _types, _modifiers) = notRequired "GetPropertyImpl" (nameText()) + override __.GetNestedTypes _bindingAttr = notRequired "GetNestedTypes" (nameText()) + override __.GetNestedType(_name, _bindingAttr) = notRequired "GetNestedType" (nameText()) + override __.GetAttributeFlagsImpl() = notRequired "GetAttributeFlagsImpl" (nameText()) + override this.UnderlyingSystemType = + match kind with + | ProvidedSymbolKind.SDArray + | ProvidedSymbolKind.Array _ + | ProvidedSymbolKind.Pointer + | ProvidedSymbolKind.FSharpTypeAbbreviation _ + | ProvidedSymbolKind.ByRef -> upcast this + | ProvidedSymbolKind.Generic gty -> gty.UnderlyingSystemType +#if FX_NO_CUSTOMATTRIBUTEDATA +#else + override __.GetCustomAttributesData() = ([| |] :> IList<_>) +#endif + override __.MemberType = notRequired "MemberType" (nameText()) + override __.GetMember(_name,_mt,_bindingAttr) = notRequired "GetMember" (nameText()) + override __.GUID = notRequired "GUID" (nameText()) + override __.InvokeMember(_name, _invokeAttr, _binder, _target, _args, _modifiers, _culture, _namedParameters) = notRequired "InvokeMember" (nameText()) + override __.AssemblyQualifiedName = notRequired "AssemblyQualifiedName" (nameText()) + override __.GetConstructorImpl(_bindingAttr, _binder, _callConvention, _types, _modifiers) = notRequired "GetConstructorImpl" (nameText()) + override __.GetCustomAttributes(_inherit) = [| |] + override __.GetCustomAttributes(_attributeType, _inherit) = [| |] + override __.IsDefined(_attributeType, _inherit) = false + // FSharp.Data addition: this was added to support arrays of arrays + override this.MakeArrayType() = ProvidedSymbolType(ProvidedSymbolKind.SDArray, [this], convToTgt) :> Type + override this.MakeArrayType arg = ProvidedSymbolType(ProvidedSymbolKind.Array arg, [this], convToTgt) :> Type + +type ProvidedSymbolMethod(genericMethodDefinition: MethodInfo, parameters: Type list) = + inherit System.Reflection.MethodInfo() + + let convParam (p:ParameterInfo) = + { new System.Reflection.ParameterInfo() with + override __.Name = p.Name + override __.ParameterType = ProvidedSymbolType.convType parameters p.ParameterType + override __.Attributes = p.Attributes + override __.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 __.GetGenericMethodDefinition() = genericMethodDefinition + + override __.DeclaringType = ProvidedSymbolType.convType parameters genericMethodDefinition.DeclaringType + override __.ToString() = "Method " + genericMethodDefinition.Name + override __.Name = genericMethodDefinition.Name + override __.MetadataToken = genericMethodDefinition.MetadataToken + override __.Attributes = genericMethodDefinition.Attributes + override __.CallingConvention = genericMethodDefinition.CallingConvention + override __.MemberType = genericMethodDefinition.MemberType + + override __.IsDefined(_attributeType, _inherit) : bool = notRequired "IsDefined" genericMethodDefinition.Name + override __.ReturnType = ProvidedSymbolType.convType parameters genericMethodDefinition.ReturnType + override __.GetParameters() = genericMethodDefinition.GetParameters() |> Array.map convParam + override __.ReturnParameter = genericMethodDefinition.ReturnParameter |> convParam + override __.ReturnTypeCustomAttributes = notRequired "ReturnTypeCustomAttributes" genericMethodDefinition.Name + override __.GetBaseDefinition() = notRequired "GetBaseDefinition" genericMethodDefinition.Name + override __.GetMethodImplementationFlags() = notRequired "GetMethodImplementationFlags" genericMethodDefinition.Name + override __.MethodHandle = notRequired "MethodHandle" genericMethodDefinition.Name + override __.Invoke(_obj, _invokeAttr, _binder, _parameters, _culture) = notRequired "Invoke" genericMethodDefinition.Name + override __.ReflectedType = notRequired "ReflectedType" genericMethodDefinition.Name + override __.GetCustomAttributes(_inherit) = notRequired "GetCustomAttributes" genericMethodDefinition.Name + override __.GetCustomAttributes(_attributeType, _inherit) = notRequired "GetCustomAttributes" genericMethodDefinition.Name + + + +type ProvidedTypeBuilder() = + static member MakeGenericType(genericTypeDefinition, genericArguments) = ProvidedSymbolType(Generic genericTypeDefinition, genericArguments, id) :> Type + static member MakeGenericMethod(genericMethodDefinition, genericArguments) = ProvidedSymbolMethod(genericMethodDefinition, genericArguments) :> MethodInfo + +type ZProvidedTypeBuilder(convToTgt: Type -> Type) = + member __.MakeGenericType(genericTypeDefinition, genericArguments) = ProvidedSymbolType(Generic genericTypeDefinition, genericArguments, convToTgt) :> Type + member __.MakeGenericMethod(genericMethodDefinition, genericArguments) = ProvidedSymbolMethod(genericMethodDefinition, genericArguments) :> MethodInfo + +[] +type ProvidedMeasureBuilder() = + + // TODO: this shouldn't be hardcoded, but without creating a dependency on FSharp.Compiler.Service + // 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 __.One = typeof + member __.Product (m1,m2) = typedefof>.MakeGenericType [| m1;m2 |] + member __.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 __.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(ProvidedSymbolKind.FSharpTypeAbbreviation(typeof.Assembly,ns,[| unitName |]), [], id) :> Type + | None -> + typedefof>.Assembly.GetType("Microsoft.FSharp.Data.UnitSystems.SI.UnitNames." + mLowerCase) + + member __.AnnotateType (basicType, annotation) = ProvidedSymbolType(Generic basicType, annotation, id) :> Type + + + +[] +type TypeContainer = + | Namespace of Assembly * string // namespace + | Type of System.Type + | TypeToBeDecided + +#if NO_GENERATIVE +#else +module GlobalProvidedAssemblyElementsTable = + let theTable = Dictionary>() +#endif + +type ProvidedTypeDefinition(container:TypeContainer, className : string, baseType : Type option, convToTgt) 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 = None + 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" className) + + 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" className) + + 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" className) + + 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" className) + + 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 __.AddXmlDocComputed xmlDocFunction = customAttributesImpl.AddXmlDocComputed xmlDocFunction + member __.AddXmlDocDelayed xmlDocFunction = customAttributesImpl.AddXmlDocDelayed xmlDocFunction + member __.AddXmlDoc xmlDoc = customAttributesImpl.AddXmlDoc xmlDoc + member __.AddObsoleteAttribute (message,?isError) = customAttributesImpl.AddObsolete (message,defaultArg isError false) + member __.AddDefinitionLocation(line,column,filePath) = customAttributesImpl.AddDefinitionLocation(line, column, filePath) + member __.HideObjectMethods with set v = customAttributesImpl.HideObjectMethods <- v + member __.NonNullable with set v = customAttributesImpl.NonNullable <- v + member __.GetCustomAttributesDataImpl() = customAttributesImpl.GetCustomAttributesData() + member __.AddCustomAttribute attribute = customAttributesImpl.AddCustomAttribute attribute +#if FX_NO_CUSTOMATTRIBUTEDATA +#else + override __.GetCustomAttributesData() = customAttributesImpl.GetCustomAttributesData() +#endif + + member __.ResetEnclosingType (ty) = + container <- TypeContainer.Type ty + new (assembly:Assembly,namespaceName,className,baseType) = new ProvidedTypeDefinition(TypeContainer.Namespace (assembly,namespaceName), className, baseType, id) + new (className:string,baseType) = new ProvidedTypeDefinition(TypeContainer.TypeToBeDecided, className, baseType, id) + + new (assembly:Assembly,namespaceName,className,baseType,convToTgt) = new ProvidedTypeDefinition(TypeContainer.Namespace (assembly,namespaceName), className, baseType, convToTgt) + new (className,baseType, convToTgt) = new ProvidedTypeDefinition(TypeContainer.TypeToBeDecided, className, baseType, convToTgt) + // state ops + + override __.UnderlyingSystemType = typeof + + member __.SetEnumUnderlyingType(ty) = enumUnderlyingType <- Some ty + + override __.GetEnumUnderlyingType() = + if this.IsEnum then + match enumUnderlyingType with + | None -> convToTgt typeof + | Some ty -> ty + else invalidOp "not enum type" + + member __.SetBaseType t = baseType <- lazy Some t + + member __.SetBaseTypeDelayed baseTypeFunction = baseType <- lazy (Some (baseTypeFunction())) + + member __.SetAttributes x = attributes <- x + + // Add MemberInfos + member __.AddMembersDelayed(membersFunction : unit -> list<#MemberInfo>) = + membersQueue.Add (fun () -> membersFunction() |> List.map (fun x -> patchUpAddedMemberInfo this x; x :> MemberInfo )) + + member __.AddMembers(memberInfos:list<#MemberInfo>) = (* strict *) + memberInfos |> List.iter (patchUpAddedMemberInfo this) // strict: patch up now + membersQueue.Add (fun () -> memberInfos |> List.map (fun x -> x :> MemberInfo)) + + member __.AddMember(memberInfo:MemberInfo) = + this.AddMembers [memberInfo] + + member __.AddMemberDelayed(memberFunction : unit -> #MemberInfo) = + this.AddMembersDelayed(fun () -> [memberFunction()]) + +#if NO_GENERATIVE +#else + member __.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) +#endif + + /// Abstract a type to a parametric-type. Requires "formal parameters" and "instantiation function". + member __.DefineStaticParameters(staticParameters : list, apply : (string -> obj[] -> ProvidedTypeDefinition)) = + staticParams <- staticParameters + staticParamsApply <- Some apply + + /// Get ParameterInfo[] for the parametric type parameters (//s GetGenericParameters) + member __.GetStaticParameters() = [| for p in staticParams -> p :> ParameterInfo |] + + /// Instantiate parametrics type + member __.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 __.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 __.Assembly = theAssembly.Force() + + member __.SetAssembly assembly = theAssembly <- lazy assembly + + member __.SetAssemblyLazy assembly = theAssembly <- assembly + + override __.FullName = fullName.Force() + + override __.Namespace = rootNamespace.Force() + + override __.BaseType = match baseType.Value with Some ty -> ty | None -> null + + // Constructors + override __.GetConstructors bindingAttr = + [| for m in this.GetMembers bindingAttr do + if m.MemberType = MemberTypes.Constructor then + yield (m :?> ConstructorInfo) |] + // Methods + override __.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 __.GetMethods bindingAttr = + this.GetMembers bindingAttr + |> Array.filter (fun m -> m.MemberType.HasFlag(MemberTypes.Method)) + |> Array.map (fun m -> m :?> MethodInfo) + + // Fields + override __.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 __.GetFields bindingAttr = + [| for m in this.GetMembers bindingAttr do if m.MemberType.HasFlag(MemberTypes.Field) then yield m :?> FieldInfo |] + + override __.GetInterface(_name, _ignoreCase) = notRequired "GetInterface" this.Name + + override __.GetInterfaces() = + [| yield! getInterfaces() |] + + member __.GetInterfaceImplementations() = + [| yield! getInterfaces() |] + + member __.AddInterfaceImplementation ityp = interfaceImpls.Add ityp + + member __.AddInterfaceImplementationsDelayed itypf = interfaceImplsDelayed.Add itypf + + member __.GetMethodOverrides() = + [| yield! methodOverrides |] + + member __.DefineMethodOverride (bodyMethInfo,declMethInfo) = methodOverrides.Add (bodyMethInfo, declMethInfo) + + // Events + override __.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 __.GetEvents bindingAttr = + [| for m in this.GetMembers bindingAttr do if m.MemberType.HasFlag(MemberTypes.Event) then yield downcast m |] + + // Properties + override __.GetProperties bindingAttr = + [| for m in this.GetMembers bindingAttr do if m.MemberType.HasFlag(MemberTypes.Property) then yield downcast m |] + + override __.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 __.MakeArrayType() = ProvidedSymbolType(ProvidedSymbolKind.SDArray, [this], convToTgt) :> Type + override __.MakeArrayType arg = ProvidedSymbolType(ProvidedSymbolKind.Array arg, [this], convToTgt) :> Type + override __.MakePointerType() = ProvidedSymbolType(ProvidedSymbolKind.Pointer, [this], convToTgt) :> Type + override __.MakeByRefType() = ProvidedSymbolType(ProvidedSymbolKind.ByRef, [this], convToTgt) :> 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) : Type = + match t with + | :? ProvidedTypeDefinition as ptd when ptd.IsErased -> ProvidedTypeDefinition.EraseType t.BaseType + | t when t.IsArray -> + let rank = t.GetArrayRank() + let et = ProvidedTypeDefinition.EraseType (t.GetElementType()) + if rank = 0 then et.MakeArrayType() else et.MakeArrayType(rank) + | :? ProvidedSymbolType as sym when sym.IsFSharpUnitAnnotated -> + t.UnderlyingSystemType + | 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 __.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 __.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 __.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 __.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 __.GetAttributeFlagsImpl() = adjustTypeAttributes attributes this.IsNested + override this.IsValueTypeImpl() = if this.BaseType <> null then this.BaseType = typeof || this.BaseType.IsValueType else false + override __.IsArrayImpl() = false + override __.IsByRefImpl() = false + override __.IsPointerImpl() = false + override __.IsPrimitiveImpl() = false + override __.IsCOMObjectImpl() = false + override __.HasElementTypeImpl() = false + override __.Name = className + override __.DeclaringType = declaringType.Force() + override __.MemberType = if this.IsNested then MemberTypes.NestedType else MemberTypes.TypeInfo + override __.GetHashCode() = rootNamespace.GetHashCode() ^^^ className.GetHashCode() + override __.Equals(that:obj) = + match that with + | null -> false + | :? ProvidedTypeDefinition as ti -> System.Object.ReferenceEquals(this,ti) + | _ -> false + + override __.GetGenericArguments() = [||] + override __.ToString() = this.Name + + + override __.Module : Module = notRequired "Module" this.Name + override __.GUID = Guid.Empty + override __.GetConstructorImpl(_bindingAttr, _binder, _callConvention, _types, _modifiers) = null + override __.GetCustomAttributes(_inherit) = [| |] + override __.GetCustomAttributes(_attributeType, _inherit) = [| |] + override __.IsDefined(_attributeType: Type, _inherit) = false + + override __.GetElementType() = notRequired "Module" this.Name + override __.InvokeMember(_name, _invokeAttr, _binder, _target, _args, _modifiers, _culture, _namedParameters) = notRequired "Module" this.Name + override __.AssemblyQualifiedName = notRequired "Module" this.Name + member __.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 __.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)) + + +#if NO_GENERATIVE +#else +//------------------------------------------------------------------------------------------------- +// The assembly compiler for generative type providers. + +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 transType (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 transType (ty.GetGenericArguments())) + elif ty.HasElementType then + let ety = transType (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 transCtor (f:ConstructorInfo) = match f with :? ProvidedConstructor as pc when ctorMap.ContainsKey pc -> ctorMap.[pc] :> ConstructorInfo | c -> c + let transField (f:FieldInfo) = match f with :? ProvidedField as pf when fieldMap.ContainsKey pf -> fieldMap.[pf] :> FieldInfo | f -> f + let transMeth (m:MethodInfo) = match m with :? ProvidedMethod as pm when methMap.ContainsKey pm -> methMap.[pm] :> MethodInfo | m -> m + let isLiteralEnumField (f:FieldInfo) = match f with :? ProvidedLiteralField as plf -> plf.DeclaringType.IsEnum | _ -> false + + 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(transType 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() -> transType 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, transType finfo.FieldType, finfo.Attributes, pinfo.GetCustomAttributesDataImpl(), None) + | :? ProvidedLiteralField as pinfo -> + Some (pinfo.Name, transType 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, transType minfo.ReturnType, [| for p in minfo.GetParameters() -> transType 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, transType ctorArg.ParameterType, FieldAttributes.Private) ] + + + + // 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 Var("this", pcinfo.DeclaringType) + for p in pcinfo.GetParameters() do + yield Var(p.Name, p.ParameterType) |] + + let codeGen = CodeGenerator(assemblyMainModule, uniqueLambdaTypeName, implicitCtorArgsAsFields, transType, transField, transMeth, transCtor, isLiteralEnumField, ilg, locals, parameterVars) + let parameters = + [| for v in parameterVars -> 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 + codeGen.EmitExpr (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 parameters + codeGen.EmitExpr (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 [||] + let codeGen = CodeGenerator(assemblyMainModule, uniqueLambdaTypeName, implicitCtorArgsAsFields, transType, transField, transMeth, transCtor, isLiteralEnumField, ilg, new Dictionary<_, _>(), [| |]) + codeGen.EmitExpr (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 Var("this", pminfo.DeclaringType) + for p in pminfo.GetParameters() do + yield Var(p.Name, p.ParameterType) |] + let parameters = + [| for v in parameterVars -> 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 + let codeGen = CodeGenerator(assemblyMainModule, uniqueLambdaTypeName, implicitCtorArgsAsFields, transType, transField, transMeth, transCtor, isLiteralEnumField, ilg, locals, parameterVars) + codeGen.EmitExpr (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, transType pinfo.PropertyType, [| for p in pinfo.GetIndexParameters() -> transType 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 + + let resolveHandler = ResolveEventHandler(fun _ args -> + // On Mono args.Name is full name of the type, on .NET - just name (no namespace) + typeMap.Values + |> Seq.filter (fun tb -> tb.FullName = args.Name || tb.Name = args.Name) + |> Seq.iter (fun tb -> tb.CreateType() |> ignore) + + assemblyMainModule.Assembly) + + try + AppDomain.CurrentDomain.add_TypeResolve resolveHandler + iterateTypes (fun tb _ -> tb.CreateType() |> ignore) + finally + AppDomain.CurrentDomain.remove_TypeResolve resolveHandler + +#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 + +#endif // NO_GENERATIVE + +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 + } + + +#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 __.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 __.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 __.RegisterProbingFolder (folder) = + // use GetFullPath to ensure that folder is valid + ignore(IO.Path.GetFullPath folder) + probingFolders.Add folder + + member __.RegisterRuntimeAssemblyLocationAsProbingFolder (config : TypeProviderConfig) = + config.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 this.Invalidate() = invalidateE.Trigger(this,EventArgs()) + + member __.GetStaticParametersForMethod(mb: MethodBase) = + // printfn "In GetStaticParametersForMethod" + match mb with + | :? ProvidedMethod as t -> t.GetStaticParameters() + | _ -> [| |] + + member __.ApplyStaticArgumentsForMethod(mb: MethodBase, mangledName, objs) = + // printfn "In ApplyStaticArgumentsForMethod" + match mb with + | :? ProvidedMethod as t -> t.ApplyStaticArguments(mangledName, objs) :> MethodBase + | _ -> failwith (sprintf "ApplyStaticArguments: static parameters for method %s are unexpected" mb.Name) + + interface ITypeProvider with + + [] + override __.Invalidate = invalidateE.Publish + + override __.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 -> + Expr.NewObjectUnchecked(cinfo, Array.toList parameters) + | :? System.Reflection.MethodInfo as minfo -> + if minfo.IsStatic then + Expr.CallUnchecked(minfo, Array.toList parameters) + else + Expr.CallUnchecked(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 + | NewObject(ctor, args) -> getInvokerExpression ctor [| for arg in args -> expand arg|] + | Call(inst, mi, args) -> + let args = + [| + match inst with + | Some inst -> yield expand inst + | _ -> () + yield! List.map expand args + |] + getInvokerExpression mi args + | ShapeCombinationUnchecked(shape, args) -> RebuildShapeCombinationUnchecked(shape, List.map expand args) + | ShapeVarUnchecked v -> Expr.Var v + | ShapeLambdaUnchecked(v, body) -> Expr.Lambda(v, expand body) + 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 __.GetStaticParameters(ty) = + match ty with + | :? ProvidedTypeDefinition as t -> + if ty.Name = t.Name (* REVIEW: use equality? *) then + t.GetStaticParameters() + else + [| |] + | _ -> [| |] + + override __.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 NO_GENERATIVE + override __.GetGeneratedAssemblyContents(_assembly) = + failwith "no generative assemblies" +#else +#if FX_NO_LOCAL_FILESYSTEM + override __.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 __.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 +#endif \ No newline at end of file diff --git a/src/Xamarin.iOSProviders/ProvidedTypes.fsi b/src/Xamarin.iOSProviders/ProvidedTypes.fsi index 3eb5025..fadc9fe 100644 --- a/src/Xamarin.iOSProviders/ProvidedTypes.fsi +++ b/src/Xamarin.iOSProviders/ProvidedTypes.fsi @@ -14,17 +14,21 @@ namespace ProviderImplementation.ProvidedTypes open System open System.Reflection open System.Linq.Expressions +open Microsoft.FSharp.Quotations open Microsoft.FSharp.Core.CompilerServices /// Represents an erased provided parameter type ProvidedParameter = inherit ParameterInfo + // [] new : parameterName: string * parameterType: Type * ?isOut:bool * ?optionalValue:obj -> ProvidedParameter member IsParamArray : bool with get,set + member IsReflectedDefinition : bool with get,set /// Represents a provided static parameter. type ProvidedStaticParameter = inherit ParameterInfo + // [] new : parameterName: string * parameterType:Type * ?parameterDefaultValue:obj -> ProvidedStaticParameter /// Add XML documentation information to this provided constructor @@ -38,9 +42,10 @@ type ProvidedConstructor = inherit 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 + /// Add a 'Obsolete' attribute to this provided constructor member AddObsoleteAttribute : message: string * ?isError: bool -> unit /// Add XML documentation information to this provided constructor @@ -53,13 +58,13 @@ type ProvidedConstructor = 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 + member InvokeCode : (Expr list -> Expr) with set - /// FSharp.Data addition: this method is used by Debug.fs - member internal GetInvokeCodeInternal : bool -> (Quotations.Expr [] -> Quotations.Expr) + /// This method is used by Debug.fs + member internal GetInvokeCodeInternal : bool -> (Expr [] -> 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 + member BaseConstructorCall : (Expr list -> ConstructorInfo * 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 @@ -75,6 +80,7 @@ type ProvidedMethod = inherit 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 @@ -99,10 +105,10 @@ type ProvidedMethod = 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 + member InvokeCode : (Expr list -> Expr) with set - /// FSharp.Data addition: this method is used by Debug.fs - member internal GetInvokeCodeInternal : bool -> (Quotations.Expr [] -> Quotations.Expr) + // this method is used by Debug.fs + member internal GetInvokeCodeInternal : bool -> (Expr [] -> Expr) /// Add definition location information to the provided type definition. member AddDefinitionLocation : line:int * column:int * filePath:string -> unit @@ -117,10 +123,11 @@ type ProvidedMethod = type ProvidedProperty = inherit PropertyInfo - /// Create a new provided type. It is not initially associated with any specific provided type definition. + /// Create a new provided property. 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 + /// Add a 'Obsolete' attribute to this provided property member AddObsoleteAttribute : message: string * ?isError: bool -> unit /// Add XML documentation information to this provided constructor @@ -134,14 +141,13 @@ type ProvidedProperty = 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 + member GetterCode : (Expr list -> 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 + member SetterCode : (Expr list -> Expr) with set /// Add definition location information to the provided type definition. member AddDefinitionLocation : line:int * column:int * filePath:string -> unit @@ -170,10 +176,10 @@ type ProvidedEvent = 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 + member AdderCode : (Expr list -> 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 + member RemoverCode : (Expr list -> Expr) with set /// Add definition location information to the provided type definition. member AddDefinitionLocation : line:int * column:int * filePath:string -> unit @@ -183,9 +189,10 @@ type ProvidedLiteralField = inherit 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 + // [] + new : fieldName: string * fieldType: Type * literalValue: obj -> ProvidedLiteralField - /// Add a 'System.Obsolete' attribute to this provided field + /// Add a 'Obsolete' attribute to this provided field member AddObsoleteAttribute : message: string * ?isError: bool -> unit /// Add XML documentation information to this provided field @@ -206,9 +213,10 @@ type ProvidedField = inherit 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 + /// Add a 'Obsolete' attribute to this provided field member AddObsoleteAttribute : message: string * ?isError: bool -> unit /// Add XML documentation information to this provided field @@ -228,7 +236,7 @@ type ProvidedField = /// Represents the type constructor in a provided symbol type. [] -type SymbolKind = +type ProvidedSymbolKind = /// Indicates that the type constructor is for a single-dimensional array | SDArray /// Indicates that the type constructor is for a multi-dimensional array @@ -250,11 +258,16 @@ type ProvidedSymbolType = inherit Type /// Returns the kind of this symbolic type - member Kind : SymbolKind + member Kind : ProvidedSymbolKind /// Return the provided types used as arguments of this symbolic type member Args : list + /// For example, kg + member IsFSharpTypeAbbreviation: bool + + /// For example, int or int + member IsFSharpUnitAnnotated : bool /// Helpers to build symbolic provided types [] @@ -266,6 +279,13 @@ type ProvidedTypeBuilder = /// Like methodInfo.MakeGenericMethod, but will also work with unit-annotated types and provided types static member MakeGenericMethod: genericMethodDefinition: MethodInfo * genericArguments: Type list -> MethodInfo +[] +/// Used internally for ProvidedTypesContext +type internal ZProvidedTypeBuilder = + new : convToTgt: (Type -> Type) -> ZProvidedTypeBuilder + member MakeGenericType: genericTypeDefinition: Type * genericArguments: Type list -> Type + member MakeGenericMethod: genericMethodDefinition: MethodInfo * genericArguments: Type list -> MethodInfo + /// Helps create erased provided unit-of-measure annotations. [] type ProvidedMeasureBuilder = @@ -301,11 +321,18 @@ type ProvidedTypeDefinition = inherit 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 + + internal new : assembly: Assembly * namespaceName: string * className: string * baseType: Type option * convToTgt: (Type -> Type) -> ProvidedTypeDefinition + internal new : className : string * baseType: Type option * convToTgt: (Type -> Type) -> ProvidedTypeDefinition + + /// Add the given type as an implemented interface. member AddInterfaceImplementation : interfaceType: Type -> unit @@ -315,7 +342,7 @@ type ProvidedTypeDefinition = /// 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 + /// Add a 'Obsolete' attribute to this provided type definition member AddObsoleteAttribute : message: string * ?isError: bool -> unit /// Add XML documentation information to this provided constructor @@ -356,8 +383,11 @@ type ProvidedTypeDefinition = /// Add a set of members to a ProvidedTypeDefinition, delaying computation of the members until required by the compilation context. member AddMembersDelayed : membersFunction:(unit -> list<#MemberInfo>) -> unit +#if NO_GENERATIVE +#else /// Add the types of the generated assembly as generative types, where types in namespaces get hierarchically positioned as nested types. member AddAssemblyTypesAsNestedTypesDelayed : assemblyFunction:(unit -> Assembly) -> unit +#endif /// Define the static parameters available on a statically parameterized type member DefineStaticParameters : parameters: ProvidedStaticParameter list * instantiationFunction: (string -> obj[] -> ProvidedTypeDefinition) -> unit @@ -365,7 +395,7 @@ type ProvidedTypeDefinition = /// 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 + /// Suppress Object entries in intellisense menus in instances of this provided type member HideObjectMethods : bool with set /// Disallows the use of the null literal. @@ -378,7 +408,7 @@ type ProvidedTypeDefinition = [] member SuppressRelocation : bool with get,set - /// FSharp.Data addition: this method is used by Debug.fs + // This method is used by Debug.fs member MakeParametricType : name:string * args:obj[] -> ProvidedTypeDefinition /// Add a custom attribute to the provided type definition. @@ -394,6 +424,8 @@ type ProvidedTypeDefinition = /// Get or set a utility function to log the creation of root Provided Type. Used to debug caching/invalidation. static member Logger : (string -> unit) option ref +#if NO_GENERATIVE +#else /// A provided generated assembly type ProvidedAssembly = /// Create a provided generated assembly @@ -421,6 +453,8 @@ type ProvidedAssembly = static member RegisterGenerated : fileName:string -> Assembly #endif +#endif + /// A base type providing default implementations of type provider functionality when all provided /// types are of type ProvidedTypeDefinition. @@ -450,8 +484,8 @@ type TypeProviderForNamespaces = #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 + abstract ResolveAssembly : ResolveEventArgs -> Assembly + default ResolveAssembly : ResolveEventArgs -> Assembly /// Registers custom probing path that can be used for probing assemblies member RegisterProbingFolder : folder: string -> unit @@ -465,3 +499,28 @@ type TypeProviderForNamespaces = member Disposing : IEvent interface ITypeProvider + + +module internal UncheckedQuotations = + + type Expr with + static member NewDelegateUnchecked : ty:Type * vs:Var list * body:Expr -> Expr + static member NewObjectUnchecked : cinfo:ConstructorInfo * args:Expr list -> Expr + static member NewArrayUnchecked : elementType:Type * elements:Expr list -> Expr + static member CallUnchecked : minfo:MethodInfo * args:Expr list -> Expr + static member CallUnchecked : obj:Expr * minfo:MethodInfo * args:Expr list -> Expr + static member ApplicationUnchecked : f:Expr * x:Expr -> Expr + static member PropertyGetUnchecked : pinfo:PropertyInfo * args:Expr list -> Expr + static member PropertyGetUnchecked : obj:Expr * pinfo:PropertyInfo * ?args:Expr list -> Expr + static member PropertySetUnchecked : pinfo:PropertyInfo * value:Expr * ?args:Expr list -> Expr + static member PropertySetUnchecked : obj:Expr * pinfo:PropertyInfo * value:Expr * args:Expr list -> Expr + static member FieldGetUnchecked : pinfo:FieldInfo -> Expr + static member FieldGetUnchecked : obj:Expr * pinfo:FieldInfo -> Expr + static member FieldSetUnchecked : pinfo:FieldInfo * value:Expr -> Expr + static member FieldSetUnchecked : obj:Expr * pinfo:FieldInfo * value:Expr -> Expr + static member TupleGetUnchecked : e:Expr * n:int -> Expr + static member LetUnchecked : v:Var * e:Expr * body:Expr -> Expr + + type Shape + val ( |ShapeCombinationUnchecked|ShapeVarUnchecked|ShapeLambdaUnchecked| ) : e:Expr -> Choice<(Shape * Expr list),Var, (Var * Expr)> + val RebuildShapeCombinationUnchecked : Shape * args:Expr list -> Expr \ No newline at end of file From 1d306e3e7916216a2cf27ca8189a32c39b50d7a0 Mon Sep 17 00:00:00 2001 From: Dave Thomas Date: Mon, 26 Jun 2017 20:49:07 +0100 Subject: [PATCH 05/10] Fix script file --- src/Xamarin.iOSProviders/Script.fsx | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Xamarin.iOSProviders/Script.fsx b/src/Xamarin.iOSProviders/Script.fsx index ed2aa3b..16f9902 100644 --- a/src/Xamarin.iOSProviders/Script.fsx +++ b/src/Xamarin.iOSProviders/Script.fsx @@ -1,7 +1,7 @@ #I "/Developer/MonoTouch/usr/lib/mono/2.1" #r "/Applications/Xamarin Studio.app/Contents/Resources/lib/monodevelop/AddIns/MonoDevelop.IPhone/MonoTouch.Design.dll" #r "/Applications/Xamarin Studio.app/Contents/Resources/lib/monodevelop/AddIns/MonoDevelop.IPhone/MonoTouch.Design.Client.dll" -#r "packages/ExtCore.0.8.45/lib/net45/ExtCore.dll" +#r "../packages/ExtCore.0.8.45/lib/net45/ExtCore.dll" #r "/Library/Frameworks/Xamarin.iOS.framework/Versions/Current/lib/mono/Xamarin.iOS/Xamarin.iOS.dll" #r "System.xml.Linq" #load "ProvidedTypes.fs" @@ -16,7 +16,7 @@ open System.Net open System.Linq open ProviderImplementation open ProviderImplementation.ProvidedTypes -open Xamarin.iOSProviders +open Xamarin.UIProviders let (/) a b = Path.Combine(a, b) let outputFolder = __SOURCE_DIRECTORY__ / "bin" / "Debug" @@ -24,7 +24,7 @@ let workingFolder = __SOURCE_DIRECTORY__ / "../../samples/StoryBoards/" let assemblyName = "iOSDesignerTypeProvider.exe" let runtimeAssembly = outputFolder / assemblyName let config = [|box false;box true;box true |] -let generated = Debug.generate workingFolder runtimeAssembly (fun cfg -> new iOSDesignerProvider(cfg)) config +let generated = Debug.generate workingFolder runtimeAssembly (fun cfg -> new DesignTime.iOSDesignerProvider(cfg)) config let output = Debug.prettyPrint false false 10 100 generated printfn "%s" output From df003eb62f689c7d7aaca9efaa1dc3a9714f8747 Mon Sep 17 00:00:00 2001 From: Dave Thomas Date: Mon, 26 Jun 2017 20:52:15 +0100 Subject: [PATCH 06/10] Use paket reference to provided types --- .../src}/ProvidedTypes.fs | 6088 ++++++++--------- .../src}/ProvidedTypes.fsi | 2 +- .../src/paket.version | 1 + paket.dependencies | 5 +- paket.lock | 4 + .../Xamarin.UIProviders.DesignTime.fsproj | 8 + src/Xamarin.iOSProviders/paket.references | 6 +- 7 files changed, 3067 insertions(+), 3047 deletions(-) rename {src/Xamarin.iOSProviders => paket-files/fsprojects/FSharp.TypeProviders.StarterPack/src}/ProvidedTypes.fs (98%) rename {src/Xamarin.iOSProviders => paket-files/fsprojects/FSharp.TypeProviders.StarterPack/src}/ProvidedTypes.fsi (99%) create mode 100644 paket-files/fsprojects/FSharp.TypeProviders.StarterPack/src/paket.version diff --git a/src/Xamarin.iOSProviders/ProvidedTypes.fs b/paket-files/fsprojects/FSharp.TypeProviders.StarterPack/src/ProvidedTypes.fs similarity index 98% rename from src/Xamarin.iOSProviders/ProvidedTypes.fs rename to paket-files/fsprojects/FSharp.TypeProviders.StarterPack/src/ProvidedTypes.fs index 0f7d8c3..7a2991c 100644 --- a/src/Xamarin.iOSProviders/ProvidedTypes.fs +++ b/paket-files/fsprojects/FSharp.TypeProviders.StarterPack/src/ProvidedTypes.fs @@ -1,3044 +1,3044 @@ -// 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-4.0 releases - -namespace ProviderImplementation.ProvidedTypes - -open System -open System.Text -open System.IO -open System.Reflection -open System.Linq.Expressions -open System.Collections.Generic -open Microsoft.FSharp.Quotations -open Microsoft.FSharp.Quotations.Patterns -open Microsoft.FSharp.Quotations.DerivedPatterns -open Microsoft.FSharp.Core.CompilerServices - -#if NO_GENERATIVE -#else -open System.Reflection.Emit -#endif - -//-------------------------------------------------------------------------------- -// UncheckedQuotations - -// The FSharp.Core 2.0 - 4.0 (4.0.0.0 - 4.4.0.0) quotations implementation is overly strict in that it doesn't allow -// generation of quotations for cross-targeted FSharp.Core. Below we define a series of Unchecked methods -// implemented via reflection hacks to allow creation of various nodes when using a cross-targets FSharp.Core and -// mscorlib.dll. -// -// - Most importantly, these cross-targeted quotations can be provided to the F# compiler by a type provider. -// They are generally produced via the AssemblyReplacer.fs component through a process of rewriting design-time quotations that -// are not cross-targeted. -// -// - However, these quotation values are a bit fragile. Using existing FSharp.Core.Quotations.Patterns -// active patterns on these quotation nodes will generally work correctly. But using ExprShape.RebuildShapeCombination -// on these new nodes will not succed, nor will operations that build new quotations such as Expr.Call. -// Instead, use the replacement provided in this module. -// -// - Likewise, some operations in these quotation values like "expr.Type" may be a bit fragile, possibly returning non cross-targeted types in -// the result. However those operations are not used by the F# compiler. -[] -module internal UncheckedQuotations = - - let qTy = typeof.Assembly.GetType("Microsoft.FSharp.Quotations.ExprConstInfo") - assert (qTy <> null) - let pTy = typeof.Assembly.GetType("Microsoft.FSharp.Quotations.PatternsModule") - assert (pTy<> null) - - // These are handles to the internal functions that create quotation nodes of different sizes. Although internal, - // these function names have been stable since F# 2.0. - let mkFE0 = pTy.GetMethod("mkFE0", BindingFlags.Static ||| BindingFlags.Public ||| BindingFlags.NonPublic) - assert (mkFE0 <> null) - let mkFE1 = pTy.GetMethod("mkFE1", BindingFlags.Static ||| BindingFlags.Public ||| BindingFlags.NonPublic) - assert (mkFE1 <> null) - let mkFE2 = pTy.GetMethod("mkFE2", BindingFlags.Static ||| BindingFlags.Public ||| BindingFlags.NonPublic) - assert (mkFE2 <> null) - let mkFEN = pTy.GetMethod("mkFEN", BindingFlags.Static ||| BindingFlags.Public ||| BindingFlags.NonPublic) - assert (mkFEN <> null) - - // These are handles to the internal tags attached to quotation nodes of different sizes. Although internal, - // these function names have been stable since F# 2.0. - let newDelegateOp = qTy.GetMethod("NewNewDelegateOp", BindingFlags.Static ||| BindingFlags.Public ||| BindingFlags.NonPublic) - assert (newDelegateOp <> null) - let instanceCallOp = qTy.GetMethod("NewInstanceMethodCallOp", BindingFlags.Static ||| BindingFlags.Public ||| BindingFlags.NonPublic) - assert (instanceCallOp <> null) - let staticCallOp = qTy.GetMethod("NewStaticMethodCallOp", BindingFlags.Static ||| BindingFlags.Public ||| BindingFlags.NonPublic) - assert (staticCallOp <> null) - let newObjectOp = qTy.GetMethod("NewNewObjectOp", BindingFlags.Static ||| BindingFlags.Public ||| BindingFlags.NonPublic) - assert (newObjectOp <> null) - let newArrayOp = qTy.GetMethod("NewNewArrayOp", BindingFlags.Static ||| BindingFlags.Public ||| BindingFlags.NonPublic) - assert (newArrayOp <> null) - let appOp = qTy.GetMethod("get_AppOp", BindingFlags.Static ||| BindingFlags.Public ||| BindingFlags.NonPublic) - assert (appOp <> null) - let instancePropGetOp = qTy.GetMethod("NewInstancePropGetOp", BindingFlags.Static ||| BindingFlags.Public ||| BindingFlags.NonPublic) - assert (instancePropGetOp <> null) - let staticPropGetOp = qTy.GetMethod("NewStaticPropGetOp", BindingFlags.Static ||| BindingFlags.Public ||| BindingFlags.NonPublic) - assert (staticPropGetOp <> null) - let instancePropSetOp = qTy.GetMethod("NewInstancePropSetOp", BindingFlags.Static ||| BindingFlags.Public ||| BindingFlags.NonPublic) - assert (instancePropSetOp <> null) - let staticPropSetOp = qTy.GetMethod("NewStaticPropSetOp", BindingFlags.Static ||| BindingFlags.Public ||| BindingFlags.NonPublic) - assert (staticPropSetOp <> null) - let instanceFieldGetOp = qTy.GetMethod("NewInstanceFieldGetOp", BindingFlags.Static ||| BindingFlags.Public ||| BindingFlags.NonPublic) - assert (instanceFieldGetOp <> null) - let staticFieldGetOp = qTy.GetMethod("NewStaticFieldGetOp", BindingFlags.Static ||| BindingFlags.Public ||| BindingFlags.NonPublic) - assert (staticFieldGetOp <> null) - let instanceFieldSetOp = qTy.GetMethod("NewInstanceFieldSetOp", BindingFlags.Static ||| BindingFlags.Public ||| BindingFlags.NonPublic) - assert (instanceFieldSetOp <> null) - let staticFieldSetOp = qTy.GetMethod("NewStaticFieldSetOp", BindingFlags.Static ||| BindingFlags.Public ||| BindingFlags.NonPublic) - assert (staticFieldSetOp <> null) - let tupleGetOp = qTy.GetMethod("NewTupleGetOp", BindingFlags.Static ||| BindingFlags.Public ||| BindingFlags.NonPublic) - assert (tupleGetOp <> null) - let letOp = qTy.GetMethod("get_LetOp", BindingFlags.Static ||| BindingFlags.Public ||| BindingFlags.NonPublic) - assert (letOp <> null) - - type Microsoft.FSharp.Quotations.Expr with - - static member NewDelegateUnchecked (ty: Type, vs: Var list, body: Expr) = - let e = List.foldBack (fun v acc -> Expr.Lambda(v,acc)) vs body - let op = newDelegateOp.Invoke(null, [| box ty |]) - mkFE1.Invoke(null, [| box op; box e |]) :?> Expr - - static member NewObjectUnchecked (cinfo: ConstructorInfo, args : Expr list) = - let op = newObjectOp.Invoke(null, [| box cinfo |]) - mkFEN.Invoke(null, [| box op; box args |]) :?> Expr - - static member NewArrayUnchecked (elementType: Type, elements : Expr list) = - let op = newArrayOp.Invoke(null, [| box elementType |]) - mkFEN.Invoke(null, [| box op; box elements |]) :?> Expr - - static member CallUnchecked (minfo: MethodInfo, args : Expr list) = - let op = staticCallOp.Invoke(null, [| box minfo |]) - mkFEN.Invoke(null, [| box op; box args |]) :?> Expr - - static member CallUnchecked (obj: Expr, minfo: MethodInfo, args : Expr list) = - let op = instanceCallOp.Invoke(null, [| box minfo |]) - mkFEN.Invoke(null, [| box op; box (obj::args) |]) :?> Expr - - static member ApplicationUnchecked (f: Expr, x: Expr) = - let op = appOp.Invoke(null, [| |]) - mkFE2.Invoke(null, [| box op; box f; box x |]) :?> Expr - - static member PropertyGetUnchecked (pinfo: PropertyInfo, args : Expr list) = - let op = staticPropGetOp.Invoke(null, [| box pinfo |]) - mkFEN.Invoke(null, [| box op; box args |]) :?> Expr - - static member PropertyGetUnchecked (obj: Expr, pinfo: PropertyInfo, ?args : Expr list) = - let args = defaultArg args [] - let op = instancePropGetOp.Invoke(null, [| box pinfo |]) - mkFEN.Invoke(null, [| box op; box (obj::args) |]) :?> Expr - - static member PropertySetUnchecked (pinfo: PropertyInfo, value: Expr, ?args : Expr list) = - let args = defaultArg args [] - let op = staticPropSetOp.Invoke(null, [| box pinfo |]) - mkFEN.Invoke(null, [| box op; box (args@[value]) |]) :?> Expr - - static member PropertySetUnchecked (obj: Expr, pinfo: PropertyInfo, value: Expr, args : Expr list) = - let op = instancePropSetOp.Invoke(null, [| box pinfo |]) - mkFEN.Invoke(null, [| box op; box (obj::(args@[value])) |]) :?> Expr - - static member FieldGetUnchecked (pinfo: FieldInfo) = - let op = staticFieldGetOp.Invoke(null, [| box pinfo |]) - mkFE0.Invoke(null, [| box op; |]) :?> Expr - - static member FieldGetUnchecked (obj: Expr, pinfo: FieldInfo) = - let op = instanceFieldGetOp.Invoke(null, [| box pinfo |]) - mkFE1.Invoke(null, [| box op; box obj |]) :?> Expr - - static member FieldSetUnchecked (pinfo: FieldInfo, value: Expr) = - let op = staticFieldSetOp.Invoke(null, [| box pinfo |]) - mkFE1.Invoke(null, [| box op; box value |]) :?> Expr - - static member FieldSetUnchecked (obj: Expr, pinfo: FieldInfo, value: Expr) = - let op = instanceFieldSetOp.Invoke(null, [| box pinfo |]) - mkFE2.Invoke(null, [| box op; box obj; box value |]) :?> Expr - - static member TupleGetUnchecked (e: Expr, n:int) = - let op = tupleGetOp.Invoke(null, [| box e.Type; box n |]) - mkFE1.Invoke(null, [| box op; box e |]) :?> Expr - - static member LetUnchecked (v:Var, e: Expr, body:Expr) = - let lam = Expr.Lambda(v,body) - let op = letOp.Invoke(null, [| |]) - mkFE2.Invoke(null, [| box op; box e; box lam |]) :?> Expr - - type Shape = Shape of (Expr list -> Expr) - - let (|ShapeCombinationUnchecked|ShapeVarUnchecked|ShapeLambdaUnchecked|) e = - match e with - | NewObject (cinfo, args) -> - ShapeCombinationUnchecked (Shape (function args -> Expr.NewObjectUnchecked (cinfo, args)), args) - | NewArray (ty, args) -> - ShapeCombinationUnchecked (Shape (function args -> Expr.NewArrayUnchecked (ty, args)), args) - | NewDelegate (t, vars, expr) -> - ShapeCombinationUnchecked (Shape (function [expr] -> Expr.NewDelegateUnchecked (t, vars, expr) | _ -> invalidArg "expr" "invalid shape"), [expr]) - | TupleGet (expr, n) -> - ShapeCombinationUnchecked (Shape (function [expr] -> Expr.TupleGetUnchecked (expr, n) | _ -> invalidArg "expr" "invalid shape"), [expr]) - | Application (f, x) -> - ShapeCombinationUnchecked (Shape (function [f; x] -> Expr.ApplicationUnchecked (f, x) | _ -> invalidArg "expr" "invalid shape"), [f; x]) - | Call (objOpt, minfo, args) -> - match objOpt with - | None -> ShapeCombinationUnchecked (Shape (function args -> Expr.CallUnchecked (minfo, args)), args) - | Some obj -> ShapeCombinationUnchecked (Shape (function (obj::args) -> Expr.CallUnchecked (obj, minfo, args) | _ -> invalidArg "expr" "invalid shape"), obj::args) - | PropertyGet (objOpt, pinfo, args) -> - match objOpt with - | None -> ShapeCombinationUnchecked (Shape (function args -> Expr.PropertyGetUnchecked (pinfo, args)), args) - | Some obj -> ShapeCombinationUnchecked (Shape (function (obj::args) -> Expr.PropertyGetUnchecked (obj, pinfo, args) | _ -> invalidArg "expr" "invalid shape"), obj::args) - | PropertySet (objOpt, pinfo, args, value) -> - match objOpt with - | None -> ShapeCombinationUnchecked (Shape (function (value::args) -> Expr.PropertySetUnchecked (pinfo, value, args) | _ -> invalidArg "expr" "invalid shape"), value::args) - | Some obj -> ShapeCombinationUnchecked (Shape (function (obj::value::args) -> Expr.PropertySetUnchecked (obj, pinfo, value, args) | _ -> invalidArg "expr" "invalid shape"), obj::value::args) - | FieldGet (objOpt, pinfo) -> - match objOpt with - | None -> ShapeCombinationUnchecked (Shape (function _ -> Expr.FieldGetUnchecked (pinfo)), []) - | Some obj -> ShapeCombinationUnchecked (Shape (function [obj] -> Expr.FieldGetUnchecked (obj, pinfo) | _ -> invalidArg "expr" "invalid shape"), [obj]) - | FieldSet (objOpt, pinfo, value) -> - match objOpt with - | None -> ShapeCombinationUnchecked (Shape (function [value] -> Expr.FieldSetUnchecked (pinfo, value) | _ -> invalidArg "expr" "invalid shape"), [value]) - | Some obj -> ShapeCombinationUnchecked (Shape (function [obj;value] -> Expr.FieldSetUnchecked (obj, pinfo, value) | _ -> invalidArg "expr" "invalid shape"), [obj; value]) - | Let (var, value, body) -> - ShapeCombinationUnchecked (Shape (function [value;Lambda(var, body)] -> Expr.LetUnchecked(var, value, body) | _ -> invalidArg "expr" "invalid shape"), [value; Expr.Lambda(var, body)]) - | TupleGet (expr, i) -> - ShapeCombinationUnchecked (Shape (function [expr] -> Expr.TupleGetUnchecked (expr, i) | _ -> invalidArg "expr" "invalid shape"), [expr]) - | ExprShape.ShapeCombination (comb,args) -> - ShapeCombinationUnchecked (Shape (fun args -> ExprShape.RebuildShapeCombination(comb, args)), args) - | ExprShape.ShapeVar v -> ShapeVarUnchecked v - | ExprShape.ShapeLambda (v, e) -> ShapeLambdaUnchecked (v,e) - - let RebuildShapeCombinationUnchecked (Shape comb,args) = comb args - -//-------------------------------------------------------------------------------- -// The quotation simplifier -// -// This is invoked for each quotation specified by the type provider, just before it is -// handed to the F# compiler, allowing a broader range of -// quotations to be accepted. Specifically accept: -// -// - NewTuple nodes (for generative type providers) -// - TupleGet nodes (for generative type providers) -// - array and list values as constants -// - PropertyGet and PropertySet nodes -// - Application, NewUnionCase, NewRecord, UnionCaseTest nodes -// - Let nodes (defining "byref" values) -// - LetRecursive nodes -// -// Additionally, a set of code optimizations are applied to generated code: -// - inlineRightPipe -// - optimizeCurriedApplications -// - inlineValueBindings - -type QuotationSimplifier(isGenerated: bool) = - - let rec transExpr q = - match q with - // convert NewTuple to the call to the constructor of the Tuple type (only for generated types) - | NewTuple(items) when isGenerated -> - let rec mkCtor args ty = - let ctor, restTyOpt = Reflection.FSharpValue.PreComputeTupleConstructorInfo ty - match restTyOpt with - | None -> Expr.NewObject(ctor, List.map transExpr args) - | Some restTy -> - let curr = [for a in Seq.take 7 args -> transExpr a] - let rest = List.ofSeq (Seq.skip 7 args) - Expr.NewObject(ctor, curr @ [mkCtor rest restTy]) - let tys = [| for e in items -> e.Type |] - let tupleTy = Reflection.FSharpType.MakeTupleType tys - transExpr (mkCtor items tupleTy) - // convert TupleGet to the chain of PropertyGet calls (only for generated types) - | TupleGet(e, i) when isGenerated -> - let rec mkGet ty i (e : Expr) = - let pi, restOpt = Reflection.FSharpValue.PreComputeTuplePropertyInfo(ty, i) - let propGet = Expr.PropertyGet(e, pi) - match restOpt with - | None -> propGet - | Some (restTy, restI) -> mkGet restTy restI propGet - transExpr (mkGet e.Type i (transExpr e)) - | Value(value, ty) -> - if value <> null then - let tyOfValue = value.GetType() - transValue(value, tyOfValue, ty) - else q - // Eliminate F# property gets to method calls - | PropertyGet(obj,propInfo,args) -> - match obj with - | None -> transExpr (Expr.CallUnchecked(propInfo.GetGetMethod(),args)) - | Some o -> transExpr (Expr.CallUnchecked(transExpr o,propInfo.GetGetMethod(),args)) - // Eliminate F# property sets to method calls - | PropertySet(obj,propInfo,args,v) -> - match obj with - | None -> transExpr (Expr.CallUnchecked(propInfo.GetSetMethod(),args@[v])) - | Some o -> transExpr (Expr.CallUnchecked(transExpr o,propInfo.GetSetMethod(),args@[v])) - // Eliminate F# function applications to FSharpFunc<_,_>.Invoke calls - | Application(f,e) -> - transExpr (Expr.CallUnchecked(transExpr f, f.Type.GetMethod "Invoke", [ e ]) ) - | NewUnionCase(ci, es) -> - transExpr (Expr.CallUnchecked(Reflection.FSharpValue.PreComputeUnionConstructorInfo ci, es) ) - | NewRecord(ci, es) -> - transExpr (Expr.NewObjectUnchecked(Reflection.FSharpValue.PreComputeRecordConstructorInfo ci, es) ) - | UnionCaseTest(e,uc) -> - let tagInfo = Reflection.FSharpValue.PreComputeUnionTagMemberInfo uc.DeclaringType - let tagExpr = - match tagInfo with - | :? PropertyInfo as tagProp -> - transExpr (Expr.PropertyGet(e,tagProp) ) - | :? MethodInfo as tagMeth -> - if tagMeth.IsStatic then transExpr (Expr.Call(tagMeth, [e])) - else transExpr (Expr.Call(e,tagMeth,[])) - | _ -> failwith "unreachable: unexpected result from PreComputeUnionTagMemberInfo" - let tagNumber = uc.Tag - transExpr <@@ (%%(tagExpr) : int) = tagNumber @@> - - // Explicitly handle weird byref variables in lets (used to populate out parameters), since the generic handlers can't deal with byrefs. - // - // 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 - | Let(v,vexpr,bexpr) when v.Type.IsByRef -> transLetOfByref v vexpr bexpr - - // Eliminate recursive let bindings (which are unsupported by the type provider API) to regular let bindings - | LetRecursive(bindings, expr) -> transLetRec bindings expr - - // Handle the generic cases - | ShapeLambdaUnchecked(v,body) -> Expr.Lambda(v, transExpr body) - | ShapeCombinationUnchecked(comb,args) -> RebuildShapeCombinationUnchecked(comb,List.map transExpr args) - | ShapeVarUnchecked _ -> q - - and transLetRec 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 Call(None, r, [_]) -> r | _ -> failwith "Extracting MethodInfo from <@ 1 @> failed" - let d = match <@ Unchecked.defaultof<_> @> with Call(None, d, []) -> d | _ -> failwith "Extracting MethodInfo from <@ Unchecked.defaultof<_> @> failed" - Expr.Call(r.GetGenericMethodDefinition().MakeGenericMethod(t), [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 Call(None, m, [_]) -> m | _ -> failwith "Extracting MethodInfo from <@ !(ref 1) @> failed" - let tyArgs = v.Type.GetGenericArguments() - Expr.Call(m.GetGenericMethodDefinition().MakeGenericMethod(tyArgs), [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 Call(None, m, [_;_]) -> m | _ -> failwith "Extracting MethodInfo from <@ (ref 1) := 2 @> failed" - Expr.Call(m.GetGenericMethodDefinition().MakeGenericMethod(v.Type), [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) -> 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 -> Expr.LetUnchecked(varDict.[v], init v.Type, b)) body - |> transExpr - - - and transLetOfByref v vexpr bexpr = - match vexpr with - | Sequential(e',vexpr') -> - (* let v = (e'; vexpr') in bexpr => e'; let v = vexpr' in bexpr *) - Expr.Sequential(e', transLetOfByref v vexpr' bexpr) - |> transExpr - | 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 *) - // - // Note, this duplicates "bexpr" - Expr.IfThenElse(c, transLetOfByref v b1 bexpr, transLetOfByref v b2 bexpr) - |> transExpr - | Var _ -> - (* let v = v1 in bexpr => bexpr[v/v1] *) - bexpr.Substitute(fun v' -> if v = v' then Some vexpr else None) - |> transExpr - | _ -> - failwith (sprintf "Unexpected byref binding: %A = %A" v vexpr) - - and transValueArray (o : Array, ty : Type) = - let elemTy = ty.GetElementType() - let converter = getValueConverterForType elemTy - let elements = [ for el in o -> converter el ] - Expr.NewArrayUnchecked(elemTy, elements) - - and transValueList(o, ty : Type, nil, cons) = - let converter = getValueConverterForType (ty.GetGenericArguments().[0]) - o - |> Seq.cast - |> List.ofSeq - |> fun l -> List.foldBack(fun o s -> Expr.NewUnionCase(cons, [ converter(o); s ])) l (Expr.NewUnionCase(nil, [])) - |> transExpr - - and getValueConverterForType (ty : Type) = - if ty.IsArray then - fun (v : obj) -> transValueArray(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 -> transValueList (v :?> System.Collections.IEnumerable, ty, nil, cons) - else - fun v -> Expr.Value(v, ty) - - and transValue (v : obj, tyOfValue : Type, expectedTy : Type) = - let converter = getValueConverterForType tyOfValue - let r = converter v - if tyOfValue <> expectedTy then Expr.Coerce(r, expectedTy) - else r - -#if NO_GENERATIVE -#else - // TODO: this works over FSharp.Core 4.4.0.0 types. These types need to be retargeted to the target runtime. - 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 (===) a b = LanguagePrimitives.PhysicalEquality a b - - let traverse f = - let rec fallback e = - match e with - | Let(v, value, body) -> - let fixedValue = f fallback value - let fixedBody = f fallback body - if fixedValue === value && fixedBody === body then - e - else - Expr.Let(v, fixedValue, fixedBody) - | ShapeVarUnchecked _ -> e - | ShapeLambdaUnchecked(v, body) -> - let fixedBody = f fallback body - if fixedBody === body then - e - else - Expr.Lambda(v, fixedBody) - | ShapeCombinationUnchecked(shape, exprs) -> - let exprs1 = List.map (f fallback) exprs - if List.forall2 (===) exprs exprs1 then - e - else - RebuildShapeCombinationUnchecked(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 - | SpecificCall RightPipe (None, _, [operand; applicable]) -> - let fixedOperand = loop operand - match loop applicable with - | Lambda(arg, body) -> - let v = Quotations.Var("__temp", operand.Type) - let ev = Expr.Var v - - let fixedBody = loop body - Expr.Let(v, fixedOperand, fixedBody.Substitute(fun v1 -> if v1 = arg then Some ev else None)) - | fixedApplicable -> Expr.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 - | Let(id, (Value(_) as v), body) when not id.IsMutable -> - map.[id] <- v - let fixedBody = loop body - map.Remove(id) |> ignore - fixedBody - | ShapeVarUnchecked 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 - | 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 - | Application(e, arg) -> - let e1 = tryPeelApplications e ((loop arg)::args) - if e1 === e then - orig - else - e1 - | Let(id, applicable, (Lambda(_) as body)) when n > 0 -> - let numberOfApplication = countPeelableApplications body id 0 - if numberOfApplication = 0 then orig - elif n = 1 then Expr.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.toArray - |> (fun arr -> arr.[n - 1]) - - let adaptMethod = getFastFuncType args resultType - let adapted = Expr.Call(adaptMethod, [loop applicable]) - let invoke = adapted.Type.GetMethod("Invoke", [| for arg in args -> arg.Type |]) - Expr.Call(adapted, invoke, args) - else - (applicable, args) ||> List.fold (fun e a -> Expr.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 - | Lambda(arg, Let(v1, Application(Var f, Var arg1), rest)) when v = f && arg = arg1 -> countPeelableApplications rest v1 (n + 1) - // \arg -> (f arg) ==> f - | Lambda(arg, Application(Var f, Var arg1)) when v = f && arg = arg1 -> n - | _ -> n - loop expr -#endif - - member __.TranslateExpression q = transExpr q - - member __.TranslateQuotationToCode qexprf (paramNames: string[]) (argExprs: Expr[]) = - // Use the real variable names instead of indices, to improve output of Debug.fs - // 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 -> Expr.Var v]) - - let pairs = Array.zip argExprs vars - let expr = Array.foldBack (fun (arg, var) e -> Expr.LetUnchecked(var, arg, e)) pairs expr -#if NO_GENERATIVE -#else - let expr = - if isGenerated then - let e1 = inlineRightPipe expr - let e2 = optimizeCurriedApplications e1 - let e3 = inlineValueBindings e2 - e3 - else - expr -#endif - - transExpr expr - -//------------------------------------------------------------------------------------------------- -// Generate IL code from quotations - - -#if NO_GENERATIVE -#else - -type (*internal*) ExpectedStackState = - | Empty = 1 - | Address = 2 - | Value = 3 - -type CodeGenerator(assemblyMainModule: ModuleBuilder, uniqueLambdaTypeName, - implicitCtorArgsAsFields: FieldBuilder list, - transType: Type -> Type, - transField: FieldInfo -> FieldInfo, - transMethod: MethodInfo -> MethodInfo, - transCtor: ConstructorInfo -> ConstructorInfo, - isLiteralEnumField: FieldInfo -> bool, - ilg: ILGenerator, locals:Dictionary, parameterVars) = - - // TypeBuilderInstantiation should really be a public type, since we - // have to use alternative means for various Method/Field/Constructor lookups on this kind of type. - // Also, on Mono 3.x and 4.x this type had a different name. - let TypeBuilderInstantiationType = - let runningOnMono = try System.Type.GetType("Mono.Runtime") <> null with e-> false - let ty = - if runningOnMono then - let ty = Type.GetType("System.Reflection.MonoGenericClass") - match ty with - | null -> Type.GetType("System.Reflection.Emit.TypeBuilderInstantiation") - | _ -> ty - else - Type.GetType("System.Reflection.Emit.TypeBuilderInstantiation") - - ty - - // TODO: this works over FSharp.Core 4.4.0.0 types and methods. These types need to be retargeted to the target runtime. - - 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 rec emitLambda(callSiteIlg : ILGenerator, v : Quotations.Var, body : 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 lambdaLocals = 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) - lambdaLocals.[v] <- l - - let expectedState = if (invoke.ReturnType = typeof) then ExpectedStackState.Empty else ExpectedStackState.Value - let lambadParamVars = [| Quotations.Var("this", lambda); v|] - let codeGen = CodeGenerator(assemblyMainModule, uniqueLambdaTypeName, implicitCtorArgsAsFields, transType, transField, transMethod, transCtor, isLiteralEnumField, ilg, lambdaLocals, lambadParamVars) - codeGen.EmitExpr (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 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 - match expr with - | 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(transType loopVar.Type) - locals.Add(loopVar, lb) - lb - - // loopVar = first - emitExpr ExpectedStackState.Value first - ilg.Emit(OpCodes.Stloc, lb) - - let before = ilg.DefineLabel() - let after = ilg.DefineLabel() - - ilg.MarkLabel before - ilg.Emit(OpCodes.Ldloc, lb) - - emitExpr ExpectedStackState.Value last - ilg.Emit(OpCodes.Bgt, after) - - emitExpr 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) - - | NewArray(elementTy, elements) -> - ilg.Emit(OpCodes.Ldc_I4, List.length elements) - ilg.Emit(OpCodes.Newarr, transType elementTy) - - elements - |> List.iteri (fun i el -> - ilg.Emit(OpCodes.Dup) - ilg.Emit(OpCodes.Ldc_I4, i) - emitExpr ExpectedStackState.Value el - ilg.Emit(OpCodes.Stelem, transType elementTy)) - - popIfEmptyExpected expectedState - - | WhileLoop(cond, body) -> - let before = ilg.DefineLabel() - let after = ilg.DefineLabel() - - ilg.MarkLabel before - emitExpr ExpectedStackState.Value cond - ilg.Emit(OpCodes.Brfalse, after) - emitExpr ExpectedStackState.Empty body - ilg.Emit(OpCodes.Br, before) - - ilg.MarkLabel after - - | Var v -> - if isEmpty expectedState then () else - - // Try to interpret this as a method parameter - 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 -> - - // Try to interpret this as an implicit field in a class - 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 -> - - // Try to interpret this as a local - 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" - - | Coerce (arg,ty) -> - // castClass may lead to observable side-effects - InvalidCastException - emitExpr ExpectedStackState.Value arg - let argTy = transType arg.Type - let targetTy = transType 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 && (TypeBuilderInstantiationType.Equals(targetTy.GetType()) || not (targetTy.IsAssignableFrom(argTy))) then - ilg.Emit(OpCodes.Castclass, targetTy) - - popIfEmptyExpected expectedState - - | SpecificCall <@ (-) @>(None, [t1; t2; _], [a1; a2]) -> - assert(t1 = t2) - emitExpr ExpectedStackState.Value a1 - emitExpr ExpectedStackState.Value a2 - if t1 = typeof then - ilg.Emit(OpCodes.Call, typeof.GetMethod "op_Subtraction") - else - ilg.Emit(OpCodes.Sub) - emitConvIfNecessary t1 - - popIfEmptyExpected expectedState - - | SpecificCall <@ (/) @> (None, [t1; t2; _], [a1; a2]) -> - assert (t1 = t2) - emitExpr ExpectedStackState.Value a1 - emitExpr 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 - - | SpecificCall <@ int @>(None, [sourceTy], [v]) -> - emitExpr ExpectedStackState.Value v - match Type.GetTypeCode(sourceTy) with - | TypeCode.String -> - ilg.Emit(OpCodes.Call, 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" - - | SpecificCall <@ LanguagePrimitives.IntrinsicFunctions.GetArray @> (None, [ty], [arr; index]) -> - // observable side-effect - IndexOutOfRangeException - emitExpr ExpectedStackState.Value arr - emitExpr ExpectedStackState.Value index - if isAddress expectedState then - ilg.Emit(OpCodes.Readonly) - ilg.Emit(OpCodes.Ldelema, transType ty) - else - ilg.Emit(OpCodes.Ldelem, transType ty) - - popIfEmptyExpected expectedState - - | SpecificCall <@ LanguagePrimitives.IntrinsicFunctions.GetArray2D @> (None, _ty, arr::indices) - | SpecificCall <@ LanguagePrimitives.IntrinsicFunctions.GetArray3D @> (None, _ty, arr::indices) - | 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 - emitExpr ExpectedStackState.Value arr - for index in indices do - emitExpr ExpectedStackState.Value index - - if isAddress expectedState then - ilg.Emit(OpCodes.Readonly) - - ilg.Emit(OpCodes.Call, meth) - - popIfEmptyExpected expectedState - - - | FieldGet (None,field) when isLiteralEnumField field -> - if expectedState <> ExpectedStackState.Empty then - emitExpr expectedState (Expr.Value(field.GetRawConstantValue(), field.FieldType.GetEnumUnderlyingType())) - - | FieldGet (objOpt,field) -> - objOpt |> Option.iter (fun e -> - let s = if e.Type.IsValueType then ExpectedStackState.Address else ExpectedStackState.Value - emitExpr s e) - let field = transField field - if field.IsStatic then - ilg.Emit(OpCodes.Ldsfld, field) - else - ilg.Emit(OpCodes.Ldfld, field) - - | FieldSet (objOpt,field,v) -> - objOpt |> Option.iter (fun e -> - let s = if e.Type.IsValueType then ExpectedStackState.Address else ExpectedStackState.Value - emitExpr s e) - emitExpr ExpectedStackState.Value v - let field = transField field - if field.IsStatic then - ilg.Emit(OpCodes.Stsfld, field) - else - ilg.Emit(OpCodes.Stfld, field) - - | Call (objOpt,meth,args) -> - objOpt |> Option.iter (fun e -> - let s = if e.Type.IsValueType then ExpectedStackState.Address else ExpectedStackState.Value - emitExpr s e) - - for pe in args do - emitExpr ExpectedStackState.Value pe - - // 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 transType - let gmd = meth.GetGenericMethodDefinition() |> transMethod - gmd.GetGenericMethodDefinition().MakeGenericMethod args - elif meth.DeclaringType.IsGenericType then - let gdty = transType (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 transType meth.DeclaringType with - | :? TypeBuilder as dty -> TypeBuilder.GetMethod(dty, gdtym) - | dty -> MethodBase.GetMethodFromHandle(meth.MethodHandle, dty.TypeHandle) :?> _ - - assert (dtym <> null) - dtym - else - transMethod meth - match objOpt with - | Some obj when mappedMeth.IsAbstract || mappedMeth.IsVirtual -> - if obj.Type.IsValueType then ilg.Emit(OpCodes.Constrained, transType 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) - | _ -> () - - | NewObject (ctor,args) -> - for pe in args do - emitExpr ExpectedStackState.Value pe - let meth = transCtor ctor - ilg.Emit(OpCodes.Newobj, meth) - - popIfEmptyExpected expectedState - - | 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, transType ty) - ilg.Emit(OpCodes.Call, 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, DecimalConstructor()) - | :? DateTime as x -> - ilg.Emit(OpCodes.Ldc_I8, x.Ticks) - ilg.Emit(OpCodes.Ldc_I4, int x.Kind) - ilg.Emit(OpCodes.Newobj, DateTimeConstructor()) - | :? DateTimeOffset as x -> - ilg.Emit(OpCodes.Ldc_I8, x.Ticks) - ilg.Emit(OpCodes.Ldc_I8, x.Offset.Ticks) - ilg.Emit(OpCodes.Newobj, TimeSpanConstructor()) - ilg.Emit(OpCodes.Newobj, DateTimeOffsetConstructor()) - | null -> ilg.Emit(OpCodes.Ldnull) - | _ -> failwithf "unknown constant '%A' in generated method" v - if isEmpty expectedState then () - else emitC obj - - | Let(v,e,b) -> - let lb = ilg.DeclareLocal (transType v.Type) - locals.Add (v, lb) - emitExpr ExpectedStackState.Value e - ilg.Emit(OpCodes.Stloc, lb.LocalIndex) - emitExpr expectedState b - - | Sequential(e1, e2) -> - emitExpr ExpectedStackState.Empty e1 - emitExpr expectedState e2 - - | IfThenElse(cond, ifTrue, ifFalse) -> - let ifFalseLabel = ilg.DefineLabel() - let endLabel = ilg.DefineLabel() - - emitExpr ExpectedStackState.Value cond - - ilg.Emit(OpCodes.Brfalse, ifFalseLabel) - - emitExpr expectedState ifTrue - ilg.Emit(OpCodes.Br, endLabel) - - ilg.MarkLabel(ifFalseLabel) - emitExpr expectedState ifFalse - - ilg.Emit(OpCodes.Nop) - ilg.MarkLabel(endLabel) - - | TryWith(body, _filterVar, _filterBody, catchVar, catchBody) -> - - let stres, ldres = - if isEmpty expectedState then ignore, ignore - else - let local = ilg.DeclareLocal (transType body.Type) - let stres = fun () -> ilg.Emit(OpCodes.Stloc, local) - let ldres = fun () -> ilg.Emit(OpCodes.Ldloc, local) - stres, ldres - - let exceptionVar = ilg.DeclareLocal(transType catchVar.Type) - locals.Add(catchVar, exceptionVar) - - let _exnBlock = ilg.BeginExceptionBlock() - - emitExpr expectedState body - stres() - - ilg.BeginCatchBlock(transType catchVar.Type) - ilg.Emit(OpCodes.Stloc, exceptionVar) - emitExpr expectedState catchBody - stres() - ilg.EndExceptionBlock() - - ldres() - - | VarSet(v,e) -> - emitExpr 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" - | Lambda(v, body) -> - emitLambda(ilg, v, body, expr.GetFreeVars(), locals, parameterVars) - popIfEmptyExpected expectedState - | n -> - failwith (sprintf "unknown expression '%A' in generated method" n) - - member __.EmitExpr (expectedState, expr) = emitExpr expectedState expr - -#endif - -[] -module internal Misc = - - - 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 = 2) - member __.ConstructorArguments = upcast [|CustomAttributeTypedArgument(typeof, message) ; CustomAttributeTypedArgument(typeof, isError) |] - member __.NamedArguments = upcast [| |] } - - let mkReflectedDefinitionCustomAttributeData() = -#if FX_NO_CUSTOMATTRIBUTEDATA - { new IProvidedCustomAttributeData with -#else - { new CustomAttributeData() with -#endif - member __.Constructor = typeof.GetConstructors().[0] - member __.ConstructorArguments = upcast [| |] - 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 - let mutable hasReflectedDefinition = 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() - if hasReflectedDefinition then yield mkReflectedDefinitionCustomAttributeData() - yield! customAttributes |] - - member __.AddDefinitionLocation(line:int,column:int,filePath:string) = customAttributes.Add(mkDefinitionLocationAttributeCustomAttributeData(line, column, filePath)) - member __.AddObsolete(message : string, isError) = obsoleteMessage <- Some (message,isError) - member __.HasParamArray with get() = hasParamArray and set(v) = hasParamArray <- v - member __.HasReflectedDefinition with get() = hasReflectedDefinition and set(v) = hasReflectedDefinition <- v - member __.AddXmlDocComputed xmlDocFunction = xmlDocAlwaysRecomputed <- Some xmlDocFunction - member __.AddXmlDocDelayed xmlDocFunction = xmlDocDelayed <- Some xmlDocFunction - member __.AddXmlDoc xmlDoc = xmlDocDelayed <- Some (fun () -> xmlDoc) - 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() - // Recomputed XML doc is evaluated on every call to GetCustomAttributesData() - match xmlDocAlwaysRecomputed with None -> () | Some f -> yield mkXmlDocCustomAttributeData (f()) |] - :> IList<_> - - - 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 xmlDocFunction = customAttributesImpl.AddXmlDocDelayed xmlDocFunction - member __.AddXmlDocComputed xmlDocFunction = customAttributesImpl.AddXmlDocComputed xmlDocFunction - member __.AddXmlDoc xmlDoc = customAttributesImpl.AddXmlDoc xmlDoc - - 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 __.IsParamArray with get() = customAttributesImpl.HasParamArray and set(v) = customAttributesImpl.HasParamArray <- v - member __.IsReflectedDefinition with get() = customAttributesImpl.HasReflectedDefinition and set(v) = customAttributesImpl.HasReflectedDefinition <- v - override __.Name = name - override __.ParameterType = parameterType - override __.Attributes = (base.Attributes ||| (if isOut then ParameterAttributes.Out else enum 0) - ||| (match optionalValue with None -> enum 0 | Some _ -> ParameterAttributes.Optional ||| ParameterAttributes.HasDefault)) - override __.RawDefaultValue = defaultArg optionalValue null - member __.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 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 isStatic() = ctorAttributes.HasFlag(MethodAttributes.Static) - - let customAttributesImpl = CustomAttributesImpl() - member __.IsTypeInitializer - with get() = isStatic() && ctorAttributes.HasFlag(MethodAttributes.Private) - and set(v) = - let typeInitializerAttributes = MethodAttributes.Static ||| MethodAttributes.Private - ctorAttributes <- if v then ctorAttributes ||| typeInitializerAttributes else ctorAttributes &&& ~~~typeInitializerAttributes - - member __.AddXmlDocComputed xmlDocFunction = customAttributesImpl.AddXmlDocComputed xmlDocFunction - member __.AddXmlDocDelayed xmlDocFunction = customAttributesImpl.AddXmlDocDelayed xmlDocFunction - member __.AddXmlDoc xmlDoc = customAttributesImpl.AddXmlDoc xmlDoc - member __.AddObsoleteAttribute (message,?isError) = customAttributesImpl.AddObsolete (message,defaultArg isError false) - member __.AddDefinitionLocation(line,column,filePath) = customAttributesImpl.AddDefinitionLocation(line, column, filePath) - member __.GetCustomAttributesDataImpl() = customAttributesImpl.GetCustomAttributesData() -#if FX_NO_CUSTOMATTRIBUTEDATA -#else - override __.GetCustomAttributesData() = customAttributesImpl.GetCustomAttributesData() -#endif - - member __.DeclaringTypeImpl - with set x = - if declaringType<>null then failwith (sprintf "ProvidedConstructor: declaringType already set on '%s'" (nameText())); - declaringType <- x - - member __.InvokeCode - with set (q:Expr list -> Expr) = - match invokeCode with - | None -> invokeCode <- Some q - | Some _ -> failwith (sprintf "ProvidedConstructor: code already given for '%s'" (nameText())) - - member __.BaseConstructorCall - with set (d:Expr list -> (ConstructorInfo * Expr list)) = - match baseCall with - | None -> baseCall <- Some d - | Some _ -> failwith (sprintf "ProvidedConstructor: base call already given for '%s'" (nameText())) - - member __.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 || isStatic() then [] else ["this"]) - |> Array.ofList - QuotationSimplifier(isGenerated).TranslateQuotationToCode f paramNames - | None -> failwith (sprintf "ProvidedConstructor: no invoker for '%s'" (nameText())) - - member __.GetBaseConstructorCallInternal isGenerated = - match baseCall with - | Some f -> Some(fun ctorArgs -> let c,baseCtorArgExprs = f ctorArgs in c, List.map (QuotationSimplifier(isGenerated).TranslateExpression) baseCtorArgExprs) - | None -> None - - member __.IsImplicitCtor with get() = isImplicitCtor and set v = isImplicitCtor <- v - - // Implement overloads - override __.GetParameters() = parameters |> List.toArray - override __.Attributes = ctorAttributes - override __.Name = if isStatic() then ".cctor" else ".ctor" - override __.DeclaringType = declaringType |> nonNull "ProvidedConstructor.DeclaringType" - override __.IsDefined(_attributeType, _inherit) = true - - override __.Invoke(_invokeAttr, _binder, _parameters, _culture) = notRequired "Invoke" (nameText()) - override __.Invoke(_obj, _invokeAttr, _binder, _parameters, _culture) = notRequired "Invoke" (nameText()) - override __.ReflectedType = notRequired "ReflectedType" (nameText()) - override __.GetMethodImplementationFlags() = notRequired "GetMethodImplementationFlags" (nameText()) - override __.MethodHandle = notRequired "MethodHandle" (nameText()) - override __.GetCustomAttributes(_inherit) = notRequired "GetCustomAttributes" (nameText()) - override __.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 Expr> - let mutable staticParams = [ ] - let mutable staticParamsApply = None - let isStatic() = methodAttrs.HasFlag(MethodAttributes.Static) - let customAttributesImpl = CustomAttributesImpl() - - member __.AddXmlDocComputed xmlDocFunction = customAttributesImpl.AddXmlDocComputed xmlDocFunction - member __.AddXmlDocDelayed xmlDocFunction = customAttributesImpl.AddXmlDocDelayed xmlDocFunction - member __.AddXmlDoc xmlDoc = customAttributesImpl.AddXmlDoc xmlDoc - member __.AddObsoleteAttribute (message,?isError) = customAttributesImpl.AddObsolete (message,defaultArg isError false) - member __.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 __.GetCustomAttributesData() = customAttributesImpl.GetCustomAttributesData() -#endif - - member __.SetMethodAttrs m = methodAttrs <- m - member __.AddMethodAttrs m = methodAttrs <- methodAttrs ||| m - member __.DeclaringTypeImpl with set x = declaringType <- x // check: not set twice - member __.IsStaticMethod - with get() = isStatic() - and set x = if x then methodAttrs <- methodAttrs ||| MethodAttributes.Static - else methodAttrs <- methodAttrs &&& (~~~ MethodAttributes.Static) - - member __.InvokeCode - with set (q:Expr list -> Expr) = - match invokeCode with - | None -> invokeCode <- Some q - | Some _ -> failwith (sprintf "ProvidedConstructor: code already given for %s on type %s" methodName (if declaringType=null then "" else declaringType.FullName)) - - - /// Abstract a type to a parametric-type. Requires "formal parameters" and "instantiation function". - member __.DefineStaticParameters(staticParameters : list, apply : (string -> obj[] -> ProvidedMethod)) = - staticParams <- staticParameters - staticParamsApply <- Some apply - - /// Get ParameterInfo[] for the parametric type parameters (//s GetGenericParameters) - member __.GetStaticParameters() = [| for p in staticParams -> p :> ParameterInfo |] - - /// Instantiate parametrics type - member __.ApplyStaticArguments(mangledName: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 method %s" staticParams.Length args.Length methodName) - match staticParamsApply with - | None -> failwith "ProvidedTypeDefinition: DefineStaticParameters was not called" - | Some f -> f mangledName args - else - failwith (sprintf "ProvidedTypeDefinition: static parameters supplied but not expected for method %s" methodName) - - member __.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 isStatic() then [] else ["this"]) - |> Array.ofList - QuotationSimplifier(isGenerated).TranslateQuotationToCode f paramNames - | None -> failwith (sprintf "ProvidedMethod: no invoker for %s on type %s" methodName (if declaringType=null then "" else declaringType.FullName)) - - // Implement overloads - override __.GetParameters() = argParams |> Array.ofList - override __.Attributes = methodAttrs - override __.Name = methodName - override __.DeclaringType = declaringType |> nonNull "ProvidedMethod.DeclaringType" - override __.IsDefined(_attributeType, _inherit) : bool = true - override __.MemberType = MemberTypes.Method - override __.CallingConvention = - let cc = CallingConventions.Standard - let cc = if not (isStatic()) then cc ||| CallingConventions.HasThis else cc - cc - override __.ReturnType = returnType - override __.ReturnParameter = null // REVIEW: Give it a name and type? - override __.ToString() = "Method " + methodName - - // 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 __.MetadataToken = hash declaringType + hash methodName - override __.MethodHandle = RuntimeMethodHandle() - - override __.ReturnTypeCustomAttributes = notRequired "ReturnTypeCustomAttributes" methodName - override __.GetBaseDefinition() = notRequired "GetBaseDefinition" methodName - override __.GetMethodImplementationFlags() = notRequired "GetMethodImplementationFlags" methodName - override __.Invoke(_obj, _invokeAttr, _binder, _parameters, _culture) = notRequired "Invoke" methodName - override __.ReflectedType = notRequired "ReflectedType" methodName - override __.GetCustomAttributes(_inherit) = notRequired "GetCustomAttributes" methodName - override __.GetCustomAttributes(_attributeType, _inherit) = notRequired "GetCustomAttributes" methodName - - -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 Expr> - let mutable setterCode = None : option 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 __.AddXmlDocComputed xmlDocFunction = customAttributesImpl.AddXmlDocComputed xmlDocFunction - member __.AddXmlDocDelayed xmlDocFunction = customAttributesImpl.AddXmlDocDelayed xmlDocFunction - member __.AddXmlDoc xmlDoc = customAttributesImpl.AddXmlDoc xmlDoc - member __.AddObsoleteAttribute (message,?isError) = customAttributesImpl.AddObsolete (message,defaultArg isError false) - member __.AddDefinitionLocation(line,column,filePath) = customAttributesImpl.AddDefinitionLocation(line, column, filePath) - member __.GetCustomAttributesDataImpl() = customAttributesImpl.GetCustomAttributesData() - member __.AddCustomAttribute attribute = customAttributesImpl.AddCustomAttribute attribute -#if FX_NO_CUSTOMATTRIBUTEDATA -#else - override __.GetCustomAttributesData() = customAttributesImpl.GetCustomAttributesData() -#endif - - member __.DeclaringTypeImpl with set x = declaringType <- x // check: not set twice - - member __.IsStatic - with get() = isStatic - and set x = isStatic <- x - - member __.GetterCode - with set (q:Expr list -> Expr) = - if not getter.IsValueCreated then getterCode <- Some q else failwith "ProvidedProperty: getter MethodInfo has already been created" - - member __.SetterCode - with set (q:Expr list -> Expr) = - if not (setter.IsValueCreated) then setterCode <- Some q else failwith "ProvidedProperty: setter MethodInfo has already been created" - - // Implement overloads - override __.PropertyType = propertyType - override __.SetValue(_obj, _value, _invokeAttr, _binder, _index, _culture) = notRequired "SetValue" propertyName - override __.GetAccessors _nonPublic = notRequired "nonPublic" propertyName - override __.GetGetMethod _nonPublic = if hasGetter() then getter.Force() :> MethodInfo else null - override __.GetSetMethod _nonPublic = if hasSetter() then setter.Force() :> MethodInfo else null - override __.GetIndexParameters() = [| for p in parameters -> upcast p |] - override __.Attributes = PropertyAttributes.None - override __.CanRead = hasGetter() - override __.CanWrite = hasSetter() - override __.GetValue(_obj, _invokeAttr, _binder, _index, _culture) : obj = notRequired "GetValue" propertyName - override __.Name = propertyName - override __.DeclaringType = declaringType |> nonNull "ProvidedProperty.DeclaringType" - override __.MemberType : MemberTypes = MemberTypes.Property - - override __.ReflectedType = notRequired "ReflectedType" propertyName - override __.GetCustomAttributes(_inherit) = notRequired "GetCustomAttributes" propertyName - override __.GetCustomAttributes(_attributeType, _inherit) = notRequired "GetCustomAttributes" propertyName - override __.IsDefined(_attributeType, _inherit) = notRequired "IsDefined" propertyName - -type ProvidedEvent(eventName:string,eventHandlerType:Type) = - inherit System.Reflection.EventInfo() - // State - - let mutable declaringType = null - let mutable isStatic = false - let mutable adderCode = None : option Expr> - let mutable removerCode = None : option 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 __.AddXmlDocComputed xmlDocFunction = customAttributesImpl.AddXmlDocComputed xmlDocFunction - member __.AddXmlDocDelayed xmlDocFunction = customAttributesImpl.AddXmlDocDelayed xmlDocFunction - member __.AddXmlDoc xmlDoc = customAttributesImpl.AddXmlDoc xmlDoc - member __.AddDefinitionLocation(line,column,filePath) = customAttributesImpl.AddDefinitionLocation(line, column, filePath) - member __.GetCustomAttributesDataImpl() = customAttributesImpl.GetCustomAttributesData() -#if FX_NO_CUSTOMATTRIBUTEDATA -#else - override __.GetCustomAttributesData() = customAttributesImpl.GetCustomAttributesData() -#endif - - member __.DeclaringTypeImpl with set x = declaringType <- x // check: not set twice - member __.IsStatic - with get() = isStatic - and set x = isStatic <- x - - member __.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 __.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 __.EventHandlerType = eventHandlerType - override __.GetAddMethod _nonPublic = adder.Force() :> MethodInfo - override __.GetRemoveMethod _nonPublic = remover.Force() :> MethodInfo - override __.Attributes = EventAttributes.None - override __.Name = eventName - override __.DeclaringType = declaringType |> nonNull "ProvidedEvent.DeclaringType" - override __.MemberType : MemberTypes = MemberTypes.Event - - override __.GetRaiseMethod _nonPublic = notRequired "GetRaiseMethod" eventName - override __.ReflectedType = notRequired "ReflectedType" eventName - override __.GetCustomAttributes(_inherit) = notRequired "GetCustomAttributes" eventName - override __.GetCustomAttributes(_attributeType, _inherit) = notRequired "GetCustomAttributes" eventName - override __.IsDefined(_attributeType, _inherit) = notRequired "IsDefined" eventName - -type ProvidedLiteralField(fieldName:string,fieldType:Type,literalValue:obj) = - inherit System.Reflection.FieldInfo() - // State - - let mutable declaringType = null - - let customAttributesImpl = CustomAttributesImpl() - member __.AddXmlDocComputed xmlDocFunction = customAttributesImpl.AddXmlDocComputed xmlDocFunction - member __.AddXmlDocDelayed xmlDocFunction = customAttributesImpl.AddXmlDocDelayed xmlDocFunction - member __.AddXmlDoc xmlDoc = customAttributesImpl.AddXmlDoc xmlDoc - member __.AddObsoleteAttribute (message,?isError) = customAttributesImpl.AddObsolete (message,defaultArg isError false) - member __.AddDefinitionLocation(line,column,filePath) = customAttributesImpl.AddDefinitionLocation(line, column, filePath) - member __.GetCustomAttributesDataImpl() = customAttributesImpl.GetCustomAttributesData() -#if FX_NO_CUSTOMATTRIBUTEDATA -#else - override __.GetCustomAttributesData() = customAttributesImpl.GetCustomAttributesData() -#endif - - member __.DeclaringTypeImpl with set x = declaringType <- x // check: not set twice - - - // Implement overloads - override __.FieldType = fieldType - override __.GetRawConstantValue() = literalValue - override __.Attributes = FieldAttributes.Static ||| FieldAttributes.Literal ||| FieldAttributes.Public - override __.Name = fieldName - override __.DeclaringType = declaringType |> nonNull "ProvidedLiteralField.DeclaringType" - override __.MemberType : MemberTypes = MemberTypes.Field - - override __.ReflectedType = notRequired "ReflectedType" fieldName - override __.GetCustomAttributes(_inherit) = notRequired "GetCustomAttributes" fieldName - override __.GetCustomAttributes(_attributeType, _inherit) = notRequired "GetCustomAttributes" fieldName - override __.IsDefined(_attributeType, _inherit) = notRequired "IsDefined" fieldName - - override __.SetValue(_obj, _value, _invokeAttr, _binder, _culture) = notRequired "SetValue" fieldName - override __.GetValue(_obj) : obj = notRequired "GetValue" fieldName - override __.FieldHandle = notRequired "FieldHandle" fieldName - -type ProvidedField(fieldName:string,fieldType:Type) = - inherit System.Reflection.FieldInfo() - // State - - let mutable declaringType = null - - let customAttributesImpl = CustomAttributesImpl() - let mutable fieldAttrs = FieldAttributes.Private - member __.AddXmlDocComputed xmlDocFunction = customAttributesImpl.AddXmlDocComputed xmlDocFunction - member __.AddXmlDocDelayed xmlDocFunction = customAttributesImpl.AddXmlDocDelayed xmlDocFunction - member __.AddXmlDoc xmlDoc = customAttributesImpl.AddXmlDoc xmlDoc - member __.AddObsoleteAttribute (message,?isError) = customAttributesImpl.AddObsolete (message,defaultArg isError false) - member __.AddDefinitionLocation(line,column,filePath) = customAttributesImpl.AddDefinitionLocation(line, column, filePath) - member __.GetCustomAttributesDataImpl() = customAttributesImpl.GetCustomAttributesData() -#if FX_NO_CUSTOMATTRIBUTEDATA -#else - override __.GetCustomAttributesData() = customAttributesImpl.GetCustomAttributesData() -#endif - - member __.DeclaringTypeImpl with set x = declaringType <- x // check: not set twice - - member __.SetFieldAttributes attrs = fieldAttrs <- attrs - // Implement overloads - override __.FieldType = fieldType - override __.GetRawConstantValue() = null - override __.Attributes = fieldAttrs - override __.Name = fieldName - override __.DeclaringType = declaringType |> nonNull "ProvidedField.DeclaringType" - override __.MemberType : MemberTypes = MemberTypes.Field - - override __.ReflectedType = notRequired "ReflectedType" fieldName - override __.GetCustomAttributes(_inherit) = notRequired "GetCustomAttributes" fieldName - override __.GetCustomAttributes(_attributeType, _inherit) = notRequired "GetCustomAttributes" fieldName - override __.IsDefined(_attributeType, _inherit) = notRequired "IsDefined" fieldName - - override __.SetValue(_obj, _value, _invokeAttr, _binder, _culture) = notRequired "SetValue" fieldName - override __.GetValue(_obj) : obj = notRequired "GetValue" fieldName - override __.FieldHandle = notRequired "FieldHandle" fieldName - -/// Represents the type constructor in a provided symbol type. -[] -type ProvidedSymbolKind = - | 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: ProvidedSymbolKind, args: Type list, convToTgt: Type -> Type) = - 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 - | ProvidedSymbolKind.SDArray, [ty] | ProvidedSymbolKind.Array _, [ty] when otherTy.IsArray-> ty.Equals(otherTy.GetElementType()) - | ProvidedSymbolKind.ByRef, [ty] when otherTy.IsByRef -> ty.Equals(otherTy.GetElementType()) - | ProvidedSymbolKind.Pointer, [ty] when otherTy.IsPointer -> ty.Equals(otherTy.GetElementType()) - | ProvidedSymbolKind.Generic baseTy, args -> otherTy.IsGenericType && isEquivalentTo baseTy (otherTy.GetGenericTypeDefinition()) && Seq.forall2 isEquivalentTo args (otherTy.GetGenericArguments()) - | _ -> false - | a, b -> a.Equals b - - let nameText() = - match kind,args with - | ProvidedSymbolKind.SDArray,[arg] -> arg.Name + "[]" - | ProvidedSymbolKind.Array _,[arg] -> arg.Name + "[*]" - | ProvidedSymbolKind.Pointer,[arg] -> arg.Name + "*" - | ProvidedSymbolKind.ByRef,[arg] -> arg.Name + "&" - | ProvidedSymbolKind.Generic gty, args -> gty.Name + (sprintf "%A" args) - | ProvidedSymbolKind.FSharpTypeAbbreviation (_,_,path),_ -> path.[path.Length-1] - | _ -> failwith "unreachable" - - /// Substitute types for type variables. - 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()) - ty.GetGenericTypeDefinition().MakeGenericType(args) - elif ty.HasElementType then - let ety = ProvidedSymbolType.convType parameters (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 - elif ty.IsGenericParameter then - if ty.GenericParameterPosition <= parameters.Length - 1 then - parameters.[ty.GenericParameterPosition] - else - ty - else ty - - override __.FullName = - match kind,args with - | ProvidedSymbolKind.SDArray,[arg] -> arg.FullName + "[]" - | ProvidedSymbolKind.Array _,[arg] -> arg.FullName + "[*]" - | ProvidedSymbolKind.Pointer,[arg] -> arg.FullName + "*" - | ProvidedSymbolKind.ByRef,[arg] -> arg.FullName + "&" - | ProvidedSymbolKind.Generic gty, args -> gty.FullName + "[" + (args |> List.map (fun arg -> arg.ToString()) |> String.concat ",") + "]" - | ProvidedSymbolKind.FSharpTypeAbbreviation (_,nsp,path),args -> String.concat "." (Array.append [| nsp |] path) + (match args with [] -> "" | _ -> 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 __.DeclaringType = - match kind,args with - | ProvidedSymbolKind.SDArray,[arg] -> arg - | ProvidedSymbolKind.Array _,[arg] -> arg - | ProvidedSymbolKind.Pointer,[arg] -> arg - | ProvidedSymbolKind.ByRef,[arg] -> arg - | ProvidedSymbolKind.Generic gty,_ -> gty - | ProvidedSymbolKind.FSharpTypeAbbreviation _,_ -> null - | _ -> failwith "unreachable" - - override __.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 __.Name = nameText() - - override __.BaseType = - match kind with - | ProvidedSymbolKind.SDArray -> convToTgt typeof - | ProvidedSymbolKind.Array _ -> convToTgt typeof - | ProvidedSymbolKind.Pointer -> convToTgt typeof - | ProvidedSymbolKind.ByRef -> convToTgt typeof - | ProvidedSymbolKind.Generic gty -> - if gty.BaseType = null then null else - ProvidedSymbolType.convType args gty.BaseType - | ProvidedSymbolKind.FSharpTypeAbbreviation _ -> convToTgt typeof - - override __.GetArrayRank() = (match kind with ProvidedSymbolKind.Array n -> n | ProvidedSymbolKind.SDArray -> 1 | _ -> invalidOp "non-array type") - override __.IsValueTypeImpl() = (match kind with ProvidedSymbolKind.Generic gtd -> gtd.IsValueType | _ -> false) - override __.IsArrayImpl() = (match kind with ProvidedSymbolKind.Array _ | ProvidedSymbolKind.SDArray -> true | _ -> false) - override __.IsByRefImpl() = (match kind with ProvidedSymbolKind.ByRef _ -> true | _ -> false) - override __.IsPointerImpl() = (match kind with ProvidedSymbolKind.Pointer _ -> true | _ -> false) - override __.IsPrimitiveImpl() = false - override __.IsGenericType = (match kind with ProvidedSymbolKind.Generic _ -> true | _ -> false) - override __.GetGenericArguments() = (match kind with ProvidedSymbolKind.Generic _ -> args |> List.toArray | _ -> invalidOp "non-generic type") - override __.GetGenericTypeDefinition() = (match kind with ProvidedSymbolKind.Generic e -> e | _ -> invalidOp "non-generic type") - override __.IsCOMObjectImpl() = false - override __.HasElementTypeImpl() = (match kind with ProvidedSymbolKind.Generic _ -> false | _ -> true) - override __.GetElementType() = (match kind,args with (ProvidedSymbolKind.Array _ | ProvidedSymbolKind.SDArray | ProvidedSymbolKind.ByRef | ProvidedSymbolKind.Pointer),[e] -> e | _ -> invalidOp "not an array, pointer or byref type") - override this.ToString() = this.FullName - - override __.Assembly = - match kind with - | ProvidedSymbolKind.FSharpTypeAbbreviation (assembly,_nsp,_path) -> assembly - | ProvidedSymbolKind.Generic gty -> gty.Assembly - | _ -> notRequired "Assembly" (nameText()) - - override __.Namespace = - match kind with - | ProvidedSymbolKind.FSharpTypeAbbreviation (_assembly,nsp,_path) -> nsp - | _ -> notRequired "Namespace" (nameText()) - - override __.GetHashCode() = - match kind,args with - | ProvidedSymbolKind.SDArray,[arg] -> 10 + hash arg - | ProvidedSymbolKind.Array _,[arg] -> 163 + hash arg - | ProvidedSymbolKind.Pointer,[arg] -> 283 + hash arg - | ProvidedSymbolKind.ByRef,[arg] -> 43904 + hash arg - | ProvidedSymbolKind.Generic gty,_ -> 9797 + hash gty + List.sumBy hash args - | ProvidedSymbolKind.FSharpTypeAbbreviation _,_ -> 3092 - | _ -> failwith "unreachable" - - override __.Equals(other: obj) = - match other with - | :? ProvidedSymbolType as otherTy -> (kind, args) = (otherTy.Kind, otherTy.Args) - | _ -> false - - member __.Kind = kind - member __.Args = args - - member __.IsFSharpTypeAbbreviation = match kind with FSharpTypeAbbreviation _ -> true | _ -> false - // For example, int - member __.IsFSharpUnitAnnotated = match kind with ProvidedSymbolKind.Generic gtd -> not gtd.IsGenericTypeDefinition | _ -> false - - override __.Module : Module = notRequired "Module" (nameText()) - override __.GetConstructors _bindingAttr = notRequired "GetConstructors" (nameText()) - override __.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" (nameText()) - override __.GetMembers _bindingAttr = notRequired "GetMembers" (nameText()) - override __.GetMethods _bindingAttr = notRequired "GetMethods" (nameText()) - override __.GetField(_name, _bindingAttr) = notRequired "GetField" (nameText()) - override __.GetFields _bindingAttr = notRequired "GetFields" (nameText()) - override __.GetInterface(_name, _ignoreCase) = notRequired "GetInterface" (nameText()) - override __.GetInterfaces() = notRequired "GetInterfaces" (nameText()) - override __.GetEvent(_name, _bindingAttr) = notRequired "GetEvent" (nameText()) - override __.GetEvents _bindingAttr = notRequired "GetEvents" (nameText()) - override __.GetProperties _bindingAttr = notRequired "GetProperties" (nameText()) - override __.GetPropertyImpl(_name, _bindingAttr, _binder, _returnType, _types, _modifiers) = notRequired "GetPropertyImpl" (nameText()) - override __.GetNestedTypes _bindingAttr = notRequired "GetNestedTypes" (nameText()) - override __.GetNestedType(_name, _bindingAttr) = notRequired "GetNestedType" (nameText()) - override __.GetAttributeFlagsImpl() = notRequired "GetAttributeFlagsImpl" (nameText()) - override this.UnderlyingSystemType = - match kind with - | ProvidedSymbolKind.SDArray - | ProvidedSymbolKind.Array _ - | ProvidedSymbolKind.Pointer - | ProvidedSymbolKind.FSharpTypeAbbreviation _ - | ProvidedSymbolKind.ByRef -> upcast this - | ProvidedSymbolKind.Generic gty -> gty.UnderlyingSystemType -#if FX_NO_CUSTOMATTRIBUTEDATA -#else - override __.GetCustomAttributesData() = ([| |] :> IList<_>) -#endif - override __.MemberType = notRequired "MemberType" (nameText()) - override __.GetMember(_name,_mt,_bindingAttr) = notRequired "GetMember" (nameText()) - override __.GUID = notRequired "GUID" (nameText()) - override __.InvokeMember(_name, _invokeAttr, _binder, _target, _args, _modifiers, _culture, _namedParameters) = notRequired "InvokeMember" (nameText()) - override __.AssemblyQualifiedName = notRequired "AssemblyQualifiedName" (nameText()) - override __.GetConstructorImpl(_bindingAttr, _binder, _callConvention, _types, _modifiers) = notRequired "GetConstructorImpl" (nameText()) - override __.GetCustomAttributes(_inherit) = [| |] - override __.GetCustomAttributes(_attributeType, _inherit) = [| |] - override __.IsDefined(_attributeType, _inherit) = false - // FSharp.Data addition: this was added to support arrays of arrays - override this.MakeArrayType() = ProvidedSymbolType(ProvidedSymbolKind.SDArray, [this], convToTgt) :> Type - override this.MakeArrayType arg = ProvidedSymbolType(ProvidedSymbolKind.Array arg, [this], convToTgt) :> Type - -type ProvidedSymbolMethod(genericMethodDefinition: MethodInfo, parameters: Type list) = - inherit System.Reflection.MethodInfo() - - let convParam (p:ParameterInfo) = - { new System.Reflection.ParameterInfo() with - override __.Name = p.Name - override __.ParameterType = ProvidedSymbolType.convType parameters p.ParameterType - override __.Attributes = p.Attributes - override __.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 __.GetGenericMethodDefinition() = genericMethodDefinition - - override __.DeclaringType = ProvidedSymbolType.convType parameters genericMethodDefinition.DeclaringType - override __.ToString() = "Method " + genericMethodDefinition.Name - override __.Name = genericMethodDefinition.Name - override __.MetadataToken = genericMethodDefinition.MetadataToken - override __.Attributes = genericMethodDefinition.Attributes - override __.CallingConvention = genericMethodDefinition.CallingConvention - override __.MemberType = genericMethodDefinition.MemberType - - override __.IsDefined(_attributeType, _inherit) : bool = notRequired "IsDefined" genericMethodDefinition.Name - override __.ReturnType = ProvidedSymbolType.convType parameters genericMethodDefinition.ReturnType - override __.GetParameters() = genericMethodDefinition.GetParameters() |> Array.map convParam - override __.ReturnParameter = genericMethodDefinition.ReturnParameter |> convParam - override __.ReturnTypeCustomAttributes = notRequired "ReturnTypeCustomAttributes" genericMethodDefinition.Name - override __.GetBaseDefinition() = notRequired "GetBaseDefinition" genericMethodDefinition.Name - override __.GetMethodImplementationFlags() = notRequired "GetMethodImplementationFlags" genericMethodDefinition.Name - override __.MethodHandle = notRequired "MethodHandle" genericMethodDefinition.Name - override __.Invoke(_obj, _invokeAttr, _binder, _parameters, _culture) = notRequired "Invoke" genericMethodDefinition.Name - override __.ReflectedType = notRequired "ReflectedType" genericMethodDefinition.Name - override __.GetCustomAttributes(_inherit) = notRequired "GetCustomAttributes" genericMethodDefinition.Name - override __.GetCustomAttributes(_attributeType, _inherit) = notRequired "GetCustomAttributes" genericMethodDefinition.Name - - - -type ProvidedTypeBuilder() = - static member MakeGenericType(genericTypeDefinition, genericArguments) = ProvidedSymbolType(Generic genericTypeDefinition, genericArguments, id) :> Type - static member MakeGenericMethod(genericMethodDefinition, genericArguments) = ProvidedSymbolMethod(genericMethodDefinition, genericArguments) :> MethodInfo - -type ZProvidedTypeBuilder(convToTgt: Type -> Type) = - member __.MakeGenericType(genericTypeDefinition, genericArguments) = ProvidedSymbolType(Generic genericTypeDefinition, genericArguments, convToTgt) :> Type - member __.MakeGenericMethod(genericMethodDefinition, genericArguments) = ProvidedSymbolMethod(genericMethodDefinition, genericArguments) :> MethodInfo - -[] -type ProvidedMeasureBuilder() = - - // TODO: this shouldn't be hardcoded, but without creating a dependency on FSharp.Compiler.Service - // 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 __.One = typeof - member __.Product (m1,m2) = typedefof>.MakeGenericType [| m1;m2 |] - member __.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 __.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(ProvidedSymbolKind.FSharpTypeAbbreviation(typeof.Assembly,ns,[| unitName |]), [], id) :> Type - | None -> - typedefof>.Assembly.GetType("Microsoft.FSharp.Data.UnitSystems.SI.UnitNames." + mLowerCase) - - member __.AnnotateType (basicType, annotation) = ProvidedSymbolType(Generic basicType, annotation, id) :> Type - - - -[] -type TypeContainer = - | Namespace of Assembly * string // namespace - | Type of System.Type - | TypeToBeDecided - -#if NO_GENERATIVE -#else -module GlobalProvidedAssemblyElementsTable = - let theTable = Dictionary>() -#endif - -type ProvidedTypeDefinition(container:TypeContainer, className : string, baseType : Type option, convToTgt) 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 = None - 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" className) - - 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" className) - - 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" className) - - 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" className) - - 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 __.AddXmlDocComputed xmlDocFunction = customAttributesImpl.AddXmlDocComputed xmlDocFunction - member __.AddXmlDocDelayed xmlDocFunction = customAttributesImpl.AddXmlDocDelayed xmlDocFunction - member __.AddXmlDoc xmlDoc = customAttributesImpl.AddXmlDoc xmlDoc - member __.AddObsoleteAttribute (message,?isError) = customAttributesImpl.AddObsolete (message,defaultArg isError false) - member __.AddDefinitionLocation(line,column,filePath) = customAttributesImpl.AddDefinitionLocation(line, column, filePath) - member __.HideObjectMethods with set v = customAttributesImpl.HideObjectMethods <- v - member __.NonNullable with set v = customAttributesImpl.NonNullable <- v - member __.GetCustomAttributesDataImpl() = customAttributesImpl.GetCustomAttributesData() - member __.AddCustomAttribute attribute = customAttributesImpl.AddCustomAttribute attribute -#if FX_NO_CUSTOMATTRIBUTEDATA -#else - override __.GetCustomAttributesData() = customAttributesImpl.GetCustomAttributesData() -#endif - - member __.ResetEnclosingType (ty) = - container <- TypeContainer.Type ty - new (assembly:Assembly,namespaceName,className,baseType) = new ProvidedTypeDefinition(TypeContainer.Namespace (assembly,namespaceName), className, baseType, id) - new (className:string,baseType) = new ProvidedTypeDefinition(TypeContainer.TypeToBeDecided, className, baseType, id) - - new (assembly:Assembly,namespaceName,className,baseType,convToTgt) = new ProvidedTypeDefinition(TypeContainer.Namespace (assembly,namespaceName), className, baseType, convToTgt) - new (className,baseType, convToTgt) = new ProvidedTypeDefinition(TypeContainer.TypeToBeDecided, className, baseType, convToTgt) - // state ops - - override __.UnderlyingSystemType = typeof - - member __.SetEnumUnderlyingType(ty) = enumUnderlyingType <- Some ty - - override __.GetEnumUnderlyingType() = - if this.IsEnum then - match enumUnderlyingType with - | None -> convToTgt typeof - | Some ty -> ty - else invalidOp "not enum type" - - member __.SetBaseType t = baseType <- lazy Some t - - member __.SetBaseTypeDelayed baseTypeFunction = baseType <- lazy (Some (baseTypeFunction())) - - member __.SetAttributes x = attributes <- x - - // Add MemberInfos - member __.AddMembersDelayed(membersFunction : unit -> list<#MemberInfo>) = - membersQueue.Add (fun () -> membersFunction() |> List.map (fun x -> patchUpAddedMemberInfo this x; x :> MemberInfo )) - - member __.AddMembers(memberInfos:list<#MemberInfo>) = (* strict *) - memberInfos |> List.iter (patchUpAddedMemberInfo this) // strict: patch up now - membersQueue.Add (fun () -> memberInfos |> List.map (fun x -> x :> MemberInfo)) - - member __.AddMember(memberInfo:MemberInfo) = - this.AddMembers [memberInfo] - - member __.AddMemberDelayed(memberFunction : unit -> #MemberInfo) = - this.AddMembersDelayed(fun () -> [memberFunction()]) - -#if NO_GENERATIVE -#else - member __.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) -#endif - - /// Abstract a type to a parametric-type. Requires "formal parameters" and "instantiation function". - member __.DefineStaticParameters(staticParameters : list, apply : (string -> obj[] -> ProvidedTypeDefinition)) = - staticParams <- staticParameters - staticParamsApply <- Some apply - - /// Get ParameterInfo[] for the parametric type parameters (//s GetGenericParameters) - member __.GetStaticParameters() = [| for p in staticParams -> p :> ParameterInfo |] - - /// Instantiate parametrics type - member __.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 __.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 __.Assembly = theAssembly.Force() - - member __.SetAssembly assembly = theAssembly <- lazy assembly - - member __.SetAssemblyLazy assembly = theAssembly <- assembly - - override __.FullName = fullName.Force() - - override __.Namespace = rootNamespace.Force() - - override __.BaseType = match baseType.Value with Some ty -> ty | None -> null - - // Constructors - override __.GetConstructors bindingAttr = - [| for m in this.GetMembers bindingAttr do - if m.MemberType = MemberTypes.Constructor then - yield (m :?> ConstructorInfo) |] - // Methods - override __.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 __.GetMethods bindingAttr = - this.GetMembers bindingAttr - |> Array.filter (fun m -> m.MemberType.HasFlag(MemberTypes.Method)) - |> Array.map (fun m -> m :?> MethodInfo) - - // Fields - override __.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 __.GetFields bindingAttr = - [| for m in this.GetMembers bindingAttr do if m.MemberType.HasFlag(MemberTypes.Field) then yield m :?> FieldInfo |] - - override __.GetInterface(_name, _ignoreCase) = notRequired "GetInterface" this.Name - - override __.GetInterfaces() = - [| yield! getInterfaces() |] - - member __.GetInterfaceImplementations() = - [| yield! getInterfaces() |] - - member __.AddInterfaceImplementation ityp = interfaceImpls.Add ityp - - member __.AddInterfaceImplementationsDelayed itypf = interfaceImplsDelayed.Add itypf - - member __.GetMethodOverrides() = - [| yield! methodOverrides |] - - member __.DefineMethodOverride (bodyMethInfo,declMethInfo) = methodOverrides.Add (bodyMethInfo, declMethInfo) - - // Events - override __.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 __.GetEvents bindingAttr = - [| for m in this.GetMembers bindingAttr do if m.MemberType.HasFlag(MemberTypes.Event) then yield downcast m |] - - // Properties - override __.GetProperties bindingAttr = - [| for m in this.GetMembers bindingAttr do if m.MemberType.HasFlag(MemberTypes.Property) then yield downcast m |] - - override __.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 __.MakeArrayType() = ProvidedSymbolType(ProvidedSymbolKind.SDArray, [this], convToTgt) :> Type - override __.MakeArrayType arg = ProvidedSymbolType(ProvidedSymbolKind.Array arg, [this], convToTgt) :> Type - override __.MakePointerType() = ProvidedSymbolType(ProvidedSymbolKind.Pointer, [this], convToTgt) :> Type - override __.MakeByRefType() = ProvidedSymbolType(ProvidedSymbolKind.ByRef, [this], convToTgt) :> 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) : Type = - match t with - | :? ProvidedTypeDefinition as ptd when ptd.IsErased -> ProvidedTypeDefinition.EraseType t.BaseType - | t when t.IsArray -> - let rank = t.GetArrayRank() - let et = ProvidedTypeDefinition.EraseType (t.GetElementType()) - if rank = 0 then et.MakeArrayType() else et.MakeArrayType(rank) - | :? ProvidedSymbolType as sym when sym.IsFSharpUnitAnnotated -> - t.UnderlyingSystemType - | 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 __.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 __.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 __.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 __.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 __.GetAttributeFlagsImpl() = adjustTypeAttributes attributes this.IsNested - override this.IsValueTypeImpl() = if this.BaseType <> null then this.BaseType = typeof || this.BaseType.IsValueType else false - override __.IsArrayImpl() = false - override __.IsByRefImpl() = false - override __.IsPointerImpl() = false - override __.IsPrimitiveImpl() = false - override __.IsCOMObjectImpl() = false - override __.HasElementTypeImpl() = false - override __.Name = className - override __.DeclaringType = declaringType.Force() - override __.MemberType = if this.IsNested then MemberTypes.NestedType else MemberTypes.TypeInfo - override __.GetHashCode() = rootNamespace.GetHashCode() ^^^ className.GetHashCode() - override __.Equals(that:obj) = - match that with - | null -> false - | :? ProvidedTypeDefinition as ti -> System.Object.ReferenceEquals(this,ti) - | _ -> false - - override __.GetGenericArguments() = [||] - override __.ToString() = this.Name - - - override __.Module : Module = notRequired "Module" this.Name - override __.GUID = Guid.Empty - override __.GetConstructorImpl(_bindingAttr, _binder, _callConvention, _types, _modifiers) = null - override __.GetCustomAttributes(_inherit) = [| |] - override __.GetCustomAttributes(_attributeType, _inherit) = [| |] - override __.IsDefined(_attributeType: Type, _inherit) = false - - override __.GetElementType() = notRequired "Module" this.Name - override __.InvokeMember(_name, _invokeAttr, _binder, _target, _args, _modifiers, _culture, _namedParameters) = notRequired "Module" this.Name - override __.AssemblyQualifiedName = notRequired "Module" this.Name - member __.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 __.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)) - - -#if NO_GENERATIVE -#else -//------------------------------------------------------------------------------------------------- -// The assembly compiler for generative type providers. - -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 transType (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 transType (ty.GetGenericArguments())) - elif ty.HasElementType then - let ety = transType (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 transCtor (f:ConstructorInfo) = match f with :? ProvidedConstructor as pc when ctorMap.ContainsKey pc -> ctorMap.[pc] :> ConstructorInfo | c -> c - let transField (f:FieldInfo) = match f with :? ProvidedField as pf when fieldMap.ContainsKey pf -> fieldMap.[pf] :> FieldInfo | f -> f - let transMeth (m:MethodInfo) = match m with :? ProvidedMethod as pm when methMap.ContainsKey pm -> methMap.[pm] :> MethodInfo | m -> m - let isLiteralEnumField (f:FieldInfo) = match f with :? ProvidedLiteralField as plf -> plf.DeclaringType.IsEnum | _ -> false - - 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(transType 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() -> transType 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, transType finfo.FieldType, finfo.Attributes, pinfo.GetCustomAttributesDataImpl(), None) - | :? ProvidedLiteralField as pinfo -> - Some (pinfo.Name, transType 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, transType minfo.ReturnType, [| for p in minfo.GetParameters() -> transType 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, transType ctorArg.ParameterType, FieldAttributes.Private) ] - - - - // 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 Var("this", pcinfo.DeclaringType) - for p in pcinfo.GetParameters() do - yield Var(p.Name, p.ParameterType) |] - - let codeGen = CodeGenerator(assemblyMainModule, uniqueLambdaTypeName, implicitCtorArgsAsFields, transType, transField, transMeth, transCtor, isLiteralEnumField, ilg, locals, parameterVars) - let parameters = - [| for v in parameterVars -> 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 - codeGen.EmitExpr (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 parameters - codeGen.EmitExpr (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 [||] - let codeGen = CodeGenerator(assemblyMainModule, uniqueLambdaTypeName, implicitCtorArgsAsFields, transType, transField, transMeth, transCtor, isLiteralEnumField, ilg, new Dictionary<_, _>(), [| |]) - codeGen.EmitExpr (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 Var("this", pminfo.DeclaringType) - for p in pminfo.GetParameters() do - yield Var(p.Name, p.ParameterType) |] - let parameters = - [| for v in parameterVars -> 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 - let codeGen = CodeGenerator(assemblyMainModule, uniqueLambdaTypeName, implicitCtorArgsAsFields, transType, transField, transMeth, transCtor, isLiteralEnumField, ilg, locals, parameterVars) - codeGen.EmitExpr (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, transType pinfo.PropertyType, [| for p in pinfo.GetIndexParameters() -> transType 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 - - let resolveHandler = ResolveEventHandler(fun _ args -> - // On Mono args.Name is full name of the type, on .NET - just name (no namespace) - typeMap.Values - |> Seq.filter (fun tb -> tb.FullName = args.Name || tb.Name = args.Name) - |> Seq.iter (fun tb -> tb.CreateType() |> ignore) - - assemblyMainModule.Assembly) - - try - AppDomain.CurrentDomain.add_TypeResolve resolveHandler - iterateTypes (fun tb _ -> tb.CreateType() |> ignore) - finally - AppDomain.CurrentDomain.remove_TypeResolve resolveHandler - -#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 - -#endif // NO_GENERATIVE - -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 - } - - -#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 __.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 __.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 __.RegisterProbingFolder (folder) = - // use GetFullPath to ensure that folder is valid - ignore(IO.Path.GetFullPath folder) - probingFolders.Add folder - - member __.RegisterRuntimeAssemblyLocationAsProbingFolder (config : TypeProviderConfig) = - config.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 this.Invalidate() = invalidateE.Trigger(this,EventArgs()) - - member __.GetStaticParametersForMethod(mb: MethodBase) = - // printfn "In GetStaticParametersForMethod" - match mb with - | :? ProvidedMethod as t -> t.GetStaticParameters() - | _ -> [| |] - - member __.ApplyStaticArgumentsForMethod(mb: MethodBase, mangledName, objs) = - // printfn "In ApplyStaticArgumentsForMethod" - match mb with - | :? ProvidedMethod as t -> t.ApplyStaticArguments(mangledName, objs) :> MethodBase - | _ -> failwith (sprintf "ApplyStaticArguments: static parameters for method %s are unexpected" mb.Name) - - interface ITypeProvider with - - [] - override __.Invalidate = invalidateE.Publish - - override __.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 -> - Expr.NewObjectUnchecked(cinfo, Array.toList parameters) - | :? System.Reflection.MethodInfo as minfo -> - if minfo.IsStatic then - Expr.CallUnchecked(minfo, Array.toList parameters) - else - Expr.CallUnchecked(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 - | NewObject(ctor, args) -> getInvokerExpression ctor [| for arg in args -> expand arg|] - | Call(inst, mi, args) -> - let args = - [| - match inst with - | Some inst -> yield expand inst - | _ -> () - yield! List.map expand args - |] - getInvokerExpression mi args - | ShapeCombinationUnchecked(shape, args) -> RebuildShapeCombinationUnchecked(shape, List.map expand args) - | ShapeVarUnchecked v -> Expr.Var v - | ShapeLambdaUnchecked(v, body) -> Expr.Lambda(v, expand body) - 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 __.GetStaticParameters(ty) = - match ty with - | :? ProvidedTypeDefinition as t -> - if ty.Name = t.Name (* REVIEW: use equality? *) then - t.GetStaticParameters() - else - [| |] - | _ -> [| |] - - override __.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 NO_GENERATIVE - override __.GetGeneratedAssemblyContents(_assembly) = - failwith "no generative assemblies" -#else -#if FX_NO_LOCAL_FILESYSTEM - override __.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 __.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 -#endif \ No newline at end of file +// 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-4.0 releases + +namespace ProviderImplementation.ProvidedTypes + +open System +open System.Text +open System.IO +open System.Reflection +open System.Linq.Expressions +open System.Collections.Generic +open Microsoft.FSharp.Quotations +open Microsoft.FSharp.Quotations.Patterns +open Microsoft.FSharp.Quotations.DerivedPatterns +open Microsoft.FSharp.Core.CompilerServices + +#if NO_GENERATIVE +#else +open System.Reflection.Emit +#endif + +//-------------------------------------------------------------------------------- +// UncheckedQuotations + +// The FSharp.Core 2.0 - 4.0 (4.0.0.0 - 4.4.0.0) quotations implementation is overly strict in that it doesn't allow +// generation of quotations for cross-targeted FSharp.Core. Below we define a series of Unchecked methods +// implemented via reflection hacks to allow creation of various nodes when using a cross-targets FSharp.Core and +// mscorlib.dll. +// +// - Most importantly, these cross-targeted quotations can be provided to the F# compiler by a type provider. +// They are generally produced via the AssemblyReplacer.fs component through a process of rewriting design-time quotations that +// are not cross-targeted. +// +// - However, these quotation values are a bit fragile. Using existing FSharp.Core.Quotations.Patterns +// active patterns on these quotation nodes will generally work correctly. But using ExprShape.RebuildShapeCombination +// on these new nodes will not succed, nor will operations that build new quotations such as Expr.Call. +// Instead, use the replacement provided in this module. +// +// - Likewise, some operations in these quotation values like "expr.Type" may be a bit fragile, possibly returning non cross-targeted types in +// the result. However those operations are not used by the F# compiler. +[] +module internal UncheckedQuotations = + + let qTy = typeof.Assembly.GetType("Microsoft.FSharp.Quotations.ExprConstInfo") + assert (qTy <> null) + let pTy = typeof.Assembly.GetType("Microsoft.FSharp.Quotations.PatternsModule") + assert (pTy<> null) + + // These are handles to the internal functions that create quotation nodes of different sizes. Although internal, + // these function names have been stable since F# 2.0. + let mkFE0 = pTy.GetMethod("mkFE0", BindingFlags.Static ||| BindingFlags.Public ||| BindingFlags.NonPublic) + assert (mkFE0 <> null) + let mkFE1 = pTy.GetMethod("mkFE1", BindingFlags.Static ||| BindingFlags.Public ||| BindingFlags.NonPublic) + assert (mkFE1 <> null) + let mkFE2 = pTy.GetMethod("mkFE2", BindingFlags.Static ||| BindingFlags.Public ||| BindingFlags.NonPublic) + assert (mkFE2 <> null) + let mkFEN = pTy.GetMethod("mkFEN", BindingFlags.Static ||| BindingFlags.Public ||| BindingFlags.NonPublic) + assert (mkFEN <> null) + + // These are handles to the internal tags attached to quotation nodes of different sizes. Although internal, + // these function names have been stable since F# 2.0. + let newDelegateOp = qTy.GetMethod("NewNewDelegateOp", BindingFlags.Static ||| BindingFlags.Public ||| BindingFlags.NonPublic) + assert (newDelegateOp <> null) + let instanceCallOp = qTy.GetMethod("NewInstanceMethodCallOp", BindingFlags.Static ||| BindingFlags.Public ||| BindingFlags.NonPublic) + assert (instanceCallOp <> null) + let staticCallOp = qTy.GetMethod("NewStaticMethodCallOp", BindingFlags.Static ||| BindingFlags.Public ||| BindingFlags.NonPublic) + assert (staticCallOp <> null) + let newObjectOp = qTy.GetMethod("NewNewObjectOp", BindingFlags.Static ||| BindingFlags.Public ||| BindingFlags.NonPublic) + assert (newObjectOp <> null) + let newArrayOp = qTy.GetMethod("NewNewArrayOp", BindingFlags.Static ||| BindingFlags.Public ||| BindingFlags.NonPublic) + assert (newArrayOp <> null) + let appOp = qTy.GetMethod("get_AppOp", BindingFlags.Static ||| BindingFlags.Public ||| BindingFlags.NonPublic) + assert (appOp <> null) + let instancePropGetOp = qTy.GetMethod("NewInstancePropGetOp", BindingFlags.Static ||| BindingFlags.Public ||| BindingFlags.NonPublic) + assert (instancePropGetOp <> null) + let staticPropGetOp = qTy.GetMethod("NewStaticPropGetOp", BindingFlags.Static ||| BindingFlags.Public ||| BindingFlags.NonPublic) + assert (staticPropGetOp <> null) + let instancePropSetOp = qTy.GetMethod("NewInstancePropSetOp", BindingFlags.Static ||| BindingFlags.Public ||| BindingFlags.NonPublic) + assert (instancePropSetOp <> null) + let staticPropSetOp = qTy.GetMethod("NewStaticPropSetOp", BindingFlags.Static ||| BindingFlags.Public ||| BindingFlags.NonPublic) + assert (staticPropSetOp <> null) + let instanceFieldGetOp = qTy.GetMethod("NewInstanceFieldGetOp", BindingFlags.Static ||| BindingFlags.Public ||| BindingFlags.NonPublic) + assert (instanceFieldGetOp <> null) + let staticFieldGetOp = qTy.GetMethod("NewStaticFieldGetOp", BindingFlags.Static ||| BindingFlags.Public ||| BindingFlags.NonPublic) + assert (staticFieldGetOp <> null) + let instanceFieldSetOp = qTy.GetMethod("NewInstanceFieldSetOp", BindingFlags.Static ||| BindingFlags.Public ||| BindingFlags.NonPublic) + assert (instanceFieldSetOp <> null) + let staticFieldSetOp = qTy.GetMethod("NewStaticFieldSetOp", BindingFlags.Static ||| BindingFlags.Public ||| BindingFlags.NonPublic) + assert (staticFieldSetOp <> null) + let tupleGetOp = qTy.GetMethod("NewTupleGetOp", BindingFlags.Static ||| BindingFlags.Public ||| BindingFlags.NonPublic) + assert (tupleGetOp <> null) + let letOp = qTy.GetMethod("get_LetOp", BindingFlags.Static ||| BindingFlags.Public ||| BindingFlags.NonPublic) + assert (letOp <> null) + + type Microsoft.FSharp.Quotations.Expr with + + static member NewDelegateUnchecked (ty: Type, vs: Var list, body: Expr) = + let e = List.foldBack (fun v acc -> Expr.Lambda(v,acc)) vs body + let op = newDelegateOp.Invoke(null, [| box ty |]) + mkFE1.Invoke(null, [| box op; box e |]) :?> Expr + + static member NewObjectUnchecked (cinfo: ConstructorInfo, args : Expr list) = + let op = newObjectOp.Invoke(null, [| box cinfo |]) + mkFEN.Invoke(null, [| box op; box args |]) :?> Expr + + static member NewArrayUnchecked (elementType: Type, elements : Expr list) = + let op = newArrayOp.Invoke(null, [| box elementType |]) + mkFEN.Invoke(null, [| box op; box elements |]) :?> Expr + + static member CallUnchecked (minfo: MethodInfo, args : Expr list) = + let op = staticCallOp.Invoke(null, [| box minfo |]) + mkFEN.Invoke(null, [| box op; box args |]) :?> Expr + + static member CallUnchecked (obj: Expr, minfo: MethodInfo, args : Expr list) = + let op = instanceCallOp.Invoke(null, [| box minfo |]) + mkFEN.Invoke(null, [| box op; box (obj::args) |]) :?> Expr + + static member ApplicationUnchecked (f: Expr, x: Expr) = + let op = appOp.Invoke(null, [| |]) + mkFE2.Invoke(null, [| box op; box f; box x |]) :?> Expr + + static member PropertyGetUnchecked (pinfo: PropertyInfo, args : Expr list) = + let op = staticPropGetOp.Invoke(null, [| box pinfo |]) + mkFEN.Invoke(null, [| box op; box args |]) :?> Expr + + static member PropertyGetUnchecked (obj: Expr, pinfo: PropertyInfo, ?args : Expr list) = + let args = defaultArg args [] + let op = instancePropGetOp.Invoke(null, [| box pinfo |]) + mkFEN.Invoke(null, [| box op; box (obj::args) |]) :?> Expr + + static member PropertySetUnchecked (pinfo: PropertyInfo, value: Expr, ?args : Expr list) = + let args = defaultArg args [] + let op = staticPropSetOp.Invoke(null, [| box pinfo |]) + mkFEN.Invoke(null, [| box op; box (args@[value]) |]) :?> Expr + + static member PropertySetUnchecked (obj: Expr, pinfo: PropertyInfo, value: Expr, args : Expr list) = + let op = instancePropSetOp.Invoke(null, [| box pinfo |]) + mkFEN.Invoke(null, [| box op; box (obj::(args@[value])) |]) :?> Expr + + static member FieldGetUnchecked (pinfo: FieldInfo) = + let op = staticFieldGetOp.Invoke(null, [| box pinfo |]) + mkFE0.Invoke(null, [| box op; |]) :?> Expr + + static member FieldGetUnchecked (obj: Expr, pinfo: FieldInfo) = + let op = instanceFieldGetOp.Invoke(null, [| box pinfo |]) + mkFE1.Invoke(null, [| box op; box obj |]) :?> Expr + + static member FieldSetUnchecked (pinfo: FieldInfo, value: Expr) = + let op = staticFieldSetOp.Invoke(null, [| box pinfo |]) + mkFE1.Invoke(null, [| box op; box value |]) :?> Expr + + static member FieldSetUnchecked (obj: Expr, pinfo: FieldInfo, value: Expr) = + let op = instanceFieldSetOp.Invoke(null, [| box pinfo |]) + mkFE2.Invoke(null, [| box op; box obj; box value |]) :?> Expr + + static member TupleGetUnchecked (e: Expr, n:int) = + let op = tupleGetOp.Invoke(null, [| box e.Type; box n |]) + mkFE1.Invoke(null, [| box op; box e |]) :?> Expr + + static member LetUnchecked (v:Var, e: Expr, body:Expr) = + let lam = Expr.Lambda(v,body) + let op = letOp.Invoke(null, [| |]) + mkFE2.Invoke(null, [| box op; box e; box lam |]) :?> Expr + + type Shape = Shape of (Expr list -> Expr) + + let (|ShapeCombinationUnchecked|ShapeVarUnchecked|ShapeLambdaUnchecked|) e = + match e with + | NewObject (cinfo, args) -> + ShapeCombinationUnchecked (Shape (function args -> Expr.NewObjectUnchecked (cinfo, args)), args) + | NewArray (ty, args) -> + ShapeCombinationUnchecked (Shape (function args -> Expr.NewArrayUnchecked (ty, args)), args) + | NewDelegate (t, vars, expr) -> + ShapeCombinationUnchecked (Shape (function [expr] -> Expr.NewDelegateUnchecked (t, vars, expr) | _ -> invalidArg "expr" "invalid shape"), [expr]) + | TupleGet (expr, n) -> + ShapeCombinationUnchecked (Shape (function [expr] -> Expr.TupleGetUnchecked (expr, n) | _ -> invalidArg "expr" "invalid shape"), [expr]) + | Application (f, x) -> + ShapeCombinationUnchecked (Shape (function [f; x] -> Expr.ApplicationUnchecked (f, x) | _ -> invalidArg "expr" "invalid shape"), [f; x]) + | Call (objOpt, minfo, args) -> + match objOpt with + | None -> ShapeCombinationUnchecked (Shape (function args -> Expr.CallUnchecked (minfo, args)), args) + | Some obj -> ShapeCombinationUnchecked (Shape (function (obj::args) -> Expr.CallUnchecked (obj, minfo, args) | _ -> invalidArg "expr" "invalid shape"), obj::args) + | PropertyGet (objOpt, pinfo, args) -> + match objOpt with + | None -> ShapeCombinationUnchecked (Shape (function args -> Expr.PropertyGetUnchecked (pinfo, args)), args) + | Some obj -> ShapeCombinationUnchecked (Shape (function (obj::args) -> Expr.PropertyGetUnchecked (obj, pinfo, args) | _ -> invalidArg "expr" "invalid shape"), obj::args) + | PropertySet (objOpt, pinfo, args, value) -> + match objOpt with + | None -> ShapeCombinationUnchecked (Shape (function (value::args) -> Expr.PropertySetUnchecked (pinfo, value, args) | _ -> invalidArg "expr" "invalid shape"), value::args) + | Some obj -> ShapeCombinationUnchecked (Shape (function (obj::value::args) -> Expr.PropertySetUnchecked (obj, pinfo, value, args) | _ -> invalidArg "expr" "invalid shape"), obj::value::args) + | FieldGet (objOpt, pinfo) -> + match objOpt with + | None -> ShapeCombinationUnchecked (Shape (function _ -> Expr.FieldGetUnchecked (pinfo)), []) + | Some obj -> ShapeCombinationUnchecked (Shape (function [obj] -> Expr.FieldGetUnchecked (obj, pinfo) | _ -> invalidArg "expr" "invalid shape"), [obj]) + | FieldSet (objOpt, pinfo, value) -> + match objOpt with + | None -> ShapeCombinationUnchecked (Shape (function [value] -> Expr.FieldSetUnchecked (pinfo, value) | _ -> invalidArg "expr" "invalid shape"), [value]) + | Some obj -> ShapeCombinationUnchecked (Shape (function [obj;value] -> Expr.FieldSetUnchecked (obj, pinfo, value) | _ -> invalidArg "expr" "invalid shape"), [obj; value]) + | Let (var, value, body) -> + ShapeCombinationUnchecked (Shape (function [value;Lambda(var, body)] -> Expr.LetUnchecked(var, value, body) | _ -> invalidArg "expr" "invalid shape"), [value; Expr.Lambda(var, body)]) + | TupleGet (expr, i) -> + ShapeCombinationUnchecked (Shape (function [expr] -> Expr.TupleGetUnchecked (expr, i) | _ -> invalidArg "expr" "invalid shape"), [expr]) + | ExprShape.ShapeCombination (comb,args) -> + ShapeCombinationUnchecked (Shape (fun args -> ExprShape.RebuildShapeCombination(comb, args)), args) + | ExprShape.ShapeVar v -> ShapeVarUnchecked v + | ExprShape.ShapeLambda (v, e) -> ShapeLambdaUnchecked (v,e) + + let RebuildShapeCombinationUnchecked (Shape comb,args) = comb args + +//-------------------------------------------------------------------------------- +// The quotation simplifier +// +// This is invoked for each quotation specified by the type provider, just before it is +// handed to the F# compiler, allowing a broader range of +// quotations to be accepted. Specifically accept: +// +// - NewTuple nodes (for generative type providers) +// - TupleGet nodes (for generative type providers) +// - array and list values as constants +// - PropertyGet and PropertySet nodes +// - Application, NewUnionCase, NewRecord, UnionCaseTest nodes +// - Let nodes (defining "byref" values) +// - LetRecursive nodes +// +// Additionally, a set of code optimizations are applied to generated code: +// - inlineRightPipe +// - optimizeCurriedApplications +// - inlineValueBindings + +type QuotationSimplifier(isGenerated: bool) = + + let rec transExpr q = + match q with + // convert NewTuple to the call to the constructor of the Tuple type (only for generated types) + | NewTuple(items) when isGenerated -> + let rec mkCtor args ty = + let ctor, restTyOpt = Reflection.FSharpValue.PreComputeTupleConstructorInfo ty + match restTyOpt with + | None -> Expr.NewObject(ctor, List.map transExpr args) + | Some restTy -> + let curr = [for a in Seq.take 7 args -> transExpr a] + let rest = List.ofSeq (Seq.skip 7 args) + Expr.NewObject(ctor, curr @ [mkCtor rest restTy]) + let tys = [| for e in items -> e.Type |] + let tupleTy = Reflection.FSharpType.MakeTupleType tys + transExpr (mkCtor items tupleTy) + // convert TupleGet to the chain of PropertyGet calls (only for generated types) + | TupleGet(e, i) when isGenerated -> + let rec mkGet ty i (e : Expr) = + let pi, restOpt = Reflection.FSharpValue.PreComputeTuplePropertyInfo(ty, i) + let propGet = Expr.PropertyGet(e, pi) + match restOpt with + | None -> propGet + | Some (restTy, restI) -> mkGet restTy restI propGet + transExpr (mkGet e.Type i (transExpr e)) + | Value(value, ty) -> + if value <> null then + let tyOfValue = value.GetType() + transValue(value, tyOfValue, ty) + else q + // Eliminate F# property gets to method calls + | PropertyGet(obj,propInfo,args) -> + match obj with + | None -> transExpr (Expr.CallUnchecked(propInfo.GetGetMethod(),args)) + | Some o -> transExpr (Expr.CallUnchecked(transExpr o,propInfo.GetGetMethod(),args)) + // Eliminate F# property sets to method calls + | PropertySet(obj,propInfo,args,v) -> + match obj with + | None -> transExpr (Expr.CallUnchecked(propInfo.GetSetMethod(),args@[v])) + | Some o -> transExpr (Expr.CallUnchecked(transExpr o,propInfo.GetSetMethod(),args@[v])) + // Eliminate F# function applications to FSharpFunc<_,_>.Invoke calls + | Application(f,e) -> + transExpr (Expr.CallUnchecked(transExpr f, f.Type.GetMethod "Invoke", [ e ]) ) + | NewUnionCase(ci, es) -> + transExpr (Expr.CallUnchecked(Reflection.FSharpValue.PreComputeUnionConstructorInfo ci, es) ) + | NewRecord(ci, es) -> + transExpr (Expr.NewObjectUnchecked(Reflection.FSharpValue.PreComputeRecordConstructorInfo ci, es) ) + | UnionCaseTest(e,uc) -> + let tagInfo = Reflection.FSharpValue.PreComputeUnionTagMemberInfo uc.DeclaringType + let tagExpr = + match tagInfo with + | :? PropertyInfo as tagProp -> + transExpr (Expr.PropertyGet(e,tagProp) ) + | :? MethodInfo as tagMeth -> + if tagMeth.IsStatic then transExpr (Expr.Call(tagMeth, [e])) + else transExpr (Expr.Call(e,tagMeth,[])) + | _ -> failwith "unreachable: unexpected result from PreComputeUnionTagMemberInfo" + let tagNumber = uc.Tag + transExpr <@@ (%%(tagExpr) : int) = tagNumber @@> + + // Explicitly handle weird byref variables in lets (used to populate out parameters), since the generic handlers can't deal with byrefs. + // + // 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 + | Let(v,vexpr,bexpr) when v.Type.IsByRef -> transLetOfByref v vexpr bexpr + + // Eliminate recursive let bindings (which are unsupported by the type provider API) to regular let bindings + | LetRecursive(bindings, expr) -> transLetRec bindings expr + + // Handle the generic cases + | ShapeLambdaUnchecked(v,body) -> Expr.Lambda(v, transExpr body) + | ShapeCombinationUnchecked(comb,args) -> RebuildShapeCombinationUnchecked(comb,List.map transExpr args) + | ShapeVarUnchecked _ -> q + + and transLetRec 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 Call(None, r, [_]) -> r | _ -> failwith "Extracting MethodInfo from <@ 1 @> failed" + let d = match <@ Unchecked.defaultof<_> @> with Call(None, d, []) -> d | _ -> failwith "Extracting MethodInfo from <@ Unchecked.defaultof<_> @> failed" + Expr.Call(r.GetGenericMethodDefinition().MakeGenericMethod(t), [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 Call(None, m, [_]) -> m | _ -> failwith "Extracting MethodInfo from <@ !(ref 1) @> failed" + let tyArgs = v.Type.GetGenericArguments() + Expr.Call(m.GetGenericMethodDefinition().MakeGenericMethod(tyArgs), [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 Call(None, m, [_;_]) -> m | _ -> failwith "Extracting MethodInfo from <@ (ref 1) := 2 @> failed" + Expr.Call(m.GetGenericMethodDefinition().MakeGenericMethod(v.Type), [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) -> 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 -> Expr.LetUnchecked(varDict.[v], init v.Type, b)) body + |> transExpr + + + and transLetOfByref v vexpr bexpr = + match vexpr with + | Sequential(e',vexpr') -> + (* let v = (e'; vexpr') in bexpr => e'; let v = vexpr' in bexpr *) + Expr.Sequential(e', transLetOfByref v vexpr' bexpr) + |> transExpr + | 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 *) + // + // Note, this duplicates "bexpr" + Expr.IfThenElse(c, transLetOfByref v b1 bexpr, transLetOfByref v b2 bexpr) + |> transExpr + | Var _ -> + (* let v = v1 in bexpr => bexpr[v/v1] *) + bexpr.Substitute(fun v' -> if v = v' then Some vexpr else None) + |> transExpr + | _ -> + failwith (sprintf "Unexpected byref binding: %A = %A" v vexpr) + + and transValueArray (o : Array, ty : Type) = + let elemTy = ty.GetElementType() + let converter = getValueConverterForType elemTy + let elements = [ for el in o -> converter el ] + Expr.NewArrayUnchecked(elemTy, elements) + + and transValueList(o, ty : Type, nil, cons) = + let converter = getValueConverterForType (ty.GetGenericArguments().[0]) + o + |> Seq.cast + |> List.ofSeq + |> fun l -> List.foldBack(fun o s -> Expr.NewUnionCase(cons, [ converter(o); s ])) l (Expr.NewUnionCase(nil, [])) + |> transExpr + + and getValueConverterForType (ty : Type) = + if ty.IsArray then + fun (v : obj) -> transValueArray(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 -> transValueList (v :?> System.Collections.IEnumerable, ty, nil, cons) + else + fun v -> Expr.Value(v, ty) + + and transValue (v : obj, tyOfValue : Type, expectedTy : Type) = + let converter = getValueConverterForType tyOfValue + let r = converter v + if tyOfValue <> expectedTy then Expr.Coerce(r, expectedTy) + else r + +#if NO_GENERATIVE +#else + // TODO: this works over FSharp.Core 4.4.0.0 types. These types need to be retargeted to the target runtime. + 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 (===) a b = LanguagePrimitives.PhysicalEquality a b + + let traverse f = + let rec fallback e = + match e with + | Let(v, value, body) -> + let fixedValue = f fallback value + let fixedBody = f fallback body + if fixedValue === value && fixedBody === body then + e + else + Expr.Let(v, fixedValue, fixedBody) + | ShapeVarUnchecked _ -> e + | ShapeLambdaUnchecked(v, body) -> + let fixedBody = f fallback body + if fixedBody === body then + e + else + Expr.Lambda(v, fixedBody) + | ShapeCombinationUnchecked(shape, exprs) -> + let exprs1 = List.map (f fallback) exprs + if List.forall2 (===) exprs exprs1 then + e + else + RebuildShapeCombinationUnchecked(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 + | SpecificCall RightPipe (None, _, [operand; applicable]) -> + let fixedOperand = loop operand + match loop applicable with + | Lambda(arg, body) -> + let v = Quotations.Var("__temp", operand.Type) + let ev = Expr.Var v + + let fixedBody = loop body + Expr.Let(v, fixedOperand, fixedBody.Substitute(fun v1 -> if v1 = arg then Some ev else None)) + | fixedApplicable -> Expr.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 + | Let(id, (Value(_) as v), body) when not id.IsMutable -> + map.[id] <- v + let fixedBody = loop body + map.Remove(id) |> ignore + fixedBody + | ShapeVarUnchecked 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 + | 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 + | Application(e, arg) -> + let e1 = tryPeelApplications e ((loop arg)::args) + if e1 === e then + orig + else + e1 + | Let(id, applicable, (Lambda(_) as body)) when n > 0 -> + let numberOfApplication = countPeelableApplications body id 0 + if numberOfApplication = 0 then orig + elif n = 1 then Expr.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.toArray + |> (fun arr -> arr.[n - 1]) + + let adaptMethod = getFastFuncType args resultType + let adapted = Expr.Call(adaptMethod, [loop applicable]) + let invoke = adapted.Type.GetMethod("Invoke", [| for arg in args -> arg.Type |]) + Expr.Call(adapted, invoke, args) + else + (applicable, args) ||> List.fold (fun e a -> Expr.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 + | Lambda(arg, Let(v1, Application(Var f, Var arg1), rest)) when v = f && arg = arg1 -> countPeelableApplications rest v1 (n + 1) + // \arg -> (f arg) ==> f + | Lambda(arg, Application(Var f, Var arg1)) when v = f && arg = arg1 -> n + | _ -> n + loop expr +#endif + + member __.TranslateExpression q = transExpr q + + member __.TranslateQuotationToCode qexprf (paramNames: string[]) (argExprs: Expr[]) = + // Use the real variable names instead of indices, to improve output of Debug.fs + // 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 -> Expr.Var v]) + + let pairs = Array.zip argExprs vars + let expr = Array.foldBack (fun (arg, var) e -> Expr.LetUnchecked(var, arg, e)) pairs expr +#if NO_GENERATIVE +#else + let expr = + if isGenerated then + let e1 = inlineRightPipe expr + let e2 = optimizeCurriedApplications e1 + let e3 = inlineValueBindings e2 + e3 + else + expr +#endif + + transExpr expr + +//------------------------------------------------------------------------------------------------- +// Generate IL code from quotations + + +#if NO_GENERATIVE +#else + +type (*internal*) ExpectedStackState = + | Empty = 1 + | Address = 2 + | Value = 3 + +type CodeGenerator(assemblyMainModule: ModuleBuilder, uniqueLambdaTypeName, + implicitCtorArgsAsFields: FieldBuilder list, + transType: Type -> Type, + transField: FieldInfo -> FieldInfo, + transMethod: MethodInfo -> MethodInfo, + transCtor: ConstructorInfo -> ConstructorInfo, + isLiteralEnumField: FieldInfo -> bool, + ilg: ILGenerator, locals:Dictionary, parameterVars) = + + // TypeBuilderInstantiation should really be a public type, since we + // have to use alternative means for various Method/Field/Constructor lookups on this kind of type. + // Also, on Mono 3.x and 4.x this type had a different name. + let TypeBuilderInstantiationType = + let runningOnMono = try System.Type.GetType("Mono.Runtime") <> null with e-> false + let ty = + if runningOnMono then + let ty = Type.GetType("System.Reflection.MonoGenericClass") + match ty with + | null -> Type.GetType("System.Reflection.Emit.TypeBuilderInstantiation") + | _ -> ty + else + Type.GetType("System.Reflection.Emit.TypeBuilderInstantiation") + + ty + + // TODO: this works over FSharp.Core 4.4.0.0 types and methods. These types need to be retargeted to the target runtime. + + 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 rec emitLambda(callSiteIlg : ILGenerator, v : Quotations.Var, body : 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 lambdaLocals = 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) + lambdaLocals.[v] <- l + + let expectedState = if (invoke.ReturnType = typeof) then ExpectedStackState.Empty else ExpectedStackState.Value + let lambadParamVars = [| Quotations.Var("this", lambda); v|] + let codeGen = CodeGenerator(assemblyMainModule, uniqueLambdaTypeName, implicitCtorArgsAsFields, transType, transField, transMethod, transCtor, isLiteralEnumField, ilg, lambdaLocals, lambadParamVars) + codeGen.EmitExpr (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 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 + match expr with + | 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(transType loopVar.Type) + locals.Add(loopVar, lb) + lb + + // loopVar = first + emitExpr ExpectedStackState.Value first + ilg.Emit(OpCodes.Stloc, lb) + + let before = ilg.DefineLabel() + let after = ilg.DefineLabel() + + ilg.MarkLabel before + ilg.Emit(OpCodes.Ldloc, lb) + + emitExpr ExpectedStackState.Value last + ilg.Emit(OpCodes.Bgt, after) + + emitExpr 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) + + | NewArray(elementTy, elements) -> + ilg.Emit(OpCodes.Ldc_I4, List.length elements) + ilg.Emit(OpCodes.Newarr, transType elementTy) + + elements + |> List.iteri (fun i el -> + ilg.Emit(OpCodes.Dup) + ilg.Emit(OpCodes.Ldc_I4, i) + emitExpr ExpectedStackState.Value el + ilg.Emit(OpCodes.Stelem, transType elementTy)) + + popIfEmptyExpected expectedState + + | WhileLoop(cond, body) -> + let before = ilg.DefineLabel() + let after = ilg.DefineLabel() + + ilg.MarkLabel before + emitExpr ExpectedStackState.Value cond + ilg.Emit(OpCodes.Brfalse, after) + emitExpr ExpectedStackState.Empty body + ilg.Emit(OpCodes.Br, before) + + ilg.MarkLabel after + + | Var v -> + if isEmpty expectedState then () else + + // Try to interpret this as a method parameter + 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 -> + + // Try to interpret this as an implicit field in a class + 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 -> + + // Try to interpret this as a local + 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" + + | Coerce (arg,ty) -> + // castClass may lead to observable side-effects - InvalidCastException + emitExpr ExpectedStackState.Value arg + let argTy = transType arg.Type + let targetTy = transType 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 && (TypeBuilderInstantiationType.Equals(targetTy.GetType()) || not (targetTy.IsAssignableFrom(argTy))) then + ilg.Emit(OpCodes.Castclass, targetTy) + + popIfEmptyExpected expectedState + + | SpecificCall <@ (-) @>(None, [t1; t2; _], [a1; a2]) -> + assert(t1 = t2) + emitExpr ExpectedStackState.Value a1 + emitExpr ExpectedStackState.Value a2 + if t1 = typeof then + ilg.Emit(OpCodes.Call, typeof.GetMethod "op_Subtraction") + else + ilg.Emit(OpCodes.Sub) + emitConvIfNecessary t1 + + popIfEmptyExpected expectedState + + | SpecificCall <@ (/) @> (None, [t1; t2; _], [a1; a2]) -> + assert (t1 = t2) + emitExpr ExpectedStackState.Value a1 + emitExpr 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 + + | SpecificCall <@ int @>(None, [sourceTy], [v]) -> + emitExpr ExpectedStackState.Value v + match Type.GetTypeCode(sourceTy) with + | TypeCode.String -> + ilg.Emit(OpCodes.Call, 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" + + | SpecificCall <@ LanguagePrimitives.IntrinsicFunctions.GetArray @> (None, [ty], [arr; index]) -> + // observable side-effect - IndexOutOfRangeException + emitExpr ExpectedStackState.Value arr + emitExpr ExpectedStackState.Value index + if isAddress expectedState then + ilg.Emit(OpCodes.Readonly) + ilg.Emit(OpCodes.Ldelema, transType ty) + else + ilg.Emit(OpCodes.Ldelem, transType ty) + + popIfEmptyExpected expectedState + + | SpecificCall <@ LanguagePrimitives.IntrinsicFunctions.GetArray2D @> (None, _ty, arr::indices) + | SpecificCall <@ LanguagePrimitives.IntrinsicFunctions.GetArray3D @> (None, _ty, arr::indices) + | 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 + emitExpr ExpectedStackState.Value arr + for index in indices do + emitExpr ExpectedStackState.Value index + + if isAddress expectedState then + ilg.Emit(OpCodes.Readonly) + + ilg.Emit(OpCodes.Call, meth) + + popIfEmptyExpected expectedState + + + | FieldGet (None,field) when isLiteralEnumField field -> + if expectedState <> ExpectedStackState.Empty then + emitExpr expectedState (Expr.Value(field.GetRawConstantValue(), field.FieldType.GetEnumUnderlyingType())) + + | FieldGet (objOpt,field) -> + objOpt |> Option.iter (fun e -> + let s = if e.Type.IsValueType then ExpectedStackState.Address else ExpectedStackState.Value + emitExpr s e) + let field = transField field + if field.IsStatic then + ilg.Emit(OpCodes.Ldsfld, field) + else + ilg.Emit(OpCodes.Ldfld, field) + + | FieldSet (objOpt,field,v) -> + objOpt |> Option.iter (fun e -> + let s = if e.Type.IsValueType then ExpectedStackState.Address else ExpectedStackState.Value + emitExpr s e) + emitExpr ExpectedStackState.Value v + let field = transField field + if field.IsStatic then + ilg.Emit(OpCodes.Stsfld, field) + else + ilg.Emit(OpCodes.Stfld, field) + + | Call (objOpt,meth,args) -> + objOpt |> Option.iter (fun e -> + let s = if e.Type.IsValueType then ExpectedStackState.Address else ExpectedStackState.Value + emitExpr s e) + + for pe in args do + emitExpr ExpectedStackState.Value pe + + // 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 transType + let gmd = meth.GetGenericMethodDefinition() |> transMethod + gmd.GetGenericMethodDefinition().MakeGenericMethod args + elif meth.DeclaringType.IsGenericType then + let gdty = transType (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 transType meth.DeclaringType with + | :? TypeBuilder as dty -> TypeBuilder.GetMethod(dty, gdtym) + | dty -> MethodBase.GetMethodFromHandle(meth.MethodHandle, dty.TypeHandle) :?> _ + + assert (dtym <> null) + dtym + else + transMethod meth + match objOpt with + | Some obj when mappedMeth.IsAbstract || mappedMeth.IsVirtual -> + if obj.Type.IsValueType then ilg.Emit(OpCodes.Constrained, transType 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) + | _ -> () + + | NewObject (ctor,args) -> + for pe in args do + emitExpr ExpectedStackState.Value pe + let meth = transCtor ctor + ilg.Emit(OpCodes.Newobj, meth) + + popIfEmptyExpected expectedState + + | 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, transType ty) + ilg.Emit(OpCodes.Call, 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, DecimalConstructor()) + | :? DateTime as x -> + ilg.Emit(OpCodes.Ldc_I8, x.Ticks) + ilg.Emit(OpCodes.Ldc_I4, int x.Kind) + ilg.Emit(OpCodes.Newobj, DateTimeConstructor()) + | :? DateTimeOffset as x -> + ilg.Emit(OpCodes.Ldc_I8, x.Ticks) + ilg.Emit(OpCodes.Ldc_I8, x.Offset.Ticks) + ilg.Emit(OpCodes.Newobj, TimeSpanConstructor()) + ilg.Emit(OpCodes.Newobj, DateTimeOffsetConstructor()) + | null -> ilg.Emit(OpCodes.Ldnull) + | _ -> failwithf "unknown constant '%A' in generated method" v + if isEmpty expectedState then () + else emitC obj + + | Let(v,e,b) -> + let lb = ilg.DeclareLocal (transType v.Type) + locals.Add (v, lb) + emitExpr ExpectedStackState.Value e + ilg.Emit(OpCodes.Stloc, lb.LocalIndex) + emitExpr expectedState b + + | Sequential(e1, e2) -> + emitExpr ExpectedStackState.Empty e1 + emitExpr expectedState e2 + + | IfThenElse(cond, ifTrue, ifFalse) -> + let ifFalseLabel = ilg.DefineLabel() + let endLabel = ilg.DefineLabel() + + emitExpr ExpectedStackState.Value cond + + ilg.Emit(OpCodes.Brfalse, ifFalseLabel) + + emitExpr expectedState ifTrue + ilg.Emit(OpCodes.Br, endLabel) + + ilg.MarkLabel(ifFalseLabel) + emitExpr expectedState ifFalse + + ilg.Emit(OpCodes.Nop) + ilg.MarkLabel(endLabel) + + | TryWith(body, _filterVar, _filterBody, catchVar, catchBody) -> + + let stres, ldres = + if isEmpty expectedState then ignore, ignore + else + let local = ilg.DeclareLocal (transType body.Type) + let stres = fun () -> ilg.Emit(OpCodes.Stloc, local) + let ldres = fun () -> ilg.Emit(OpCodes.Ldloc, local) + stres, ldres + + let exceptionVar = ilg.DeclareLocal(transType catchVar.Type) + locals.Add(catchVar, exceptionVar) + + let _exnBlock = ilg.BeginExceptionBlock() + + emitExpr expectedState body + stres() + + ilg.BeginCatchBlock(transType catchVar.Type) + ilg.Emit(OpCodes.Stloc, exceptionVar) + emitExpr expectedState catchBody + stres() + ilg.EndExceptionBlock() + + ldres() + + | VarSet(v,e) -> + emitExpr 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" + | Lambda(v, body) -> + emitLambda(ilg, v, body, expr.GetFreeVars(), locals, parameterVars) + popIfEmptyExpected expectedState + | n -> + failwith (sprintf "unknown expression '%A' in generated method" n) + + member __.EmitExpr (expectedState, expr) = emitExpr expectedState expr + +#endif + +[] +module internal Misc = + + + 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 = 2) + member __.ConstructorArguments = upcast [|CustomAttributeTypedArgument(typeof, message) ; CustomAttributeTypedArgument(typeof, isError) |] + member __.NamedArguments = upcast [| |] } + + let mkReflectedDefinitionCustomAttributeData() = +#if FX_NO_CUSTOMATTRIBUTEDATA + { new IProvidedCustomAttributeData with +#else + { new CustomAttributeData() with +#endif + member __.Constructor = typeof.GetConstructors().[0] + member __.ConstructorArguments = upcast [| |] + 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 + let mutable hasReflectedDefinition = 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() + if hasReflectedDefinition then yield mkReflectedDefinitionCustomAttributeData() + yield! customAttributes |] + + member __.AddDefinitionLocation(line:int,column:int,filePath:string) = customAttributes.Add(mkDefinitionLocationAttributeCustomAttributeData(line, column, filePath)) + member __.AddObsolete(message : string, isError) = obsoleteMessage <- Some (message,isError) + member __.HasParamArray with get() = hasParamArray and set(v) = hasParamArray <- v + member __.HasReflectedDefinition with get() = hasReflectedDefinition and set(v) = hasReflectedDefinition <- v + member __.AddXmlDocComputed xmlDocFunction = xmlDocAlwaysRecomputed <- Some xmlDocFunction + member __.AddXmlDocDelayed xmlDocFunction = xmlDocDelayed <- Some xmlDocFunction + member __.AddXmlDoc xmlDoc = xmlDocDelayed <- Some (fun () -> xmlDoc) + 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() + // Recomputed XML doc is evaluated on every call to GetCustomAttributesData() + match xmlDocAlwaysRecomputed with None -> () | Some f -> yield mkXmlDocCustomAttributeData (f()) |] + :> IList<_> + + + 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 xmlDocFunction = customAttributesImpl.AddXmlDocDelayed xmlDocFunction + member __.AddXmlDocComputed xmlDocFunction = customAttributesImpl.AddXmlDocComputed xmlDocFunction + member __.AddXmlDoc xmlDoc = customAttributesImpl.AddXmlDoc xmlDoc + + 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 __.IsParamArray with get() = customAttributesImpl.HasParamArray and set(v) = customAttributesImpl.HasParamArray <- v + member __.IsReflectedDefinition with get() = customAttributesImpl.HasReflectedDefinition and set(v) = customAttributesImpl.HasReflectedDefinition <- v + override __.Name = name + override __.ParameterType = parameterType + override __.Attributes = (base.Attributes ||| (if isOut then ParameterAttributes.Out else enum 0) + ||| (match optionalValue with None -> enum 0 | Some _ -> ParameterAttributes.Optional ||| ParameterAttributes.HasDefault)) + override __.RawDefaultValue = defaultArg optionalValue null + member __.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 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 isStatic() = ctorAttributes.HasFlag(MethodAttributes.Static) + + let customAttributesImpl = CustomAttributesImpl() + member __.IsTypeInitializer + with get() = isStatic() && ctorAttributes.HasFlag(MethodAttributes.Private) + and set(v) = + let typeInitializerAttributes = MethodAttributes.Static ||| MethodAttributes.Private + ctorAttributes <- if v then ctorAttributes ||| typeInitializerAttributes else ctorAttributes &&& ~~~typeInitializerAttributes + + member __.AddXmlDocComputed xmlDocFunction = customAttributesImpl.AddXmlDocComputed xmlDocFunction + member __.AddXmlDocDelayed xmlDocFunction = customAttributesImpl.AddXmlDocDelayed xmlDocFunction + member __.AddXmlDoc xmlDoc = customAttributesImpl.AddXmlDoc xmlDoc + member __.AddObsoleteAttribute (message,?isError) = customAttributesImpl.AddObsolete (message,defaultArg isError false) + member __.AddDefinitionLocation(line,column,filePath) = customAttributesImpl.AddDefinitionLocation(line, column, filePath) + member __.GetCustomAttributesDataImpl() = customAttributesImpl.GetCustomAttributesData() +#if FX_NO_CUSTOMATTRIBUTEDATA +#else + override __.GetCustomAttributesData() = customAttributesImpl.GetCustomAttributesData() +#endif + + member __.DeclaringTypeImpl + with set x = + if declaringType<>null then failwith (sprintf "ProvidedConstructor: declaringType already set on '%s'" (nameText())); + declaringType <- x + + member __.InvokeCode + with set (q:Expr list -> Expr) = + match invokeCode with + | None -> invokeCode <- Some q + | Some _ -> failwith (sprintf "ProvidedConstructor: code already given for '%s'" (nameText())) + + member __.BaseConstructorCall + with set (d:Expr list -> (ConstructorInfo * Expr list)) = + match baseCall with + | None -> baseCall <- Some d + | Some _ -> failwith (sprintf "ProvidedConstructor: base call already given for '%s'" (nameText())) + + member __.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 || isStatic() then [] else ["this"]) + |> Array.ofList + QuotationSimplifier(isGenerated).TranslateQuotationToCode f paramNames + | None -> failwith (sprintf "ProvidedConstructor: no invoker for '%s'" (nameText())) + + member __.GetBaseConstructorCallInternal isGenerated = + match baseCall with + | Some f -> Some(fun ctorArgs -> let c,baseCtorArgExprs = f ctorArgs in c, List.map (QuotationSimplifier(isGenerated).TranslateExpression) baseCtorArgExprs) + | None -> None + + member __.IsImplicitCtor with get() = isImplicitCtor and set v = isImplicitCtor <- v + + // Implement overloads + override __.GetParameters() = parameters |> List.toArray + override __.Attributes = ctorAttributes + override __.Name = if isStatic() then ".cctor" else ".ctor" + override __.DeclaringType = declaringType |> nonNull "ProvidedConstructor.DeclaringType" + override __.IsDefined(_attributeType, _inherit) = true + + override __.Invoke(_invokeAttr, _binder, _parameters, _culture) = notRequired "Invoke" (nameText()) + override __.Invoke(_obj, _invokeAttr, _binder, _parameters, _culture) = notRequired "Invoke" (nameText()) + override __.ReflectedType = notRequired "ReflectedType" (nameText()) + override __.GetMethodImplementationFlags() = notRequired "GetMethodImplementationFlags" (nameText()) + override __.MethodHandle = notRequired "MethodHandle" (nameText()) + override __.GetCustomAttributes(_inherit) = notRequired "GetCustomAttributes" (nameText()) + override __.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 Expr> + let mutable staticParams = [ ] + let mutable staticParamsApply = None + let isStatic() = methodAttrs.HasFlag(MethodAttributes.Static) + let customAttributesImpl = CustomAttributesImpl() + + member __.AddXmlDocComputed xmlDocFunction = customAttributesImpl.AddXmlDocComputed xmlDocFunction + member __.AddXmlDocDelayed xmlDocFunction = customAttributesImpl.AddXmlDocDelayed xmlDocFunction + member __.AddXmlDoc xmlDoc = customAttributesImpl.AddXmlDoc xmlDoc + member __.AddObsoleteAttribute (message,?isError) = customAttributesImpl.AddObsolete (message,defaultArg isError false) + member __.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 __.GetCustomAttributesData() = customAttributesImpl.GetCustomAttributesData() +#endif + + member __.SetMethodAttrs m = methodAttrs <- m + member __.AddMethodAttrs m = methodAttrs <- methodAttrs ||| m + member __.DeclaringTypeImpl with set x = declaringType <- x // check: not set twice + member __.IsStaticMethod + with get() = isStatic() + and set x = if x then methodAttrs <- methodAttrs ||| MethodAttributes.Static + else methodAttrs <- methodAttrs &&& (~~~ MethodAttributes.Static) + + member __.InvokeCode + with set (q:Expr list -> Expr) = + match invokeCode with + | None -> invokeCode <- Some q + | Some _ -> failwith (sprintf "ProvidedConstructor: code already given for %s on type %s" methodName (if declaringType=null then "" else declaringType.FullName)) + + + /// Abstract a type to a parametric-type. Requires "formal parameters" and "instantiation function". + member __.DefineStaticParameters(staticParameters : list, apply : (string -> obj[] -> ProvidedMethod)) = + staticParams <- staticParameters + staticParamsApply <- Some apply + + /// Get ParameterInfo[] for the parametric type parameters (//s GetGenericParameters) + member __.GetStaticParameters() = [| for p in staticParams -> p :> ParameterInfo |] + + /// Instantiate parametrics type + member __.ApplyStaticArguments(mangledName: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 method %s" staticParams.Length args.Length methodName) + match staticParamsApply with + | None -> failwith "ProvidedTypeDefinition: DefineStaticParameters was not called" + | Some f -> f mangledName args + else + failwith (sprintf "ProvidedTypeDefinition: static parameters supplied but not expected for method %s" methodName) + + member __.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 isStatic() then [] else ["this"]) + |> Array.ofList + QuotationSimplifier(isGenerated).TranslateQuotationToCode f paramNames + | None -> failwith (sprintf "ProvidedMethod: no invoker for %s on type %s" methodName (if declaringType=null then "" else declaringType.FullName)) + + // Implement overloads + override __.GetParameters() = argParams |> Array.ofList + override __.Attributes = methodAttrs + override __.Name = methodName + override __.DeclaringType = declaringType |> nonNull "ProvidedMethod.DeclaringType" + override __.IsDefined(_attributeType, _inherit) : bool = true + override __.MemberType = MemberTypes.Method + override __.CallingConvention = + let cc = CallingConventions.Standard + let cc = if not (isStatic()) then cc ||| CallingConventions.HasThis else cc + cc + override __.ReturnType = returnType + override __.ReturnParameter = null // REVIEW: Give it a name and type? + override __.ToString() = "Method " + methodName + + // 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 __.MetadataToken = hash declaringType + hash methodName + override __.MethodHandle = RuntimeMethodHandle() + + override __.ReturnTypeCustomAttributes = notRequired "ReturnTypeCustomAttributes" methodName + override __.GetBaseDefinition() = notRequired "GetBaseDefinition" methodName + override __.GetMethodImplementationFlags() = notRequired "GetMethodImplementationFlags" methodName + override __.Invoke(_obj, _invokeAttr, _binder, _parameters, _culture) = notRequired "Invoke" methodName + override __.ReflectedType = notRequired "ReflectedType" methodName + override __.GetCustomAttributes(_inherit) = notRequired "GetCustomAttributes" methodName + override __.GetCustomAttributes(_attributeType, _inherit) = notRequired "GetCustomAttributes" methodName + + +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 Expr> + let mutable setterCode = None : option 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 __.AddXmlDocComputed xmlDocFunction = customAttributesImpl.AddXmlDocComputed xmlDocFunction + member __.AddXmlDocDelayed xmlDocFunction = customAttributesImpl.AddXmlDocDelayed xmlDocFunction + member __.AddXmlDoc xmlDoc = customAttributesImpl.AddXmlDoc xmlDoc + member __.AddObsoleteAttribute (message,?isError) = customAttributesImpl.AddObsolete (message,defaultArg isError false) + member __.AddDefinitionLocation(line,column,filePath) = customAttributesImpl.AddDefinitionLocation(line, column, filePath) + member __.GetCustomAttributesDataImpl() = customAttributesImpl.GetCustomAttributesData() + member __.AddCustomAttribute attribute = customAttributesImpl.AddCustomAttribute attribute +#if FX_NO_CUSTOMATTRIBUTEDATA +#else + override __.GetCustomAttributesData() = customAttributesImpl.GetCustomAttributesData() +#endif + + member __.DeclaringTypeImpl with set x = declaringType <- x // check: not set twice + + member __.IsStatic + with get() = isStatic + and set x = isStatic <- x + + member __.GetterCode + with set (q:Expr list -> Expr) = + if not getter.IsValueCreated then getterCode <- Some q else failwith "ProvidedProperty: getter MethodInfo has already been created" + + member __.SetterCode + with set (q:Expr list -> Expr) = + if not (setter.IsValueCreated) then setterCode <- Some q else failwith "ProvidedProperty: setter MethodInfo has already been created" + + // Implement overloads + override __.PropertyType = propertyType + override __.SetValue(_obj, _value, _invokeAttr, _binder, _index, _culture) = notRequired "SetValue" propertyName + override __.GetAccessors _nonPublic = notRequired "nonPublic" propertyName + override __.GetGetMethod _nonPublic = if hasGetter() then getter.Force() :> MethodInfo else null + override __.GetSetMethod _nonPublic = if hasSetter() then setter.Force() :> MethodInfo else null + override __.GetIndexParameters() = [| for p in parameters -> upcast p |] + override __.Attributes = PropertyAttributes.None + override __.CanRead = hasGetter() + override __.CanWrite = hasSetter() + override __.GetValue(_obj, _invokeAttr, _binder, _index, _culture) : obj = notRequired "GetValue" propertyName + override __.Name = propertyName + override __.DeclaringType = declaringType |> nonNull "ProvidedProperty.DeclaringType" + override __.MemberType : MemberTypes = MemberTypes.Property + + override __.ReflectedType = notRequired "ReflectedType" propertyName + override __.GetCustomAttributes(_inherit) = notRequired "GetCustomAttributes" propertyName + override __.GetCustomAttributes(_attributeType, _inherit) = notRequired "GetCustomAttributes" propertyName + override __.IsDefined(_attributeType, _inherit) = notRequired "IsDefined" propertyName + +type ProvidedEvent(eventName:string,eventHandlerType:Type) = + inherit System.Reflection.EventInfo() + // State + + let mutable declaringType = null + let mutable isStatic = false + let mutable adderCode = None : option Expr> + let mutable removerCode = None : option 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 __.AddXmlDocComputed xmlDocFunction = customAttributesImpl.AddXmlDocComputed xmlDocFunction + member __.AddXmlDocDelayed xmlDocFunction = customAttributesImpl.AddXmlDocDelayed xmlDocFunction + member __.AddXmlDoc xmlDoc = customAttributesImpl.AddXmlDoc xmlDoc + member __.AddDefinitionLocation(line,column,filePath) = customAttributesImpl.AddDefinitionLocation(line, column, filePath) + member __.GetCustomAttributesDataImpl() = customAttributesImpl.GetCustomAttributesData() +#if FX_NO_CUSTOMATTRIBUTEDATA +#else + override __.GetCustomAttributesData() = customAttributesImpl.GetCustomAttributesData() +#endif + + member __.DeclaringTypeImpl with set x = declaringType <- x // check: not set twice + member __.IsStatic + with get() = isStatic + and set x = isStatic <- x + + member __.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 __.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 __.EventHandlerType = eventHandlerType + override __.GetAddMethod _nonPublic = adder.Force() :> MethodInfo + override __.GetRemoveMethod _nonPublic = remover.Force() :> MethodInfo + override __.Attributes = EventAttributes.None + override __.Name = eventName + override __.DeclaringType = declaringType |> nonNull "ProvidedEvent.DeclaringType" + override __.MemberType : MemberTypes = MemberTypes.Event + + override __.GetRaiseMethod _nonPublic = notRequired "GetRaiseMethod" eventName + override __.ReflectedType = notRequired "ReflectedType" eventName + override __.GetCustomAttributes(_inherit) = notRequired "GetCustomAttributes" eventName + override __.GetCustomAttributes(_attributeType, _inherit) = notRequired "GetCustomAttributes" eventName + override __.IsDefined(_attributeType, _inherit) = notRequired "IsDefined" eventName + +type ProvidedLiteralField(fieldName:string,fieldType:Type,literalValue:obj) = + inherit System.Reflection.FieldInfo() + // State + + let mutable declaringType = null + + let customAttributesImpl = CustomAttributesImpl() + member __.AddXmlDocComputed xmlDocFunction = customAttributesImpl.AddXmlDocComputed xmlDocFunction + member __.AddXmlDocDelayed xmlDocFunction = customAttributesImpl.AddXmlDocDelayed xmlDocFunction + member __.AddXmlDoc xmlDoc = customAttributesImpl.AddXmlDoc xmlDoc + member __.AddObsoleteAttribute (message,?isError) = customAttributesImpl.AddObsolete (message,defaultArg isError false) + member __.AddDefinitionLocation(line,column,filePath) = customAttributesImpl.AddDefinitionLocation(line, column, filePath) + member __.GetCustomAttributesDataImpl() = customAttributesImpl.GetCustomAttributesData() +#if FX_NO_CUSTOMATTRIBUTEDATA +#else + override __.GetCustomAttributesData() = customAttributesImpl.GetCustomAttributesData() +#endif + + member __.DeclaringTypeImpl with set x = declaringType <- x // check: not set twice + + + // Implement overloads + override __.FieldType = fieldType + override __.GetRawConstantValue() = literalValue + override __.Attributes = FieldAttributes.Static ||| FieldAttributes.Literal ||| FieldAttributes.Public + override __.Name = fieldName + override __.DeclaringType = declaringType |> nonNull "ProvidedLiteralField.DeclaringType" + override __.MemberType : MemberTypes = MemberTypes.Field + + override __.ReflectedType = notRequired "ReflectedType" fieldName + override __.GetCustomAttributes(_inherit) = notRequired "GetCustomAttributes" fieldName + override __.GetCustomAttributes(_attributeType, _inherit) = notRequired "GetCustomAttributes" fieldName + override __.IsDefined(_attributeType, _inherit) = notRequired "IsDefined" fieldName + + override __.SetValue(_obj, _value, _invokeAttr, _binder, _culture) = notRequired "SetValue" fieldName + override __.GetValue(_obj) : obj = notRequired "GetValue" fieldName + override __.FieldHandle = notRequired "FieldHandle" fieldName + +type ProvidedField(fieldName:string,fieldType:Type) = + inherit System.Reflection.FieldInfo() + // State + + let mutable declaringType = null + + let customAttributesImpl = CustomAttributesImpl() + let mutable fieldAttrs = FieldAttributes.Private + member __.AddXmlDocComputed xmlDocFunction = customAttributesImpl.AddXmlDocComputed xmlDocFunction + member __.AddXmlDocDelayed xmlDocFunction = customAttributesImpl.AddXmlDocDelayed xmlDocFunction + member __.AddXmlDoc xmlDoc = customAttributesImpl.AddXmlDoc xmlDoc + member __.AddObsoleteAttribute (message,?isError) = customAttributesImpl.AddObsolete (message,defaultArg isError false) + member __.AddDefinitionLocation(line,column,filePath) = customAttributesImpl.AddDefinitionLocation(line, column, filePath) + member __.GetCustomAttributesDataImpl() = customAttributesImpl.GetCustomAttributesData() +#if FX_NO_CUSTOMATTRIBUTEDATA +#else + override __.GetCustomAttributesData() = customAttributesImpl.GetCustomAttributesData() +#endif + + member __.DeclaringTypeImpl with set x = declaringType <- x // check: not set twice + + member __.SetFieldAttributes attrs = fieldAttrs <- attrs + // Implement overloads + override __.FieldType = fieldType + override __.GetRawConstantValue() = null + override __.Attributes = fieldAttrs + override __.Name = fieldName + override __.DeclaringType = declaringType |> nonNull "ProvidedField.DeclaringType" + override __.MemberType : MemberTypes = MemberTypes.Field + + override __.ReflectedType = notRequired "ReflectedType" fieldName + override __.GetCustomAttributes(_inherit) = notRequired "GetCustomAttributes" fieldName + override __.GetCustomAttributes(_attributeType, _inherit) = notRequired "GetCustomAttributes" fieldName + override __.IsDefined(_attributeType, _inherit) = notRequired "IsDefined" fieldName + + override __.SetValue(_obj, _value, _invokeAttr, _binder, _culture) = notRequired "SetValue" fieldName + override __.GetValue(_obj) : obj = notRequired "GetValue" fieldName + override __.FieldHandle = notRequired "FieldHandle" fieldName + +/// Represents the type constructor in a provided symbol type. +[] +type ProvidedSymbolKind = + | 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: ProvidedSymbolKind, args: Type list, convToTgt: Type -> Type) = + 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 + | ProvidedSymbolKind.SDArray, [ty] | ProvidedSymbolKind.Array _, [ty] when otherTy.IsArray-> ty.Equals(otherTy.GetElementType()) + | ProvidedSymbolKind.ByRef, [ty] when otherTy.IsByRef -> ty.Equals(otherTy.GetElementType()) + | ProvidedSymbolKind.Pointer, [ty] when otherTy.IsPointer -> ty.Equals(otherTy.GetElementType()) + | ProvidedSymbolKind.Generic baseTy, args -> otherTy.IsGenericType && isEquivalentTo baseTy (otherTy.GetGenericTypeDefinition()) && Seq.forall2 isEquivalentTo args (otherTy.GetGenericArguments()) + | _ -> false + | a, b -> a.Equals b + + let nameText() = + match kind,args with + | ProvidedSymbolKind.SDArray,[arg] -> arg.Name + "[]" + | ProvidedSymbolKind.Array _,[arg] -> arg.Name + "[*]" + | ProvidedSymbolKind.Pointer,[arg] -> arg.Name + "*" + | ProvidedSymbolKind.ByRef,[arg] -> arg.Name + "&" + | ProvidedSymbolKind.Generic gty, args -> gty.Name + (sprintf "%A" args) + | ProvidedSymbolKind.FSharpTypeAbbreviation (_,_,path),_ -> path.[path.Length-1] + | _ -> failwith "unreachable" + + /// Substitute types for type variables. + 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()) + ty.GetGenericTypeDefinition().MakeGenericType(args) + elif ty.HasElementType then + let ety = ProvidedSymbolType.convType parameters (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 + elif ty.IsGenericParameter then + if ty.GenericParameterPosition <= parameters.Length - 1 then + parameters.[ty.GenericParameterPosition] + else + ty + else ty + + override __.FullName = + match kind,args with + | ProvidedSymbolKind.SDArray,[arg] -> arg.FullName + "[]" + | ProvidedSymbolKind.Array _,[arg] -> arg.FullName + "[*]" + | ProvidedSymbolKind.Pointer,[arg] -> arg.FullName + "*" + | ProvidedSymbolKind.ByRef,[arg] -> arg.FullName + "&" + | ProvidedSymbolKind.Generic gty, args -> gty.FullName + "[" + (args |> List.map (fun arg -> arg.ToString()) |> String.concat ",") + "]" + | ProvidedSymbolKind.FSharpTypeAbbreviation (_,nsp,path),args -> String.concat "." (Array.append [| nsp |] path) + (match args with [] -> "" | _ -> 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 __.DeclaringType = + match kind,args with + | ProvidedSymbolKind.SDArray,[arg] -> arg + | ProvidedSymbolKind.Array _,[arg] -> arg + | ProvidedSymbolKind.Pointer,[arg] -> arg + | ProvidedSymbolKind.ByRef,[arg] -> arg + | ProvidedSymbolKind.Generic gty,_ -> gty + | ProvidedSymbolKind.FSharpTypeAbbreviation _,_ -> null + | _ -> failwith "unreachable" + + override __.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 __.Name = nameText() + + override __.BaseType = + match kind with + | ProvidedSymbolKind.SDArray -> convToTgt typeof + | ProvidedSymbolKind.Array _ -> convToTgt typeof + | ProvidedSymbolKind.Pointer -> convToTgt typeof + | ProvidedSymbolKind.ByRef -> convToTgt typeof + | ProvidedSymbolKind.Generic gty -> + if gty.BaseType = null then null else + ProvidedSymbolType.convType args gty.BaseType + | ProvidedSymbolKind.FSharpTypeAbbreviation _ -> convToTgt typeof + + override __.GetArrayRank() = (match kind with ProvidedSymbolKind.Array n -> n | ProvidedSymbolKind.SDArray -> 1 | _ -> invalidOp "non-array type") + override __.IsValueTypeImpl() = (match kind with ProvidedSymbolKind.Generic gtd -> gtd.IsValueType | _ -> false) + override __.IsArrayImpl() = (match kind with ProvidedSymbolKind.Array _ | ProvidedSymbolKind.SDArray -> true | _ -> false) + override __.IsByRefImpl() = (match kind with ProvidedSymbolKind.ByRef _ -> true | _ -> false) + override __.IsPointerImpl() = (match kind with ProvidedSymbolKind.Pointer _ -> true | _ -> false) + override __.IsPrimitiveImpl() = false + override __.IsGenericType = (match kind with ProvidedSymbolKind.Generic _ -> true | _ -> false) + override __.GetGenericArguments() = (match kind with ProvidedSymbolKind.Generic _ -> args |> List.toArray | _ -> invalidOp "non-generic type") + override __.GetGenericTypeDefinition() = (match kind with ProvidedSymbolKind.Generic e -> e | _ -> invalidOp "non-generic type") + override __.IsCOMObjectImpl() = false + override __.HasElementTypeImpl() = (match kind with ProvidedSymbolKind.Generic _ -> false | _ -> true) + override __.GetElementType() = (match kind,args with (ProvidedSymbolKind.Array _ | ProvidedSymbolKind.SDArray | ProvidedSymbolKind.ByRef | ProvidedSymbolKind.Pointer),[e] -> e | _ -> invalidOp "not an array, pointer or byref type") + override this.ToString() = this.FullName + + override __.Assembly = + match kind with + | ProvidedSymbolKind.FSharpTypeAbbreviation (assembly,_nsp,_path) -> assembly + | ProvidedSymbolKind.Generic gty -> gty.Assembly + | _ -> notRequired "Assembly" (nameText()) + + override __.Namespace = + match kind with + | ProvidedSymbolKind.FSharpTypeAbbreviation (_assembly,nsp,_path) -> nsp + | _ -> notRequired "Namespace" (nameText()) + + override __.GetHashCode() = + match kind,args with + | ProvidedSymbolKind.SDArray,[arg] -> 10 + hash arg + | ProvidedSymbolKind.Array _,[arg] -> 163 + hash arg + | ProvidedSymbolKind.Pointer,[arg] -> 283 + hash arg + | ProvidedSymbolKind.ByRef,[arg] -> 43904 + hash arg + | ProvidedSymbolKind.Generic gty,_ -> 9797 + hash gty + List.sumBy hash args + | ProvidedSymbolKind.FSharpTypeAbbreviation _,_ -> 3092 + | _ -> failwith "unreachable" + + override __.Equals(other: obj) = + match other with + | :? ProvidedSymbolType as otherTy -> (kind, args) = (otherTy.Kind, otherTy.Args) + | _ -> false + + member __.Kind = kind + member __.Args = args + + member __.IsFSharpTypeAbbreviation = match kind with FSharpTypeAbbreviation _ -> true | _ -> false + // For example, int + member __.IsFSharpUnitAnnotated = match kind with ProvidedSymbolKind.Generic gtd -> not gtd.IsGenericTypeDefinition | _ -> false + + override __.Module : Module = notRequired "Module" (nameText()) + override __.GetConstructors _bindingAttr = notRequired "GetConstructors" (nameText()) + override __.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" (nameText()) + override __.GetMembers _bindingAttr = notRequired "GetMembers" (nameText()) + override __.GetMethods _bindingAttr = notRequired "GetMethods" (nameText()) + override __.GetField(_name, _bindingAttr) = notRequired "GetField" (nameText()) + override __.GetFields _bindingAttr = notRequired "GetFields" (nameText()) + override __.GetInterface(_name, _ignoreCase) = notRequired "GetInterface" (nameText()) + override __.GetInterfaces() = notRequired "GetInterfaces" (nameText()) + override __.GetEvent(_name, _bindingAttr) = notRequired "GetEvent" (nameText()) + override __.GetEvents _bindingAttr = notRequired "GetEvents" (nameText()) + override __.GetProperties _bindingAttr = notRequired "GetProperties" (nameText()) + override __.GetPropertyImpl(_name, _bindingAttr, _binder, _returnType, _types, _modifiers) = notRequired "GetPropertyImpl" (nameText()) + override __.GetNestedTypes _bindingAttr = notRequired "GetNestedTypes" (nameText()) + override __.GetNestedType(_name, _bindingAttr) = notRequired "GetNestedType" (nameText()) + override __.GetAttributeFlagsImpl() = notRequired "GetAttributeFlagsImpl" (nameText()) + override this.UnderlyingSystemType = + match kind with + | ProvidedSymbolKind.SDArray + | ProvidedSymbolKind.Array _ + | ProvidedSymbolKind.Pointer + | ProvidedSymbolKind.FSharpTypeAbbreviation _ + | ProvidedSymbolKind.ByRef -> upcast this + | ProvidedSymbolKind.Generic gty -> gty.UnderlyingSystemType +#if FX_NO_CUSTOMATTRIBUTEDATA +#else + override __.GetCustomAttributesData() = ([| |] :> IList<_>) +#endif + override __.MemberType = notRequired "MemberType" (nameText()) + override __.GetMember(_name,_mt,_bindingAttr) = notRequired "GetMember" (nameText()) + override __.GUID = notRequired "GUID" (nameText()) + override __.InvokeMember(_name, _invokeAttr, _binder, _target, _args, _modifiers, _culture, _namedParameters) = notRequired "InvokeMember" (nameText()) + override __.AssemblyQualifiedName = notRequired "AssemblyQualifiedName" (nameText()) + override __.GetConstructorImpl(_bindingAttr, _binder, _callConvention, _types, _modifiers) = notRequired "GetConstructorImpl" (nameText()) + override __.GetCustomAttributes(_inherit) = [| |] + override __.GetCustomAttributes(_attributeType, _inherit) = [| |] + override __.IsDefined(_attributeType, _inherit) = false + // FSharp.Data addition: this was added to support arrays of arrays + override this.MakeArrayType() = ProvidedSymbolType(ProvidedSymbolKind.SDArray, [this], convToTgt) :> Type + override this.MakeArrayType arg = ProvidedSymbolType(ProvidedSymbolKind.Array arg, [this], convToTgt) :> Type + +type ProvidedSymbolMethod(genericMethodDefinition: MethodInfo, parameters: Type list) = + inherit System.Reflection.MethodInfo() + + let convParam (p:ParameterInfo) = + { new System.Reflection.ParameterInfo() with + override __.Name = p.Name + override __.ParameterType = ProvidedSymbolType.convType parameters p.ParameterType + override __.Attributes = p.Attributes + override __.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 __.GetGenericMethodDefinition() = genericMethodDefinition + + override __.DeclaringType = ProvidedSymbolType.convType parameters genericMethodDefinition.DeclaringType + override __.ToString() = "Method " + genericMethodDefinition.Name + override __.Name = genericMethodDefinition.Name + override __.MetadataToken = genericMethodDefinition.MetadataToken + override __.Attributes = genericMethodDefinition.Attributes + override __.CallingConvention = genericMethodDefinition.CallingConvention + override __.MemberType = genericMethodDefinition.MemberType + + override __.IsDefined(_attributeType, _inherit) : bool = notRequired "IsDefined" genericMethodDefinition.Name + override __.ReturnType = ProvidedSymbolType.convType parameters genericMethodDefinition.ReturnType + override __.GetParameters() = genericMethodDefinition.GetParameters() |> Array.map convParam + override __.ReturnParameter = genericMethodDefinition.ReturnParameter |> convParam + override __.ReturnTypeCustomAttributes = notRequired "ReturnTypeCustomAttributes" genericMethodDefinition.Name + override __.GetBaseDefinition() = notRequired "GetBaseDefinition" genericMethodDefinition.Name + override __.GetMethodImplementationFlags() = notRequired "GetMethodImplementationFlags" genericMethodDefinition.Name + override __.MethodHandle = notRequired "MethodHandle" genericMethodDefinition.Name + override __.Invoke(_obj, _invokeAttr, _binder, _parameters, _culture) = notRequired "Invoke" genericMethodDefinition.Name + override __.ReflectedType = notRequired "ReflectedType" genericMethodDefinition.Name + override __.GetCustomAttributes(_inherit) = notRequired "GetCustomAttributes" genericMethodDefinition.Name + override __.GetCustomAttributes(_attributeType, _inherit) = notRequired "GetCustomAttributes" genericMethodDefinition.Name + + + +type ProvidedTypeBuilder() = + static member MakeGenericType(genericTypeDefinition, genericArguments) = ProvidedSymbolType(Generic genericTypeDefinition, genericArguments, id) :> Type + static member MakeGenericMethod(genericMethodDefinition, genericArguments) = ProvidedSymbolMethod(genericMethodDefinition, genericArguments) :> MethodInfo + +type ZProvidedTypeBuilder(convToTgt: Type -> Type) = + member __.MakeGenericType(genericTypeDefinition, genericArguments) = ProvidedSymbolType(Generic genericTypeDefinition, genericArguments, convToTgt) :> Type + member __.MakeGenericMethod(genericMethodDefinition, genericArguments) = ProvidedSymbolMethod(genericMethodDefinition, genericArguments) :> MethodInfo + +[] +type ProvidedMeasureBuilder() = + + // TODO: this shouldn't be hardcoded, but without creating a dependency on FSharp.Compiler.Service + // 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 __.One = typeof + member __.Product (m1,m2) = typedefof>.MakeGenericType [| m1;m2 |] + member __.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 __.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(ProvidedSymbolKind.FSharpTypeAbbreviation(typeof.Assembly,ns,[| unitName |]), [], id) :> Type + | None -> + typedefof>.Assembly.GetType("Microsoft.FSharp.Data.UnitSystems.SI.UnitNames." + mLowerCase) + + member __.AnnotateType (basicType, annotation) = ProvidedSymbolType(Generic basicType, annotation, id) :> Type + + + +[] +type TypeContainer = + | Namespace of Assembly * string // namespace + | Type of System.Type + | TypeToBeDecided + +#if NO_GENERATIVE +#else +module GlobalProvidedAssemblyElementsTable = + let theTable = Dictionary>() +#endif + +type ProvidedTypeDefinition(container:TypeContainer, className : string, baseType : Type option, convToTgt) 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 = None + 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" className) + + 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" className) + + 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" className) + + 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" className) + + 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 __.AddXmlDocComputed xmlDocFunction = customAttributesImpl.AddXmlDocComputed xmlDocFunction + member __.AddXmlDocDelayed xmlDocFunction = customAttributesImpl.AddXmlDocDelayed xmlDocFunction + member __.AddXmlDoc xmlDoc = customAttributesImpl.AddXmlDoc xmlDoc + member __.AddObsoleteAttribute (message,?isError) = customAttributesImpl.AddObsolete (message,defaultArg isError false) + member __.AddDefinitionLocation(line,column,filePath) = customAttributesImpl.AddDefinitionLocation(line, column, filePath) + member __.HideObjectMethods with set v = customAttributesImpl.HideObjectMethods <- v + member __.NonNullable with set v = customAttributesImpl.NonNullable <- v + member __.GetCustomAttributesDataImpl() = customAttributesImpl.GetCustomAttributesData() + member __.AddCustomAttribute attribute = customAttributesImpl.AddCustomAttribute attribute +#if FX_NO_CUSTOMATTRIBUTEDATA +#else + override __.GetCustomAttributesData() = customAttributesImpl.GetCustomAttributesData() +#endif + + member __.ResetEnclosingType (ty) = + container <- TypeContainer.Type ty + new (assembly:Assembly,namespaceName,className,baseType) = new ProvidedTypeDefinition(TypeContainer.Namespace (assembly,namespaceName), className, baseType, id) + new (className:string,baseType) = new ProvidedTypeDefinition(TypeContainer.TypeToBeDecided, className, baseType, id) + + new (assembly:Assembly,namespaceName,className,baseType,convToTgt) = new ProvidedTypeDefinition(TypeContainer.Namespace (assembly,namespaceName), className, baseType, convToTgt) + new (className,baseType, convToTgt) = new ProvidedTypeDefinition(TypeContainer.TypeToBeDecided, className, baseType, convToTgt) + // state ops + + override __.UnderlyingSystemType = typeof + + member __.SetEnumUnderlyingType(ty) = enumUnderlyingType <- Some ty + + override __.GetEnumUnderlyingType() = + if this.IsEnum then + match enumUnderlyingType with + | None -> convToTgt typeof + | Some ty -> ty + else invalidOp "not enum type" + + member __.SetBaseType t = baseType <- lazy Some t + + member __.SetBaseTypeDelayed baseTypeFunction = baseType <- lazy (Some (baseTypeFunction())) + + member __.SetAttributes x = attributes <- x + + // Add MemberInfos + member __.AddMembersDelayed(membersFunction : unit -> list<#MemberInfo>) = + membersQueue.Add (fun () -> membersFunction() |> List.map (fun x -> patchUpAddedMemberInfo this x; x :> MemberInfo )) + + member __.AddMembers(memberInfos:list<#MemberInfo>) = (* strict *) + memberInfos |> List.iter (patchUpAddedMemberInfo this) // strict: patch up now + membersQueue.Add (fun () -> memberInfos |> List.map (fun x -> x :> MemberInfo)) + + member __.AddMember(memberInfo:MemberInfo) = + this.AddMembers [memberInfo] + + member __.AddMemberDelayed(memberFunction : unit -> #MemberInfo) = + this.AddMembersDelayed(fun () -> [memberFunction()]) + +#if NO_GENERATIVE +#else + member __.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) +#endif + + /// Abstract a type to a parametric-type. Requires "formal parameters" and "instantiation function". + member __.DefineStaticParameters(staticParameters : list, apply : (string -> obj[] -> ProvidedTypeDefinition)) = + staticParams <- staticParameters + staticParamsApply <- Some apply + + /// Get ParameterInfo[] for the parametric type parameters (//s GetGenericParameters) + member __.GetStaticParameters() = [| for p in staticParams -> p :> ParameterInfo |] + + /// Instantiate parametrics type + member __.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 __.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 __.Assembly = theAssembly.Force() + + member __.SetAssembly assembly = theAssembly <- lazy assembly + + member __.SetAssemblyLazy assembly = theAssembly <- assembly + + override __.FullName = fullName.Force() + + override __.Namespace = rootNamespace.Force() + + override __.BaseType = match baseType.Value with Some ty -> ty | None -> null + + // Constructors + override __.GetConstructors bindingAttr = + [| for m in this.GetMembers bindingAttr do + if m.MemberType = MemberTypes.Constructor then + yield (m :?> ConstructorInfo) |] + // Methods + override __.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 __.GetMethods bindingAttr = + this.GetMembers bindingAttr + |> Array.filter (fun m -> m.MemberType.HasFlag(MemberTypes.Method)) + |> Array.map (fun m -> m :?> MethodInfo) + + // Fields + override __.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 __.GetFields bindingAttr = + [| for m in this.GetMembers bindingAttr do if m.MemberType.HasFlag(MemberTypes.Field) then yield m :?> FieldInfo |] + + override __.GetInterface(_name, _ignoreCase) = notRequired "GetInterface" this.Name + + override __.GetInterfaces() = + [| yield! getInterfaces() |] + + member __.GetInterfaceImplementations() = + [| yield! getInterfaces() |] + + member __.AddInterfaceImplementation ityp = interfaceImpls.Add ityp + + member __.AddInterfaceImplementationsDelayed itypf = interfaceImplsDelayed.Add itypf + + member __.GetMethodOverrides() = + [| yield! methodOverrides |] + + member __.DefineMethodOverride (bodyMethInfo,declMethInfo) = methodOverrides.Add (bodyMethInfo, declMethInfo) + + // Events + override __.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 __.GetEvents bindingAttr = + [| for m in this.GetMembers bindingAttr do if m.MemberType.HasFlag(MemberTypes.Event) then yield downcast m |] + + // Properties + override __.GetProperties bindingAttr = + [| for m in this.GetMembers bindingAttr do if m.MemberType.HasFlag(MemberTypes.Property) then yield downcast m |] + + override __.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 __.MakeArrayType() = ProvidedSymbolType(ProvidedSymbolKind.SDArray, [this], convToTgt) :> Type + override __.MakeArrayType arg = ProvidedSymbolType(ProvidedSymbolKind.Array arg, [this], convToTgt) :> Type + override __.MakePointerType() = ProvidedSymbolType(ProvidedSymbolKind.Pointer, [this], convToTgt) :> Type + override __.MakeByRefType() = ProvidedSymbolType(ProvidedSymbolKind.ByRef, [this], convToTgt) :> 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) : Type = + match t with + | :? ProvidedTypeDefinition as ptd when ptd.IsErased -> ProvidedTypeDefinition.EraseType t.BaseType + | t when t.IsArray -> + let rank = t.GetArrayRank() + let et = ProvidedTypeDefinition.EraseType (t.GetElementType()) + if rank = 0 then et.MakeArrayType() else et.MakeArrayType(rank) + | :? ProvidedSymbolType as sym when sym.IsFSharpUnitAnnotated -> + t.UnderlyingSystemType + | 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 __.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 __.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 __.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 __.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 __.GetAttributeFlagsImpl() = adjustTypeAttributes attributes this.IsNested + override this.IsValueTypeImpl() = if this.BaseType <> null then this.BaseType = typeof || this.BaseType.IsValueType else false + override __.IsArrayImpl() = false + override __.IsByRefImpl() = false + override __.IsPointerImpl() = false + override __.IsPrimitiveImpl() = false + override __.IsCOMObjectImpl() = false + override __.HasElementTypeImpl() = false + override __.Name = className + override __.DeclaringType = declaringType.Force() + override __.MemberType = if this.IsNested then MemberTypes.NestedType else MemberTypes.TypeInfo + override __.GetHashCode() = rootNamespace.GetHashCode() ^^^ className.GetHashCode() + override __.Equals(that:obj) = + match that with + | null -> false + | :? ProvidedTypeDefinition as ti -> System.Object.ReferenceEquals(this,ti) + | _ -> false + + override __.GetGenericArguments() = [||] + override __.ToString() = this.Name + + + override __.Module : Module = notRequired "Module" this.Name + override __.GUID = Guid.Empty + override __.GetConstructorImpl(_bindingAttr, _binder, _callConvention, _types, _modifiers) = null + override __.GetCustomAttributes(_inherit) = [| |] + override __.GetCustomAttributes(_attributeType, _inherit) = [| |] + override __.IsDefined(_attributeType: Type, _inherit) = false + + override __.GetElementType() = notRequired "Module" this.Name + override __.InvokeMember(_name, _invokeAttr, _binder, _target, _args, _modifiers, _culture, _namedParameters) = notRequired "Module" this.Name + override __.AssemblyQualifiedName = notRequired "Module" this.Name + member __.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 __.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)) + + +#if NO_GENERATIVE +#else +//------------------------------------------------------------------------------------------------- +// The assembly compiler for generative type providers. + +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 transType (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 transType (ty.GetGenericArguments())) + elif ty.HasElementType then + let ety = transType (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 transCtor (f:ConstructorInfo) = match f with :? ProvidedConstructor as pc when ctorMap.ContainsKey pc -> ctorMap.[pc] :> ConstructorInfo | c -> c + let transField (f:FieldInfo) = match f with :? ProvidedField as pf when fieldMap.ContainsKey pf -> fieldMap.[pf] :> FieldInfo | f -> f + let transMeth (m:MethodInfo) = match m with :? ProvidedMethod as pm when methMap.ContainsKey pm -> methMap.[pm] :> MethodInfo | m -> m + let isLiteralEnumField (f:FieldInfo) = match f with :? ProvidedLiteralField as plf -> plf.DeclaringType.IsEnum | _ -> false + + 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(transType 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() -> transType 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, transType finfo.FieldType, finfo.Attributes, pinfo.GetCustomAttributesDataImpl(), None) + | :? ProvidedLiteralField as pinfo -> + Some (pinfo.Name, transType 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, transType minfo.ReturnType, [| for p in minfo.GetParameters() -> transType 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, transType ctorArg.ParameterType, FieldAttributes.Private) ] + + + + // 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 Var("this", pcinfo.DeclaringType) + for p in pcinfo.GetParameters() do + yield Var(p.Name, p.ParameterType) |] + + let codeGen = CodeGenerator(assemblyMainModule, uniqueLambdaTypeName, implicitCtorArgsAsFields, transType, transField, transMeth, transCtor, isLiteralEnumField, ilg, locals, parameterVars) + let parameters = + [| for v in parameterVars -> 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 + codeGen.EmitExpr (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 parameters + codeGen.EmitExpr (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 [||] + let codeGen = CodeGenerator(assemblyMainModule, uniqueLambdaTypeName, implicitCtorArgsAsFields, transType, transField, transMeth, transCtor, isLiteralEnumField, ilg, new Dictionary<_, _>(), [| |]) + codeGen.EmitExpr (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 Var("this", pminfo.DeclaringType) + for p in pminfo.GetParameters() do + yield Var(p.Name, p.ParameterType) |] + let parameters = + [| for v in parameterVars -> 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 + let codeGen = CodeGenerator(assemblyMainModule, uniqueLambdaTypeName, implicitCtorArgsAsFields, transType, transField, transMeth, transCtor, isLiteralEnumField, ilg, locals, parameterVars) + codeGen.EmitExpr (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, transType pinfo.PropertyType, [| for p in pinfo.GetIndexParameters() -> transType 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 + + let resolveHandler = ResolveEventHandler(fun _ args -> + // On Mono args.Name is full name of the type, on .NET - just name (no namespace) + typeMap.Values + |> Seq.filter (fun tb -> tb.FullName = args.Name || tb.Name = args.Name) + |> Seq.iter (fun tb -> tb.CreateType() |> ignore) + + assemblyMainModule.Assembly) + + try + AppDomain.CurrentDomain.add_TypeResolve resolveHandler + iterateTypes (fun tb _ -> tb.CreateType() |> ignore) + finally + AppDomain.CurrentDomain.remove_TypeResolve resolveHandler + +#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 + +#endif // NO_GENERATIVE + +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 + } + + +#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 __.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 __.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 __.RegisterProbingFolder (folder) = + // use GetFullPath to ensure that folder is valid + ignore(IO.Path.GetFullPath folder) + probingFolders.Add folder + + member __.RegisterRuntimeAssemblyLocationAsProbingFolder (config : TypeProviderConfig) = + config.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 this.Invalidate() = invalidateE.Trigger(this,EventArgs()) + + member __.GetStaticParametersForMethod(mb: MethodBase) = + // printfn "In GetStaticParametersForMethod" + match mb with + | :? ProvidedMethod as t -> t.GetStaticParameters() + | _ -> [| |] + + member __.ApplyStaticArgumentsForMethod(mb: MethodBase, mangledName, objs) = + // printfn "In ApplyStaticArgumentsForMethod" + match mb with + | :? ProvidedMethod as t -> t.ApplyStaticArguments(mangledName, objs) :> MethodBase + | _ -> failwith (sprintf "ApplyStaticArguments: static parameters for method %s are unexpected" mb.Name) + + interface ITypeProvider with + + [] + override __.Invalidate = invalidateE.Publish + + override __.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 -> + Expr.NewObjectUnchecked(cinfo, Array.toList parameters) + | :? System.Reflection.MethodInfo as minfo -> + if minfo.IsStatic then + Expr.CallUnchecked(minfo, Array.toList parameters) + else + Expr.CallUnchecked(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 + | NewObject(ctor, args) -> getInvokerExpression ctor [| for arg in args -> expand arg|] + | Call(inst, mi, args) -> + let args = + [| + match inst with + | Some inst -> yield expand inst + | _ -> () + yield! List.map expand args + |] + getInvokerExpression mi args + | ShapeCombinationUnchecked(shape, args) -> RebuildShapeCombinationUnchecked(shape, List.map expand args) + | ShapeVarUnchecked v -> Expr.Var v + | ShapeLambdaUnchecked(v, body) -> Expr.Lambda(v, expand body) + 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 __.GetStaticParameters(ty) = + match ty with + | :? ProvidedTypeDefinition as t -> + if ty.Name = t.Name (* REVIEW: use equality? *) then + t.GetStaticParameters() + else + [| |] + | _ -> [| |] + + override __.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 NO_GENERATIVE + override __.GetGeneratedAssemblyContents(_assembly) = + failwith "no generative assemblies" +#else +#if FX_NO_LOCAL_FILESYSTEM + override __.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 __.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 +#endif diff --git a/src/Xamarin.iOSProviders/ProvidedTypes.fsi b/paket-files/fsprojects/FSharp.TypeProviders.StarterPack/src/ProvidedTypes.fsi similarity index 99% rename from src/Xamarin.iOSProviders/ProvidedTypes.fsi rename to paket-files/fsprojects/FSharp.TypeProviders.StarterPack/src/ProvidedTypes.fsi index fadc9fe..145bb9a 100644 --- a/src/Xamarin.iOSProviders/ProvidedTypes.fsi +++ b/paket-files/fsprojects/FSharp.TypeProviders.StarterPack/src/ProvidedTypes.fsi @@ -523,4 +523,4 @@ module internal UncheckedQuotations = type Shape val ( |ShapeCombinationUnchecked|ShapeVarUnchecked|ShapeLambdaUnchecked| ) : e:Expr -> Choice<(Shape * Expr list),Var, (Var * Expr)> - val RebuildShapeCombinationUnchecked : Shape * args:Expr list -> Expr \ No newline at end of file + val RebuildShapeCombinationUnchecked : Shape * args:Expr list -> Expr diff --git a/paket-files/fsprojects/FSharp.TypeProviders.StarterPack/src/paket.version b/paket-files/fsprojects/FSharp.TypeProviders.StarterPack/src/paket.version new file mode 100644 index 0000000..4123ca0 --- /dev/null +++ b/paket-files/fsprojects/FSharp.TypeProviders.StarterPack/src/paket.version @@ -0,0 +1 @@ +1dab4f94411500794342f61f877feab772e5a754 diff --git a/paket.dependencies b/paket.dependencies index 0d585cf..ade02db 100644 --- a/paket.dependencies +++ b/paket.dependencies @@ -5,4 +5,7 @@ nuget FSharp.TypeProviders.StarterPack 1.1.3.88 nuget Unquote 3.1.1 nuget Xamarin.Android.Support.v4 23.1.1.0 restriction: >= monoandroid6.0 nuget Xamarin.Android.Support.v7.AppCompat 23.1.1.0 restriction: >= monoandroid6.0 -nuget Xamarin.TestCloud.Agent 0.14.1 restriction: >= xamarinios \ No newline at end of file +nuget Xamarin.TestCloud.Agent 0.14.1 restriction: >= xamarinios + +github fsprojects/FSharp.TypeProviders.StarterPack src/ProvidedTypes.fsi +github fsprojects/FSharp.TypeProviders.StarterPack src/ProvidedTypes.fs \ No newline at end of file diff --git a/paket.lock b/paket.lock index 4edba5d..d692076 100644 --- a/paket.lock +++ b/paket.lock @@ -7,3 +7,7 @@ NUGET Xamarin.Android.Support.v7.AppCompat (23.1.1) - restriction: >= monoandroid6.0 Xamarin.Android.Support.v4 (23.1.1) Xamarin.TestCloud.Agent (0.14.1) - restriction: >= xamarinios +GITHUB + remote: fsprojects/FSharp.TypeProviders.StarterPack + src/ProvidedTypes.fs (1dab4f94411500794342f61f877feab772e5a754) + src/ProvidedTypes.fsi (1dab4f94411500794342f61f877feab772e5a754) \ No newline at end of file diff --git a/src/Xamarin.iOSProviders/Xamarin.UIProviders.DesignTime.fsproj b/src/Xamarin.iOSProviders/Xamarin.UIProviders.DesignTime.fsproj index 6acab2a..998f543 100644 --- a/src/Xamarin.iOSProviders/Xamarin.UIProviders.DesignTime.fsproj +++ b/src/Xamarin.iOSProviders/Xamarin.UIProviders.DesignTime.fsproj @@ -62,6 +62,14 @@ + + True + paket-files/ProvidedTypes.fsi + + + True + paket-files/ProvidedTypes.fs + True diff --git a/src/Xamarin.iOSProviders/paket.references b/src/Xamarin.iOSProviders/paket.references index 7323c9c..a96da9f 100644 --- a/src/Xamarin.iOSProviders/paket.references +++ b/src/Xamarin.iOSProviders/paket.references @@ -1,3 +1,7 @@ ExtCore FSharp.TypeProviders.StarterPack -Unquote \ No newline at end of file +Unquote + +File:ProvidedTypes.fsi +File:ProvidedTypes.fs + From 63a3129a312fafae311e19899e5d92fe83460b55 Mon Sep 17 00:00:00 2001 From: Dave Thomas Date: Mon, 26 Jun 2017 21:00:09 +0100 Subject: [PATCH 07/10] Simplify references --- paket.dependencies | 1 - .../cs_test/paket.references | 1 - .../Xamarin.UIProviders.DesignTime.fsproj | 9 --------- src/Xamarin.iOSProviders/paket.references | 4 +--- 4 files changed, 1 insertion(+), 14 deletions(-) diff --git a/paket.dependencies b/paket.dependencies index ade02db..24efe9f 100644 --- a/paket.dependencies +++ b/paket.dependencies @@ -3,7 +3,6 @@ source https://www.nuget.org/api/v2 nuget ExtCore 0.8.45 restriction: >= net45 nuget FSharp.TypeProviders.StarterPack 1.1.3.88 nuget Unquote 3.1.1 -nuget Xamarin.Android.Support.v4 23.1.1.0 restriction: >= monoandroid6.0 nuget Xamarin.Android.Support.v7.AppCompat 23.1.1.0 restriction: >= monoandroid6.0 nuget Xamarin.TestCloud.Agent 0.14.1 restriction: >= xamarinios diff --git a/src/Xamarin.Android.DesignerTest/cs_test/paket.references b/src/Xamarin.Android.DesignerTest/cs_test/paket.references index 6820170..76b6e2b 100644 --- a/src/Xamarin.Android.DesignerTest/cs_test/paket.references +++ b/src/Xamarin.Android.DesignerTest/cs_test/paket.references @@ -1,2 +1 @@ -Xamarin.Android.Support.v4 Xamarin.Android.Support.v7.AppCompat \ No newline at end of file diff --git a/src/Xamarin.iOSProviders/Xamarin.UIProviders.DesignTime.fsproj b/src/Xamarin.iOSProviders/Xamarin.UIProviders.DesignTime.fsproj index 998f543..e14db13 100644 --- a/src/Xamarin.iOSProviders/Xamarin.UIProviders.DesignTime.fsproj +++ b/src/Xamarin.iOSProviders/Xamarin.UIProviders.DesignTime.fsproj @@ -71,18 +71,9 @@ paket-files/ProvidedTypes.fs - - True - - - True - - - True - diff --git a/src/Xamarin.iOSProviders/paket.references b/src/Xamarin.iOSProviders/paket.references index a96da9f..1f4c358 100644 --- a/src/Xamarin.iOSProviders/paket.references +++ b/src/Xamarin.iOSProviders/paket.references @@ -1,7 +1,5 @@ ExtCore -FSharp.TypeProviders.StarterPack Unquote File:ProvidedTypes.fsi -File:ProvidedTypes.fs - +File:ProvidedTypes.fs \ No newline at end of file From 698357a4eca7492f2ee09597fefc89c841a4a2b5 Mon Sep 17 00:00:00 2001 From: Dave Thomas Date: Mon, 26 Jun 2017 21:00:19 +0100 Subject: [PATCH 08/10] Fix mac provider --- src/Xamarin.iOSProviders/MacParsing.fs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/Xamarin.iOSProviders/MacParsing.fs b/src/Xamarin.iOSProviders/MacParsing.fs index 8b0de72..1b9094c 100644 --- a/src/Xamarin.iOSProviders/MacParsing.fs +++ b/src/Xamarin.iOSProviders/MacParsing.fs @@ -70,7 +70,8 @@ module Mac = |> Seq.collect (fun scene -> let vcElement = scene.Descendants(xn "viewController") vcElement |> Seq.choose (viewControllerMapping tryLookup) - |> Seq.map (fun vc -> {ViewControllers=vc})) + |> Seq.map (fun vc -> {ViewController=vc + View=[]})) let scenesFromStoryBoardFileName (sb:string) = let xdoc = XDocument.Load(new StreamReader(sb, true)) From f66a43407d76c1df40d7ab0b6dd20ac4104df48a Mon Sep 17 00:00:00 2001 From: Dave Thomas Date: Mon, 26 Jun 2017 21:01:54 +0100 Subject: [PATCH 09/10] Remove component from TP shims --- .../XAmarin.UIProvider.iOSRuntime.fsproj | 1 - .../Xamarin.UIProvider.OSXRuntime.fsproj | 1 - .../Xamarin.UIProvider.TVOSRuntime.fsproj | 1 - 3 files changed, 3 deletions(-) diff --git a/src/XAmarin.UIProvider.iOSRuntime/XAmarin.UIProvider.iOSRuntime.fsproj b/src/XAmarin.UIProvider.iOSRuntime/XAmarin.UIProvider.iOSRuntime.fsproj index da3d872..3785186 100644 --- a/src/XAmarin.UIProvider.iOSRuntime/XAmarin.UIProvider.iOSRuntime.fsproj +++ b/src/XAmarin.UIProvider.iOSRuntime/XAmarin.UIProvider.iOSRuntime.fsproj @@ -46,7 +46,6 @@ - \ No newline at end of file diff --git a/src/Xamarin.UIProvider.OSXRuntime/Xamarin.UIProvider.OSXRuntime.fsproj b/src/Xamarin.UIProvider.OSXRuntime/Xamarin.UIProvider.OSXRuntime.fsproj index 83b83aa..908a646 100644 --- a/src/Xamarin.UIProvider.OSXRuntime/Xamarin.UIProvider.OSXRuntime.fsproj +++ b/src/Xamarin.UIProvider.OSXRuntime/Xamarin.UIProvider.OSXRuntime.fsproj @@ -56,7 +56,6 @@ - \ No newline at end of file diff --git a/src/Xamarin.UIProvider.TVOSRuntime/Xamarin.UIProvider.TVOSRuntime.fsproj b/src/Xamarin.UIProvider.TVOSRuntime/Xamarin.UIProvider.TVOSRuntime.fsproj index b14d25b..479ea86 100644 --- a/src/Xamarin.UIProvider.TVOSRuntime/Xamarin.UIProvider.TVOSRuntime.fsproj +++ b/src/Xamarin.UIProvider.TVOSRuntime/Xamarin.UIProvider.TVOSRuntime.fsproj @@ -32,7 +32,6 @@ - From 581c77f32c7be24c7599e4f5b1c5f69530228db6 Mon Sep 17 00:00:00 2001 From: Dave Thomas Date: Mon, 26 Jun 2017 21:21:26 +0100 Subject: [PATCH 10/10] View grouping --- src/Xamarin.iOSProviders/Model.fs | 2 +- src/Xamarin.iOSProviders/iOSDesignerProvider.fs | 10 +++++++++- 2 files changed, 10 insertions(+), 2 deletions(-) diff --git a/src/Xamarin.iOSProviders/Model.fs b/src/Xamarin.iOSProviders/Model.fs index e4a7cda..780a4b4 100644 --- a/src/Xamarin.iOSProviders/Model.fs +++ b/src/Xamarin.iOSProviders/Model.fs @@ -25,4 +25,4 @@ type View = { type Scene = { ViewController : ViewController - View : View list } \ No newline at end of file + View : View } \ No newline at end of file diff --git a/src/Xamarin.iOSProviders/iOSDesignerProvider.fs b/src/Xamarin.iOSProviders/iOSDesignerProvider.fs index 47c3adc..42bb699 100644 --- a/src/Xamarin.iOSProviders/iOSDesignerProvider.fs +++ b/src/Xamarin.iOSProviders/iOSDesignerProvider.fs @@ -49,6 +49,10 @@ type iOSDesignerProvider(config: TypeProviderConfig) as this = query {for scene in scenes do groupValBy scene.ViewController scene.ViewController.CustomClass} + let groupedViews = + query {for scene in scenes do + groupValBy scene.View scene.View.CustomClass} + //generate storyboard container let container = ProvidedTypeDefinition(asm, ns, typeName, Some(typeof), IsErased=false) @@ -56,7 +60,11 @@ type iOSDesignerProvider(config: TypeProviderConfig) as this = let generatedTypes = [ for sc in groupedViewControllers do let viewControllers = sc.AsEnumerable() - yield TypeBuilder.buildController runtimeBinding viewControllers isAbstract addUnitCtor register config ] + yield TypeBuilder.buildController runtimeBinding viewControllers isAbstract addUnitCtor register config + + for v in groupedViews do + let views = v.AsEnumerable() + () ] //Add the types to the container container.AddMembers generatedTypes