/
sformat.fs
1343 lines (1142 loc) · 58.7 KB
/
sformat.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.
// This file is compiled twice in the codebase
// - as the internal implementation of printf '%A' formatting in FSharp.Core
// - as the implementation of structured formatting in the compiler, F# Interactive and FSharp.Compiler.Service.
//
// The one implementation file is used because we keep the implementations of
// structured formatting the same for fsi.exe and '%A' printing. However F# Interactive has
// a richer feature set.
#nowarn "52" // The value has been copied to ensure the original is not mutated by this operation
#if COMPILER
namespace Internal.Utilities.StructuredFormat
#else
// FSharp.Core.dll:
namespace Microsoft.FSharp.Text.StructuredPrintfImpl
#endif
// Breakable block layout implementation.
// This is a fresh implementation of pre-existing ideas.
open System
open System.IO
open System.Reflection
open System.Globalization
open System.Collections.Generic
open Microsoft.FSharp.Core
open Microsoft.FSharp.Core.LanguagePrimitives.IntrinsicOperators
open Microsoft.FSharp.Reflection
open Microsoft.FSharp.Collections
[<StructuralEquality; NoComparison>]
type LayoutTag =
| ActivePatternCase
| ActivePatternResult
| Alias
| Class
| Union
| UnionCase
| Delegate
| Enum
| Event
| Field
| Interface
| Keyword
| LineBreak
| Local
| Record
| RecordField
| Method
| Member
| ModuleBinding
| Function
| Module
| Namespace
| NumericLiteral
| Operator
| Parameter
| Property
| Space
| StringLiteral
| Struct
| TypeParameter
| Text
| Punctuation
| UnknownType
| UnknownEntity
type TaggedText =
abstract Tag: LayoutTag
abstract Text: string
type TaggedTextWriter =
abstract Write: t: TaggedText -> unit
abstract WriteLine: unit -> unit
/// A joint, between 2 layouts, is either:
/// - unbreakable, or
/// - breakable, and if broken the second block has a given indentation.
[<StructuralEquality; NoComparison>]
type Joint =
| Unbreakable
| Breakable of indentation: int
| Broken of indentation: int
/// If either juxtaposition flag is true, then no space between words.
[<NoEquality; NoComparison>]
type Layout =
| ObjLeaf of juxtLeft: bool * object: obj * juxtRight: bool
| Leaf of juxtLeft: bool * text: TaggedText * justRight: bool
| Node of leftLayout: Layout * rightLayout: Layout * joint: Joint
| Attr of text: string * attributes: (string * string) list * layout: Layout
member layout.JuxtapositionLeft =
match layout with
| ObjLeaf (jl, _, _) -> jl
| Leaf (jl, _, _) -> jl
| Node (left, _, _) -> left.JuxtapositionLeft
| Attr (_, _, subLayout) -> subLayout.JuxtapositionLeft
static member JuxtapositionMiddle (left: Layout, right: Layout) =
left.JuxtapositionRight || right.JuxtapositionLeft
member layout.JuxtapositionRight =
match layout with
| ObjLeaf (_, _, jr) -> jr
| Leaf (_, _, jr) -> jr
| Node (_, right, _) -> right.JuxtapositionRight
| Attr (_, _, subLayout) -> subLayout.JuxtapositionRight
[<NoEquality; NoComparison>]
type IEnvironment =
abstract GetLayout: obj -> Layout
abstract MaxColumns: int
abstract MaxRows: int
module TaggedTextOps =
let mkTag tag text =
{ new TaggedText with
member _.Tag = tag
member _.Text = text }
let length (tt: TaggedText) = tt.Text.Length
let toText (tt: TaggedText) = tt.Text
let tagAlias t = mkTag LayoutTag.Alias t
let keywordFunctions =
[
"raise"
"reraise"
"typeof"
"typedefof"
"sizeof"
"nameof"
"char"
"decimal"
"double"
"float"
"float32"
"int"
"int8"
"int16"
"int32"
"int64"
"sbyte"
"seq" // 'seq x' when 'x' is a string works, strangely enough
"single"
"string"
"unit"
"uint"
"uint8"
"uint16"
"uint32"
"uint64"
"unativeint"
]
|> Set.ofList
let tagClass name = mkTag LayoutTag.Class name
let tagUnionCase t = mkTag LayoutTag.UnionCase t
let tagDelegate t = mkTag LayoutTag.Delegate t
let tagEnum t = mkTag LayoutTag.Enum t
let tagEvent t = mkTag LayoutTag.Event t
let tagField t = mkTag LayoutTag.Field t
let tagInterface t = mkTag LayoutTag.Interface t
let tagKeyword t = mkTag LayoutTag.Keyword t
let tagLineBreak t = mkTag LayoutTag.LineBreak t
let tagLocal t = mkTag LayoutTag.Local t
let tagRecord t = mkTag LayoutTag.Record t
let tagRecordField t = mkTag LayoutTag.RecordField t
let tagMethod t = mkTag LayoutTag.Method t
let tagModule t = mkTag LayoutTag.Module t
let tagModuleBinding name = if keywordFunctions.Contains name then mkTag LayoutTag.Keyword name else mkTag LayoutTag.ModuleBinding name
let tagFunction t = mkTag LayoutTag.Function t
let tagNamespace t = mkTag LayoutTag.Namespace t
let tagNumericLiteral t = mkTag LayoutTag.NumericLiteral t
let tagOperator t = mkTag LayoutTag.Operator t
let tagParameter t = mkTag LayoutTag.Parameter t
let tagProperty t = mkTag LayoutTag.Property t
let tagSpace t = mkTag LayoutTag.Space t
let tagStringLiteral t = mkTag LayoutTag.StringLiteral t
let tagStruct t = mkTag LayoutTag.Struct t
let tagTypeParameter t = mkTag LayoutTag.TypeParameter t
let tagText t = mkTag LayoutTag.Text t
let tagPunctuation t = mkTag LayoutTag.Punctuation t
module Literals =
// common tagged literals
let lineBreak = tagLineBreak "\n"
let space = tagSpace " "
let comma = tagPunctuation ","
let semicolon = tagPunctuation ";"
let leftParen = tagPunctuation "("
let rightParen = tagPunctuation ")"
let leftBracket = tagPunctuation "["
let rightBracket = tagPunctuation "]"
let leftBrace= tagPunctuation "{"
let rightBrace = tagPunctuation "}"
let leftBraceBar = tagPunctuation "{|"
let rightBraceBar = tagPunctuation "|}"
let equals = tagOperator "="
let arrow = tagPunctuation "->"
let questionMark = tagPunctuation "?"
module LayoutOps =
open TaggedTextOps
let mkNode l r joint =
Node(l, r, joint)
// constructors
let objL (value:obj) =
match value with
| :? string as s -> Leaf (false, mkTag LayoutTag.Text s, false)
| o -> ObjLeaf (false, o, false)
let sLeaf (l, t, r) = Leaf (l, t, r)
let wordL text = sLeaf (false, text, false)
let sepL text = sLeaf (true , text, true)
let rightL text = sLeaf (true , text, false)
let leftL text = sLeaf (false, text, true)
let emptyL = sLeaf (true, mkTag LayoutTag.Text "", true)
let isEmptyL layout =
match layout with
| Leaf(true, s, true) -> s.Text = ""
| _ -> false
let aboveL layout1 layout2 = mkNode layout1 layout2 (Broken 0)
let tagAttrL text maps layout = Attr(text, maps, layout)
let apply2 f l r =
if isEmptyL l then r
elif isEmptyL r then l
else f l r
let (^^) layout1 layout2 = mkNode layout1 layout2 (Unbreakable)
let (++) layout1 layout2 = mkNode layout1 layout2 (Breakable 0)
let (--) layout1 layout2 = mkNode layout1 layout2 (Breakable 1)
let (---) layout1 layout2 = mkNode layout1 layout2 (Breakable 2)
let (@@) layout1 layout2 = apply2 (fun l r -> mkNode l r (Broken 0)) layout1 layout2
let (@@-) layout1 layout2 = apply2 (fun l r -> mkNode l r (Broken 1)) layout1 layout2
let (@@--) layout1 layout2 = apply2 (fun l r -> mkNode l r (Broken 2)) layout1 layout2
let tagListL tagger els =
match els with
| [] -> emptyL
| [x] -> x
| x :: xs ->
let rec process' prefixL yl =
match yl with
| [] -> prefixL
| y :: ys -> process' (tagger prefixL ++ y) ys
process' x xs
let commaListL layouts = tagListL (fun prefixL -> prefixL ^^ rightL Literals.comma) layouts
let semiListL layouts = tagListL (fun prefixL -> prefixL ^^ rightL Literals.semicolon) layouts
let spaceListL layouts = tagListL (fun prefixL -> prefixL) layouts
let sepListL layout1 layouts = tagListL (fun prefixL -> prefixL ^^ layout1) layouts
let bracketL layout = leftL Literals.leftParen ^^ layout ^^ rightL Literals.rightParen
let tupleL layouts = bracketL (sepListL (sepL Literals.comma) layouts)
let aboveListL layouts =
match layouts with
| [] -> emptyL
| [x] -> x
| x :: ys -> List.fold (fun pre y -> pre @@ y) x ys
let optionL selector value =
match value with
| None -> wordL (tagUnionCase "None")
| Some x -> wordL (tagUnionCase "Some") -- (selector x)
let listL selector value =
leftL Literals.leftBracket ^^ sepListL (sepL Literals.semicolon) (List.map selector value) ^^ rightL Literals.rightBracket
let squareBracketL layout =
leftL Literals.leftBracket ^^ layout ^^ rightL Literals.rightBracket
let braceL layout =
leftL Literals.leftBrace ^^ layout ^^ rightL Literals.rightBrace
let boundedUnfoldL
(itemL: 'a -> Layout)
(project: 'z -> ('a * 'z) option)
(stopShort: 'z -> bool)
(z: 'z)
maxLength =
let rec consume n z =
if stopShort z then [wordL (tagPunctuation "...")] else
match project z with
| None -> [] // exhausted input
| Some (x, z) -> if n<=0 then [wordL (tagPunctuation "...")] // hit print_length limit
else itemL x :: consume (n-1) z // cons recursive...
consume maxLength z
let unfoldL selector folder state count =
boundedUnfoldL selector folder (fun _ -> false) state count
/// These are a typical set of options used to control structured formatting.
[<NoEquality; NoComparison>]
type FormatOptions =
{ FloatingPointFormat: string
AttributeProcessor: (string -> (string * string) list -> bool -> unit)
#if COMPILER // This is the PrintIntercepts extensibility point currently revealed by fsi.exe's AddPrinter
PrintIntercepts: (IEnvironment -> obj -> Layout option) list
StringLimit: int
#endif
FormatProvider: IFormatProvider
BindingFlags: BindingFlags
PrintWidth: int
PrintDepth: int
PrintLength: int
PrintSize: int
ShowProperties: bool
ShowIEnumerable: bool
}
static member Default =
{ FormatProvider = (CultureInfo.InvariantCulture :> IFormatProvider)
#if COMPILER // This is the PrintIntercepts extensibility point currently revealed by fsi.exe's AddPrinter
PrintIntercepts = []
StringLimit = Int32.MaxValue
#endif
AttributeProcessor= (fun _ _ _ -> ())
BindingFlags = BindingFlags.Public
FloatingPointFormat = "g10"
PrintWidth = 80
PrintDepth = 100
PrintLength = 100
PrintSize = 10000
ShowProperties = false
ShowIEnumerable = true
}
module ReflectUtils =
[<NoEquality; NoComparison>]
type TypeInfo =
| TupleType of Type list
| FunctionType of Type * Type
| RecordType of (string * Type) list
| SumType of (string * (string * Type) list) list
| UnitType
| ObjectType of Type
let isNamedType (ty:Type) = not (ty.IsArray || ty.IsByRef || ty.IsPointer)
let equivHeadTypes (ty1:Type) (ty2:Type) =
isNamedType(ty1) &&
if ty1.IsGenericType then
ty2.IsGenericType && (ty1.GetGenericTypeDefinition()).Equals(ty2.GetGenericTypeDefinition())
else
ty1.Equals(ty2)
let option = typedefof<obj option>
let func = typedefof<(obj -> obj)>
let isOptionTy ty = equivHeadTypes ty (typeof<int option>)
let isUnitType ty = equivHeadTypes ty (typeof<unit>)
let isListType ty =
FSharpType.IsUnion ty &&
(let cases = FSharpType.GetUnionCases ty
cases.Length > 0 && equivHeadTypes (typedefof<list<_>>) cases.[0].DeclaringType)
[<RequireQualifiedAccess; StructuralComparison; StructuralEquality>]
type TupleType =
| Value
| Reference
[<NoEquality; NoComparison>]
type ValueInfo =
| TupleValue of TupleType * (obj * Type)[]
| FunctionClosureValue of Type
| RecordValue of (string * obj * Type)[]
| UnionCaseValue of declaringType: Type option * string * (string * (obj * Type))[]
| ExceptionValue of Type * (string * (obj * Type))[]
| NullValue
| UnitValue
| ObjectValue of obj
module Value =
// Returns true if a given type has the RequireQualifiedAccess attribute
let private requiresQualifiedAccess (declaringType: Type) =
let rqaAttr = declaringType.GetCustomAttribute(typeof<RequireQualifiedAccessAttribute>, false)
isNull rqaAttr |> not
// Analyze an object to see if it the representation
// of an F# value.
let GetValueInfoOfObject (bindingFlags: BindingFlags) (obj: obj) =
match obj with
| null -> NullValue
| _ ->
let reprty = obj.GetType()
// First a bunch of special rules for tuples
// Because of the way F# currently compiles tuple values
// of size > 7 we can only reliably reflect on sizes up
// to 7.
if FSharpType.IsTuple reprty then
let tyArgs = FSharpType.GetTupleElements(reprty)
let fields = FSharpValue.GetTupleFields obj |> Array.mapi (fun i v -> (v, tyArgs.[i]))
let tupleType =
if reprty.Name.StartsWith "ValueTuple" then TupleType.Value
else TupleType.Reference
TupleValue (tupleType, fields)
elif FSharpType.IsFunction reprty then
FunctionClosureValue reprty
// It must be exception, abstract, record or union.
// Either way we assume the only properties defined on
// the type are the actual fields of the type. Again,
// we should be reading attributes here that indicate the
// true structure of the type, e.g. the order of the fields.
elif FSharpType.IsUnion(reprty, bindingFlags) then
let tag, vals = FSharpValue.GetUnionFields (obj, reprty, bindingFlags)
let props = tag.GetFields()
let pvals = (props, vals) ||> Array.map2 (fun prop v -> prop.Name, (v, prop.PropertyType))
let declaringType =
if requiresQualifiedAccess tag.DeclaringType then Some tag.DeclaringType
else None
UnionCaseValue(declaringType, tag.Name, pvals)
elif FSharpType.IsExceptionRepresentation(reprty, bindingFlags) then
let props = FSharpType.GetExceptionFields(reprty, bindingFlags)
let vals = FSharpValue.GetExceptionFields(obj, bindingFlags)
let pvals = (props, vals) ||> Array.map2 (fun prop v -> prop.Name, (v, prop.PropertyType))
ExceptionValue(reprty, pvals)
elif FSharpType.IsRecord(reprty, bindingFlags) then
let props = FSharpType.GetRecordFields(reprty, bindingFlags)
RecordValue(props |> Array.map (fun prop -> prop.Name, prop.GetValue (obj, null), prop.PropertyType))
else
ObjectValue(obj)
// This one is like the above but can make use of additional
// statically-known type information to aid in the
// analysis of null values.
let GetValueInfo bindingFlags (x: 'a, ty: Type) (* x could be null *) =
let obj = (box x)
match obj with
| null ->
let isNullaryUnion =
match ty.GetCustomAttributes(typeof<CompilationRepresentationAttribute>, false) with
| [|:? CompilationRepresentationAttribute as attr|] ->
(attr.Flags &&& CompilationRepresentationFlags.UseNullAsTrueValue) = CompilationRepresentationFlags.UseNullAsTrueValue
| _ -> false
if isNullaryUnion then
let nullaryCase = FSharpType.GetUnionCases ty |> Array.filter (fun uc -> uc.GetFields().Length = 0) |> Array.item 0
let declaringType =
if requiresQualifiedAccess ty then Some ty
else None
UnionCaseValue(declaringType, nullaryCase.Name, [| |])
elif isUnitType ty then UnitValue
else NullValue
| _ ->
GetValueInfoOfObject bindingFlags (obj)
module Display =
open ReflectUtils
open LayoutOps
open TaggedTextOps
let string_of_int (i:int) = i.ToString()
let typeUsesSystemObjectToString (ty:System.Type) =
try
let methInfo = ty.GetMethod("ToString", BindingFlags.Public ||| BindingFlags.Instance, null, [| |], null)
methInfo.DeclaringType = typeof<System.Object>
with _e -> false
/// If "str" ends with "ending" then remove it from "str", otherwise no change.
let trimEnding (ending:string) (str:string) =
if str.EndsWith(ending, StringComparison.Ordinal) then
str.Substring(0, str.Length - ending.Length)
else str
let catchExn f = try Choice1Of2 (f ()) with e -> Choice2Of2 e
// An implementation of break stack.
// Uses mutable state, relying on linear threading of the state.
[<NoEquality; NoComparison>]
type Breaks =
Breaks of
/// pos of next free slot
nextFreeSlot: int *
/// pos of next possible "outer" break - OR - outer=next if none possible
nextOuterBreak: int *
/// stack of savings, -ve means it has been broken
savingsStack: int[]
// next is next slot to push into - aka size of current occupied stack.
// outer counts up from 0, and is next slot to break if break forced.
// - if all breaks forced, then outer=next.
// - popping under these conditions needs to reduce outer and next.
let chunkN = 400
let breaks0 () = Breaks(0, 0, Array.create chunkN 0)
let pushBreak saving (Breaks(next, outer, stack)) =
let stack =
if next = stack.Length then
Array.init (next + chunkN) (fun i -> if i < next then stack.[i] else 0) // expand if full
else
stack
stack.[next] <- saving;
Breaks(next+1, outer, stack)
let popBreak (Breaks(next, outer, stack)) =
if next=0 then raise (Failure "popBreak: underflow");
let topBroke = stack.[next-1] < 0
let outer = if outer=next then outer-1 else outer // if all broken, unwind
let next = next - 1
Breaks(next, outer, stack), topBroke
let forceBreak (Breaks(next, outer, stack)) =
if outer=next then
// all broken
None
else
let saving = stack.[outer]
stack.[outer] <- -stack.[outer];
let outer = outer+1
Some (Breaks(next, outer, stack), saving)
/// fitting
let squashToAux (maxWidth, leafFormatter: _ -> TaggedText) layout =
let (|ObjToTaggedText|) = leafFormatter
if maxWidth <= 0 then layout else
let rec fit breaks (pos, layout) =
// breaks = break context, can force to get indentation savings.
// pos = current position in line
// layout = to fit
//------
// returns:
// breaks
// layout - with breaks put in to fit it.
// pos - current pos in line = rightmost position of last line of block.
// offset - width of last line of block
// NOTE: offset <= pos -- depending on tabbing of last block
let breaks, layout, pos, offset =
match layout with
| Attr (tag, attrs, l) ->
let breaks, layout, pos, offset = fit breaks (pos, l)
let layout = Attr (tag, attrs, layout)
breaks, layout, pos, offset
| Leaf (jl, text, jr)
| ObjLeaf (jl, ObjToTaggedText text, jr) ->
// save the formatted text from the squash
let layout = Leaf(jl, text, jr)
let textWidth = length text
let rec fitLeaf breaks pos =
if pos + textWidth <= maxWidth then
breaks, layout, pos + textWidth, textWidth // great, it fits
else
match forceBreak breaks with
| None ->
breaks, layout, pos + textWidth, textWidth // tough, no more breaks
| Some (breaks, saving) ->
let pos = pos - saving
fitLeaf breaks pos
fitLeaf breaks pos
| Node (l, r, joint) ->
let jm = Layout.JuxtapositionMiddle (l, r)
let mid = if jm then 0 else 1
match joint with
| Unbreakable ->
let breaks, l, pos, offsetl = fit breaks (pos, l) // fit left
let pos = pos + mid // fit space if juxt says so
let breaks, r, pos, offsetr = fit breaks (pos, r) // fit right
breaks, Node (l, r, Unbreakable), pos, offsetl + mid + offsetr
| Broken indent ->
let breaks, l, pos, offsetl = fit breaks (pos, l) // fit left
let pos = pos - offsetl + indent // broken so - offset left + ident
let breaks, r, pos, offsetr = fit breaks (pos, r) // fit right
breaks, Node (l, r, Broken indent), pos, indent + offsetr
| Breakable indent ->
let breaks, l, pos, offsetl = fit breaks (pos, l) // fit left
// have a break possibility, with saving
let saving = offsetl + mid - indent
let pos = pos + mid
if saving>0 then
let breaks = pushBreak saving breaks
let breaks, r, pos, offsetr = fit breaks (pos, r)
let breaks, broken = popBreak breaks
if broken then
breaks, Node (l, r, Broken indent) , pos, indent + offsetr
else
breaks, Node (l, r, Breakable indent), pos, offsetl + mid + offsetr
else
// actually no saving so no break
let breaks, r, pos, offsetr = fit breaks (pos, r)
breaks, Node (l, r, Breakable indent) , pos, offsetl + mid + offsetr
//printf "\nDone: pos=%d offset=%d" pos offset;
breaks, layout, pos, offset
let breaks = breaks0 ()
let pos = 0
let _, layout, _, _ = fit breaks (pos, layout)
layout
let combine (strs: string list) = String.Concat strs
let showL opts leafFormatter layout =
let push x rstrs = x :: rstrs
let z0 = [], 0
let addText (rstrs, i) (text:string) = push text rstrs, i + text.Length
let index (_, i) = i
let extract rstrs = combine(List.rev rstrs)
let newLine (rstrs, _) n = // \n then spaces...
let indent = new String(' ', n)
let rstrs = push "\n" rstrs
let rstrs = push indent rstrs
rstrs, n
// addL: pos is tab level
let rec addL z pos layout =
match layout with
| ObjLeaf (_, obj, _) ->
let text = leafFormatter obj
addText z text
| Leaf (_, obj, _) ->
addText z obj.Text
| Node (l, r, Broken indent)
// Print width = 0 implies 1D layout, no squash
when not (opts.PrintWidth = 0) ->
let z = addL z pos l
let z = newLine z (pos+indent)
let z = addL z (pos+indent) r
z
| Node (l, r, _) ->
let jm = Layout.JuxtapositionMiddle (l, r)
let z = addL z pos l
let z = if jm then z else addText z " "
let pos = index z
let z = addL z pos r
z
| Attr (_, _, l) ->
addL z pos l
let rstrs, _ = addL z0 0 layout
extract rstrs
let outL outAttribute leafFormatter (chan: TaggedTextWriter) layout =
// write layout to output chan directly
let write s = chan.Write(s)
// z is just current indent
let z0 = 0
let index i = i
let addText z text = write text; (z + length text)
let newLine _ n = // \n then spaces...
let indent = new String(' ', n)
chan.WriteLine();
write (tagText indent);
n
// addL: pos is tab level
let rec addL z pos layout =
match layout with
| ObjLeaf (_, obj, _) ->
let text = leafFormatter obj
addText z text
| Leaf (_, obj, _) ->
addText z obj
| Node (l, r, Broken indent) ->
let z = addL z pos l
let z = newLine z (pos+indent)
let z = addL z (pos+indent) r
z
| Node (l, r, _) ->
let jm = Layout.JuxtapositionMiddle (l, r)
let z = addL z pos l
let z = if jm then z else addText z Literals.space
let pos = index z
let z = addL z pos r
z
| Attr (tag, attrs, l) ->
let _ = outAttribute tag attrs true
let z = addL z pos l
let _ = outAttribute tag attrs false
z
let _ = addL z0 0 layout
()
let unpackCons recd =
match recd with
| [|(_, h);(_, t)|] -> (h, t)
| _ -> failwith "unpackCons"
let getListValueInfo bindingFlags (x:obj, ty:Type) =
match x with
| null -> None
| _ ->
match Value.GetValueInfo bindingFlags (x, ty) with
| UnionCaseValue (_, "Cons", recd) -> Some (unpackCons recd)
| UnionCaseValue (_, "Empty", [| |]) -> None
| _ -> failwith "List value had unexpected ValueInfo"
let structL = wordL (tagKeyword "struct")
let nullL = wordL (tagKeyword "null")
let unitL = wordL (tagPunctuation "()")
let makeRecordL nameXs =
let itemL (name, xL) = wordL name ^^ wordL Literals.equals -- xL
let braceL xs = (wordL Literals.leftBrace) ^^ xs ^^ (wordL Literals.rightBrace)
nameXs
|> List.map itemL
|> aboveListL
|> braceL
let makePropertiesL nameXs =
let itemL (name, v) =
let labelL = wordL name
(labelL ^^ wordL Literals.equals)
^^ (match v with
| None -> wordL Literals.questionMark
| Some xL -> xL)
^^ (rightL Literals.semicolon)
let braceL xs = (leftL Literals.leftBrace) ^^ xs ^^ (rightL Literals.rightBrace)
braceL (aboveListL (List.map itemL nameXs))
let makeListL itemLs =
(leftL Literals.leftBracket)
^^ sepListL (rightL Literals.semicolon) itemLs
^^ (rightL Literals.rightBracket)
let makeArrayL xs =
(leftL (tagPunctuation "[|"))
^^ sepListL (rightL Literals.semicolon) xs
^^ (rightL (tagPunctuation "|]"))
let makeArray2L xs = leftL Literals.leftBracket ^^ aboveListL xs ^^ rightL Literals.rightBracket
let getProperty (ty: Type) (obj: obj) name =
ty.InvokeMember(name, (BindingFlags.GetProperty ||| BindingFlags.Instance ||| BindingFlags.Public ||| BindingFlags.NonPublic), null, obj, [| |],CultureInfo.InvariantCulture)
let getField obj (fieldInfo: FieldInfo) =
fieldInfo.GetValue(obj)
let formatChar isChar c =
match c with
| '\'' when isChar -> "\\\'"
| '\"' when not isChar -> "\\\""
| '\\' -> "\\\\"
| '\b' -> "\\b"
| _ when System.Char.IsControl(c) ->
let d1 = (int c / 100) % 10
let d2 = (int c / 10) % 10
let d3 = int c % 10
"\\" + d1.ToString() + d2.ToString() + d3.ToString()
| _ -> c.ToString()
let formatString (s:string) =
let rec check i = i < s.Length && not (System.Char.IsControl(s,i)) && s.[i] <> '\"' && check (i+1)
let rec conv i acc = if i = s.Length then combine (List.rev acc) else conv (i+1) (formatChar false s.[i] :: acc)
"\"" + s + "\""
// Return a truncated version of the string, e.g.
// "This is the initial text, which has been truncated"+[12 chars]
//
// Note: The layout code forces breaks based on leaf size and possible break points.
// It does not force leaf size based on width.
// So long leaf-string width can not depend on their printing context...
//
// The suffix like "+[dd chars]" is 11 chars.
// 12345678901
let formatStringInWidth (width:int) (str:string) =
let suffixLength = 11 // turning point suffix length
let prefixMinLength = 12 // arbitrary. If print width is reduced, want to print a minimum of information on strings...
let prefixLength = max (width - 2 (*quotes*) - suffixLength) prefixMinLength
"\"" + (str.Substring(0,prefixLength)) + "\"" + "+[" + (str.Length - prefixLength).ToString() + " chars]"
type Precedence =
| BracketIfTupleOrNotAtomic = 2
| BracketIfTuple = 3
| NeverBracket = 4
// In fsi.exe, certain objects are not printed for top-level bindings.
[<StructuralEquality; NoComparison>]
type ShowMode =
| ShowAll
| ShowTopLevelBinding
let isSetOrMapType (ty:Type) =
ty.IsGenericType &&
(ty.GetGenericTypeDefinition() = typedefof<Map<_,_>>
|| ty.GetGenericTypeDefinition() = typedefof<Set<_>>)
// showMode = ShowTopLevelBinding on the outermost expression when called from fsi.exe,
// This allows certain outputs, e.g. objects that would print as <seq> to be suppressed, etc. See 4343.
// Calls to layout proper sub-objects should pass showMode = ShowAll.
//
// Precedences to ensure we add brackets in the right places
type ObjectGraphFormatter(opts: FormatOptions, bindingFlags) =
// Keep a record of objects encountered along the way
let path = Dictionary<obj,int>(10,HashIdentity.Reference)
// Roughly count the "nodes" printed, e.g. leaf items and inner nodes, but not every bracket and comma.
let mutable size = opts.PrintSize
let exceededPrintSize() = size<=0
let countNodes n = if size > 0 then size <- size - n else () // no need to keep decrementing (and avoid wrap around)
let stopShort _ = exceededPrintSize() // for unfoldL
// Recursive descent
let rec nestedObjL depthLim prec (x:obj, ty:Type) =
objL ShowAll depthLim prec (x, ty)
and objL showMode depthLim prec (x:obj, ty:Type) =
let info = Value.GetValueInfo bindingFlags (x, ty)
try
if depthLim<=0 || exceededPrintSize() then wordL (tagPunctuation "...") else
match x with
| null ->
reprL showMode (depthLim-1) prec info x
| _ ->
if (path.ContainsKey(x)) then
wordL (tagPunctuation "...")
else
path.Add(x,0)
let res =
// Lazy<T> values. VS2008 used StructuredFormatDisplayAttribute to show via ToString. Dev10 (no attr) needs a special case.
let ty = x.GetType()
if ty.IsGenericType && ty.GetGenericTypeDefinition() = typedefof<Lazy<_>> then
Some (wordL (tagText(x.ToString())))
else
// Try the StructuredFormatDisplayAttribute extensibility attribute
match ty.GetCustomAttributes (typeof<StructuredFormatDisplayAttribute>, true) with
| null | [| |] -> None
| res ->
structuredFormatObjectL showMode ty depthLim (res.[0] :?> StructuredFormatDisplayAttribute) x
#if COMPILER
// This is the PrintIntercepts extensibility point currently revealed by fsi.exe's AddPrinter
let res =
match res with
| Some _ -> res
| None ->
let env =
{ new IEnvironment with
member _.GetLayout(y) = nestedObjL (depthLim-1) Precedence.BracketIfTuple (y, y.GetType())
member _.MaxColumns = opts.PrintLength
member _.MaxRows = opts.PrintLength }
opts.PrintIntercepts |> List.tryPick (fun intercept -> intercept env x)
#endif
let res =
match res with
| Some res -> res
| None -> reprL showMode (depthLim-1) prec info x
path.Remove(x) |> ignore
res
with
e ->
countNodes 1
wordL (tagText("Error: " + e.Message))
// Format an object that has a layout specified by StructuredFormatAttribute
and structuredFormatObjectL showMode ty depthLim (attr: StructuredFormatDisplayAttribute) (obj: obj) =
let txt = attr.Value
if isNull txt || txt.Length <= 1 then
None
else
let messageRegexPattern = @"^(?<pre>.*?)(?<!\\){(?<prop>.*?)(?<!\\)}(?<post>.*)$"
let illFormedBracketPattern = @"(?<!\\){|(?<!\\)}"
let rec buildObjMessageL (txt:string) (layouts:Layout list) =
let replaceEscapedBrackets (txt:string) =
txt.Replace("\{", "{").Replace("\}", "}")
// to simplify support for escaped brackets, switch to using a Regex to simply parse the text as the following regex groups:
// 1) Everything up to the first opening bracket not preceded by a "\", lazily
// 2) Everything between that opening bracket and a closing bracket not preceded by a "\", lazily
// 3) Everything after that closing bracket
let m = System.Text.RegularExpressions.Regex.Match(txt, messageRegexPattern)
if not m.Success then
// there isn't a match on the regex looking for a property, so now let's make sure we don't have an ill-formed format string (i.e. mismatched/stray brackets)
let illFormedMatch = System.Text.RegularExpressions.Regex.IsMatch(txt, illFormedBracketPattern)
if illFormedMatch then
None // there are mismatched brackets, bail out
elif layouts.Length > 1 then Some (spaceListL (List.rev ((wordL (tagText(replaceEscapedBrackets(txt))) :: layouts))))
else Some (wordL (tagText(replaceEscapedBrackets(txt))))
else
// we have a hit on a property reference
let preText = replaceEscapedBrackets(m.Groups.["pre"].Value) // everything before the first opening bracket
let postText = m.Groups.["post"].Value // Everything after the closing bracket
let prop = replaceEscapedBrackets(m.Groups.["prop"].Value) // Unescape everything between the opening and closing brackets
match catchExn (fun () -> getProperty ty obj prop) with
| Choice2Of2 e -> Some (wordL (tagText("<StructuredFormatDisplay exception: " + e.Message + ">")))
| Choice1Of2 alternativeObj ->
try
let alternativeObjL =
match alternativeObj with
// A particular rule is that if the alternative property
// returns a string, we turn off auto-quoting and escaping of
// the string, i.e. just treat the string as display text.
// This allows simple implementations of
// such as
//
// [<StructuredFormatDisplay("{StructuredDisplayString}I")>]
// type BigInt(signInt:int, v: BigNat) =
// member x.StructuredDisplayString = x.ToString()
//
| :? string as s -> sepL (tagText s)
| _ ->
// recursing like this can be expensive, so let's throttle it severely
objL showMode (depthLim/10) Precedence.BracketIfTuple (alternativeObj, alternativeObj.GetType())
countNodes 0 // 0 means we do not count the preText and postText
let postTextMatch = System.Text.RegularExpressions.Regex.Match(postText, messageRegexPattern)
// the postText for this node will be everything up to the next occurrence of an opening brace, if one exists
let currentPostText =
match postTextMatch.Success with
| false -> postText
| true -> postTextMatch.Groups.["pre"].Value
let newLayouts = (sepL (tagText preText) ^^ alternativeObjL ^^ sepL (tagText currentPostText)) :: layouts
match postText with
| "" ->
//We are done, build a space-delimited layout from the collection of layouts we've accumulated
Some (spaceListL (List.rev newLayouts))
| remainingPropertyText when postTextMatch.Success ->
// look for stray brackets in the text before the next opening bracket
let strayClosingMatch = System.Text.RegularExpressions.Regex.IsMatch(postTextMatch.Groups.["pre"].Value, illFormedBracketPattern)
if strayClosingMatch then
None
else
// More to process, keep going, using the postText starting at the next instance of a '{'
let openingBracketIndex = postTextMatch.Groups.["prop"].Index-1
buildObjMessageL remainingPropertyText.[openingBracketIndex..] newLayouts
| remaingPropertyText ->
// make sure we don't have any stray brackets
let strayClosingMatch = System.Text.RegularExpressions.Regex.IsMatch(remaingPropertyText, illFormedBracketPattern)
if strayClosingMatch then
None
else
// We are done, there's more text but it doesn't contain any more properties, we need to remove escaped brackets now though
// since that wasn't done when creating currentPostText
Some (spaceListL (List.rev ((sepL (tagText preText) ^^ alternativeObjL ^^ sepL (tagText(replaceEscapedBrackets(remaingPropertyText)))) :: layouts)))
with _ ->
None
// Seed with an empty layout with a space to the left for formatting purposes
buildObjMessageL txt [leftL (tagText "")]
and recdAtomicTupleL depthLim recd =
// tuples up args to UnionConstruction or ExceptionConstructor. no node count.
match recd with
| [(_,x)] -> nestedObjL depthLim Precedence.BracketIfTupleOrNotAtomic x
| txs -> leftL Literals.leftParen ^^ commaListL (List.map (snd >> nestedObjL depthLim Precedence.BracketIfTuple) txs) ^^ rightL Literals.rightParen