csharpfftfsharpintegrationinterpolationlinear-algebramathdifferentiationmatrixnumericsrandomregressionstatisticsmathnet
You can not select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
325 lines
12 KiB
325 lines
12 KiB
// (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
|
|
|