pp-stream-fn.sml

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

	    | NL => let
		val PP{fmtStk, ...} = strm
		in
		  case !fmtStk
		   of ((_, wid)::r) => breakNewLine (strm, 0, wid)
		    | _ => outputNL strm
		  (* end case *)
		end
	    | IF_NL => raise Fail "IF_NL"
	    | (CTL ctlFn) => let
		val PP{dev, ...} = strm
		in
		  ctlFn dev
		end
	  (* end case *))

    fun advanceLeft strm = let
	  val PP{spaceLeft, leftTot, rightTot, queue, ...} = strm
	  fun advance () = (case Q.peek queue
		 of (SOME{tok, sz=ref sz, len}) =>
		      if ((sz >= 0) orelse (!rightTot - !leftTot >= !spaceLeft))
			then (
			  ignore(Q.dequeue queue);
			  format (strm, if sz < 0 then infinity else sz, tok);
			  leftTot := len + !leftTot;
			  advance())
			else ()
		  | NONE => ()
		(* end case *))
	  in
	    advance ()
	  end

    fun enqueueAndAdvance (strm, tok) = (
	  enqueueTok (strm, tok);
	  advanceLeft strm)

    fun enqueueTokenWithLen (strm, tok, len) =
	  enqueueAndAdvance (strm, {sz = ref len, len = len, tok = tok})

    fun enqueueStringWithLen (strm, s, len) =
	  enqueueTokenWithLen (strm, TEXT s, len)

    fun enqueueToken (strm, tok) = enqueueTokenWithLen (strm, tok, 0)

  (* the scan stack always has this element on its bottom *)
    val scanStkBot = (~1, {sz = ref ~1, tok = TEXT "", len = 0})

  (* clear the scan stack *)
    fun clearScanStk (PP{scanStk, ...}) = scanStk := [scanStkBot]

  (* Set the size of the element on the top of the scan stack.  The isBreak
   * flag is set to true for breaks and false for boxes.
   *)
    fun setSize (strm, isBreak) = let
	(* NOTE: scanStk should never be empty *)
	  val PP{leftTot, rightTot, scanStk as ref((leftTot', elem)::r), ...} = strm
	  in
	  (* check for obsolete elements *)
	    if (leftTot' < !leftTot)
	      then clearScanStk strm
	      else (case (elem, isBreak)
		 of ({sz, tok=BREAK _, ...}, true) => (
		      sz := !sz + !rightTot;
		      scanStk := r)
		  | ({sz, tok=BEGIN _, ...}, false) => (
		      sz := !sz + !rightTot;
		      scanStk := r)
		  | _ => ()
		(* end case *))
	  end

    fun pushScanElem (strm as PP{scanStk, rightTot, ...}, setSz, tok) = (
	  enqueueTok (strm, tok);
	  if setSz then setSize (strm, true) else ();
	  scanStk := (!rightTot, tok) :: !scanStk)

  (* Open a new box *)
    fun ppOpenBox (strm, indent, brType) = let
	  val PP{rightTot, curDepth, ...} = strm
	  in
	    curDepth := !curDepth + 1;
(**** CAML code
	    (* check that !curDepth < maxDepth *)
****)
	    pushScanElem (strm, false, {
		sz = ref(~(!rightTot)),
		tok = BEGIN(indent, brType),
		len = 0
	      })
	  end

  (* the root box, which is always open *)
    fun openSysBox (strm as PP{rightTot, curDepth, ...}) = (
	  curDepth := !curDepth + 1;
	  pushScanElem (strm, false, {
	      sz = ref(~(!rightTot)), tok = BEGIN(Rel 0, HOVBOX), len = 0
	    }))

  (* close a box *)
    fun ppCloseBox (strm as PP{curDepth as ref depth, ...}) =
	  if (depth > 1)
	    then (
(**** CAML code
	    (* check that depth < maxDepth *)
****)
	      enqueueTok (strm, {sz = ref 0, tok = END, len = 0});
	      setSize (strm, true);
	      setSize (strm, false);
	      curDepth := depth-1)
	    else raise Fail "unmatched close box"

    fun ppBreak (strm as PP{rightTot, ...}, arg) = (
(**** CAML code
****)
	  pushScanElem (strm, true, {
	      sz = ref(~(!rightTot)), tok = BREAK arg, len = #nsp arg
	    }))

    fun ppInit (strm as PP pp) = (
	  #leftTot pp := 1;
	  #rightTot pp := 1;
	  Q.clear(#queue pp);
	  clearScanStk strm;
	  #curIndent pp := 0;
	  #curDepth pp := 0;
	  #spaceLeft pp := #width pp;
	  #fmtStk pp := [];
	  #styleStk pp := [];
	  openSysBox strm)

    fun ppNewline strm =
	  enqueueAndAdvance (strm, {sz = ref 0, tok = NL, len = 0})

    fun ppFlush (strm as PP{dev, curDepth, rightTot, ...}, withNL) = let
	  fun closeBoxes () = if (!curDepth > 1)
		then (ppCloseBox strm; closeBoxes())
		else ()
	  in
	    closeBoxes ();
	    rightTot := infinity;
	    advanceLeft strm;
	    if withNL then outputNL strm else ();
	    D.flush dev;
	    ppInit strm
	  end

  (**** USER FUNCTIONS ****)
    fun openStream d = let
	  val strm = PP{
		  dev = d,
		  closed = ref false,
		  width = Option.getOpt(D.lineWidth d, infinity),
		  spaceLeft = ref 0,
		  curIndent = ref 0,
		  curDepth = ref 0,
		  leftTot = ref 1,	(* why 1 ? *)
		  rightTot = ref 1,	(* why 1 ? *)
		  queue = Q.mkQueue(),
		  fmtStk = ref [],
		  scanStk = ref [],
		  styleStk = ref []
		}
	  in
	    ppInit strm;
	    strm
	  end

    fun flushStream strm = ppFlush(strm, false)
    fun closeStream (strm as PP{closed, ...}) = (flushStream strm; closed := true)

    fun openHBox strm = ppOpenBox (strm, Abs 0, HBOX)
    fun openVBox strm indent = ppOpenBox (strm, indent, VBOX)
    fun openHVBox strm indent = ppOpenBox (strm, indent, HVBOX)
    fun openHOVBox strm indent = ppOpenBox (strm, indent, HOVBOX)
    fun openBox strm indent = ppOpenBox (strm, indent, BOX)
    fun closeBox strm = ppCloseBox strm

    fun token (strm as PP{dev, ...}) t = let
	  val tokStyle = T.style t
	  in
	    if (D.sameStyle(currentStyle strm, tokStyle))
	      then enqueueStringWithLen (strm, T.string t, T.size t)
	      else (
		enqueueToken (strm, PUSH_STYLE tokStyle);
		enqueueStringWithLen (strm, T.string t, T.size t);
		enqueueToken (strm, POP_STYLE))
	  end
    fun string strm s = enqueueStringWithLen(strm, s, size s)

    fun pushStyle (strm as PP{styleStk, ...}, sty) = (
	  if (D.sameStyle(currentStyle strm, sty))
	    then ()
	    else enqueueToken (strm, PUSH_STYLE sty);
	  styleStk := sty :: !styleStk)
    fun popStyle (strm as PP{styleStk, ...}) = (case !styleStk
	   of [] => raise Fail "PP: unmatched popStyle"
	    | (sty::r) => (
		styleStk := r;
		if (D.sameStyle(currentStyle strm, sty))
		  then ()
		  else enqueueToken (strm, POP_STYLE))
	  (* end case *))

    fun break strm arg = ppBreak (strm, arg)
    fun space strm n = break strm {nsp=n, offset=0}
    fun cut strm = break strm {nsp=0, offset=0}
    fun newline strm = ppNewline strm
    fun nbSpace strm n = enqueueTokenWithLen (strm, NBSP n, n)

    fun onNewline  strm () = raise Fail "onNewline"

    fun control strm ctlFn = enqueueToken (strm, CTL ctlFn)

  (* pretty print a description *)
    type pp_desc = (token, style, device) PPD.pp_desc

    fun description strm = let
	  fun pp (PPD.HBox l) = (openHBox strm; ppList l; closeBox strm)
	    | pp (PPD.VBox(i, l)) = (openVBox strm i; ppList l; closeBox strm)
	    | pp (PPD.HVBox(i, l)) = (openHVBox strm i; ppList l; closeBox strm)
	    | pp (PPD.HOVBox(i, l)) = (openHOVBox strm i; ppList l; closeBox strm)
	    | pp (PPD.Box(i, l)) = (openBox strm i; ppList l; closeBox strm)
	    | pp (PPD.Token tok) = token strm tok
	    | pp (PPD.String s) = string strm s
	    | pp (PPD.Style(sty, l)) = (
		pushStyle(strm, sty); ppList l; popStyle strm)
	    | pp (PPD.Break brk) = break strm brk
	    | pp PPD.NewLine = newline strm
	    | pp (PPD.NBSpace n) = nbSpace strm n
	    | pp (PPD.Control ctlFn) = control strm ctlFn
	  and ppList [] = ()
	    | ppList (item::r) = (pp item; ppList r)
	  in
	    pp
	  end

  (* PP description constructors *)
    structure Desc =
      struct
	val hBox    = PPD.HBox
	val vBox    = PPD.VBox
	val hvBox   = PPD.HVBox
	val hovBox  = PPD.HOVBox
	val box     = PPD.Box
	val token   = PPD.Token
	val string  = PPD.String
	val style   = PPD.Style
	val break   = PPD.Break
	fun space n = PPD.Break{nsp = n, offset = 0}
	val cut     = PPD.Break{nsp = 0, offset = 0}
	val newline = PPD.NewLine
	val control = PPD.Control
      end

  end