-
Notifications
You must be signed in to change notification settings - Fork 790
/
sformat.fs
1322 lines (1168 loc) · 66.9 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 3(!) times in the codebase
// - as the internal implementation of printf '%A' formatting in FSharp.Core
// - as the internal implementation of structured formatting in the compiler and F# Interactive
// defines: COMPILER
//
// The one implementation file is used because we very much want to keep the implementations of
// structured formatting the same for fsi.exe and '%A' printing. However fsi.exe may have
// a richer feature set.
//
// Note no layout objects are ever transferred between the above implementations, and in
// all 4 cases the layout types are really different types.
#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.Diagnostics
open System.Text
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.Core.Operators
open Microsoft.FSharp.Reflection
open Microsoft.FSharp.Collections
open Microsoft.FSharp.Primitives.Basics
#if FX_RESHAPED_REFLECTION
open PrimReflectionAdapters
open ReflectionAdapters
#endif
[<StructuralEquality; NoComparison>]
type LayoutTag =
| ActivePatternCase
| ActivePatternResult
| Alias
| Class
| Union
| UnionCase
| Delegate
| Enum
| Event
| Field
| Interface
| Keyword
| LineBreak
| Local
| Record
| RecordField
| Method
| Member
| ModuleBinding
| 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 int
| Broken of int
/// Leaf juxt,data,juxt
/// Node juxt,left,juxt,right,juxt and joint
///
/// If either juxt flag is true, then no space between words.
[<NoEquality; NoComparison>]
type Layout =
| ObjLeaf of bool * obj * bool
| Leaf of bool * TaggedText * bool
| Node of bool * layout * bool * layout * bool * joint
| Attr of string * (string * string) list * layout
and layout = Layout
and joint = Joint
[<NoEquality; NoComparison>]
type IEnvironment =
abstract GetLayout : obj -> layout
abstract MaxColumns : int
abstract MaxRows : int
module TaggedTextOps =
let tag tag text =
{ new TaggedText with
member x.Tag = tag
member x.Text = text }
let length (tt: TaggedText) = tt.Text.Length
let toText (tt: TaggedText) = tt.Text
let tagAlias t = tag LayoutTag.Alias t
let keywordFunctions = Set ["raise"; "reraise"; "typeof"; "typedefof"; "sizeof"; "nameof"]
let keywordTypes =
[
"array"
"bigint"
"bool"
"byref"
"byte"
"char"
"decimal"
"double"
"float"
"float32"
"int"
"int8"
"int16"
"int32"
"int64"
"list"
"nativeint"
"obj"
"sbyte"
"seq"
"single"
"string"
"unit"
"uint"
"uint8"
"uint16"
"uint32"
"uint64"
"unativeint"
] |> Set.ofList
let tagClass name = if Set.contains name keywordTypes then tag LayoutTag.Keyword name else tag LayoutTag.Class name
let tagUnionCase t = tag LayoutTag.UnionCase t
let tagDelegate t = tag LayoutTag.Delegate t
let tagEnum t = tag LayoutTag.Enum t
let tagEvent t = tag LayoutTag.Event t
let tagField t = tag LayoutTag.Field t
let tagInterface t = tag LayoutTag.Interface t
let tagKeyword t = tag LayoutTag.Keyword t
let tagLineBreak t = tag LayoutTag.LineBreak t
let tagLocal t = tag LayoutTag.Local t
let tagRecord t = tag LayoutTag.Record t
let tagRecordField t = tag LayoutTag.RecordField t
let tagMethod t = tag LayoutTag.Method t
let tagModule t = tag LayoutTag.Module t
let tagModuleBinding name = if keywordFunctions.Contains name then tag LayoutTag.Keyword name else tag LayoutTag.ModuleBinding name
let tagNamespace t = tag LayoutTag.Namespace t
let tagNumericLiteral t = tag LayoutTag.NumericLiteral t
let tagOperator t = tag LayoutTag.Operator t
let tagParameter t = tag LayoutTag.Parameter t
let tagProperty t = tag LayoutTag.Property t
let tagSpace t = tag LayoutTag.Space t
let tagStringLiteral t = tag LayoutTag.StringLiteral t
let tagStruct t = tag LayoutTag.Struct t
let tagTypeParameter t = tag LayoutTag.TypeParameter t
let tagText t = tag LayoutTag.Text t
let tagPunctuation t = tag 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 rec juxtLeft = function
| ObjLeaf (jl,_,_) -> jl
| Leaf (jl,_,_) -> jl
| Node (jl,_,_,_,_,_) -> jl
| Attr (_,_,l) -> juxtLeft l
let rec juxtRight = function
| ObjLeaf (_,_,jr) -> jr
| Leaf (_,_,jr) -> jr
| Node (_,_,_,_,jr,_) -> jr
| Attr (_,_,l) -> juxtRight l
let mkNode l r joint =
let jl = juxtLeft l
let jm = juxtRight l || juxtLeft r
let jr = juxtRight r
Node(jl,l,jm,r,jr,joint)
// constructors
let objL (value:obj) =
match value with
| :? string as s -> Leaf (false, tag 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, tag 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 else
if 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 = function
| [] -> emptyL
| [x] -> x
| x :: xs ->
let rec process' prefixL = function
| [] -> 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: System.IFormatProvider;
#if FX_RESHAPED_REFLECTION
ShowNonPublic : bool
#else
BindingFlags: System.Reflection.BindingFlags
#endif
PrintWidth : int;
PrintDepth : int;
PrintLength : int;
PrintSize : int;
ShowProperties : bool;
ShowIEnumerable: bool; }
static member Default =
{ FormatProvider = (System.Globalization.CultureInfo.InvariantCulture :> System.IFormatProvider);
#if COMPILER // This is the PrintIntercepts extensibility point currently revealed by fsi.exe's AddPrinter
PrintIntercepts = [];
StringLimit = System.Int32.MaxValue;
#endif
AttributeProcessor= (fun _ _ _ -> ());
#if FX_RESHAPED_REFLECTION
ShowNonPublic = false
#else
BindingFlags = System.Reflection.BindingFlags.Public;
#endif
FloatingPointFormat = "g10";
PrintWidth = 80 ;
PrintDepth = 100 ;
PrintLength = 100;
PrintSize = 10000;
ShowProperties = false;
ShowIEnumerable = true; }
module ReflectUtils =
open System
open System.Reflection
#if FX_RESHAPED_REFLECTION
open PrimReflectionAdapters
open Microsoft.FSharp.Core.ReflectionAdapters
#endif
[<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)
[<NoEquality; NoComparison>]
type ValueInfo =
| TupleValue of (obj * Type) list
| FunctionClosureValue of System.Type
| RecordValue of (string * obj * Type) list
| ConstructorValue of string * (string * (obj * Type)) list
| ExceptionValue of System.Type * (string * (obj * Type)) list
| UnitValue
| ObjectValue of obj
module Value =
// Analyze an object to see if it the representation
// of an F# value.
let GetValueInfoOfObject (bindingFlags:BindingFlags) (obj : obj) =
#if FX_RESHAPED_REFLECTION
let showNonPublic = isNonPublicFlag bindingFlags
#endif
match obj with
| null -> ObjectValue(obj)
| _ ->
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)
TupleValue (FSharpValue.GetTupleFields obj |> Array.mapi (fun i v -> (v, tyArgs.[i])) |> Array.toList)
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.
#if FX_RESHAPED_REFLECTION
elif FSharpType.IsUnion(reprty, showNonPublic) then
let tag,vals = FSharpValue.GetUnionFields (obj,reprty, showNonPublic)
#else
elif FSharpType.IsUnion(reprty,bindingFlags) then
let tag,vals = FSharpValue.GetUnionFields (obj,reprty,bindingFlags)
#endif
let props = tag.GetFields()
let pvals = (props,vals) ||> Array.map2 (fun prop v -> prop.Name,(v, prop.PropertyType))
ConstructorValue(tag.Name, Array.toList pvals)
#if FX_RESHAPED_REFLECTION
elif FSharpType.IsExceptionRepresentation(reprty, showNonPublic) then
let props = FSharpType.GetExceptionFields(reprty, showNonPublic)
let vals = FSharpValue.GetExceptionFields(obj, showNonPublic)
#else
elif FSharpType.IsExceptionRepresentation(reprty,bindingFlags) then
let props = FSharpType.GetExceptionFields(reprty,bindingFlags)
let vals = FSharpValue.GetExceptionFields(obj,bindingFlags)
#endif
let pvals = (props,vals) ||> Array.map2 (fun prop v -> prop.Name,(v, prop.PropertyType))
ExceptionValue(reprty, pvals |> Array.toList)
#if FX_RESHAPED_REFLECTION
elif FSharpType.IsRecord(reprty, showNonPublic) then
let props = FSharpType.GetRecordFields(reprty, showNonPublic)
#else
elif FSharpType.IsRecord(reprty,bindingFlags) then
let props = FSharpType.GetRecordFields(reprty,bindingFlags)
#endif
RecordValue(props |> Array.map (fun prop -> prop.Name, prop.GetValue(obj,null), prop.PropertyType) |> Array.toList)
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
ConstructorValue(nullaryCase.Name, [])
elif isUnitType ty then UnitValue
else ObjectValue(obj)
| _ ->
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
#if FX_RESHAPED_REFLECTION
let methInfo = ty.GetRuntimeMethod("ToString",[| |])
#else
let methInfo = ty.GetMethod("ToString",BindingFlags.Public ||| BindingFlags.Instance,null,[| |],null)
#endif
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
int * // pos of next free slot
int * // pos of next possible "outer" break - OR - outer=next if none possible
int array // stack of savings, -ve means it has been broken
// 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 dumpBreaks prefix (Breaks(next,outer,stack)) = ()
// printf "%s: next=%d outer=%d stack.Length=%d\n" prefix next outer stack.Length;
// stdout.Flush()
let chunkN = 400
let breaks0 () = Breaks(0,0,Array.create chunkN 0)
let pushBreak saving (Breaks(next,outer,stack)) =
//dumpBreaks "pushBreak" (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)) =
//dumpBreaks "popBreak" (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)) =
//dumpBreaks "forceBreak" (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 squashTo (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 (jl,l,jm,r,jr,joint) ->
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 (jl,l,jm,r,jr,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 (jl,l,jm,r,jr,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 (jl,l,jm,r,jr,Broken indent) ,pos,indent + offsetr
else
breaks,Node (jl,l,jm,r,jr,Breakable indent),pos,offsetl + mid + offsetr
else
// actually no saving so no break
let breaks,r,pos,offsetr = fit breaks (pos,r)
breaks,Node (jl,l,jm,r,jr,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
// -------------------------------------------------------------------------
// showL
// ------------------------------------------------------------------------
let combine (strs: string list) = System.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 System.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,jm,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
// -------------------------------------------------------------------------
// outL
// ------------------------------------------------------------------------
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 System.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,jm,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
()
// --------------------------------------------------------------------
// pprinter: using general-purpose reflection...
// --------------------------------------------------------------------
let getValueInfo bindingFlags (x:'a, ty:Type) = Value.GetValueInfo bindingFlags (x, ty)
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 getValueInfo bindingFlags (x, ty) with
| ConstructorValue ("Cons",recd) -> Some (unpackCons recd)
| ConstructorValue ("Empty",[]) -> None
| _ -> failwith "List value had unexpected ValueInfo"
let compactCommaListL xs = sepListL (sepL Literals.comma) xs // compact, no spaces around ","
let nullL = wordL (tagKeyword "null")
let measureL = wordL (tagPunctuation "()")
// --------------------------------------------------------------------
// pprinter: attributes
// --------------------------------------------------------------------
let makeRecordVerticalL nameXs =
let itemL (name,xL) = let labelL = wordL name in ((labelL ^^ wordL Literals.equals)) -- (xL ^^ (rightL Literals.semicolon))
let braceL xs = (leftL Literals.leftBrace) ^^ xs ^^ (rightL Literals.rightBrace)
braceL (aboveListL (List.map itemL nameXs))
// This is a more compact rendering of records - and is more like tuples
let makeRecordHorizontalL nameXs =
let itemL (name,xL) = let labelL = wordL name in ((labelL ^^ wordL Literals.equals)) -- xL
let braceL xs = (leftL Literals.leftBrace) ^^ xs ^^ (rightL Literals.rightBrace)
braceL (sepListL (rightL Literals.semicolon) (List.map itemL nameXs))
let makeRecordL nameXs = makeRecordVerticalL nameXs
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
// --------------------------------------------------------------------
// pprinter: anyL - support functions
// --------------------------------------------------------------------
let getProperty (ty: Type) (obj: obj) name =
#if FX_RESHAPED_REFLECTION
let prop = ty.GetProperty(name, (BindingFlags.Instance ||| BindingFlags.Public ||| BindingFlags.NonPublic))
if not (isNull prop) then prop.GetValue(obj,[||])
// Others raise MissingMethodException
else
let msg = System.String.Concat([| "Method '"; ty.FullName; "."; name; "' not found." |])
raise (System.MissingMethodException(msg))
#else
ty.InvokeMember(name, (BindingFlags.GetProperty ||| BindingFlags.Instance ||| BindingFlags.Public ||| BindingFlags.NonPublic), null, obj, [| |],CultureInfo.InvariantCulture)
#endif
let getField obj (fieldInfo: FieldInfo) =
fieldInfo.GetValue(obj)
let formatChar isChar c =
match c with
| '\'' when isChar -> "\\\'"
| '\"' when not isChar -> "\\\""
//| '\n' -> "\\n"
//| '\r' -> "\\r"
//| '\t' -> "\\t"
| '\\' -> "\\\\"
| '\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 + "\""
// REVIEW: should we check for the common case of no control characters? Reinstate the following?
//"\"" + (if check 0 then s else conv 0 []) + "\""
let formatStringInWidth (width:int) (str:string) =
// 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 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]"
// --------------------------------------------------------------------
// pprinter: anyL
// --------------------------------------------------------------------
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
// polymorphic and inner recursion limitations prevent us defining polyL in the recursive loop
let polyL bindingFlags (objL: ShowMode -> int -> Precedence -> ValueInfo -> obj -> Layout) showMode i prec (x:'a ,ty : Type) (* x could be null *) =
objL showMode i prec (getValueInfo bindingFlags (x, ty)) (box x)
let anyL showMode bindingFlags (opts:FormatOptions) (x:'a, ty:Type) =
// 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
// 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 size = ref 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 objL depthLim prec (x:obj, ty:Type) = polyL bindingFlags objWithReprL ShowAll depthLim prec (x, ty) // showMode for inner expr
and sameObjL depthLim prec (x:obj, ty:Type) = polyL bindingFlags objWithReprL showMode depthLim prec (x, ty) // showMode preserved
and objWithReprL showMode depthLim prec (info:ValueInfo) (x:obj) (* x could be null *) =
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 ->
let attr = (res.[0] :?> StructuredFormatDisplayAttribute)
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)
match m.Success with
| false ->
// 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)
match illFormedMatch with
| true -> None // there are mismatched brackets, bail out
| false when layouts.Length > 1 -> Some (spaceListL (List.rev ((wordL (tagText(replaceEscapedBrackets(txt))) :: layouts))))
| false -> Some (wordL (tagText(replaceEscapedBrackets(txt))))
| true ->
// 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 x 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
sameObjL (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)
match strayClosingMatch with
| true -> None
| false ->
// 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)
match strayClosingMatch with
| true -> None
| false ->
// 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