-
Notifications
You must be signed in to change notification settings - Fork 95
/
Copy pathProvidedTypes.fs
14797 lines (12562 loc) · 771 KB
/
ProvidedTypes.fs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
// Copyright (c) Microsoft Corporation, Tomas Petricek, Gustavo Guerra, and other contributors
//
// Licensed under the MIT License see LICENSE.md in this project
namespace ProviderImplementation.ProvidedTypes
#nowarn "1182"
// 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# 4.x releases
open System
open System.Reflection
open System.Collections.Generic
open System.Diagnostics
open Microsoft.FSharp.Quotations
open Microsoft.FSharp.Quotations.Patterns
open Microsoft.FSharp.Core.CompilerServices
[<AutoOpen>]
module Utils =
let K x = (fun () -> x)
let isNull x = match x with null -> true | _ -> false
let isNil x = match x with [] -> true | _ -> false
let isEmpty x = match x with [| |] -> true | _ -> false
module Option =
let toObj x = match x with None -> null | Some x -> x
let ofObj x = match x with null -> None | _ -> Some x
[<Struct>]
type StructOption<'T> (hasValue: bool, value: 'T) =
member __.IsNone = not hasValue
member __.HasValue = hasValue
member __.Value = value
override __.ToString() = if hasValue then match box value with null -> "null" | x -> x.ToString() else "<none>"
type uoption<'T> = StructOption<'T>
let UNone<'T> = uoption<'T>(false, Unchecked.defaultof<'T>)
let USome v = uoption<'T>(true, v)
let (|UNone|USome|) (x:uoption<'T>) = if x.HasValue then USome x.Value else UNone
module StructOption =
let toObj x = match x with UNone -> null | USome x -> x
let ofObj x = match x with null -> UNone | x -> USome x
let tryFindMulti k map = match Map.tryFind k map with Some res -> res | None -> [| |]
let splitNameAt (nm:string) idx =
if idx < 0 then failwith "splitNameAt: idx < 0";
let last = nm.Length - 1
if idx > last then failwith "splitNameAt: idx > last";
(nm.Substring(0,idx)),
(if idx < last then nm.Substring (idx+1,last - idx) else "")
let splitILTypeName (nm:string) =
match nm.LastIndexOf '.' with
| -1 -> UNone, nm
| idx -> let a,b = splitNameAt nm idx in USome a, b
let joinILTypeName (nspace: string uoption) (nm:string) =
match nspace with
| UNone -> nm
| USome ns -> ns + "." + nm
let lengthsEqAndForall2 (arr1: 'T1[]) (arr2: 'T2[]) f =
(arr1.Length = arr2.Length) &&
(arr1,arr2) ||> Array.forall2 f
/// General implementation of .Equals(Type) logic for System.Type over symbol types. You can use this with other types too.
let rec eqTypes (ty1: Type) (ty2: Type) =
if Object.ReferenceEquals(ty1,ty2) then true
elif ty1.IsGenericTypeDefinition then ty2.IsGenericTypeDefinition && ty1.Equals(ty2)
elif ty1.IsGenericType then ty2.IsGenericType && not ty2.IsGenericTypeDefinition && eqTypes (ty1.GetGenericTypeDefinition()) (ty2.GetGenericTypeDefinition()) && lengthsEqAndForall2 (ty1.GetGenericArguments()) (ty2.GetGenericArguments()) eqTypes
elif ty1.IsArray then ty2.IsArray && ty1.GetArrayRank() = ty2.GetArrayRank() && eqTypes (ty1.GetElementType()) (ty2.GetElementType())
elif ty1.IsPointer then ty2.IsPointer && eqTypes (ty1.GetElementType()) (ty2.GetElementType())
elif ty1.IsByRef then ty2.IsByRef && eqTypes (ty1.GetElementType()) (ty2.GetElementType())
else ty1.Equals(box ty2)
/// General implementation of .Equals(obj) logic for System.Type over symbol types. You can use this with other types too.
let eqTypeObj (this: Type) (other: obj) =
match other with
| :? Type as otherTy -> eqTypes this otherTy
| _ -> false
/// General implementation of .IsAssignableFrom logic for System.Type, regardless of specific implementation
let isAssignableFrom (ty: Type) (otherTy: Type) =
eqTypes ty otherTy || (match otherTy.BaseType with null -> false | bt -> ty.IsAssignableFrom(bt))
/// General implementation of .IsSubclassOf logic for System.Type, regardless of specific implementation, with
/// an added hack to make the types usable with the FSharp.Core quotations implementation
let isSubclassOf (this: Type) (otherTy: Type) =
(this.IsClass && otherTy.IsClass && this.IsAssignableFrom(otherTy) && not (eqTypes this otherTy))
// The FSharp.Core implementation of FSharp.Quotations uses
// let isDelegateType (typ:Type) =
// if typ.IsSubclassOf(typeof<Delegate>) then ...
// This means even target type definitions must process the case where ``otherTy`` is typeof<Delegate> rather than
// the System.Delegate type for the target assemblies.
|| (match this.BaseType with
| null -> false
| bt -> bt.FullName = "System.MulticastDelegate" && (let fn = otherTy.FullName in fn = "System.Delegate" || fn = "System.MulticastDelegate" ))
/// General implementation of .GetAttributeFlags logic for System.Type over symbol types
let getAttributeFlagsImpl (ty: Type) =
if ty.IsGenericType then ty.GetGenericTypeDefinition().Attributes
elif ty.IsArray then typeof<int[]>.Attributes
elif ty.IsPointer then typeof<int>.MakePointerType().Attributes
elif ty.IsByRef then typeof<int>.MakeByRefType().Attributes
else Unchecked.defaultof<TypeAttributes>
let bindAll = BindingFlags.DeclaredOnly ||| BindingFlags.Public ||| BindingFlags.NonPublic ||| BindingFlags.Static ||| BindingFlags.Instance
let bindCommon = BindingFlags.DeclaredOnly ||| BindingFlags.Static ||| BindingFlags.Instance ||| BindingFlags.Public
let bindSome isStatic = BindingFlags.DeclaredOnly ||| BindingFlags.Public ||| BindingFlags.NonPublic ||| (if isStatic then BindingFlags.Static else BindingFlags.Instance)
let inline hasFlag e flag = (e &&& flag) <> enum 0
let memberBinds isType (bindingFlags: BindingFlags) isStatic isPublic =
(isType || hasFlag bindingFlags (if isStatic then BindingFlags.Static else BindingFlags.Instance)) &&
((hasFlag bindingFlags BindingFlags.Public && isPublic) || (hasFlag bindingFlags BindingFlags.NonPublic && not isPublic))
let rec instType inst (ty:Type) =
if isNull ty then null
elif ty.IsGenericType then
let typeArgs = Array.map (instType inst) (ty.GetGenericArguments())
ty.GetGenericTypeDefinition().MakeGenericType(typeArgs)
elif ty.HasElementType then
let ety = instType inst (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
let pos = ty.GenericParameterPosition
let (inst1: Type[], inst2: Type[]) = inst
if pos < inst1.Length then inst1.[pos]
elif pos < inst1.Length + inst2.Length then inst2.[pos - inst1.Length]
else ty
else ty
let mutable token = 0
let genToken() = token <- token + 1; token
/// Internal code of .NET expects the obj[] returned by GetCustomAttributes to be an Attribute[] even in the case of empty arrays
let emptyAttributes = (([| |]: Attribute[]) |> box |> unbox<obj[]>)
type Attributes<'T when 'T :> Attribute>() =
static let empty = ([| |] : 'T []) |> box |> unbox<obj[]>
static member Empty() = empty
type Attributes =
static member CreateEmpty (typ : Type) =
let gtype = typedefof<Attributes<_>>.MakeGenericType([| typ |])
let gmethod = gtype.GetMethod("Empty", BindingFlags.Static ||| BindingFlags.NonPublic )
gmethod.Invoke(null, [||]) :?> obj array
let nonNull str x = if isNull x then failwithf "Null in '%s', stacktrace = '%s'" str Environment.StackTrace else x
let nonNone str x = match x with None -> failwithf "No value has been specified for '%s', stacktrace = '%s'" str Environment.StackTrace | Some v -> v
let patchOption v f = match v with None -> f() | Some _ -> failwithf "Already patched, stacktrace = '%s'" Environment.StackTrace
let notRequired this opname item =
let msg = sprintf "The operation '%s' on item '%s' should not be called on provided type, member or parameter of type '%O'. Stack trace:\n%s" opname item (this.GetType()) Environment.StackTrace
Debug.Assert (false, msg)
raise (NotSupportedException msg)
let adjustTypeAttributes isNested attrs =
let visibilityAttributes =
match attrs &&& 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
(attrs &&& ~~~TypeAttributes.VisibilityMask) ||| visibilityAttributes
type ConstructorInfo with
member m.GetDefinition() =
let dty = m.DeclaringType
if (dty.IsGenericType && not dty.IsGenericTypeDefinition) then
// Search through the original type definition looking for the one with a matching metadata token
let gdty = dty.GetGenericTypeDefinition()
gdty.GetConstructors(bindAll)
|> Array.tryFind (fun c -> c.MetadataToken = m.MetadataToken)
|> function Some m2 -> m2 | None -> failwithf "couldn't rebind %O::%s back to generic constructor definition via metadata token, stacktrace = '%s'" m.DeclaringType m.Name Environment.StackTrace
else
m
type PropertyInfo with
member m.GetDefinition() =
let dty = m.DeclaringType
if (dty.IsGenericType && not dty.IsGenericTypeDefinition) then
// Search through the original type definition looking for the one with a matching metadata token
let gdty = dty.GetGenericTypeDefinition()
gdty.GetProperties(bindAll)
|> Array.tryFind (fun c -> c.MetadataToken = m.MetadataToken)
|> function Some m2 -> m2 | None -> failwithf "couldn't rebind %O::%s back to generic property definition via metadata token" m.DeclaringType m.Name
else
m
member p.IsStatic = p.CanRead && p.GetGetMethod().IsStatic || p.CanWrite && p.GetSetMethod().IsStatic
member p.IsPublic = p.CanRead && p.GetGetMethod().IsPublic || p.CanWrite && p.GetSetMethod().IsPublic
type EventInfo with
member m.GetDefinition() =
let dty = m.DeclaringType
if (dty.IsGenericType && not dty.IsGenericTypeDefinition) then
// Search through the original type definition looking for the one with a matching metadata token
let gdty = dty.GetGenericTypeDefinition()
gdty.GetEvents(bindAll)
|> Array.tryFind (fun c -> c.MetadataToken = m.MetadataToken)
|> function Some m2 -> m2 | None -> failwithf "couldn't rebind %O::%s back to generic event definition via metadata token" m.DeclaringType m.Name
else
m
member p.IsStatic = p.GetAddMethod().IsStatic || p.GetRemoveMethod().IsStatic
member p.IsPublic = p.GetAddMethod().IsPublic || p.GetRemoveMethod().IsPublic
type FieldInfo with
member m.GetDefinition() =
let dty = m.DeclaringType
if (dty.IsGenericType && not dty.IsGenericTypeDefinition) then
// Search through the original type definition looking for the one with a matching metadata token
let gdty = dty.GetGenericTypeDefinition()
gdty.GetFields(bindAll)
|> Array.tryFind (fun c -> c.MetadataToken = m.MetadataToken)
|> function Some m2 -> m2 | None -> failwithf "couldn't rebind %O::%s back to generic event definition via metadata token" m.DeclaringType m.Name
else
m
type MethodInfo with
member m.GetDefinition() =
let dty = m.DeclaringType
if (m.IsGenericMethod && not dty.IsGenericType) then m.GetGenericMethodDefinition()
elif (m.IsGenericMethod && (not m.IsGenericMethodDefinition || not dty.IsGenericTypeDefinition)) ||
(dty.IsGenericType && not dty.IsGenericTypeDefinition) then
// Search through ALL the methods on the original type definition looking for the one
// with a matching metadata token
let gdty = if dty.IsGenericType then dty.GetGenericTypeDefinition() else dty
gdty.GetMethods(bindSome m.IsStatic)
|> Array.tryFind (fun c -> c.MetadataToken = m.MetadataToken)
|> function Some m2 -> m2 | None -> failwithf "couldn't rebind generic instantiation of %O::%s back to generic method definition via metadata token" m.DeclaringType m.Name
else
m
let canBindConstructor (bindingFlags: BindingFlags) (c: ConstructorInfo) =
hasFlag bindingFlags BindingFlags.Public && c.IsPublic || hasFlag bindingFlags BindingFlags.NonPublic && not c.IsPublic
let canBindMethod (bindingFlags: BindingFlags) (c: MethodInfo) =
hasFlag bindingFlags BindingFlags.Public && c.IsPublic || hasFlag bindingFlags BindingFlags.NonPublic && not c.IsPublic
let canBindProperty (bindingFlags: BindingFlags) (c: PropertyInfo) =
hasFlag bindingFlags BindingFlags.Public && c.IsPublic || hasFlag bindingFlags BindingFlags.NonPublic && not c.IsPublic
let canBindField (bindingFlags: BindingFlags) (c: FieldInfo) =
hasFlag bindingFlags BindingFlags.Public && c.IsPublic || hasFlag bindingFlags BindingFlags.NonPublic && not c.IsPublic
let canBindEvent (bindingFlags: BindingFlags) (c: EventInfo) =
hasFlag bindingFlags BindingFlags.Public && c.IsPublic || hasFlag bindingFlags BindingFlags.NonPublic && not c.IsPublic
let canBindNestedType (bindingFlags: BindingFlags) (c: Type) =
hasFlag bindingFlags BindingFlags.Public && c.IsNestedPublic || hasFlag bindingFlags BindingFlags.NonPublic && not c.IsNestedPublic
// We only want to return source types "typeof<Void>" values as _target_ types in one very specific location due to a limitation in the
// F# compiler code for multi-targeting.
let ImportProvidedMethodBaseAsILMethodRef_OnStack_HACK() =
let rec loop i =
if i > 9 then
false
else
let frame = StackFrame(i, true)
match frame.GetMethod() with
| null -> loop (i+1)
| m -> m.Name = "ImportProvidedMethodBaseAsILMethodRef" || loop (i+1)
loop 1
//--------------------------------------------------------------------------------
// 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.
[<AutoOpen>]
module UncheckedQuotations =
let qTy = typeof<Var>.Assembly.GetType("Microsoft.FSharp.Quotations.ExprConstInfo")
assert (not (isNull qTy))
let pTy = typeof<Var>.Assembly.GetType("Microsoft.FSharp.Quotations.PatternsModule")
assert (not (isNull pTy))
// 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", bindAll)
assert (not (isNull mkFE0))
let mkFE1 = pTy.GetMethod("mkFE1", bindAll)
assert (not (isNull mkFE1))
let mkFE2 = pTy.GetMethod("mkFE2", bindAll)
assert (mkFE2 |> isNull |> not)
let mkFE3 = pTy.GetMethod("mkFE3", bindAll)
assert (mkFE3 |> isNull |> not)
let mkFEN = pTy.GetMethod("mkFEN", bindAll)
assert (mkFEN |> isNull |> not)
// 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", bindAll)
assert (newDelegateOp |> isNull |> not)
let instanceCallOp = qTy.GetMethod("NewInstanceMethodCallOp", bindAll)
assert (instanceCallOp |> isNull |> not)
let staticCallOp = qTy.GetMethod("NewStaticMethodCallOp", bindAll)
assert (staticCallOp |> isNull |> not)
let newObjectOp = qTy.GetMethod("NewNewObjectOp", bindAll)
assert (newObjectOp |> isNull |> not)
let newArrayOp = qTy.GetMethod("NewNewArrayOp", bindAll)
assert (newArrayOp |> isNull |> not)
let appOp = qTy.GetMethod("get_AppOp", bindAll)
assert (appOp |> isNull |> not)
let instancePropGetOp = qTy.GetMethod("NewInstancePropGetOp", bindAll)
assert (instancePropGetOp |> isNull |> not)
let staticPropGetOp = qTy.GetMethod("NewStaticPropGetOp", bindAll)
assert (staticPropGetOp |> isNull |> not)
let instancePropSetOp = qTy.GetMethod("NewInstancePropSetOp", bindAll)
assert (instancePropSetOp |> isNull |> not)
let staticPropSetOp = qTy.GetMethod("NewStaticPropSetOp", bindAll)
assert (staticPropSetOp |> isNull |> not)
let instanceFieldGetOp = qTy.GetMethod("NewInstanceFieldGetOp", bindAll)
assert (instanceFieldGetOp |> isNull |> not)
let staticFieldGetOp = qTy.GetMethod("NewStaticFieldGetOp", bindAll)
assert (staticFieldGetOp |> isNull |> not)
let instanceFieldSetOp = qTy.GetMethod("NewInstanceFieldSetOp", bindAll)
assert (instanceFieldSetOp |> isNull |> not)
let staticFieldSetOp = qTy.GetMethod("NewStaticFieldSetOp", bindAll)
assert (staticFieldSetOp |> isNull |> not)
let tupleGetOp = qTy.GetMethod("NewTupleGetOp", bindAll)
assert (tupleGetOp |> isNull |> not)
let letOp = qTy.GetMethod("get_LetOp", bindAll)
assert (letOp |> isNull |> not)
let forIntegerRangeLoopOp = qTy.GetMethod("get_ForIntegerRangeLoopOp", bindAll)
assert (forIntegerRangeLoopOp |> isNull |> not)
let whileLoopOp = qTy.GetMethod("get_WhileLoopOp", bindAll)
assert (whileLoopOp |> isNull |> not)
let ifThenElseOp = qTy.GetMethod("get_IfThenElseOp", bindAll)
assert (ifThenElseOp |> isNull |> not)
let newUnionCaseOp = qTy.GetMethod("NewNewUnionCaseOp", bindAll)
assert (newUnionCaseOp |> isNull |> not)
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 args = defaultArg args []
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
static member ForIntegerRangeLoopUnchecked (loopVariable, startExpr:Expr, endExpr:Expr, body:Expr) =
let lam = Expr.Lambda(loopVariable, body)
let op = forIntegerRangeLoopOp.Invoke(null, [| |])
mkFE3.Invoke(null, [| box op; box startExpr; box endExpr; box lam |] ) :?> Expr
static member WhileLoopUnchecked (guard:Expr, body:Expr) =
let op = whileLoopOp.Invoke(null, [| |])
mkFE2.Invoke(null, [| box op; box guard; box body |] ):?> Expr
static member IfThenElseUnchecked (e:Expr, t:Expr, f:Expr) =
let op = ifThenElseOp.Invoke(null, [| |])
mkFE3.Invoke(null, [| box op; box e; box t; box f |] ):?> Expr
static member NewUnionCaseUnchecked (uci:Reflection.UnionCaseInfo, args:Expr list) =
let op = newUnionCaseOp.Invoke(null, [| box uci |])
mkFEN.Invoke(null, [| box op; box args |]) :?> 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)])
| ForIntegerRangeLoop (loopVar, first, last, body) ->
ShapeCombinationUnchecked (Shape (function [first; last; Lambda(loopVar, body)] -> Expr.ForIntegerRangeLoopUnchecked (loopVar, first, last, body) | _ -> invalidArg "expr" "invalid shape"), [first; last; Expr.Lambda(loopVar, body)])
| WhileLoop (cond, body) ->
ShapeCombinationUnchecked (Shape (function [cond; body] -> Expr.WhileLoopUnchecked (cond, body) | _ -> invalidArg "expr" "invalid shape"), [cond; body])
| IfThenElse (g, t, e) ->
ShapeCombinationUnchecked (Shape (function [g; t; e] -> Expr.IfThenElseUnchecked (g, t, e) | _ -> invalidArg "expr" "invalid shape"), [g; t; e])
| 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
//--------------------------------------------------------------------------------
// Instantiated symbols
//
/// Represents the type constructor in a provided symbol type.
[<NoComparison>]
type ProvidedTypeSymbolKind =
| SDArray
| Array of int
| Pointer
| ByRef
| Generic of Type
| FSharpTypeAbbreviation of (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 ProvidedTypeSymbol(kind: ProvidedTypeSymbolKind, typeArgs: Type list) as this =
inherit TypeDelegator()
let typeArgs = Array.ofList typeArgs
do this.typeImpl <- this
/// Substitute types for type variables.
override __.FullName =
match kind,typeArgs with
| ProvidedTypeSymbolKind.SDArray,[| arg |] -> arg.FullName + "[]"
| ProvidedTypeSymbolKind.Array _,[| arg |] -> arg.FullName + "[*]"
| ProvidedTypeSymbolKind.Pointer,[| arg |] -> arg.FullName + "*"
| ProvidedTypeSymbolKind.ByRef,[| arg |] -> arg.FullName + "&"
| ProvidedTypeSymbolKind.Generic gty, typeArgs -> gty.FullName + "[" + (typeArgs |> Array.map (fun arg -> arg.ToString()) |> String.concat ",") + "]"
| ProvidedTypeSymbolKind.FSharpTypeAbbreviation (_,nsp,path),typeArgs -> String.concat "." (Array.append [| nsp |] path) + (match typeArgs with [| |] -> "" | _ -> typeArgs.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<SomeProvidedType[]>.FullName
override __.DeclaringType =
match kind with
| ProvidedTypeSymbolKind.SDArray -> null
| ProvidedTypeSymbolKind.Array _ -> null
| ProvidedTypeSymbolKind.Pointer -> null
| ProvidedTypeSymbolKind.ByRef -> null
| ProvidedTypeSymbolKind.Generic gty -> gty.DeclaringType
| ProvidedTypeSymbolKind.FSharpTypeAbbreviation _ -> null
override __.Name =
match kind,typeArgs with
| ProvidedTypeSymbolKind.SDArray,[| arg |] -> arg.Name + "[]"
| ProvidedTypeSymbolKind.Array _,[| arg |] -> arg.Name + "[*]"
| ProvidedTypeSymbolKind.Pointer,[| arg |] -> arg.Name + "*"
| ProvidedTypeSymbolKind.ByRef,[| arg |] -> arg.Name + "&"
| ProvidedTypeSymbolKind.Generic gty, _typeArgs -> gty.Name
| ProvidedTypeSymbolKind.FSharpTypeAbbreviation (_,_,path),_ -> path.[path.Length-1]
| _ -> failwith "unreachable"
override __.BaseType =
match kind with
| ProvidedTypeSymbolKind.SDArray -> typeof<Array>
| ProvidedTypeSymbolKind.Array _ -> typeof<Array>
| ProvidedTypeSymbolKind.Pointer -> typeof<ValueType>
| ProvidedTypeSymbolKind.ByRef -> typeof<ValueType>
| ProvidedTypeSymbolKind.Generic gty ->
if isNull gty.BaseType then null else
instType (typeArgs, [| |]) gty.BaseType
| ProvidedTypeSymbolKind.FSharpTypeAbbreviation _ -> typeof<obj>
override __.GetArrayRank() = (match kind with ProvidedTypeSymbolKind.Array n -> n | ProvidedTypeSymbolKind.SDArray -> 1 | _ -> failwithf "non-array type '%O'" this)
override __.IsValueTypeImpl() = (match kind with ProvidedTypeSymbolKind.Generic gtd -> gtd.IsValueType | _ -> false)
override __.IsArrayImpl() = (match kind with ProvidedTypeSymbolKind.Array _ | ProvidedTypeSymbolKind.SDArray -> true | _ -> false)
override __.IsByRefImpl() = (match kind with ProvidedTypeSymbolKind.ByRef _ -> true | _ -> false)
override __.IsPointerImpl() = (match kind with ProvidedTypeSymbolKind.Pointer _ -> true | _ -> false)
override __.IsPrimitiveImpl() = false
override __.IsGenericType = (match kind with ProvidedTypeSymbolKind.Generic _ -> true | _ -> false)
override this.GetGenericArguments() = (match kind with ProvidedTypeSymbolKind.Generic _ -> typeArgs | _ -> failwithf "non-generic type '%O'" this)
override this.GetGenericTypeDefinition() = (match kind with ProvidedTypeSymbolKind.Generic e -> e | _ -> failwithf "non-generic type '%O'" this)
override __.IsCOMObjectImpl() = false
override __.HasElementTypeImpl() = (match kind with ProvidedTypeSymbolKind.Generic _ -> false | _ -> true)
override __.GetElementType() = (match kind,typeArgs with (ProvidedTypeSymbolKind.Array _ | ProvidedTypeSymbolKind.SDArray | ProvidedTypeSymbolKind.ByRef | ProvidedTypeSymbolKind.Pointer),[| e |] -> e | _ -> failwithf "not an array, pointer or byref type")
override this.Assembly =
match kind, typeArgs with
| ProvidedTypeSymbolKind.FSharpTypeAbbreviation (assembly,_nsp,_path), _ -> assembly
| ProvidedTypeSymbolKind.Generic gty, _ -> gty.Assembly
| ProvidedTypeSymbolKind.SDArray,[| arg |] -> arg.Assembly
| ProvidedTypeSymbolKind.Array _,[| arg |] -> arg.Assembly
| ProvidedTypeSymbolKind.Pointer,[| arg |] -> arg.Assembly
| ProvidedTypeSymbolKind.ByRef,[| arg |] -> arg.Assembly
| _ -> notRequired this "Assembly" this.FullName
override this.Namespace =
match kind,typeArgs with
| ProvidedTypeSymbolKind.SDArray,[| arg |] -> arg.Namespace
| ProvidedTypeSymbolKind.Array _,[| arg |] -> arg.Namespace
| ProvidedTypeSymbolKind.Pointer,[| arg |] -> arg.Namespace
| ProvidedTypeSymbolKind.ByRef,[| arg |] -> arg.Namespace
| ProvidedTypeSymbolKind.Generic gty,_ -> gty.Namespace
| ProvidedTypeSymbolKind.FSharpTypeAbbreviation (_assembly,nsp,_path),_ -> nsp
| _ -> notRequired this "Namespace" this.FullName
override x.Module = x.Assembly.ManifestModule
override __.GetHashCode() =
match kind,typeArgs with
| ProvidedTypeSymbolKind.SDArray,[| arg |] -> 10 + hash arg
| ProvidedTypeSymbolKind.Array _,[| arg |] -> 163 + hash arg
| ProvidedTypeSymbolKind.Pointer,[| arg |] -> 283 + hash arg
| ProvidedTypeSymbolKind.ByRef,[| arg |] -> 43904 + hash arg
| ProvidedTypeSymbolKind.Generic gty,_ -> 9797 + hash gty + Array.sumBy hash typeArgs
| ProvidedTypeSymbolKind.FSharpTypeAbbreviation _,_ -> 3092
| _ -> failwith "unreachable"
override this.Equals(other: obj) = eqTypeObj this other
override this.Equals(otherTy: Type) = eqTypes this otherTy
override this.IsAssignableFrom(otherTy: Type) = isAssignableFrom this otherTy
override this.IsSubclassOf(otherTy: Type) = isSubclassOf this otherTy
member __.Kind = kind
member __.Args = typeArgs
member __.IsFSharpTypeAbbreviation = match kind with FSharpTypeAbbreviation _ -> true | _ -> false
// For example, int<kg>
member __.IsFSharpUnitAnnotated = match kind with ProvidedTypeSymbolKind.Generic gtd -> not gtd.IsGenericTypeDefinition | _ -> false
override __.GetConstructorImpl(_bindingFlags, _binder, _callConventions, _types, _modifiers) = null
override this.GetMethodImpl(name, bindingFlags, _binderBinder, _callConvention, _types, _modifiers) =
match kind with
| Generic gtd ->
let ty = gtd.GetGenericTypeDefinition().MakeGenericType(typeArgs)
ty.GetMethod(name, bindingFlags)
| _ -> notRequired this "GetMethodImpl" this.FullName
override this.GetField(_name, _bindingFlags) = notRequired this "GetField" this.FullName
override this.GetPropertyImpl(_name, _bindingFlags, _binder, _returnType, _types, _modifiers) = notRequired this "GetPropertyImpl" this.FullName
override this.GetEvent(_name, _bindingFlags) = notRequired this "GetEvent" this.FullName
override this.GetNestedType(_name, _bindingFlags) = notRequired this "GetNestedType" this.FullName
override this.GetConstructors _bindingFlags = notRequired this "GetConstructors" this.FullName
override this.GetMethods _bindingFlags = notRequired this "GetMethods" this.FullName
override this.GetFields _bindingFlags = notRequired this "GetFields" this.FullName
override this.GetProperties _bindingFlags = notRequired this "GetProperties" this.FullName
override this.GetEvents _bindingFlags = notRequired this "GetEvents" this.FullName
override this.GetNestedTypes _bindingFlags = notRequired this "GetNestedTypes" this.FullName
override this.GetMembers _bindingFlags = notRequired this "GetMembers" this.FullName
override this.GetInterface(_name, _ignoreCase) = notRequired this "GetInterface" this.FullName
override this.GetInterfaces() = notRequired this "GetInterfaces" this.FullName
override this.GetAttributeFlagsImpl() = getAttributeFlagsImpl this
override this.UnderlyingSystemType =
match kind with
| ProvidedTypeSymbolKind.SDArray
| ProvidedTypeSymbolKind.Array _
| ProvidedTypeSymbolKind.Pointer
| ProvidedTypeSymbolKind.FSharpTypeAbbreviation _
| ProvidedTypeSymbolKind.ByRef -> upcast this
| ProvidedTypeSymbolKind.Generic gty -> gty.UnderlyingSystemType
override __.GetCustomAttributesData() = ([| |] :> IList<_>)
override this.MemberType = notRequired this "MemberType" this.FullName
override this.GetMember(_name,_mt,_bindingFlags) = notRequired this "GetMember" this.FullName
override this.GUID = notRequired this "GUID" this.FullName
override this.InvokeMember(_name, _invokeAttr, _binder, _target, _args, _modifiers, _culture, _namedParameters) = notRequired this "InvokeMember" this.FullName
override this.AssemblyQualifiedName = notRequired this "AssemblyQualifiedName" this.FullName
override __.GetCustomAttributes(_inherit) = emptyAttributes
override __.GetCustomAttributes(attributeType, _inherit) = Attributes.CreateEmpty attributeType
override __.IsDefined(_attributeType, _inherit) = false
override this.MakeArrayType() = ProvidedTypeSymbol(ProvidedTypeSymbolKind.SDArray, [this]) :> Type
override this.MakeArrayType arg = ProvidedTypeSymbol(ProvidedTypeSymbolKind.Array arg, [this]) :> Type
#if NETCOREAPP
// See bug https://github.com/fsprojects/FSharp.TypeProviders.SDK/issues/236
override __.IsSZArray =
match kind with
| ProvidedTypeSymbolKind.SDArray -> true
| _ -> false
#endif
override __.MetadataToken =
match kind with
| ProvidedTypeSymbolKind.SDArray -> typeof<Array>.MetadataToken
| ProvidedTypeSymbolKind.Array _ -> typeof<Array>.MetadataToken
| ProvidedTypeSymbolKind.Pointer -> typeof<ValueType>.MetadataToken
| ProvidedTypeSymbolKind.ByRef -> typeof<ValueType>.MetadataToken
| ProvidedTypeSymbolKind.Generic gty -> gty.MetadataToken
| ProvidedTypeSymbolKind.FSharpTypeAbbreviation _ -> typeof<obj>.MetadataToken
override this.GetEvents() = this.GetEvents(BindingFlags.Public ||| BindingFlags.Instance ||| BindingFlags.Static) // Needed because TypeDelegator.cs provides a delegting implementation of this, and we are self-delegating
override this.ToString() = this.FullName
type ProvidedSymbolMethod(genericMethodDefinition: MethodInfo, parameters: Type[]) =
inherit MethodInfo()
let convParam (p:ParameterInfo) =
{ new ParameterInfo() with
override __.Name = p.Name
override __.ParameterType = instType (parameters, [| |]) p.ParameterType
override __.Attributes = p.Attributes
override __.RawDefaultValue = p.RawDefaultValue
override __.GetCustomAttributesData() = p.GetCustomAttributesData()
}
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 = instType (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 this.IsDefined(_attributeType, _inherit): bool = notRequired this "IsDefined" genericMethodDefinition.Name
override __.ReturnType = instType (parameters, [| |]) genericMethodDefinition.ReturnType
override __.GetParameters() = genericMethodDefinition.GetParameters() |> Array.map convParam
override __.ReturnParameter = genericMethodDefinition.ReturnParameter |> convParam
override this.ReturnTypeCustomAttributes = notRequired this "ReturnTypeCustomAttributes" genericMethodDefinition.Name
override this.GetBaseDefinition() = notRequired this "GetBaseDefinition" genericMethodDefinition.Name
override this.GetMethodImplementationFlags() = notRequired this "GetMethodImplementationFlags" genericMethodDefinition.Name
override this.MethodHandle = notRequired this "MethodHandle" genericMethodDefinition.Name
override this.Invoke(_obj, _invokeAttr, _binder, _parameters, _culture) = notRequired this "Invoke" genericMethodDefinition.Name
override this.ReflectedType = notRequired this "ReflectedType" genericMethodDefinition.Name
override __.GetCustomAttributes(_inherit) = emptyAttributes
override __.GetCustomAttributes(attributeType, _inherit) = Attributes.CreateEmpty attributeType
//--------------------------------------------------------------------------------
// ProvidedMethod, ProvidedConstructor, ProvidedTypeDefinition and other provided objects
[<AutoOpen>]
module Misc =
let mkParamArrayCustomAttributeData() =
{ new CustomAttributeData() with
member __.Constructor = typeof<ParamArrayAttribute>.GetConstructors().[0]
member __.ConstructorArguments = upcast [| |]
member __.NamedArguments = upcast [| |] }
let mkEditorHideMethodsCustomAttributeData() =
{ new CustomAttributeData() with
member __.Constructor = typeof<TypeProviderEditorHideMethodsAttribute>.GetConstructors().[0]
member __.ConstructorArguments = upcast [| |]
member __.NamedArguments = upcast [| |] }
let mkAllowNullLiteralCustomAttributeData value =
{ new CustomAttributeData() with
member __.Constructor = typeof<AllowNullLiteralAttribute>.GetConstructors().[0]
member __.ConstructorArguments = upcast [| CustomAttributeTypedArgument(typeof<bool>, 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<string>) =
{ new CustomAttributeData() with
member __.Constructor = typeof<TypeProviderXmlDocAttribute>.GetConstructors().[0]
member __.ConstructorArguments = upcast [| CustomAttributeTypedArgument(typeof<string>, lazyText.Force()) |]
member __.NamedArguments = upcast [| |] }
let mkXmlDocCustomAttributeData(s:string) = mkXmlDocCustomAttributeDataLazy (lazy s)
let mkDefinitionLocationAttributeCustomAttributeData(line:int,column:int,filePath:string) =
{ new CustomAttributeData() with
member __.Constructor = typeof<TypeProviderDefinitionLocationAttribute>.GetConstructors().[0]
member __.ConstructorArguments = upcast [| |]
member __.NamedArguments =
upcast [| CustomAttributeNamedArgument(typeof<TypeProviderDefinitionLocationAttribute>.GetProperty("FilePath"), CustomAttributeTypedArgument(typeof<string>, filePath));
CustomAttributeNamedArgument(typeof<TypeProviderDefinitionLocationAttribute>.GetProperty("Line"), CustomAttributeTypedArgument(typeof<int>, line)) ;
CustomAttributeNamedArgument(typeof<TypeProviderDefinitionLocationAttribute>.GetProperty("Column"), CustomAttributeTypedArgument(typeof<int>, column))
|] }
let mkObsoleteAttributeCustomAttributeData(message:string, isError: bool) =
{ new CustomAttributeData() with
member __.Constructor = typeof<ObsoleteAttribute>.GetConstructors() |> Array.find (fun x -> x.GetParameters().Length = 2)
member __.ConstructorArguments = upcast [|CustomAttributeTypedArgument(typeof<string>, message) ; CustomAttributeTypedArgument(typeof<bool>, isError) |]
member __.NamedArguments = upcast [| |] }
let mkReflectedDefinitionCustomAttributeData() =
{ new CustomAttributeData() with
member __.Constructor = typeof<ReflectedDefinitionAttribute>.GetConstructors().[0]
member __.ConstructorArguments = upcast [| |]
member __.NamedArguments = upcast [| |] }
type CustomAttributesImpl(isTgt, customAttributesData) =
let customAttributes = ResizeArray<CustomAttributeData>()
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 not isTgt then
if hideObjectMethods then yield mkEditorHideMethodsCustomAttributeData()
if nonNullable then yield mkAllowNullLiteralCustomAttributeData false
match xmlDocDelayed with None -> () | Some _ -> customAttributes.Add(mkXmlDocCustomAttributeDataLazy xmlDocDelayedText)
match xmlDocAlwaysRecomputed with None -> () | Some f -> yield mkXmlDocCustomAttributeData (f())
match obsoleteMessage with None -> () | Some s -> customAttributes.Add(mkObsoleteAttributeCustomAttributeData s)
if hasParamArray then yield mkParamArrayCustomAttributeData()
if hasReflectedDefinition then yield mkReflectedDefinitionCustomAttributeData()
yield! customAttributes
yield! customAttributesData()|]
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 (K xmlDoc)
member __.HideObjectMethods with get() = hideObjectMethods and set v = hideObjectMethods <- v
member __.NonNullable with get () = nonNullable and set v = nonNullable <- v
member __.AddCustomAttribute(attribute) = customAttributes.Add(attribute)
member __.GetCustomAttributesData() =
let attrs = customAttributesOnce.Force()
let attrsWithDocHack =
match xmlDocAlwaysRecomputed with
| None ->
attrs
| Some f ->
// Recomputed XML doc is evaluated on every call to GetCustomAttributesData() when in the IDE
[| for ca in attrs ->
if ca.Constructor.DeclaringType.Name = typeof<TypeProviderXmlDocAttribute>.Name then
{ new CustomAttributeData() with
member __.Constructor = ca.Constructor
member __.ConstructorArguments = upcast [| CustomAttributeTypedArgument(typeof<string>, f()) |]
member __.NamedArguments = upcast [| |] }
else ca |]
attrsWithDocHack :> IList<_>
type ProvidedStaticParameter(isTgt: bool, parameterName:string, parameterType:Type, parameterDefaultValue:obj option, customAttributesData) =
inherit ParameterInfo()
let customAttributesImpl = CustomAttributesImpl(isTgt, customAttributesData)
new (parameterName:string, parameterType:Type, ?parameterDefaultValue:obj) =
ProvidedStaticParameter(false, parameterName, parameterType, parameterDefaultValue, (K [| |]))
member __.AddXmlDocDelayed xmlDocFunction = customAttributesImpl.AddXmlDocDelayed xmlDocFunction
member __.AddXmlDocComputed xmlDocFunction = customAttributesImpl.AddXmlDocComputed xmlDocFunction
member __.AddXmlDoc xmlDoc = customAttributesImpl.AddXmlDoc xmlDoc
member __.ParameterDefaultValue = parameterDefaultValue
member __.BelongsToTargetModel = isTgt
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) = emptyAttributes
override __.GetCustomAttributes(attributeType, _inherit) = Attributes.CreateEmpty attributeType
override __.GetCustomAttributesData() = customAttributesImpl.GetCustomAttributesData()
type ProvidedParameter(isTgt: bool, parameterName:string, attrs, parameterType:Type, optionalValue:obj option, customAttributesData) =
inherit ParameterInfo()
let customAttributesImpl = CustomAttributesImpl(isTgt, customAttributesData)
new (parameterName:string, parameterType:Type, ?isOut:bool, ?optionalValue:obj) =
ProvidedParameter(false, parameterName, parameterType, isOut, optionalValue)
new (_isTgt, parameterName:string, parameterType:Type, isOut:bool option, optionalValue:obj option) =
let isOut = defaultArg isOut false
let attrs = (if isOut then ParameterAttributes.Out else enum 0) |||
(match optionalValue with None -> enum 0 | Some _ -> ParameterAttributes.Optional ||| ParameterAttributes.HasDefault)
ProvidedParameter(false, parameterName, attrs, parameterType, optionalValue, K [| |])
member __.IsParamArray with set(v) = customAttributesImpl.HasParamArray <- v
member __.IsReflectedDefinition with set(v) = customAttributesImpl.HasReflectedDefinition <- v
member __.OptionalValue = optionalValue
member __.HasDefaultParameterValue = Option.isSome optionalValue
member __.BelongsToTargetModel = isTgt
member __.AddCustomAttribute(attribute) = customAttributesImpl.AddCustomAttribute(attribute)
override __.Name = parameterName
override __.ParameterType = parameterType
override __.Attributes = attrs
override __.RawDefaultValue = defaultArg optionalValue null
override __.GetCustomAttributesData() = customAttributesImpl.GetCustomAttributesData()
and ProvidedConstructor(isTgt: bool, attrs: MethodAttributes, parameters: ProvidedParameter[], invokeCode: (Expr list -> Expr), baseCall, isImplicitCtor, customAttributesData) =
inherit ConstructorInfo()
let parameterInfos = parameters |> Array.map (fun p -> p :> ParameterInfo)
let mutable baseCall = baseCall
let mutable declaringType : ProvidedTypeDefinition option = None
let mutable isImplicitCtor = isImplicitCtor
let mutable attrs = attrs
let isStatic() = hasFlag attrs MethodAttributes.Static
let customAttributesImpl = CustomAttributesImpl(isTgt, customAttributesData)
new (parameters, invokeCode) =
ProvidedConstructor(false, MethodAttributes.Public ||| MethodAttributes.RTSpecialName, Array.ofList parameters, invokeCode, None, false, K [| |])
member __.IsTypeInitializer
with get() = isStatic() && hasFlag attrs MethodAttributes.Private
and set(v) =
let typeInitializerAttributes = MethodAttributes.Static ||| MethodAttributes.Private
attrs <- if v then attrs ||| typeInitializerAttributes else attrs &&& ~~~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 __.PatchDeclaringType x = patchOption declaringType (fun () -> declaringType <- Some x)
member this.BaseConstructorCall
with set (d:Expr list -> (ConstructorInfo * Expr list)) =
match baseCall with
| None -> baseCall <- Some d
| Some _ -> failwithf "ProvidedConstructor: base call already given for '%s'" this.Name
member __.IsImplicitConstructor with get() = isImplicitCtor and set v = isImplicitCtor <- v
member __.BaseCall = baseCall
member __.Parameters = parameters
member __.GetInvokeCode args = invokeCode args
member __.BelongsToTargetModel = isTgt
member __.DeclaringProvidedType = declaringType
member this.IsErased = (nonNone "DeclaringType" this.DeclaringProvidedType).IsErased
// Implement overloads
override __.GetParameters() = parameterInfos
override __.Attributes = attrs
override __.Name = if isStatic() then ".cctor" else ".ctor"
override __.DeclaringType = declaringType |> nonNone "DeclaringType" :> Type
override __.IsDefined(_attributeType, _inherit) = true
override this.Invoke(_invokeAttr, _binder, _parameters, _culture) = notRequired this "Invoke" this.Name
override this.Invoke(_obj, _invokeAttr, _binder, _parameters, _culture) = notRequired this "Invoke" this.Name
override this.ReflectedType = notRequired this "ReflectedType" this.Name
override this.GetMethodImplementationFlags() = notRequired this "GetMethodImplementationFlags" this.Name
override this.MethodHandle = notRequired this "MethodHandle" this.Name
override __.GetCustomAttributes(_inherit) = emptyAttributes
override __.GetCustomAttributes(attributeType, _inherit) = Attributes.CreateEmpty attributeType
override __.GetCustomAttributesData() = customAttributesImpl.GetCustomAttributesData()
and ProvidedMethod(isTgt: bool, methodName: string, attrs: MethodAttributes, parameters: ProvidedParameter[], returnType: Type, invokeCode: (Expr list -> Expr) option, staticParams, staticParamsApply, customAttributesData) =
inherit MethodInfo()