//========================================================================= // (c) Microsoft Corporation 2005-2009. //========================================================================= // This file is compiled 4(!) times in the codebase // - as the internal implementation of printf '%A' formatting // defines: RUNTIME // - as the internal implementation of structured formatting in the FSharp.Compiler-proto.dll // defines: INTERNALIZED_POWER_PACK + BUILDING_WITH_LKG // - as the internal implementation of structured formatting in FSharp.Compiler.dll // defines: INTERNALIZED_POWER_PACK // NOTE: this implementation is used by fsi.exe. This is very important. // - as the public implementation of structured formatting in the FSharp.PowerPack.dll // defines: // // 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 INTERNALIZED_POWER_PACK // FSharp.Compiler-proto.dll: // FSharp.Compiler.dll: namespace Internal.Utilities.StructuredFormat #else #if RUNTIME // FSharp.Core.dll: namespace Microsoft.FSharp.Text.StructuredPrintfImpl #else // Powerpack: namespace Microsoft.FSharp.Text.StructuredFormat #endif #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 /// A joint, between 2 layouts, is either: /// - unbreakable, or /// - breakable, and if broken the second block has a given indentation. 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. [] type Layout = | Leaf of bool * obj * bool | Node of bool * layout * bool * layout * bool * joint | Attr of string * (string * string) list * layout and layout = Layout and joint = Joint type IEnvironment = abstract GetLayout : obj -> layout abstract MaxColumns : int abstract MaxRows : int module LayoutOps = let rec juxtLeft = function | Leaf (jl,text,jr) -> jl | Node (jl,l,jm,r,jr,joint) -> jl | Attr (tag,attrs,l) -> juxtLeft l let rec juxtRight = function | Leaf (jl,text,jr) -> jr | Node (jl,l,jm,r,jr,joint) -> jr | Attr (tag,attrs,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 (obj:obj) = Leaf (false,obj,false) let sLeaf (l,(str:string),r) = Leaf (l,(str:>obj),r) let wordL str = sLeaf (false,str,false) let sepL str = sLeaf (true ,str,true) let rightL str = sLeaf (true ,str,false) let leftL str = sLeaf (false,str,true) let emptyL = sLeaf (true,"",true) let isEmptyL = function | Leaf(true,s,true) -> match s with | :? string as s -> s = "" | _ -> false | _ -> false let aboveL l r = mkNode l r (Broken 0) let joinN i l r = mkNode l r (Breakable i) let join = joinN 0 let join1 = joinN 1 let join2 = joinN 2 let join3 = joinN 3 let tagAttrL tag attrs l = Attr(tag,attrs,l) let apply2 f l r = if isEmptyL l then r else if isEmptyL r then l else f l r let ($$) l r = mkNode l r (Unbreakable) let (++) l r = mkNode l r (Breakable 0) let (--) l r = mkNode l r (Breakable 1) let (---) l r = mkNode l r (Breakable 2) let (@@) l r = apply2 (fun l r -> mkNode l r (Broken 0)) l r let (@@-) l r = apply2 (fun l r -> mkNode l r (Broken 1)) l r let (@@--) l r = apply2 (fun l r -> mkNode l r (Broken 2)) l r let tagListL tagger = function | [] -> emptyL | [x] -> x | x::xs -> let rec process' prefixL = function [] -> prefixL | y::ys -> process' ((tagger prefixL) ++ y) ys in process' x xs let commaListL x = tagListL (fun prefixL -> prefixL $$ rightL ",") x let semiListL x = tagListL (fun prefixL -> prefixL $$ rightL ";") x let spaceListL x = tagListL (fun prefixL -> prefixL) x let sepListL x y = tagListL (fun prefixL -> prefixL $$ x) y let bracketL l = leftL "(" $$ l $$ rightL ")" let tupleL xs = bracketL (sepListL (sepL ",") xs) let aboveListL = function | [] -> emptyL | [x] -> x | x::ys -> List.fold (fun pre y -> pre @@ y) x ys let optionL xL = function None -> wordL "None" | Some x -> wordL "Some" -- (xL x) let listL xL xs = leftL "[" $$ sepListL (sepL ";") (List.map xL xs) $$ rightL "]" let squareBracketL x = leftL "[" $$ x $$ rightL "]" let braceL x = leftL "{" $$ x $$ rightL "}" 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 "..."] else match project z with | None -> [] (* exhaused input *) | Some (x,z) -> if n<=0 then [wordL "..."] (* hit print_length limit *) else itemL x :: consume (n-1) z (* cons recursive... *) consume maxLength z let unfoldL itemL project z maxLength = boundedUnfoldL itemL project (fun _ -> false) z maxLength /// These are a typical set of options used to control structured formatting. [] type FormatOptions = { FloatingPointFormat: string; AttributeProcessor: (string -> (string * string) list -> bool -> unit); #if RUNTIME #else #if INTERNALIZED_POWER_PACK // FSharp.Compiler.dll: This is the PrintIntercepts extensibility point currently revealed by fsi.exe's AddPrinter PrintIntercepts: (IEnvironment -> obj -> Layout option) list; StringLimit : int; #endif #endif FormatProvider: System.IFormatProvider; BindingFlags: System.Reflection.BindingFlags PrintWidth : int; PrintDepth : int; PrintLength : int; PrintSize : int; ShowProperties : bool; ShowIEnumerable: bool; } static member Default = { FormatProvider = (System.Globalization.CultureInfo.InvariantCulture :> System.IFormatProvider); #if RUNTIME #else #if INTERNALIZED_POWER_PACK // FSharp.Compiler.dll: This is the PrintIntercepts extensibility point currently revealed by fsi.exe's AddPrinter PrintIntercepts = []; StringLimit = System.Int32.MaxValue; #endif #endif AttributeProcessor= (fun _ _ _ -> ()); BindingFlags = System.Reflection.BindingFlags.Public; FloatingPointFormat = "g10"; PrintWidth = 80 ; PrintDepth = 100 ; PrintLength = 100; PrintSize = 10000; ShowProperties = false; ShowIEnumerable = true; } module ReflectUtils = open System open System.Reflection 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(typ:Type) = not (typ.IsArray || typ.IsByRef || typ.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 let func = typedefof<(obj -> obj)> let isOptionType typ = equivHeadTypes typ (typeof) let isUnitType typ = equivHeadTypes typ (typeof) let isListType typ = FSharpType.IsUnion typ && (let cases = FSharpType.GetUnionCases typ cases.Length > 0 && equivHeadTypes (typedefof>) cases.[0].DeclaringType) module Type = let recdDescOfProps props = props |> Array.to_list |> List.map (fun (p:PropertyInfo) -> p.Name, p.PropertyType) let getTypeInfoOfType (bindingFlags:BindingFlags) (typ:Type) = if FSharpType.IsTuple(typ) then TypeInfo.TupleType (FSharpType.GetTupleElements(typ) |> Array.to_list) elif FSharpType.IsFunction(typ) then let ty1,ty2 = FSharpType.GetFunctionElements typ in TypeInfo.FunctionType( ty1,ty2) elif FSharpType.IsUnion(typ,bindingFlags) then let cases = FSharpType.GetUnionCases(typ,bindingFlags) match cases with | [| |] -> TypeInfo.ObjectType(typ) | _ -> TypeInfo.SumType(cases |> Array.to_list |> List.map (fun case -> let flds = case.GetFields() case.Name,recdDescOfProps(flds))) elif FSharpType.IsRecord(typ,bindingFlags) then let flds = FSharpType.GetRecordFields(typ,bindingFlags) TypeInfo.RecordType(recdDescOfProps(flds)) else TypeInfo.ObjectType(typ) let IsOptionType (typ:Type) = isOptionType typ let IsListType (typ:Type) = isListType typ let IsUnitType (typ:Type) = isUnitType typ type ValueInfo = | TupleValue of obj list | FunctionClosureValue of System.Type * obj | RecordValue of (string * obj) list | ConstructorValue of string * (string * obj) list | ExceptionValue of System.Type * (string * obj) 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) = 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 TupleValue (FSharpValue.GetTupleFields obj |> Array.to_list) elif FSharpType.IsFunction reprty then FunctionClosureValue(reprty,obj) // 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) ConstructorValue(tag.Name, Array.to_list 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) ExceptionValue(reprty, pvals |> Array.to_list) elif FSharpType.IsRecord(reprty,bindingFlags) then let props = FSharpType.GetRecordFields(reprty,bindingFlags) RecordValue(props |> Array.map (fun prop -> prop.Name, prop.GetValue(obj,null)) |> Array.to_list) 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) (* x could be null *) = let obj = (box x) match obj with | null -> let typ = typeof<'a> if isOptionType typ then ConstructorValue("None", []) elif isUnitType typ then UnitValue else ObjectValue(obj) | _ -> GetValueInfoOfObject bindingFlags (obj) let GetInfo bindingFlags (v:'a) = GetValueInfo bindingFlags (v:'a) module Display = open ReflectUtils open LayoutOps let string_of_int (i:int) = i.ToString() let typeUsesSystemObjectToString (typ:System.Type) = try let methInfo = typ.GetMethod("ToString",BindingFlags.Public ||| BindingFlags.Instance,null,[| |],null) methInfo.DeclaringType = typeof with e -> false /// If "str" ends with "ending" then remove it from "str", otherwise no change. let trimEnding (ending:string) (str:string) = #if FX_NO_CULTURE_INFO_ARGS if str.EndsWith(ending) then #else if str.EndsWith(ending,false,CultureInfo.InvariantCulture) then #endif 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. 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) layout = 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,obj,jr) -> let text:string = leafFormatter obj // save the formatted text from the squash let layout = Leaf(jl,(text :> obj),jr) let textWidth = text.Length 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.printf "\nDone: pos=%d offset=%d" pos offset; breaks,layout,pos,offset let breaks = breaks0 () let pos = 0 let breaks,layout,pos,offset = fit breaks (pos,layout) layout // ------------------------------------------------------------------------- // showL // ------------------------------------------------------------------------ let combine strs = System.String.Concat(Array.of_list(strs) : string[]) 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 (rstrs,i) = i let extract rstrs = combine(List.rev rstrs) let newLine (rstrs,i) 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 | Leaf (jl,obj,jr) -> let text = leafFormatter obj addText z text | Node (jl,l,jm,r,jr,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 (jl,l,jm,r,jr,_) -> 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 (tag,attrs,l) -> addL z pos l let rstrs,i = addL z0 0 layout extract rstrs // ------------------------------------------------------------------------- // outL // ------------------------------------------------------------------------ let outL outAttribute leafFormatter (chan : TextWriter) layout = // write layout to output chan directly let write (s:string) = chan.Write(s) // z is just current indent let z0 = 0 let index i = i let addText z text = write text; (z + text.Length) let newLine z n = // \n then spaces... let indent = new System.String(' ',n) chan.WriteLine(); write indent; n // addL: pos is tab level let rec addL z pos layout = match layout with | Leaf (jl,obj,jr) -> let text = leafFormatter obj addText z text | Node (jl,l,jm,r,jr,Broken indent) -> let z = addL z pos l let z = newLine z (pos+indent) let z = addL z (pos+indent) r z | Node (jl,l,jm,r,jr,_) -> 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 (tag,attrs,l) -> let _ = outAttribute tag attrs true let z = addL z pos l let _ = outAttribute tag attrs false z let i = addL z0 0 layout () // -------------------------------------------------------------------- // pprinter: using general-purpose reflection... // -------------------------------------------------------------------- let getValueInfo bindingFlags (x:'a) = Value.GetInfo bindingFlags (x:'a) let unpackCons recd = match recd with | [(_,h);(_,t)] -> (h,t) | _ -> failwith "unpackCons" let getListValueInfo bindingFlags (x:obj) = match x with | null -> None | _ -> match getValueInfo bindingFlags x with | ConstructorValue ("Cons",recd) -> Some (unpackCons recd) | ConstructorValue ("Empty",[]) -> None | _ -> failwith "List value had unexpected ValueInfo" let compactCommaListL xs = sepListL (sepL ",") xs // compact, no spaces around "," let nullL = wordL "null" let measureL = wordL "()" // -------------------------------------------------------------------- // pprinter: attributes // -------------------------------------------------------------------- let makeRecordVerticalL nameXs = let itemL (name,xL) = let labelL = wordL name in ((labelL $$ wordL "=")) -- (xL $$ (rightL ";")) let braceL xs = (leftL "{") $$ xs $$ (rightL "}") braceL (aboveListL (List.map itemL nameXs)) let makeRecordHorizontalL nameXs = (* This is a more compact rendering of records - and is more like tuples *) let itemL (name,xL) = let labelL = wordL name in ((labelL $$ wordL "=")) -- xL let braceL xs = (leftL "{") $$ xs $$ (rightL "}") braceL (sepListL (rightL ";") (List.map itemL nameXs)) let makeRecordL nameXs = makeRecordVerticalL nameXs (* REVIEW: switch to makeRecordHorizontalL ? *) let makePropertiesL nameXs = let itemL (name,v) = let labelL = wordL name (labelL $$ wordL "=") $$ (match v with | None -> wordL "?" | Some xL -> xL) $$ (rightL ";") let braceL xs = (leftL "{") $$ xs $$ (rightL "}") braceL (aboveListL (List.map itemL nameXs)) let makeListL itemLs = (leftL "[") $$ sepListL (rightL ";") itemLs $$ (rightL "]") let makeArrayL xs = (leftL "[|") $$ sepListL (rightL ";") xs $$ (rightL "|]") let makeArray2L xs = leftL "[" $$ aboveListL xs $$ rightL "]" // -------------------------------------------------------------------- // pprinter: anyL - support functions // -------------------------------------------------------------------- let getProperty (obj: obj) name = let ty = obj.GetType() #if FX_NO_CULTURE_INFO_ARGS ty.InvokeMember(name, (BindingFlags.GetProperty ||| BindingFlags.Instance ||| BindingFlags.Public ||| BindingFlags.NonPublic), null, obj, Array.of_list [ ]) #else ty.InvokeMember(name, (BindingFlags.GetProperty ||| BindingFlags.Instance ||| BindingFlags.Public ||| BindingFlags.NonPublic), null, obj, Array.of_list [ ],CultureInfo.InvariantCulture) #endif 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 truncat"+[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. 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) (* x could be null *) = objL showMode i prec (getValueInfo bindingFlags (x:'a)) (box x) let anyL showMode bindingFlags (opts:FormatOptions) (x:'a) = // showMode = ShowTopLevelBinding on the outermost expression when called from fsi.exe, // This allows certain outputs, e.g. objects that would print as 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(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) = polyL bindingFlags objWithReprL ShowAll depthLim prec x (* showMode for inner expr *) and sameObjL depthLim prec (x:obj) = polyL bindingFlags objWithReprL showMode depthLim prec x (* showMode preserved *) and objWithReprL showMode depthLim prec (info:ValueInfo) (x:obj) (* x could be null *) = let showModeFilter lay = match showMode with ShowAll -> lay | ShowTopLevelBinding -> emptyL try if depthLim<=0 || exceededPrintSize() then wordL "..." else match x with | null -> reprL showMode (depthLim-1) prec info x | _ -> if (path.ContainsKey(x)) then wordL "..." else path.Add(x,0); let res = // Try the extensibility attribute match x.GetType().GetCustomAttributes (typeof, true) with | null | [| |] -> None | res -> let attr = (res.[0] :?> StructuredFormatDisplayAttribute) let txt = attr.Value if txt = null || txt.Length <= 1 then None else let p1 = txt.IndexOf "{" let p2 = txt.LastIndexOf "}" if p1 < 0 || p2 < 0 || p1+1 >= p2 then None else let preText = if p1 <= 0 then "" else txt.[0..p1-1] let postText = if p2+1 >= txt.Length then "" else txt.[p2+1..] let prop = txt.[p1+1..p2-1] match catchExn (fun () -> getProperty x prop) with | Choice2Of2 e -> Some (wordL ("")) | 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 esaping of // the string, i.e. just treat the string as display text. // This allows simple implementations of // such as // // [] // type BigInt(signInt:int, v : BigNat) = // member x.StructuredDisplayString = x.ToString() // | :? string as s -> sepL s | _ -> sameObjL (depthLim-1) Precedence.BracketIfTuple alternativeObj countNodes 0 (* 0 means we do not count the preText and postText *) Some (leftL preText $$ alternativeObjL $$ rightL postText) with _ -> None #if RUNTIME #else #if INTERNALIZED_POWER_PACK // FSharp.Compiler.dll: 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 env.GetLayout(y) = objL (depthLim-1) Precedence.BracketIfTuple y member env.MaxColumns = opts.PrintLength member env.MaxRows = opts.PrintLength } opts.PrintIntercepts |> List.tryPick (fun intercept -> intercept env x) #endif #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 ("Error: " + e.Message) and recdAtomicTupleL depthLim recd = // tuples up args to UnionConstruction or ExceptionConstructor. no node count. match recd with | [(_,x)] -> objL depthLim Precedence.BracketIfTupleOrNotAtomic x | txs -> leftL "(" $$ compactCommaListL (List.map (snd >> objL depthLim Precedence.BracketIfTuple) txs) $$ rightL ")" and bracketIfL b basicL = if b then (leftL "(") $$ basicL $$ (rightL ")") else basicL and reprL showMode depthLim prec repr x (* x could be null *) = let showModeFilter lay = match showMode with ShowAll -> lay | ShowTopLevelBinding -> emptyL match repr with | TupleValue vals -> let basicL = sepListL (rightL ",") (List.map (objL depthLim Precedence.BracketIfTuple ) vals) bracketIfL (prec <= Precedence.BracketIfTuple) basicL | RecordValue items -> let itemL (name,x) = countNodes 1 // record labels are counted as nodes. [REVIEW: discussion under 4090]. (name,objL depthLim Precedence.BracketIfTuple x) makeRecordL (List.map itemL items) | ConstructorValue (constr,recd) when (* x is List. Note: "null" is never a valid list value. *) x<>null && Type.IsListType (x.GetType()) -> match constr with | "Cons" -> let (x,xs) = unpackCons recd let project xs = getListValueInfo bindingFlags xs let itemLs = objL depthLim Precedence.BracketIfTuple x :: boundedUnfoldL (objL depthLim Precedence.BracketIfTuple) project stopShort xs (opts.PrintLength - 1) makeListL itemLs | _ -> countNodes 1 wordL "[]" | ConstructorValue(nm,[]) -> countNodes 1 (wordL nm) | ConstructorValue(nm,recd) -> countNodes 1 (* e.g. Some (Some (Some (Some 2))) should count for 5 *) (wordL nm --- recdAtomicTupleL depthLim recd) |> bracketIfL (prec <= Precedence.BracketIfTupleOrNotAtomic) | ExceptionValue(ty,recd) -> countNodes 1 // Bug 4045: ty.Name may have form Exception. We should be using the constructor . let name = ty.Name |> trimEnding "Exception" (* if present, trim trailing "Exception" from type name *) match recd with | [] -> (wordL name) | recd -> (wordL name --- recdAtomicTupleL depthLim recd) |> bracketIfL (prec <= Precedence.BracketIfTupleOrNotAtomic) | FunctionClosureValue(ty,obj) -> // Q: should function printing include the ty.Name? It does not convey much useful info to most users, e.g. "clo@0_123". countNodes 1 wordL ("") |> showModeFilter | ObjectValue(obj) -> match obj with | null -> (countNodes 1; nullL) | _ -> let ty = obj.GetType() match obj with | :? string as s -> countNodes 1 #if INTERNALIZED_POWER_PACK if s.Length + 2(*quotes*) <= opts.StringLimit then // With the quotes, it fits within the limit. wordL (formatString s) else // When a string is considered too long to print, there is a choice: what to print? // a) -- follows // b) -- follows and gives just the length // c) "abcdefg"+[n chars] -- gives a prefix and the remaining chars wordL (formatStringInWidth opts.StringLimit s) #else wordL (formatString s) #endif | :? System.Array as arr -> match arr.Rank with | 1 -> let n = arr.Length let b1 = arr.GetLowerBound(0) let project depthLim = if depthLim=(b1+n) then None else Some (box (arr.GetValue(depthLim)),depthLim+1) let itemLs = boundedUnfoldL (objL depthLim Precedence.BracketIfTuple) project stopShort b1 opts.PrintLength makeArrayL (if b1 = 0 then itemLs else wordL("bound1="+string_of_int b1)::itemLs) | 2 -> let n1 = arr.GetLength(0) let n2 = arr.GetLength(1) let b1 = arr.GetLowerBound(0) let b2 = arr.GetLowerBound(1) let project2 x y = if x>=(b1+n1) || y>=(b2+n2) then None else Some (box (arr.GetValue(x,y)),y+1) let rowL x = boundedUnfoldL (objL depthLim Precedence.BracketIfTuple) (project2 x) stopShort b2 opts.PrintLength |> makeListL let project1 x = if x>=(b1+n1) then None else Some (x,x+1) let rowsL = boundedUnfoldL rowL project1 stopShort b1 opts.PrintLength makeArray2L (if b1=0 && b2 = 0 then rowsL else wordL("bound1=" + string_of_int b1)::wordL("bound2=" + string_of_int b2)::rowsL) | n -> makeArrayL [wordL("rank=" + string_of_int n)] | :? System.Collections.IEnumerable as ie -> if opts.ShowIEnumerable then let it = ie.GetEnumerator() try let itemLs = boundedUnfoldL (objL depthLim Precedence.BracketIfTuple) (fun () -> if it.MoveNext() then Some(it.Current,()) else None) stopShort () (1+opts.PrintLength/30) (wordL "seq" --- makeListL itemLs) |> bracketIfL (prec <= Precedence.BracketIfTupleOrNotAtomic) finally match it with | :? System.IDisposable as e -> e.Dispose() | _ -> () else // Sequence printing is turned off for declared-values, and maybe be disabled to users. // There is choice here, what to print? or ... or ? // Also, in the declared values case, if the sequence is actually a known non-lazy type (list, array etc etc) we could print it. wordL "" |> showModeFilter | _ -> if showMode = ShowTopLevelBinding && typeUsesSystemObjectToString (obj.GetType()) then emptyL else countNodes 1 let basicL = LayoutOps.objL obj (* This burries an obj in the layout, rendered at squash time via a leafFormatter. * If the leafFormatter was directly here, then layout leaves could store strings. *) match obj with | _ when opts.ShowProperties -> let props = ty.GetProperties(BindingFlags.GetField ||| BindingFlags.Instance ||| BindingFlags.Public) // massively reign in deep printing of properties let nDepth = depthLim/10 System.Array.Sort((props:>System.Array),{ new System.Collections.IComparer with member this.Compare(p1,p2) = compare ((p1 :?> PropertyInfo).Name) ((p2 :?> PropertyInfo).Name) } ); if props.Length = 0 || (nDepth <= 0) then basicL else basicL --- (props |> Array.to_list |> List.map (fun p -> (p.Name,(try Some (objL nDepth Precedence.BracketIfTuple (getProperty obj p.Name)) with _ -> None))) |> makePropertiesL) | _ -> basicL | UnitValue -> countNodes 1; measureL polyL bindingFlags objWithReprL showMode opts.PrintDepth Precedence.BracketIfTuple x // -------------------------------------------------------------------- // pprinter: leafFormatter // -------------------------------------------------------------------- #if Suggestion4299 // See bug 4299. Suppress FSI_dddd+ from fsi printer. let fixupForInteractiveFSharpClassesWithNoToString obj (text:string) = // Given obj:T. // If T is a nested type inside a parent type called FSI_dddd, then it looks like an F# Interactive type. // Further, if the .ToString() text starts with "FSI_dddd+T" then it looks like it's the default ToString. // A better test: it is default ToString if the MethodInfo.DeclaringType is System.Object. // In this case, replace "FSI_dddd+T" by "T". // assert(obj <> null) let fullName = obj.GetType().FullName // e.g. "FSI_0123+Name" let name = obj.GetType().Name // e.g. "Name" let T = obj.GetType() if text.StartsWith(fullName) then // text could be a default .ToString() since it starts with the FullName of the type. More checks... if T.IsNested && T.DeclaringType.Name.StartsWith("FSI_") && // Name has "FSI_" which is T.DeclaringType.Name.Substring(4) |> Seq.forall System.Char.IsDigit // followed by digits? then name ^ text.Substring(fullName.Length) // replace fullName by name at start of text else text else text #endif let leafFormatter (opts:FormatOptions) (obj :obj) = match obj with | null -> "null" | :? double as d -> let s = d.ToString(opts.FloatingPointFormat,opts.FormatProvider) if System.Double.IsNaN(d) then "nan" elif System.Double.IsNegativeInfinity(d) then "-infinity" elif System.Double.IsPositiveInfinity(d) then "infinity" elif opts.FloatingPointFormat.[0] = 'g' && String.forall(fun c -> System.Char.IsDigit(c) || c = '-') s then s + ".0" else s | :? single as d -> (if System.Single.IsNaN(d) then "nan" elif System.Single.IsNegativeInfinity(d) then "-infinity" elif System.Single.IsPositiveInfinity(d) then "infinity" elif opts.FloatingPointFormat.Length >= 1 && opts.FloatingPointFormat.[0] = 'g' && float32(System.Int32.MinValue) < d && d < float32(System.Int32.MaxValue) && float32(int32(d)) = d then (System.Convert.ToInt32 d).ToString(opts.FormatProvider) + ".0" else d.ToString(opts.FloatingPointFormat,opts.FormatProvider)) + "f" | :? System.Decimal as d -> d.ToString("g",opts.FormatProvider) + "M" | :? uint64 as d -> d.ToString(opts.FormatProvider) + "UL" | :? int64 as d -> d.ToString(opts.FormatProvider) + "L" | :? int32 as d -> d.ToString(opts.FormatProvider) | :? uint32 as d -> d.ToString(opts.FormatProvider) + "u" | :? int16 as d -> d.ToString(opts.FormatProvider) + "s" | :? uint16 as d -> d.ToString(opts.FormatProvider) + "us" | :? sbyte as d -> d.ToString(opts.FormatProvider) + "y" | :? byte as d -> d.ToString(opts.FormatProvider) + "uy" | :? nativeint as d -> d.ToString() + "n" | :? unativeint as d -> d.ToString() + "un" | :? bool as b -> (if b then "true" else "false") | :? char as c -> "\'" + formatChar true c + "\'" | _ -> try let text = obj.ToString() //Suggestion4299. Not yet fixed. //#if INTERNALIZED_POWER_PACK // let text = fixupForInteractiveFSharpClassesWithNoToString obj text //#endif text with e -> // If a .ToString() call throws an exception, catch it and use the message as the result. // This may be informative, e.g. division by zero etc... "" let any_to_layout opts x = anyL ShowAll BindingFlags.Public opts x let squash_layout opts l = // Print width = 0 implies 1D layout, no squash if opts.PrintWidth = 0 then l else l |> squashTo (opts.PrintWidth,leafFormatter opts) let output_layout opts oc l = l |> squash_layout opts |> outL opts.AttributeProcessor (leafFormatter opts) oc let layout_to_string opts l = l |> squash_layout opts |> showL opts (leafFormatter opts) let output_any_ex opts oc x = x |> any_to_layout opts |> output_layout opts oc let output_any oc x = output_any_ex FormatOptions.Default oc x let layout_as_string opts x = x |> any_to_layout opts |> layout_to_string opts let any_to_string x = layout_as_string FormatOptions.Default x #if RUNTIME let internal printf_any_to_string opts (bindingFlags:BindingFlags) x = x |> anyL ShowAll bindingFlags opts |> layout_to_string opts #endif #if INTERNALIZED_POWER_PACK /// Called let fsi_any_to_layout opts x = anyL ShowTopLevelBinding BindingFlags.Public opts x #endif