pp-stream-fn.sml

这是我们参加06年全国开源软件的竞赛作品

(* pp-stream-fn.sml
 *
 * COPYRIGHT (c) 1997 Bell Labs, Lucent Technologies.
 *
 * The implementation of PP streams, where all the action is.
 *)

functor PPStreamFn (
    structure Token : PP_TOKEN
    structure Device : PP_DEVICE
      sharing type Token.style = Device.style
(**
  ) : PP_STREAM =
**)
  ) : sig include PP_STREAM val dump : (TextIO.outstream * stream) -> unit end =
  struct

    structure D = Device
    structure T = Token
    structure Q = Queue
    structure PPD = PPDesc

    type device = D.device
    type token = T.token
    type style = T.style

    datatype indent = datatype PPD.indent

  (**** DATA STRUCTURES ****)
    datatype pp_token
      = TEXT of string			(* raw text.  This includes tokens.  The *)
					(* width and style information is taken *)
					(* care of when they are inserted in *)
					(* queue. *)
      | NBSP of int			(* some number of non-breakable spaces *)
      | BREAK of {nsp : int, offset : int}
      | BEGIN of (indent * box_type)
      | END
      | PUSH_STYLE of style
      | POP_STYLE
      | NL
      | IF_NL
      | CTL of (device -> unit)		(* device control operation *)

   and box_type = HBOX | VBOX | HVBOX | HOVBOX | BOX | FITS

    type pp_queue_elem = {	(* elements of the PP queue *)
	tok : pp_token,
	sz : int ref,			(* size of blok (set when known) *)
	len : int			(* length of token *)
      }

    datatype stream = PP of {
	dev : device,			(* the underlying device *)
	closed : bool ref,		(* set to true, when the stream is *)
					(* closed *)
	width : int,			(* the width of the device *)
	spaceLeft : int ref,		(* space left on current line *)
	curIndent : int ref,		(* current indentation *)
	curDepth : int ref,		(* current nesting level of boxes. *)
	leftTot : int ref,		(* total width of tokens already printed *)
	rightTot : int ref,		(* total width of tokens ever inserted *)
					(* into the queue. *)
	queue : pp_queue_elem Q.queue,	(* the queue of pending tokens *)
	fmtStk				(* stack of information about currently *)
	  : (box_type * int) list ref,	(* active blocks *)
	scanStk
	  : (int * pp_queue_elem) list ref,
	styleStk : style list ref
      }

  (**** DEBUGGING FUNCTIONS ****)
    structure F = Format
    fun boxTypeToString HBOX = "HBOX"
      | boxTypeToString VBOX = "VBOX"
      | boxTypeToString HVBOX = "HVBOX"
      | boxTypeToString HOVBOX = "HOVBOX"
      | boxTypeToString BOX = "BOX"
      | boxTypeToString FITS = "FITS"
    fun indentToString (Abs n) = concat["Abs ", Int.toString n]
      | indentToString (Rel n) = concat["Rel ", Int.toString n]
    fun tokToString (TEXT s) = concat["TEXT \"", String.toString s, "\""]
      | tokToString (NBSP n) = concat["NBSP ", Int.toString n]
      | tokToString (BREAK{nsp, offset}) =
	  F.format "BREAK{nsp=%d, offset=%d}" [F.INT nsp, F.INT offset]
      | tokToString (BEGIN(indent, ty)) = F.format "BEGIN(%s, %s)" [
	    F.STR(indentToString indent), F.STR(boxTypeToString ty)
	  ]
      | tokToString END = "END"
      | tokToString (PUSH_STYLE _) = "PUSH_STYLE _"
      | tokToString POP_STYLE = "POP_STYLE"
      | tokToString NL = "NL"
      | tokToString IF_NL = "IF_NL"
      | tokToString (CTL f) = "CTL _"
    fun qelemToString {tok, sz, len} = F.format "{tok=%s, sz=%d, len=%d}" [
	    F.STR(tokToString tok), F.INT(!sz), F.INT len
	  ]
    fun scanElemToString (n, elem) =
	  F.format "(%d, %s)" [F.INT n, F.STR(qelemToString elem)]
    fun dump (outStrm, PP pp) = let
	  fun pr s = TextIO.output(outStrm, s)
	  fun prf (fmt, items) = pr(F.format fmt items)
	  fun fmtElemToString (ty, n) =
		F.format "(%s, %d)" [F.STR(boxTypeToString ty), F.INT n]
	  fun prl fmtElem [] = pr "[]"
	    | prl fmtElem l = pr(ListFormat.fmt {
		  init = "[\n    ", final = "]", sep = "\n    ", fmt = fmtElem
		} l)
	  in
	    pr  ("BEGIN\n");
	    prf ("  width     = %3d\n", [F.INT(#width pp)]);
	    prf ("  curIndent = %3d, curDepth = %3d\n", [
		F.INT(!(#curIndent pp)), F.INT(!(#curDepth pp))
	      ]);
	    prf ("  leftTot   = %3d, rightTot = %3d\n", [
		F.INT(!(#leftTot pp)), F.INT(!(#rightTot pp))
	      ]);
	    prf ("  spaceLeft = %3d\n", [F.INT(!(#spaceLeft pp))]);
	    pr   "  queue = "; prl qelemToString (Q.contents(#queue pp)); pr "\n";
	    pr   "  fmtStk = "; prl fmtElemToString (!(#fmtStk pp)); pr "\n";
	    pr   "  scanStk = "; prl scanElemToString (!(#scanStk pp)); pr "\n";
	    pr  ("END\n")
	  end

  (**** UTILITY FUNCTIONS ****)

    val infinity = Option.getOpt(Int.maxInt, 1000000000)

  (* output functions *)
    fun output (PP{dev, ...}, s) = D.string(dev, s)
    fun outputNL (PP{dev, ...}) = D.newline dev
    fun blanks (_, 0) = ()
      | blanks (PP{dev, ...}, n) = D.space (dev, n)

  (* add a token to the pretty-printer queue *)
    fun enqueueTok (PP{rightTot, queue, ...}, tok) = (
	  rightTot := !rightTot + #len tok;
	  Q.enqueue(queue, tok))

  (* format a break as a newline; indenting the new line.
   *   strm	-- PP stream
   *   offset	-- the extra indent amount supplied by the break
   *   wid	-- the remaining line width at the opening of the
   *		   innermost enclosing box.
   *)
    fun breakNewLine (strm, offset, wid) = let
	  val PP{width, curIndent, spaceLeft, ...} = strm
	  val indent = (width - wid) + offset
(***** CAML version does the following: *****
	  val indent = min(maxIndent, indent)
*****)
	  in
	    curIndent := indent;
	    spaceLeft := width - indent;
	    outputNL strm;
	    blanks (strm, indent)
	  end

  (* format a break as spaces.
   *   strm	-- PP stream
   *   nsp	-- number of spaces to output.
   *)
    fun breakSameLine (strm as PP{spaceLeft, ...}, nsp) = (
	  spaceLeft := !spaceLeft - nsp;
	  blanks (strm, nsp))

(***** this function is in the CAML version, but is currently not used.
    fun forceLineBreak (strm as PP{fmtStk, spaceLeft, ...}) = (case !fmtStk
	   of ((ty, wid)::r) => if (wid > !spaceLeft)
		then (case ty
		   of (FITS | HBOX) => ()
		    | _ => breakNewLine (strm, 0, wid)
		  (* end case *))
		else ()
	    | _ => outputNL strm
	  (* end case *))
*****)

  (* return the current style of the PP stream *)
    fun currentStyle (PP{styleStk = ref [], dev, ...}) = D.defaultStyle dev
      | currentStyle (PP{styleStk = ref(sty::_), ...}) = sty

  (**** FORMATTING ****)

    fun format (strm, sz, tok) = (case tok
	   of (TEXT s) => let
		val PP{spaceLeft, ...} = strm
		in
		  spaceLeft := !spaceLeft - sz;
		  output(strm, s)
		end
	    | (NBSP n) => let
		val PP{spaceLeft, ...} = strm
		in
		  spaceLeft := !spaceLeft - sz;
		  blanks (strm, n)
		end
	    | (BREAK{nsp, offset}) => let
		val PP{fmtStk, spaceLeft, width, curIndent, ...} = strm
		in
		  case !fmtStk
		   of ((HBOX, wid)::_) => breakSameLine (strm, nsp)
		    | ((VBOX, wid)::_) => breakNewLine (strm, offset, wid)
		    | ((HVBOX, wid)::_) => breakNewLine (strm, offset, wid)
		    | ((HOVBOX, wid)::_) => if (sz > !spaceLeft)
			then breakNewLine (strm, offset, wid)
			else breakSameLine (strm, nsp)
		    | ((BOX, wid)::_) =>
			if ((sz > !spaceLeft)
			orelse (!curIndent > (width - wid)+offset))
			  then breakNewLine (strm, offset, wid)
			  else breakSameLine (strm, nsp)
		    | ((FITS, wid)::_) => breakSameLine (strm, nsp)
		    | _ => () (* no open box *)
		end
	    | (BEGIN(indent, ty)) => let
		val PP{curIndent, spaceLeft, width, fmtStk, ...} = strm
		val spaceLeft' = !spaceLeft
		val insPt = width - spaceLeft'
	      (* compute offset from right margin of this block's indent *)
		val offset = (case indent
		       of (Rel off) => spaceLeft' - off
			| (Abs off) => (case !fmtStk
			     of ((_, wid)::_) => wid - off
			      | _ => width - (!curIndent + off)
(* maybe this can be
			      | _ => width - off
??? *)
			    (* end case *))
		      (* end case *))
(***** CAML version does the following: ****
		val _ = if (insPt > maxIndent)
			then forceLineBreak strm
			else ()
*****)
		val ty' = (case ty
		       of VBOX => VBOX
			| _ => if (sz > spaceLeft') then ty else FITS
		      (* end case *))
		in
		  fmtStk := (ty', offset) :: !fmtStk
		end
	    | END => let
		val PP{fmtStk, ...} = strm
		in
		  case !fmtStk
		   of (_ :: (l as _::_)) => fmtStk := l
		    | _ => () (* error: no open blocks *)
		end
	    | (PUSH_STYLE sty) => let
		val PP{dev, ...} = strm
		in
		  D.pushStyle (dev, sty)
		end
	    | POP_STYLE => let
		val PP{dev, ...} = strm
		in
		  D.popStyle dev
		end