forked from dotnet/fsharp
/
NicePrint.fs
executable file
·2089 lines (1784 loc) · 101 KB
/
NicePrint.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. All Rights Reserved. See License.txt in the project root for license information.
/// Print Signatures/Types, for signatures, intellisense, quick info, FSI responses
module internal FSharp.Compiler.NicePrint
open FSharp.Compiler
open FSharp.Compiler.AbstractIL
open FSharp.Compiler.AbstractIL.IL
open FSharp.Compiler.AbstractIL.Internal
open FSharp.Compiler.AbstractIL.Internal.Library
open FSharp.Compiler.AttributeChecking
open FSharp.Compiler.ErrorLogger
open FSharp.Compiler.Infos
open FSharp.Compiler.InfoReader
open FSharp.Compiler.Layout
open FSharp.Compiler.Layout.TaggedTextOps
open FSharp.Compiler.Lib
open FSharp.Compiler.PrettyNaming
open FSharp.Compiler.Rational
open FSharp.Compiler.SyntaxTree
open FSharp.Compiler.TcGlobals
open FSharp.Compiler.TypedTree
open FSharp.Compiler.TypedTreeBasics
open FSharp.Compiler.TypedTreeOps
open FSharp.Core.Printf
[<AutoOpen>]
module internal PrintUtilities =
let bracketIfL x lyt = if x then bracketL lyt else lyt
let squareAngleL x = LeftL.leftBracketAngle ^^ x ^^ RightL.rightBracketAngle
let angleL x = sepL Literals.leftAngle ^^ x ^^ rightL Literals.rightAngle
let braceL x = wordL Literals.leftBrace ^^ x ^^ wordL Literals.rightBrace
let braceBarL x = wordL Literals.leftBraceBar ^^ x ^^ wordL Literals.rightBraceBar
let comment str = wordL (tagText (sprintf "(* %s *)" str))
let layoutsL (ls: layout list) : layout =
match ls with
| [] -> emptyL
| [x] -> x
| x :: xs -> List.fold (^^) x xs
let suppressInheritanceAndInterfacesForTyInSimplifiedDisplays g amap m ty =
isEnumTy g ty || isDelegateTy g ty || ExistsHeadTypeInEntireHierarchy g amap m ty g.exn_tcr
let applyMaxMembers maxMembers (allDecls: _ list) =
match maxMembers with
| Some n when allDecls.Length > n -> (allDecls |> List.truncate n) @ [wordL (tagPunctuation "...")]
| _ -> allDecls
/// fix up a name coming from IL metadata by quoting "funny" names (keywords, otherwise invalid identifiers)
let adjustILName n =
n |> Lexhelp.Keywords.QuoteIdentifierIfNeeded
// Put the "+ N overloads" into the layout
let shrinkOverloads layoutFunction resultFunction group =
match group with
| [x] -> [resultFunction x (layoutFunction x)]
| (x :: rest) -> [ resultFunction x (layoutFunction x -- leftL (tagText (match rest.Length with 1 -> FSComp.SR.nicePrintOtherOverloads1() | n -> FSComp.SR.nicePrintOtherOverloadsN(n)))) ]
| _ -> []
let layoutTyconRefImpl isAttribute (denv: DisplayEnv) (tcref: TyconRef) =
let tagEntityRefName (xref: EntityRef) name =
if xref.IsNamespace then tagNamespace name
elif xref.IsModule then tagModule name
elif xref.IsTypeAbbrev then
let ty = xref.TypeAbbrev.Value
match stripTyEqns denv.g ty with
| TType_app(tcref, _) when tcref.IsStructOrEnumTycon ->
tagStruct name
| _ ->
tagAlias name
elif xref.IsFSharpDelegateTycon then tagDelegate name
elif xref.IsILEnumTycon || xref.IsFSharpEnumTycon then tagEnum name
elif xref.IsStructOrEnumTycon then tagStruct name
elif xref.IsFSharpInterfaceTycon || isInterfaceTyconRef xref then tagInterface name
elif xref.IsUnionTycon then tagUnion name
elif xref.IsRecordTycon then tagRecord name
else tagClass name
let demangled =
let name =
if denv.includeStaticParametersInTypeNames then
tcref.DisplayNameWithStaticParameters
elif tcref.DisplayName = tcref.DisplayNameWithStaticParameters then
tcref.DisplayName // has no static params
else
tcref.DisplayName+"<...>" // shorten
if isAttribute && name.EndsWithOrdinal("Attribute") then
String.dropSuffix name "Attribute"
else
name
let tyconTextL =
tagEntityRefName tcref demangled
|> mkNav tcref.DefinitionRange
|> wordL
if denv.shortTypeNames then
tyconTextL
else
let path = tcref.CompilationPath.DemangledPath
let path =
if denv.includeStaticParametersInTypeNames then
path
else
path |> List.map (fun s ->
let i = s.IndexOf(',')
if i <> -1 then s.Substring(0, i)+"<...>" // apparently has static params, shorten
else s)
let pathText = trimPathByDisplayEnv denv path
if pathText = "" then tyconTextL else leftL (tagUnknownEntity pathText) ^^ tyconTextL
let layoutBuiltinAttribute (denv: DisplayEnv) (attrib: BuiltinAttribInfo) =
let tcref = attrib.TyconRef
squareAngleL (layoutTyconRefImpl true denv tcref)
module private PrintIL =
let fullySplitILTypeRef (tref: ILTypeRef) =
(List.collect IL.splitNamespace (tref.Enclosing @ [PrettyNaming.DemangleGenericTypeName tref.Name]))
let layoutILTypeRefName denv path =
let path =
match path with
| [ "System"; "Void" ] -> ["unit"]
| [ "System"; "Object" ] -> ["obj"]
| [ "System"; "String" ] -> ["string"]
| [ "System"; "Single" ] -> ["float32"]
| [ "System"; "Double" ] -> ["float"]
| [ "System"; "Decimal"] -> ["decimal"]
| [ "System"; "Char" ] -> ["char"]
| [ "System"; "Byte" ] -> ["byte"]
| [ "System"; "SByte" ] -> ["sbyte"]
| [ "System"; "Int16" ] -> ["int16"]
| [ "System"; "Int32" ] -> ["int" ]
| [ "System"; "Int64" ] -> ["int64" ]
| [ "System"; "UInt16" ] -> ["uint16" ]
| [ "System"; "UInt32" ] -> ["uint" ]
| [ "System"; "UInt64" ] -> ["uint64" ]
| [ "System"; "IntPtr" ] -> ["nativeint" ]
| [ "System"; "UIntPtr" ] -> ["unativeint" ]
| [ "System"; "Boolean"] -> ["bool"]
| _ -> path
let p2, n = List.frontAndBack path
let tagged = if n = "obj" || n = "string" then tagClass n else tagStruct n
if denv.shortTypeNames then
wordL tagged
else
leftL (tagNamespace (trimPathByDisplayEnv denv p2)) ^^ wordL tagged
let layoutILTypeRef denv tref =
let path = fullySplitILTypeRef tref
layoutILTypeRefName denv path
let layoutILArrayShape (ILArrayShape sh) =
SepL.leftBracket ^^ wordL (tagPunctuation (sh |> List.tail |> List.map (fun _ -> ",") |> String.concat "")) ^^ RightL.rightBracket // drop off one "," so that a n-dimensional array has n - 1 ","'s
let paramsL (ps: layout list) : layout =
match ps with
| [] -> emptyL
| _ ->
let body = Layout.commaListL ps
SepL.leftAngle ^^ body ^^ RightL.rightAngle
let pruneParams (className: string) (ilTyparSubst: layout list) =
let numParams =
// can't find a way to see the number of generic parameters for *this* class (the GenericParams also include type variables for enclosing classes); this will have to do
let rightMost = className |> SplitNamesForILPath |> List.last
match System.Int32.TryParse(rightMost, System.Globalization.NumberStyles.Integer, System.Globalization.CultureInfo.InvariantCulture) with
| true, n -> n
| false, _ -> 0 // looks like it's non-generic
ilTyparSubst |> List.rev |> List.truncate numParams |> List.rev
let rec layoutILType (denv: DisplayEnv) (ilTyparSubst: layout list) (ty: ILType) : layout =
match ty with
| ILType.Void -> WordL.structUnit // These are type-theoretically totally different type-theoretically `void` is Fin 0 and `unit` is Fin (S 0) ... but, this looks like as close as we can get.
| ILType.Array (sh, t) -> layoutILType denv ilTyparSubst t ^^ layoutILArrayShape sh
| ILType.Value t -> layoutILTypeRef denv t.TypeRef ^^ (t.GenericArgs |> List.map (layoutILType denv ilTyparSubst) |> paramsL)
| ILType.Boxed t -> layoutILTypeRef denv t.TypeRef ^^ (t.GenericArgs |> List.map (layoutILType denv ilTyparSubst) |> paramsL)
| ILType.Ptr t
| ILType.Byref t -> layoutILType denv ilTyparSubst t
| ILType.FunctionPointer t -> layoutILCallingSignature denv ilTyparSubst None t
| ILType.TypeVar n -> List.item (int n) ilTyparSubst
| ILType.Modified (_, _, t) -> layoutILType denv ilTyparSubst t // Just recurse through them to the contained ILType
/// Layout a function pointer signature using type-only-F#-style. No argument names are printed.
and private layoutILCallingSignature denv ilTyparSubst cons (signature: ILCallingSignature) =
// We need a special case for
// constructors (Their return types are reported as `void`, but this is
// incorrect; so if we're dealing with a constructor we require that the
// return type be passed along as the `cons` parameter.)
let args = signature.ArgTypes |> List.map (layoutILType denv ilTyparSubst)
let res =
match cons with
| Some className ->
let names = SplitNamesForILPath (PrettyNaming.DemangleGenericTypeName className)
// special case for constructor return-type (viz., the class itself)
layoutILTypeRefName denv names ^^ (pruneParams className ilTyparSubst |> paramsL)
| None ->
signature.ReturnType |> layoutILType denv ilTyparSubst
match args with
| [] -> WordL.structUnit ^^ WordL.arrow ^^ res
| [x] -> x ^^ WordL.arrow ^^ res
| _ -> sepListL WordL.star args ^^ WordL.arrow ^^ res
let layoutILFieldInit x =
let textOpt =
match x with
| Some init ->
match init with
| ILFieldInit.Bool x ->
if x
then Some Literals.keywordTrue
else Some Literals.keywordFalse
| ILFieldInit.Char c -> ("'" + (char c).ToString () + "'") |> (tagStringLiteral >> Some)
| ILFieldInit.Int8 x -> ((x |> int32 |> string) + "y") |> (tagNumericLiteral >> Some)
| ILFieldInit.Int16 x -> ((x |> int32 |> string) + "s") |> (tagNumericLiteral >> Some)
| ILFieldInit.Int32 x -> x |> (string >> tagNumericLiteral >> Some)
| ILFieldInit.Int64 x -> ((x |> string) + "L") |> (tagNumericLiteral >> Some)
| ILFieldInit.UInt8 x -> ((x |> int32 |> string) + "uy") |> (tagNumericLiteral >> Some)
| ILFieldInit.UInt16 x -> ((x |> int32 |> string) + "us") |> (tagNumericLiteral >> Some)
| ILFieldInit.UInt32 x -> (x |> int64 |> string) + "u" |> (tagNumericLiteral >> Some)
| ILFieldInit.UInt64 x -> ((x |> int64 |> string) + "UL") |> (tagNumericLiteral >> Some)
| ILFieldInit.Single d ->
let s = d.ToString ("g12", System.Globalization.CultureInfo.InvariantCulture)
let s =
if String.forall (fun c -> System.Char.IsDigit c || c = '-') s
then s + ".0"
else s
(s + "f") |> (tagNumericLiteral >> Some)
| ILFieldInit.Double d ->
let s = d.ToString ("g12", System.Globalization.CultureInfo.InvariantCulture)
let s =
if String.forall (fun c -> System.Char.IsDigit c || c = '-') s
then (s + ".0")
else s
s |> (tagNumericLiteral >> Some)
| _ -> None
| None -> None
match textOpt with
| None -> WordL.equals ^^ (comment "value unavailable")
| Some s -> WordL.equals ^^ wordL s
let layoutILEnumDefParts nm litVal =
WordL.bar ^^ wordL (tagEnum (adjustILName nm)) ^^ layoutILFieldInit litVal
module private PrintTypes =
// Note: We need nice printing of constants in order to print literals and attributes
let layoutConst g ty c =
let str =
match c with
| Const.Bool x -> if x then Literals.keywordTrue else Literals.keywordFalse
| Const.SByte x -> (x |> string)+"y" |> tagNumericLiteral
| Const.Byte x -> (x |> string)+"uy" |> tagNumericLiteral
| Const.Int16 x -> (x |> string)+"s" |> tagNumericLiteral
| Const.UInt16 x -> (x |> string)+"us" |> tagNumericLiteral
| Const.Int32 x -> (x |> string) |> tagNumericLiteral
| Const.UInt32 x -> (x |> string)+"u" |> tagNumericLiteral
| Const.Int64 x -> (x |> string)+"L" |> tagNumericLiteral
| Const.UInt64 x -> (x |> string)+"UL" |> tagNumericLiteral
| Const.IntPtr x -> (x |> string)+"n" |> tagNumericLiteral
| Const.UIntPtr x -> (x |> string)+"un" |> tagNumericLiteral
| Const.Single d ->
((let s = d.ToString("g12", System.Globalization.CultureInfo.InvariantCulture)
if String.forall (fun c -> System.Char.IsDigit(c) || c = '-') s
then s + ".0"
else s) + "f") |> tagNumericLiteral
| Const.Double d ->
let s = d.ToString("g12", System.Globalization.CultureInfo.InvariantCulture)
(if String.forall (fun c -> System.Char.IsDigit(c) || c = '-') s
then s + ".0"
else s) |> tagNumericLiteral
| Const.Char c -> "'" + c.ToString() + "'" |> tagStringLiteral
| Const.String bs -> "\"" + bs + "\"" |> tagNumericLiteral
| Const.Unit -> "()" |> tagPunctuation
| Const.Decimal bs -> string bs + "M" |> tagNumericLiteral
// either "null" or "the default value for a struct"
| Const.Zero -> tagKeyword(if isRefTy g ty then "null" else "default")
wordL str
let layoutAccessibility (denv: DisplayEnv) accessibility itemL =
let isInternalCompPath x =
match x with
| CompPath(ILScopeRef.Local, []) -> true
| _ -> false
let (|Public|Internal|Private|) (TAccess p) =
match p with
| [] -> Public
| _ when List.forall isInternalCompPath p -> Internal
| _ -> Private
match denv.contextAccessibility, accessibility with
| Public, Internal -> WordL.keywordInternal ++ itemL // print modifier, since more specific than context
| Public, Private -> WordL.keywordPrivate ++ itemL // print modifier, since more specific than context
| Internal, Private -> WordL.keywordPrivate ++ itemL // print modifier, since more specific than context
| _ -> itemL
/// Layout a reference to a type
let layoutTyconRef denv tycon = layoutTyconRefImpl false denv tycon
/// Layout the flags of a member
let layoutMemberFlags memFlags =
let stat =
if memFlags.IsInstance || (memFlags.MemberKind = MemberKind.Constructor) then emptyL
else WordL.keywordStatic
let stat =
if memFlags.IsDispatchSlot then stat ++ WordL.keywordAbstract
elif memFlags.IsOverrideOrExplicitImpl then stat ++ WordL.keywordOverride
else stat
let stat =
if memFlags.IsOverrideOrExplicitImpl then stat else
match memFlags.MemberKind with
| MemberKind.ClassConstructor
| MemberKind.Constructor
| MemberKind.PropertyGetSet -> stat
| MemberKind.Member
| MemberKind.PropertyGet
| MemberKind.PropertySet -> stat ++ WordL.keywordMember
// let stat = if memFlags.IsFinal then stat ++ wordL "final" else stat in
stat
/// Layout a single attribute arg, following the cases of 'gen_attr_arg' in ilxgen.fs
/// This is the subset of expressions we display in the NicePrint pretty printer
/// See also dataExprL - there is overlap between these that should be removed
let rec private layoutAttribArg denv arg =
match arg with
| Expr.Const (c, _, ty) ->
if isEnumTy denv.g ty then
WordL.keywordEnum ^^ angleL (layoutType denv ty) ^^ bracketL (layoutConst denv.g ty c)
else
layoutConst denv.g ty c
| Expr.Op (TOp.Array, [_elemTy], args, _) ->
LeftL.leftBracketBar ^^ semiListL (List.map (layoutAttribArg denv) args) ^^ RightL.rightBracketBar
// Detect 'typeof<ty>' calls
| TypeOfExpr denv.g ty ->
LeftL.keywordTypeof ^^ wordL (tagPunctuation "<") ^^ layoutType denv ty ^^ rightL (tagPunctuation ">")
// Detect 'typedefof<ty>' calls
| TypeDefOfExpr denv.g ty ->
LeftL.keywordTypedefof ^^ wordL (tagPunctuation "<") ^^ layoutType denv ty ^^ rightL (tagPunctuation ">")
| Expr.Op (TOp.Coerce, [tgTy;_], [arg2], _) ->
leftL (tagPunctuation "(") ^^ layoutAttribArg denv arg2 ^^ wordL (tagPunctuation ":>") ^^ layoutType denv tgTy ^^ rightL (tagPunctuation ")")
| AttribBitwiseOrExpr denv.g (arg1, arg2) ->
layoutAttribArg denv arg1 ^^ wordL (tagPunctuation "|||") ^^ layoutAttribArg denv arg2
// Detect explicit enum values
| EnumExpr denv.g arg1 ->
WordL.keywordEnum ++ bracketL (layoutAttribArg denv arg1)
| _ -> comment "(* unsupported attribute argument *)"
/// Layout arguments of an attribute 'arg1, ..., argN'
and private layoutAttribArgs denv args =
sepListL (rightL (tagPunctuation ",")) (List.map (fun (AttribExpr(e1, _)) -> layoutAttribArg denv e1) args)
/// Layout an attribute 'Type(arg1, ..., argN)'
//
// REVIEW: we are ignoring "props" here
and layoutAttrib denv (Attrib(_, k, args, _props, _, _, _)) =
let argsL = bracketL (layoutAttribArgs denv args)
match k with
| ILAttrib ilMethRef ->
let trimmedName =
let name = ilMethRef.DeclaringTypeRef.Name
if name.EndsWithOrdinal("Attribute") then
String.dropSuffix name "Attribute"
else
name
let tref = ilMethRef.DeclaringTypeRef
let tref = ILTypeRef.Create(scope= tref.Scope, enclosing=tref.Enclosing, name=trimmedName)
PrintIL.layoutILTypeRef denv tref ++ argsL
| FSAttrib vref ->
// REVIEW: this is not trimming "Attribute"
let _, _, _, rty, _ = GetTypeOfMemberInMemberForm denv.g vref
let rty = GetFSharpViewOfReturnType denv.g rty
let tcref = tcrefOfAppTy denv.g rty
layoutTyconRef denv tcref ++ argsL
and layoutILAttribElement denv arg =
match arg with
| ILAttribElem.String (Some x) -> wordL (tagStringLiteral ("\"" + x + "\""))
| ILAttribElem.String None -> wordL (tagStringLiteral "")
| ILAttribElem.Bool x -> if x then WordL.keywordTrue else WordL.keywordFalse
| ILAttribElem.Char x -> wordL (tagStringLiteral ("'" + x.ToString() + "'" ))
| ILAttribElem.SByte x -> wordL (tagNumericLiteral ((x |> string)+"y"))
| ILAttribElem.Int16 x -> wordL (tagNumericLiteral ((x |> string)+"s"))
| ILAttribElem.Int32 x -> wordL (tagNumericLiteral ((x |> string)))
| ILAttribElem.Int64 x -> wordL (tagNumericLiteral ((x |> string)+"L"))
| ILAttribElem.Byte x -> wordL (tagNumericLiteral ((x |> string)+"uy"))
| ILAttribElem.UInt16 x -> wordL (tagNumericLiteral ((x |> string)+"us"))
| ILAttribElem.UInt32 x -> wordL (tagNumericLiteral ((x |> string)+"u"))
| ILAttribElem.UInt64 x -> wordL (tagNumericLiteral ((x |> string)+"UL"))
| ILAttribElem.Single x ->
let str =
let s = x.ToString("g12", System.Globalization.CultureInfo.InvariantCulture)
(if String.forall (fun c -> System.Char.IsDigit(c) || c = '-') s
then s + ".0"
else s) + "f"
wordL (tagNumericLiteral str)
| ILAttribElem.Double x ->
let str =
let s = x.ToString("g12", System.Globalization.CultureInfo.InvariantCulture)
if String.forall (fun c -> System.Char.IsDigit(c) || c = '-') s
then s + ".0"
else s
wordL (tagNumericLiteral str)
| ILAttribElem.Null -> wordL (tagKeyword "null")
| ILAttribElem.Array (_, xs) ->
leftL (tagPunctuation "[|") ^^ semiListL (List.map (layoutILAttribElement denv) xs) ^^ RightL.rightBracketBar
| ILAttribElem.Type (Some ty) ->
LeftL.keywordTypeof ^^ SepL.leftAngle ^^ PrintIL.layoutILType denv [] ty ^^ RightL.rightAngle
| ILAttribElem.Type None -> wordL (tagText "")
| ILAttribElem.TypeRef (Some ty) ->
LeftL.keywordTypedefof ^^ SepL.leftAngle ^^ PrintIL.layoutILTypeRef denv ty ^^ RightL.rightAngle
| ILAttribElem.TypeRef None -> emptyL
and layoutILAttrib denv (ty, args) =
let argsL = bracketL (sepListL (rightL (tagPunctuation ",")) (List.map (layoutILAttribElement denv) args))
PrintIL.layoutILType denv [] ty ++ argsL
/// Layout '[<attribs>]' above another block
and layoutAttribs denv isValue ty kind attrs restL =
if denv.showAttributes then
// Don't display DllImport attributes in generated signatures
let attrs = attrs |> List.filter (IsMatchingFSharpAttributeOpt denv.g denv.g.attrib_DllImportAttribute >> not)
let attrs = attrs |> List.filter (IsMatchingFSharpAttributeOpt denv.g denv.g.attrib_ContextStaticAttribute >> not)
let attrs = attrs |> List.filter (IsMatchingFSharpAttributeOpt denv.g denv.g.attrib_ThreadStaticAttribute >> not)
let attrs = attrs |> List.filter (IsMatchingFSharpAttribute denv.g denv.g.attrib_EntryPointAttribute >> not)
let attrs = attrs |> List.filter (IsMatchingFSharpAttributeOpt denv.g denv.g.attrib_MarshalAsAttribute >> not)
let attrs = attrs |> List.filter (IsMatchingFSharpAttribute denv.g denv.g.attrib_ReflectedDefinitionAttribute >> not)
let attrs = attrs |> List.filter (IsMatchingFSharpAttribute denv.g denv.g.attrib_StructLayoutAttribute >> not)
let attrs = attrs |> List.filter (IsMatchingFSharpAttribute denv.g denv.g.attrib_AutoSerializableAttribute >> not)
match attrs with
| [] -> restL
| _ ->
squareAngleL (sepListL (rightL (tagPunctuation ";")) (List.map (layoutAttrib denv) attrs)) @@
restL
elif not isValue && (isStructTy denv.g ty && not (isEnumTy denv.g ty)) then
squareAngleL (wordL (tagClass "Struct")) @@ restL
else
match kind with
| TyparKind.Type -> restL
| TyparKind.Measure -> squareAngleL (wordL (tagClass "Measure")) @@ restL
and layoutTyparAttribs denv kind attrs restL =
match attrs, kind with
| [], TyparKind.Type -> restL
| _, _ -> squareAngleL (sepListL (rightL (tagPunctuation ";")) ((match kind with TyparKind.Type -> [] | TyparKind.Measure -> [wordL (tagText "Measure")]) @ List.map (layoutAttrib denv) attrs)) ^^ restL
and private layoutTyparRef denv (typar: Typar) =
wordL
(tagTypeParameter
(sprintf "%s%s%s"
(if denv.showConstraintTyparAnnotations then prefixOfStaticReq typar.StaticReq else "'")
(if denv.showImperativeTyparAnnotations then prefixOfRigidTypar typar else "")
typar.DisplayName))
/// Layout a single type parameter declaration, taking TypeSimplificationInfo into account
/// There are several printing-cases for a typar:
///
/// 'a - is multiple occurrence.
/// _ - singleton occurrence, an underscore preferred over 'b. (OCaml accepts but does not print)
/// #Type - inplace coercion constraint and singleton.
/// ('a :> Type) - inplace coercion constraint not singleton.
/// ('a.opM: S->T) - inplace operator constraint.
///
and private layoutTyparRefWithInfo denv (env: SimplifyTypes.TypeSimplificationInfo) (typar: Typar) =
let varL = layoutTyparRef denv typar
let varL = if denv.showAttributes then layoutTyparAttribs denv typar.Kind typar.Attribs varL else varL
match Zmap.tryFind typar env.inplaceConstraints with
| Some (typarConstraintTy) ->
if Zset.contains typar env.singletons then
leftL (tagPunctuation "#") ^^ layoutTypeWithInfo denv env typarConstraintTy
else
(varL ^^ sepL (tagPunctuation ":>") ^^ layoutTypeWithInfo denv env typarConstraintTy) |> bracketL
| _ -> varL
/// Layout type parameter constraints, taking TypeSimplificationInfo into account
and layoutConstraintsWithInfo denv env cxs =
// Internally member constraints get attached to each type variable in their support.
// This means we get too many constraints being printed.
// So we normalize the constraints to eliminate duplicate member constraints
let cxs =
cxs
|> ListSet.setify (fun (_, cx1) (_, cx2) ->
match cx1, cx2 with
| TyparConstraint.MayResolveMember(traitInfo1, _),
TyparConstraint.MayResolveMember(traitInfo2, _) -> traitsAEquiv denv.g TypeEquivEnv.Empty traitInfo1 traitInfo2
| _ -> false)
let cxsL = List.collect (layoutConstraintWithInfo denv env) cxs
match cxsL with
| [] -> emptyL
| _ ->
if denv.abbreviateAdditionalConstraints then
wordL (tagKeyword "when") ^^ wordL(tagText "<constraints>")
elif denv.shortConstraints then
leftL (tagPunctuation "(") ^^ wordL (tagKeyword "requires") ^^ sepListL (wordL (tagKeyword "and")) cxsL ^^ rightL (tagPunctuation ")")
else
wordL (tagKeyword "when") ^^ sepListL (wordL (tagKeyword "and")) cxsL
/// Layout constraints, taking TypeSimplificationInfo into account
and private layoutConstraintWithInfo denv env (tp, tpc) =
let longConstraintPrefix l = layoutTyparRefWithInfo denv env tp ^^ WordL.colon ^^ l
match tpc with
| TyparConstraint.CoercesTo(tpct, _) ->
[layoutTyparRefWithInfo denv env tp ^^ wordL (tagOperator ":>") --- layoutTypeWithInfo denv env tpct]
| TyparConstraint.MayResolveMember(traitInfo, _) ->
[layoutTraitWithInfo denv env traitInfo]
| TyparConstraint.DefaultsTo(_, ty, _) ->
if denv.showTyparDefaultConstraints then [wordL (tagKeyword "default") ^^ layoutTyparRefWithInfo denv env tp ^^ WordL.colon ^^ layoutTypeWithInfo denv env ty]
else []
| TyparConstraint.IsEnum(ty, _) ->
if denv.shortConstraints then
[wordL (tagKeyword "enum")]
else
[longConstraintPrefix (layoutTypeAppWithInfoAndPrec denv env (wordL (tagKeyword "enum")) 2 true [ty])]
| TyparConstraint.SupportsComparison _ ->
if denv.shortConstraints then
[wordL (tagKeyword "comparison")]
else
[wordL (tagKeyword "comparison") |> longConstraintPrefix]
| TyparConstraint.SupportsEquality _ ->
if denv.shortConstraints then
[wordL (tagKeyword "equality")]
else
[wordL (tagKeyword "equality") |> longConstraintPrefix]
| TyparConstraint.IsDelegate(aty, bty, _) ->
if denv.shortConstraints then
[WordL.keywordDelegate]
else
[layoutTypeAppWithInfoAndPrec denv env (WordL.keywordDelegate) 2 true [aty;bty] |> longConstraintPrefix]
| TyparConstraint.SupportsNull _ ->
[wordL (tagKeyword "null") |> longConstraintPrefix]
| TyparConstraint.IsNonNullableStruct _ ->
if denv.shortConstraints then
[wordL (tagText "value type")]
else
[WordL.keywordStruct |> longConstraintPrefix]
| TyparConstraint.IsUnmanaged _ ->
if denv.shortConstraints then
[wordL (tagKeyword "unmanaged")]
else
[wordL (tagKeyword "unmanaged") |> longConstraintPrefix]
| TyparConstraint.IsReferenceType _ ->
if denv.shortConstraints then
[wordL (tagText "reference type")]
else
[(wordL (tagKeyword "not") ^^ wordL(tagKeyword "struct")) |> longConstraintPrefix]
| TyparConstraint.SimpleChoice(tys, _) ->
[bracketL (sepListL (sepL (tagPunctuation "|")) (List.map (layoutTypeWithInfo denv env) tys)) |> longConstraintPrefix]
| TyparConstraint.RequiresDefaultConstructor _ ->
if denv.shortConstraints then
[wordL (tagKeyword "default") ^^ wordL (tagKeyword "constructor")]
else
[bracketL (
wordL (tagKeyword "new") ^^
wordL (tagPunctuation ":") ^^
WordL.structUnit ^^
WordL.arrow ^^
(layoutTyparRefWithInfo denv env tp)) |> longConstraintPrefix]
and private layoutTraitWithInfo denv env (TTrait(tys, nm, memFlags, argtys, rty, _)) =
let nm = DemangleOperatorName nm
if denv.shortConstraints then
WordL.keywordMember ^^ wordL (tagMember nm)
else
let rty = GetFSharpViewOfReturnType denv.g rty
let stat = layoutMemberFlags memFlags
let tys = ListSet.setify (typeEquiv denv.g) tys
let tysL =
match tys with
| [ty] -> layoutTypeWithInfo denv env ty
| tys -> bracketL (layoutTypesWithInfoAndPrec denv env 2 (wordL (tagKeyword "or")) tys)
tysL ^^ wordL (tagPunctuation ":") ---
bracketL (stat ++ wordL (tagMember nm) ^^ wordL (tagPunctuation ":") ---
((layoutTypesWithInfoAndPrec denv env 2 (wordL (tagPunctuation "*")) argtys --- wordL (tagPunctuation "->")) --- (layoutReturnType denv env rty)))
/// Layout a unit expression
and private layoutMeasure denv unt =
let sortVars vs = vs |> List.sortBy (fun (v: Typar, _) -> v.DisplayName)
let sortCons cs = cs |> List.sortBy (fun (c: TyconRef, _) -> c.DisplayName)
let negvs, posvs = ListMeasureVarOccsWithNonZeroExponents unt |> sortVars |> List.partition (fun (_, e) -> SignRational e < 0)
let negcs, poscs = ListMeasureConOccsWithNonZeroExponents denv.g false unt |> sortCons |> List.partition (fun (_, e) -> SignRational e < 0)
let unparL uv = layoutTyparRef denv uv
let unconL tc = layoutTyconRef denv tc
let rationalL e = wordL (tagNumericLiteral (RationalToString e))
let measureToPowerL x e = if e = OneRational then x else x -- wordL (tagPunctuation "^") -- rationalL e
let prefix = spaceListL (List.map (fun (v, e) -> measureToPowerL (unparL v) e) posvs @
List.map (fun (c, e) -> measureToPowerL (unconL c) e) poscs)
let postfix = spaceListL (List.map (fun (v, e) -> measureToPowerL (unparL v) (NegRational e)) negvs @
List.map (fun (c, e) -> measureToPowerL (unconL c) (NegRational e)) negcs)
match (negvs, negcs) with
| [], [] -> (match posvs, poscs with [], [] -> wordL (tagNumericLiteral "1") | _ -> prefix)
| _ -> prefix ^^ sepL (tagPunctuation "/") ^^ (if List.length negvs + List.length negcs > 1 then sepL (tagPunctuation "(") ^^ postfix ^^ sepL (tagPunctuation ")") else postfix)
/// Layout type arguments, either NAME<ty, ..., ty> or (ty, ..., ty) NAME *)
and private layoutTypeAppWithInfoAndPrec denv env tcL prec prefix args =
if prefix then
match args with
| [] -> tcL
| [arg] -> tcL ^^ sepL (tagPunctuation "<") ^^ (layoutTypeWithInfoAndPrec denv env 4 arg) ^^ rightL (tagPunctuation">")
| args -> bracketIfL (prec <= 1) (tcL ^^ angleL (layoutTypesWithInfoAndPrec denv env 2 (sepL (tagPunctuation ",")) args))
else
match args with
| [] -> tcL
| [arg] -> layoutTypeWithInfoAndPrec denv env 2 arg ^^ tcL
| args -> bracketIfL (prec <= 1) (bracketL (layoutTypesWithInfoAndPrec denv env 2 (sepL (tagPunctuation ",")) args) --- tcL)
/// Layout a type, taking precedence into account to insert brackets where needed
and layoutTypeWithInfoAndPrec denv env prec ty =
match stripTyparEqns ty with
// Always prefer to format 'byref<ty, ByRefKind.In>' as 'inref<ty>'
| ty when isInByrefTy denv.g ty && (match ty with TType_app (tc, _) when denv.g.inref_tcr.CanDeref && tyconRefEq denv.g tc denv.g.byref2_tcr -> true | _ -> false) ->
layoutTypeWithInfoAndPrec denv env prec (mkInByrefTy denv.g (destByrefTy denv.g ty))
// Always prefer to format 'byref<ty, ByRefKind.Out>' as 'outref<ty>'
| ty when isOutByrefTy denv.g ty && (match ty with TType_app (tc, _) when denv.g.outref_tcr.CanDeref && tyconRefEq denv.g tc denv.g.byref2_tcr -> true | _ -> false) ->
layoutTypeWithInfoAndPrec denv env prec (mkOutByrefTy denv.g (destByrefTy denv.g ty))
// Always prefer to format 'byref<ty, ByRefKind.InOut>' as 'byref<ty>'
| ty when isByrefTy denv.g ty && (match ty with TType_app (tc, _) when denv.g.byref_tcr.CanDeref && tyconRefEq denv.g tc denv.g.byref2_tcr -> true | _ -> false) ->
layoutTypeWithInfoAndPrec denv env prec (mkByrefTy denv.g (destByrefTy denv.g ty))
// Always prefer 'float' to 'float<1>'
| TType_app (tc, args) when tc.IsMeasureableReprTycon && List.forall (isDimensionless denv.g) args ->
layoutTypeWithInfoAndPrec denv env prec (reduceTyconRefMeasureableOrProvided denv.g tc args)
// Layout a type application
| TType_app (tc, args) ->
layoutTypeAppWithInfoAndPrec denv env (layoutTyconRef denv tc) prec tc.IsPrefixDisplay args
| TType_ucase (UnionCaseRef(tc, _), args) ->
layoutTypeAppWithInfoAndPrec denv env (layoutTyconRef denv tc) prec tc.IsPrefixDisplay args
// Layout a tuple type
| TType_anon (anonInfo, tys) ->
let core = sepListL (rightL (tagPunctuation ";")) (List.map2 (fun nm ty -> wordL (tagField nm) ^^ rightL (tagPunctuation ":") ^^ layoutTypeWithInfoAndPrec denv env prec ty) (Array.toList anonInfo.SortedNames) tys)
if evalAnonInfoIsStruct anonInfo then
WordL.keywordStruct --- braceBarL core
else
braceBarL core
// Layout a tuple type
| TType_tuple (tupInfo, t) ->
if evalTupInfoIsStruct tupInfo then
WordL.keywordStruct --- bracketL (layoutTypesWithInfoAndPrec denv env 2 (wordL (tagPunctuation "*")) t)
else
bracketIfL (prec <= 2) (layoutTypesWithInfoAndPrec denv env 2 (wordL (tagPunctuation "*")) t)
// Layout a first-class generic type.
| TType_forall (tps, tau) ->
let tauL = layoutTypeWithInfoAndPrec denv env prec tau
match tps with
| [] -> tauL
| [h] -> layoutTyparRefWithInfo denv env h ^^ rightL (tagPunctuation ".") --- tauL
| (h :: t) -> spaceListL (List.map (layoutTyparRefWithInfo denv env) (h :: t)) ^^ rightL (tagPunctuation ".") --- tauL
// Layout a function type.
| TType_fun _ ->
let rec loop soFarL ty =
match stripTyparEqns ty with
| TType_fun (dty, rty) -> loop (soFarL --- (layoutTypeWithInfoAndPrec denv env 4 dty ^^ wordL (tagPunctuation "->"))) rty
| rty -> soFarL --- layoutTypeWithInfoAndPrec denv env 5 rty
bracketIfL (prec <= 4) (loop emptyL ty)
// Layout a type variable .
| TType_var r ->
layoutTyparRefWithInfo denv env r
| TType_measure unt -> layoutMeasure denv unt
/// Layout a list of types, separated with the given separator, either '*' or ','
and private layoutTypesWithInfoAndPrec denv env prec sep typl =
sepListL sep (List.map (layoutTypeWithInfoAndPrec denv env prec) typl)
and private layoutReturnType denv env rty = layoutTypeWithInfoAndPrec denv env 4 rty
/// Layout a single type, taking TypeSimplificationInfo into account
and private layoutTypeWithInfo denv env ty =
layoutTypeWithInfoAndPrec denv env 5 ty
and layoutType denv ty =
layoutTypeWithInfo denv SimplifyTypes.typeSimplificationInfo0 ty
let layoutArgInfos denv env argInfos =
// Format each argument, including its name and type
let argL (ty, argInfo: ArgReprInfo) =
// Detect an optional argument
let isOptionalArg = HasFSharpAttribute denv.g denv.g.attrib_OptionalArgumentAttribute argInfo.Attribs
let isParamArray = HasFSharpAttribute denv.g denv.g.attrib_ParamArrayAttribute argInfo.Attribs
match argInfo.Name, isOptionalArg, isParamArray, tryDestOptionTy denv.g ty with
// Layout an optional argument
| Some(id), true, _, ValueSome ty ->
leftL (tagPunctuation "?") ^^ sepL (tagParameter id.idText) ^^ SepL.colon ^^ layoutTypeWithInfoAndPrec denv env 2 ty
// Layout an unnamed argument
| None, _, _, _ ->
layoutTypeWithInfoAndPrec denv env 2 ty
// Layout a named argument
| Some id, _, isParamArray, _ ->
let prefix =
if isParamArray then
layoutBuiltinAttribute denv denv.g.attrib_ParamArrayAttribute ^^ leftL (tagParameter id.idText)
else
leftL (tagParameter id.idText)
prefix ^^ SepL.colon ^^ layoutTypeWithInfoAndPrec denv env 2 ty
let allArgsL =
argInfos
|> List.mapSquared argL
|> List.map (sepListL (wordL (tagPunctuation "*")))
allArgsL
let layoutGenericParameterTypes denv env =
function
| [] -> emptyL
| genParamTys ->
(wordL (tagPunctuation "<"))
^^
(
genParamTys
|> List.map (layoutTypeWithInfoAndPrec denv env 4)
|> sepListL (wordL (tagPunctuation ","))
)
^^
(wordL (tagPunctuation ">"))
/// Layout a single type used as the type of a member or value
let layoutTopType denv env argInfos rty cxs =
// Parenthesize the return type to match the topValInfo
let rtyL = layoutReturnType denv env rty
let cxsL = layoutConstraintsWithInfo denv env cxs
match argInfos with
| [] -> rtyL --- cxsL
| _ ->
let delimitReturnValue = tagPunctuation (if denv.useColonForReturnType then ":" else "->")
let allArgsL =
layoutArgInfos denv env argInfos
|> List.map (fun x -> (x ^^ wordL delimitReturnValue))
(List.foldBack (---) allArgsL rtyL) --- cxsL
/// Layout type parameters
let layoutTyparDecls denv nmL prefix (typars: Typars) =
let env = SimplifyTypes.typeSimplificationInfo0
let tpcs = typars |> List.collect (fun tp -> List.map (fun tpc -> tp, tpc) tp.Constraints)
match typars, tpcs with
| [], [] ->
nmL
| [h], [] when not prefix ->
layoutTyparRefWithInfo denv env h --- nmL
| _ ->
let tpcsL = layoutConstraintsWithInfo denv env tpcs
let coreL = sepListL (sepL (tagPunctuation ",")) (List.map (layoutTyparRefWithInfo denv env) typars)
(if prefix || not (isNil tpcs) then nmL ^^ angleL (coreL --- tpcsL) else bracketL coreL --- nmL)
let layoutTyparConstraint denv (tp, tpc) =
match layoutConstraintWithInfo denv SimplifyTypes.typeSimplificationInfo0 (tp, tpc) with
| h :: _ -> h
| [] -> emptyL
let prettyLayoutOfInstAndSig denv (typarInst, tys, retTy) =
let (prettyTyparInst, prettyTys, prettyRetTy), cxs = PrettyTypes.PrettifyInstAndSig denv.g (typarInst, tys, retTy)
let env = SimplifyTypes.CollectInfo true (prettyRetTy :: prettyTys) cxs
let prettyTysL = List.map (layoutTypeWithInfo denv env) prettyTys
let prettyRetTyL = layoutTopType denv env [[]] prettyRetTy []
prettyTyparInst, (prettyTys, prettyRetTy), (prettyTysL, prettyRetTyL), layoutConstraintsWithInfo denv env env.postfixConstraints
let prettyLayoutOfTopTypeInfoAux denv prettyArgInfos prettyRetTy cxs =
let env = SimplifyTypes.CollectInfo true (prettyRetTy :: List.collect (List.map fst) prettyArgInfos) cxs
layoutTopType denv env prettyArgInfos prettyRetTy env.postfixConstraints
// Oddly this is called in multiple places with argInfos=[] and denv.useColonForReturnType=true, as a complex
// way of giving give ": ty"
let prettyLayoutOfUncurriedSig denv typarInst argInfos retTy =
let (prettyTyparInst, prettyArgInfos, prettyRetTy), cxs = PrettyTypes.PrettifyInstAndUncurriedSig denv.g (typarInst, argInfos, retTy)
prettyTyparInst, prettyLayoutOfTopTypeInfoAux denv [prettyArgInfos] prettyRetTy cxs
let prettyLayoutOfCurriedMemberSig denv typarInst argInfos retTy parentTyparTys =
let (prettyTyparInst, parentTyparTys, argInfos, retTy), cxs = PrettyTypes.PrettifyInstAndCurriedSig denv.g (typarInst, parentTyparTys, argInfos, retTy)
// Filter out the parent typars, which don't get shown in the member signature
let cxs = cxs |> List.filter (fun (tp, _) -> not (parentTyparTys |> List.exists (fun ty -> match tryDestTyparTy denv.g ty with ValueSome destTypar -> typarEq tp destTypar | _ -> false)))
prettyTyparInst, prettyLayoutOfTopTypeInfoAux denv argInfos retTy cxs
let private prettyArgInfos denv allTyparInst =
function
| [] -> [(denv.g.unit_ty, ValReprInfo.unnamedTopArg1)]
| infos -> infos |> List.map (map1Of2 (instType allTyparInst))
// Layout: type spec - class, datatype, record, abbrev
let private prettyLayoutOfMemberSigCore denv memberToParentInst (typarInst, methTypars: Typars, argInfos, retTy) =
let niceMethodTypars, allTyparInst =
let methTyparNames = methTypars |> List.mapi (fun i tp -> if (PrettyTypes.NeedsPrettyTyparName tp) then sprintf "a%d" (List.length memberToParentInst + i) else tp.Name)
PrettyTypes.NewPrettyTypars memberToParentInst methTypars methTyparNames
let retTy = instType allTyparInst retTy
let argInfos = argInfos |> List.map (prettyArgInfos denv allTyparInst)
// Also format dummy types corresponding to any type variables on the container to make sure they
// aren't chosen as names for displayed variables.
let memberParentTypars = List.map fst memberToParentInst
let parentTyparTys = List.map (mkTyparTy >> instType allTyparInst) memberParentTypars
let prettyTyparInst, layout = prettyLayoutOfCurriedMemberSig denv typarInst argInfos retTy parentTyparTys
prettyTyparInst, niceMethodTypars, layout
let prettyLayoutOfMemberType denv v typarInst argInfos retTy =
match PartitionValRefTypars denv.g v with
| Some(_, _, memberMethodTypars, memberToParentInst, _) ->
prettyLayoutOfMemberSigCore denv memberToParentInst (typarInst, memberMethodTypars, argInfos, retTy)
| None ->
let prettyTyparInst, layout = prettyLayoutOfUncurriedSig denv typarInst (List.concat argInfos) retTy
prettyTyparInst, [], layout
let prettyLayoutOfMemberSig denv (memberToParentInst, nm, methTypars, argInfos, retTy) =
let _, niceMethodTypars, tauL = prettyLayoutOfMemberSigCore denv memberToParentInst (emptyTyparInst, methTypars, argInfos, retTy)
let nameL =
let nameL = DemangleOperatorNameAsLayout tagMember nm
let nameL = if denv.showTyparBinding then layoutTyparDecls denv nameL true niceMethodTypars else nameL
nameL
nameL ^^ wordL (tagPunctuation ":") ^^ tauL
/// layouts the elements of an unresolved overloaded method call:
/// argInfos: unammed and named arguments
/// retTy: return type
/// genParamTy: generic parameter types
let prettyLayoutsOfUnresolvedOverloading denv argInfos retTy genParamTys =
let _niceMethodTypars, typarInst =
let memberToParentInst = List.empty
let typars = argInfos |> List.choose (function (TType.TType_var typar,_) -> Some typar | _ -> None)
let methTyparNames = typars |> List.mapi (fun i tp -> if (PrettyTypes.NeedsPrettyTyparName tp) then sprintf "a%d" (List.length memberToParentInst + i) else tp.Name)
PrettyTypes.NewPrettyTypars memberToParentInst typars methTyparNames
let retTy = instType typarInst retTy
let argInfos = prettyArgInfos denv typarInst argInfos
let argInfos,retTy,genParamTys, cxs =
// using 0, 1, 2 as discriminant for return, arguments and generic parameters
// respectively, in order to easily retrieve each of the types with their
// expected quality below.
let typesWithDiscrimants =
[
yield 0, retTy
for ty,_ in argInfos do
yield 1, ty
for ty in genParamTys do
yield 2, ty
]
let typesWithDiscrimants,typarsAndCxs = PrettyTypes.PrettifyDiscriminantAndTypePairs denv.g typesWithDiscrimants
let retTy = typesWithDiscrimants |> List.find (function (0, _) -> true | _ -> false) |> snd
let argInfos =
typesWithDiscrimants
|> List.choose (function (1,ty) -> Some ty | _ -> None)
|> List.zip argInfos
|> List.map (fun ((_,argInfo),tTy) -> tTy, argInfo)
let genParamTys =
typesWithDiscrimants
|> List.choose (function (2,ty) -> Some ty | _ -> None)
argInfos, retTy, genParamTys, typarsAndCxs
let env = SimplifyTypes.CollectInfo true (List.collect (List.map fst) [argInfos]) cxs
let cxsL = layoutConstraintsWithInfo denv env env.postfixConstraints
(List.foldBack (---) (layoutArgInfos denv env [argInfos]) cxsL,
layoutReturnType denv env retTy,
layoutGenericParameterTypes denv env genParamTys)
let prettyLayoutOfType denv ty =
let ty, cxs = PrettyTypes.PrettifyType denv.g ty
let env = SimplifyTypes.CollectInfo true [ty] cxs
let cxsL = layoutConstraintsWithInfo denv env env.postfixConstraints
layoutTypeWithInfoAndPrec denv env 2 ty --- cxsL
let prettyLayoutOfTypeNoConstraints denv ty =
let ty, _cxs = PrettyTypes.PrettifyType denv.g ty
layoutTypeWithInfoAndPrec denv SimplifyTypes.typeSimplificationInfo0 5 ty
let layoutAssemblyName _denv (ty: TType) =
ty.GetAssemblyName()
/// Printing TAST objects
module private PrintTastMemberOrVals =
open PrintTypes
let private prettyLayoutOfMemberShortOption denv typarInst (v:Val) short =
let v = mkLocalValRef v
let membInfo = Option.get v.MemberInfo
let stat = PrintTypes.layoutMemberFlags membInfo.MemberFlags
let _tps, argInfos, rty, _ = GetTypeOfMemberInFSharpForm denv.g v
if short then
for argInfo in argInfos do
for _,info in argInfo do
info.Attribs <- []
info.Name <- None
let mkNameL niceMethodTypars tagFunction name =
let nameL =
DemangleOperatorNameAsLayout (tagFunction >> mkNav v.DefinitionRange) name
let nameL =
if denv.showMemberContainers then
layoutTyconRef denv v.MemberApparentEntity ^^ SepL.dot ^^ nameL
else
nameL
let nameL = if denv.showTyparBinding then layoutTyparDecls denv nameL true niceMethodTypars else nameL
let nameL = layoutAccessibility denv v.Accessibility nameL
nameL
match membInfo.MemberFlags.MemberKind with
| MemberKind.Member ->
let prettyTyparInst, niceMethodTypars,tauL = prettyLayoutOfMemberType denv v typarInst argInfos rty
let resL =
if short then tauL
else
let nameL = mkNameL niceMethodTypars tagMember v.LogicalName
stat --- (nameL ^^ WordL.colon ^^ tauL)
prettyTyparInst, resL
| MemberKind.ClassConstructor
| MemberKind.Constructor ->
let prettyTyparInst, _, tauL = prettyLayoutOfMemberType denv v typarInst argInfos rty
let resL =
if short then tauL
else
let newL = layoutAccessibility denv v.Accessibility WordL.keywordNew
stat ++ newL ^^ wordL (tagPunctuation ":") ^^ tauL
prettyTyparInst, resL
| MemberKind.PropertyGetSet ->
emptyTyparInst, stat
| MemberKind.PropertyGet ->
if isNil argInfos then
// use error recovery because intellisense on an incomplete file will show this
errorR(Error(FSComp.SR.tastInvalidFormForPropertyGetter(), v.Id.idRange))
let nameL = mkNameL [] tagProperty v.CoreDisplayName
let resL =
if short then nameL --- (WordL.keywordWith ^^ WordL.keywordGet)
else stat --- nameL --- (WordL.keywordWith ^^ WordL.keywordGet)
emptyTyparInst, resL
else
let argInfos =
match argInfos with
| [[(ty, _)]] when isUnitTy denv.g ty -> []
| _ -> argInfos
let prettyTyparInst, niceMethodTypars,tauL = prettyLayoutOfMemberType denv v typarInst argInfos rty
let resL =
if short then
if isNil argInfos then tauL
else tauL --- (WordL.keywordWith ^^ WordL.keywordGet)
else
let nameL = mkNameL niceMethodTypars tagProperty v.CoreDisplayName
stat --- (nameL ^^ WordL.colon ^^ (if isNil argInfos then tauL else tauL --- (WordL.keywordWith ^^ WordL.keywordGet)))
prettyTyparInst, resL
| MemberKind.PropertySet ->
if argInfos.Length <> 1 || isNil argInfos.Head then
// use error recovery because intellisense on an incomplete file will show this
errorR(Error(FSComp.SR.tastInvalidFormForPropertySetter(), v.Id.idRange))
let nameL = mkNameL [] tagProperty v.CoreDisplayName
let resL = stat --- nameL --- (WordL.keywordWith ^^ WordL.keywordSet)
emptyTyparInst, resL
else
let argInfos, valueInfo = List.frontAndBack argInfos.Head
let prettyTyparInst, niceMethodTypars, tauL = prettyLayoutOfMemberType denv v typarInst (if isNil argInfos then [] else [argInfos]) (fst valueInfo)