[MLton-commit] r6034
Vesa Karvonen
vesak at mlton.org
Wed Sep 19 05:56:09 PDT 2007
Added a monadic combinator interface to the Pretty generic allowing pretty
printing to be customized.
----------------------------------------------------------------------
U mltonlib/trunk/com/ssh/generic/unstable/detail/value/pretty.sml
U mltonlib/trunk/com/ssh/generic/unstable/public/value/pretty.sig
U mltonlib/trunk/com/ssh/generic/unstable/test/pretty.sml
----------------------------------------------------------------------
Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/value/pretty.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/value/pretty.sml 2007-09-19 10:22:43 UTC (rev 6033)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/value/pretty.sml 2007-09-19 12:56:08 UTC (rev 6034)
@@ -37,12 +37,17 @@
infixr 4 </ />
infix 2 >|
infixr 2 |<
+ infix 1 >>=
infix 0 &
infixr 0 -->
(* SML/NJ workaround --> *)
- datatype f = ATOMIC | NONFIX | INFIXL of Int.t | INFIXR of Int.t
+ structure Fixity = struct
+ datatype t = ATOMIC | NONFIX | INFIXL of Int.t | INFIXR of Int.t
+ end
+ open Fixity
+
fun mark f doc = (f, doc)
open Prettier
@@ -87,7 +92,8 @@
set : RefOpts.t -> 'a Ref.t,
chk : 'a Effect.t}
- val notNeg = Option.app (fn i => if i < 0 then raise Size else ())
+ val notNeg = fn i => if i < 0 then raise Size else ()
+ val notNegOpt = Option.app notNeg
fun chkRealFmt fmt =
if case fmt
of StringCvt.SCI (SOME i) => i < 0
@@ -100,9 +106,9 @@
val intRadix = O {get = #intRadix, set = #intRadix, chk = ignore}
val wordRadix = O {get = #wordRadix, set = #wordRadix, chk = ignore}
val realFmt = O {get = #realFmt, set = #realFmt, chk = chkRealFmt}
- val maxDepth = O {get = #maxDepth, set = #maxDepth, chk = notNeg}
- val maxLength = O {get = #maxLength, set = #maxLength, chk = notNeg}
- val maxString = O {get = #maxString, set = #maxString, chk = notNeg}
+ val maxDepth = O {get = #maxDepth, set = #maxDepth, chk = notNegOpt}
+ val maxLength = O {get = #maxLength, set = #maxLength, chk = notNegOpt}
+ val maxString = O {get = #maxString, set = #maxString, chk = notNegOpt}
structure I = MapOpts (type 'a dom = 'a and 'a cod = 'a Ref.t val f = ref)
and P = MapOpts (type 'a dom = 'a Ref.t and 'a cod = 'a val f = !)
@@ -122,7 +128,7 @@
fmt : Fmt.t}
type v = {maxDepth : OptInt.t}
datatype e = E of c * v
- type 'a t = e * 'a -> f * Prettier.t
+ type 'a t = e * 'a -> Fixity.t * Prettier.t
type 'a p = e * 'a -> Prettier.t
fun inj b a2b = b o Pair.map (id, a2b)
@@ -240,6 +246,27 @@
open PrettyRep.This
structure Pretty = struct
+ type 'a monad = e -> 'a * e
+ fun return a e = (a, e)
+ fun (aM >>= a2bM) e = uncurry a2bM (aM e)
+
+ fun getFmt (e as E ({fmt, ...}, _)) = (fmt, e)
+ fun setFmt fmt (E ({cnt, map, ...}, v)) =
+ ((), E ({cnt = cnt, fmt = fmt, map = map}, v))
+
+ fun getRemDepth (e as E (_, {maxDepth})) = (maxDepth, e)
+ fun setRemDepth maxDepth (E (c, _)) = ((), E (c, {maxDepth = maxDepth}))
+
+ structure Fixity = Fixity
+
+ type 'a t = 'a -> (Fixity.t * Prettier.t) monad
+
+ fun getPrinter aT =
+ case getT aT
+ of aP => fn a => fn e => (aP (e, a), e)
+ fun setPrinter aP = mapT (const (Pair.fst o uncurry aP o Pair.swap))
+ fun mapPrinter f t = setPrinter (f (getPrinter t)) t
+
local
fun mk con n cmpL cmpR =
if n < 0 orelse 9 < n then raise Domain else
Modified: mltonlib/trunk/com/ssh/generic/unstable/public/value/pretty.sig
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/public/value/pretty.sig 2007-09-19 10:22:43 UTC (rev 6033)
+++ mltonlib/trunk/com/ssh/generic/unstable/public/value/pretty.sig 2007-09-19 12:56:08 UTC (rev 6034)
@@ -76,6 +76,55 @@
(** Substructure for additional pretty printing combinators. *)
structure Pretty : sig
+ (** == Monadic Combinator Interface ==
+ *
+ * This interface allows the pretty printer stored in a type
+ * representation to be extracted and replaced with a custom pretty
+ * printer.
+ *)
+
+ include MONAD_CORE
+
+ val getFmt : Fmt.t monad
+ (** Returns the default formatting options. *)
+
+ val setFmt : Fmt.t -> Unit.t monad
+ (**
+ * Functionally sets the default formatting options. The new
+ * default formatting options are only passed to the children of the
+ * current monadic operation. Note that changing the {maxDepth}
+ * option has no effect on any default printers.
+ *)
+
+ val getRemDepth : Int.t Option.t monad
+ (** Returns the remaining depth. *)
+
+ val setRemDepth : Int.t Option.t -> Unit.t monad
+ (**
+ * Functionally sets the remaining depth. The new depth only
+ * affects the direct subactions of the current monadic action.
+ *)
+
+ structure Fixity : sig
+ datatype t =
+ ATOMIC
+ | NONFIX
+ | INFIXL of Int.t
+ | INFIXR of Int.t
+ end
+
+ type 'a t = 'a -> (Fixity.t * Prettier.t) monad
+ (** The type of pretty printing actions. *)
+
+ val getPrinter : ('a, 'x) PrettyRep.t -> 'a t
+ (** Returns the pretty printing action stored in a type representation. *)
+
+ val setPrinter : 'a t -> ('a, 'x) PrettyRep.t UnOp.t
+ (** Functionally updates the pretty printing action in a type rep. *)
+
+ val mapPrinter : 'a t UnOp.t -> ('a, 'x) PrettyRep.t UnOp.t
+ (** {mapPrinter f t} is equivalent to {setPrinter (f (getPrinter t)) t}. *)
+
(** == Infix Constructors ==
*
* The {infixL} and {infixR} combinators update a given sum type
Modified: mltonlib/trunk/com/ssh/generic/unstable/test/pretty.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/test/pretty.sml 2007-09-19 10:22:43 UTC (rev 6033)
+++ mltonlib/trunk/com/ssh/generic/unstable/test/pretty.sml 2007-09-19 12:56:08 UTC (rev 6034)
@@ -13,6 +13,7 @@
testEq string (fn () => {expect = s, actual = render n (pretty t v)})
structure Graph = MkGraph (Generic)
+ structure BinTree = MkBinTree (Generic)
in
val () =
unitTests
@@ -126,5 +127,23 @@
\ VTX (6, #1)]"
Graph.intGraph1)
+ let
+ open BinTree Prettier Pretty Pretty.Fixity
+ fun withAngles xP x =
+ xP x >>= (fn (_, d) =>
+ return (ATOMIC, angles d))
+ in
+ tst (SOME 30)
+ (BinTree.t (mapPrinter withAngles int))
+ "BR\n\
+ \ (BR (LF, <0>, LF),\n\
+ \ <1>,\n\
+ \ BR\n\
+ \ (LF,\n\
+ \ <2>,\n\
+ \ BR (LF, <3>, LF)))"
+ (BR (BR (LF, 0, LF), 1, BR (LF, 2, BR (LF, 3, LF))))
+ end
+
$
end
More information about the MLton-commit
mailing list