//=========================================================================
// (c) Microsoft Corporation 2005-2009. 
//=========================================================================

#nowarn "52" // The value has been copied to ensure the original is not mutated by this operation

namespace Microsoft.FSharp.Text.StructuredFormat

    // 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.Reflection

    /// 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 =
     | 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

    [<NoEquality; NoComparison>]
    type IEnvironment = 
        abstract GetLayout : obj -> layout
        abstract MaxColumns : int
        abstract MaxRows : int
     
    [<CompilationRepresentation(CompilationRepresentationFlags.ModuleSuffix)>]
    module LayoutOps = 
        let rec juxtLeft = function
          | Leaf (jl,_,_)         -> jl
          | Node (jl,_,_,_,_,_) -> jl
          | Attr (_,_,l)        -> juxtLeft l

        let rec juxtRight = function
          | 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   (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.
    [<NoEquality; NoComparison>]
    type FormatOptions = 
        { FloatingPointFormat: string;
          AttributeProcessor: (string -> (string * string) list -> bool -> unit);
          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);
              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

        [<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(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<obj option>
        let func = typedefof<(obj -> obj)>

        let isOptionType typ = equivHeadTypes typ (typeof<int option>)
        let isUnitType typ = equivHeadTypes typ (typeof<unit>)
        let isListType typ = 
            FSharpType.IsUnion typ && 
            (let cases = FSharpType.GetUnionCases typ 
             cases.Length > 0 && equivHeadTypes (typedefof<list<_>>) cases.[0].DeclaringType)

        module Type =

            let recdDescOfProps props = 
               props |> Array.toList |> 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.toList)
                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.toList |> 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

        [<NoEquality; NoComparison>]
        type ValueInfo =
          | TupleValue of obj list
          | FunctionClosureValue of System.Type 
          | 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.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.   
                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.toList 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.toList)

                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.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)  (* 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)

    [<CompilationRepresentation(CompilationRepresentationFlags.ModuleSuffix)>]
    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<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 FX_NO_CULTURE_INFO_ARGS
          if str.EndsWith(ending) then 
#else
          if str.EndsWith(ending,StringComparison.Ordinal) 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.

        [<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) 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 _,layout,_,_ = fit breaks (pos,layout)
            layout

        // -------------------------------------------------------------------------
        // showL
        // ------------------------------------------------------------------------

        let combine strs = System.String.Concat(Array.ofList(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   (_,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 System.Environment.NewLine rstrs
                let rstrs = push indent rstrs
                rstrs,n

            // addL: pos is tab level 
            let rec addL z pos layout = 
                match layout with 
                | Leaf (_,obj,_)                 -> 
                    let text = leafFormatter obj 
                    addText z 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 : 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 _ 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 (_,obj,_)                 -> 
                    let text = leafFormatter obj 
                    addText z text
                | 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 " "
                    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) = 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, [| |])
#else
            ty.InvokeMember(name, (BindingFlags.GetProperty ||| BindingFlags.Instance ||| BindingFlags.Public ||| BindingFlags.NonPublic), null, obj, [| |],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.
        [<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) (* 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 <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) = 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 *) =
                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 = 
                          // 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 (x.ToString()))
                          else
                            // Try the StructuredFormatDisplayAttribute extensibility attribute
                            match x.GetType().GetCustomAttributes (typeof<StructuredFormatDisplayAttribute>, 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 ("{", StringComparison.Ordinal)
                                  let p2 = txt.LastIndexOf ("}", StringComparison.Ordinal)
                                  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 ("<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 esaping 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 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

                        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<T>. 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
                    let name = ty.Name 
                    match recd with
                      | []   -> (wordL name)
                      | recd -> (wordL name --- recdAtomicTupleL depthLim recd) |> bracketIfL (prec <= Precedence.BracketIfTupleOrNotAtomic)

                | FunctionClosureValue ty ->
                    // 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 ("<fun:"+ty.Name+">") |> showModeFilter

                | ObjectValue(obj)  ->
                    match obj with 
                    | null -> (countNodes 1; nullL)
                    | _ -> 
                    let ty = obj.GetType()
                    match obj with 
                    | :? string as s ->
                        countNodes 1
                        wordL (formatString s)  
                    | :? 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)]
                        
                    // Format 'set' and 'map' nicely
                    | _ when  
                          (let ty = obj.GetType()
                           ty.IsGenericType && (ty.GetGenericTypeDefinition() = typedefof<Map<int,int>> 
                                                || ty.GetGenericTypeDefinition() = typedefof<Set<int>>) ) ->
                         let ty = obj.GetType()
                         let word = if ty.GetGenericTypeDefinition() = typedefof<Map<int,int>> then "map" else "set"
                         let possibleKeyValueL v = 
                             if word = "map" &&
                                (match v with null -> false | _ -> true) && 
                                v.GetType().IsGenericType && 
                                v.GetType().GetGenericTypeDefinition() = typedefof<KeyValuePair<int,int>> then
                                  objL depthLim Precedence.BracketIfTuple (v.GetType().GetProperty("Key").GetValue(v, [| |]), 
                                                                           v.GetType().GetProperty("Value").GetValue(v, [| |]))
                             else
                                  objL depthLim Precedence.BracketIfTuple v
                         let it = (obj :?>  System.Collections.IEnumerable).GetEnumerator() 
                         try 
                           let itemLs = boundedUnfoldL possibleKeyValueL (fun () -> if it.MoveNext() then Some(it.Current,()) else None) stopShort () (1+opts.PrintLength/12)
                           (wordL word --- makeListL itemLs) |> bracketIfL (prec <= Precedence.BracketIfTupleOrNotAtomic)
                         finally 
                            match it with 
                            | :? System.IDisposable as e -> e.Dispose()
                            | _ -> ()

                    | :? System.Collections.IEnumerable as ie ->
                         if opts.ShowIEnumerable then
                           let word = "seq"
                           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 word --- 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? <seq> 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 "<seq>" |> showModeFilter
                    | _ ->
                         if showMode = ShowTopLevelBinding && typeUsesSystemObjectToString (obj.GetType()) then
                           emptyL
                         else
                           countNodes 1
                           let basicL = LayoutOps.objL obj  // This buries 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.toList 
                                      |> 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+<etc> 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()
                        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...
                     "<ToString exception: " + e.Message + ">" 

        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