// (c) Microsoft Corporation. All rights reserved
#light

module Microsoft.FSharp.Compiler.Layout

open System
open System.IO
open Internal.Utilities.StructuredFormat
open Microsoft.FSharp.Text.Printf

#nowarn "62" // This construct is for compatibility with OCaml.

type layout = Internal.Utilities.StructuredFormat.Layout
let spaces n = new String(' ',n)


//--------------------------------------------------------------------------
// INDEX: support
//--------------------------------------------------------------------------

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

(* NOTE:
 * emptyL might be better represented as a constructor,
 * so then (Sep"") would have true meaning
 *)
let emptyL = Leaf (true,box "",true)
let isEmptyL = function Leaf(true,tag,true) when unbox tag = "" -> true | _ -> false
      
let mkNode l r joint =
   if isEmptyL l then r else
   if isEmptyL r then l else
   let jl = juxtLeft  l in
   let jm = juxtRight l || juxtLeft r in
   let jr = juxtRight r in
   Node(jl,l,jm,r,jr,joint)


//--------------------------------------------------------------------------
//INDEX: constructors
//--------------------------------------------------------------------------

let wordL  (str:string) = Leaf (false,box str,false)
let sepL   (str:string) = Leaf (true ,box str,true)   
let rightL (str:string) = Leaf (true ,box str,false)   
let leftL  (str:string) = Leaf (false,box str,true)

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 str attrs ly = Attr (str,attrs,ly)
let linkL str ly = tagAttrL "html:a" [("href",str)] ly

//--------------------------------------------------------------------------
//INDEX: constructors derived
//--------------------------------------------------------------------------

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 = mkNode l r (Breakable 3)
let (-----) l r = mkNode l r (Breakable 4)    
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 "]"


//--------------------------------------------------------------------------
//INDEX: breaks v2
//--------------------------------------------------------------------------
 
// A very quick implementation of break stack.
type breaks = Breaks of 
                 /// pos of next free slot 
                 int *     
                 /// pos of next possible "outer" break - OR - outer=next if none possible 
                 int *     
                 /// stack of savings, -ve means it has been broken 
                 int array 

// next  is next slot to push into - aka size of current occupied stack.
// outer counts up from 0, and is next slot to break if break forced.
// - if all breaks forced, then outer=next.
// - popping under these conditions needs to reduce outer and next.
let chunkN = 400      
let breaks0 () = Breaks(0,0,Array.create chunkN 0)
let pushBreak saving (Breaks(next,outer,stack)) =
    let stack = if next = Array.length stack then
                  Array.append stack (Array.create chunkN 0) (* expand if full *)
                else
                  stack
    stack.[next] <- saving;
    Breaks(next+1,outer,stack)

let popBreak (Breaks(next,outer,stack)) =
    if next=0 then raise (Failure "popBreak: underflow");
    let topBroke = stack.[next-1] < 0 
    let outer = if outer=next then outer-1 else outer   (* if all broken, unwind *)
    let next  = next - 1 
    Breaks(next,outer,stack),topBroke

let forceBreak (Breaks(next,outer,stack)) =
    if outer=next then
      (* all broken *)
      None
    else
      let saving = stack.[outer] 
      stack.[outer] <- -stack.[outer];    
      let outer = outer+1 
      Some (Breaks(next,outer,stack),saving)

let squashTo maxWidth 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 rec fit breaks (pos,layout) =
       (*Printf.printf "\n\nCalling pos=%d layout=[%s]\n" pos (showL layout);*)
       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) ->
               let textWidth = (unbox<string> 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 in 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 + indent *)
                   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

//--------------------------------------------------------------------------
//INDEX: render
//--------------------------------------------------------------------------

type ('a,'b) render =
    (* exists 'b.
       -- could use object type to get "exists 'b" on private state,
    *)
    abstract Start    : unit -> 'b;
    abstract AddText  : 'b -> string -> 'b;
    abstract AddBreak : 'b -> int -> 'b;
    abstract AddTag   : 'b -> string * (string * string) list * bool -> 'b;
    abstract Finish   : 'b -> 'a
      
let renderL (rr: render<_,_>) layout =
    let rec addL z pos i = function
        (* pos is tab level *)
      | Leaf (jl,text,jr)                 -> 
          rr.AddText z (unbox text),i + (unbox<string> text).Length
      | Node (jl,l,jm,r,jr,Broken indent) -> 
          let z,i = addL z pos i l 
          let z,i = rr.AddBreak z (pos+indent),(pos+indent) 
          let z,i = addL z (pos+indent) i r 
          z,i
      | Node (jl,l,jm,r,jr,_)             -> 
          let z,i = addL z pos i l 
          let z,i = if jm then z,i else rr.AddText z " ",i+1 
          let pos = i 
          let z,i = addL z pos i r 
          z,i
      | Attr (tag,attrs,l)                -> 
          let z   = rr.AddTag z (tag,attrs,true) 
          let z,i = addL z pos i l 
          let z   = rr.AddTag z (tag,attrs,false) 
          z,i
    let pos = 0 
    let z,i = rr.Start(),0 
    let z,i = addL z pos i layout 
    rr.Finish z

/// string render 
let stringR =
  { new render<string,string list> with 
      member x.Start () = []
      member x.AddText rstrs text = text::rstrs
      member x.AddBreak rstrs n = (spaces n) :: "\n" ::  rstrs 
      member x.AddTag z (_,_,_) = z
      member x.Finish rstrs = String.Join("",Array.of_list (List.rev rstrs)) }

type NoState = NoState
type NoResult = NoResult

/// channel render
let channelR (chan:TextWriter) =
  { new render<NoResult,NoState> with 
      member r.Start () = NoState
      member r.AddText z s = chan.Write s; z
      member r.AddBreak z n = chan.WriteLine(); chan.Write (spaces n); z
      member r.AddTag z (tag,attrs,start) =  z
      member r.Finish z = NoResult }

/// buffer render
let bufferR os =
  { new render<NoResult,NoState> with 
      member r.Start () = NoState
      member r.AddText z s = bprintf os "%s" s; z
      member r.AddBreak z n = bprintf os "\n"; bprintf os "%s" (spaces n); z
      member r.AddTag z (tag,attrs,start) = z
      member r.Finish z = NoResult }

/// html render - wraps HTML encoding (REVIEW) and hyperlinks
let htmlR (baseR : render<'Res,'State>) =
  { new render<'Res,'State> with 
      member r.Start () = baseR.Start()
      member r.AddText z s = baseR.AddText z s;  (* REVIEW: escape HTML chars *)
      member r.AddBreak z n = baseR.AddBreak z n
      member r.AddTag z (tag,attrs,start) =
         match tag,attrs with 
         | "html:a",[("href",link)] ->
            if start
            then baseR.AddText z (sprintf "<a href='%s'>" link)
            else baseR.AddText z (sprintf "</a>")
         | _ -> z
      member r.Finish z = baseR.Finish z }

/// indent render - wraps fixed indentation
let indentR indent (baseR : render<'Res,'State>) =
  { new render<'Res,'State> with 
      member r.Start () = 
          let z = baseR.Start() 
          let z = baseR.AddText z (spaces indent) 
          z
      member r.AddText z s = baseR.AddText z s;  (* REVIEW: escape HTML chars *)
      member r.AddBreak z n =  baseR.AddBreak z (n+indent);
      member r.AddTag z (tag,attrs,start)  = baseR.AddTag z (tag,attrs,start) 
      member r.Finish z = baseR.Finish z }

//--------------------------------------------------------------------------
//INDEX: showL, outL are most common
//--------------------------------------------------------------------------

let showL                   layout = renderL stringR         layout
let outL (chan:TextWriter)  layout = renderL (channelR chan) layout |> ignore
let bufferL os              layout = renderL (bufferR os)    layout |> ignore