[MLton-commit] r6076
Vesa Karvonen
vesak at mlton.org
Sun Oct 21 05:45:14 PDT 2007
Added an example transcript to the documentation. Sealed the
implementation of Pretty opaquely. Simplified the contString option (from
three alternatives to two), because one of the alternatives (ALWAYS_AT_NL)
wouldn't behave nicely.
----------------------------------------------------------------------
U mltonlib/trunk/com/ssh/generic/unstable/detail/value/pretty.sml
U mltonlib/trunk/com/ssh/generic/unstable/public/value/pretty.sig
----------------------------------------------------------------------
Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/value/pretty.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/value/pretty.sml 2007-10-19 22:17:22 UTC (rev 6075)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/value/pretty.sml 2007-10-21 12:32:07 UTC (rev 6076)
@@ -4,17 +4,10 @@
* See the LICENSE file or http://mlton.org/License for details.
*)
-(* XXX indentation formatting option(s) *)
-
-datatype cont_string =
- ALWAYS_AT_NL
- | AT_NL_TO_FIT
- | NEVER_CONT
-
functor MkOpts (type 'a t) = struct
type t =
{conNest : Int.t Option.t t,
- contString : cont_string t,
+ contString : Bool.t t,
fieldNest : Int.t Option.t t,
intRadix : StringCvt.radix t,
maxDepth : Int.t Option.t t,
@@ -40,393 +33,401 @@
wordRadix = f (#wordRadix r)}
end
-functor WithPretty (Arg : WITH_PRETTY_DOM) : PRETTY_CASES = struct
- (* <-- SML/NJ workaround *)
- open TopLevel
- infix 7 *`
- infix 6 +`
- infixr 6 <^> <+>
- infixr 5 <$> <$$> </> <//>
- infix 4 <\ \>
- infixr 4 </ />
- infix 2 >|
- infixr 2 |<
- infix 1 >>=
- infix 0 &
- infixr 0 -->
- (* SML/NJ workaround --> *)
+functor WithPretty (Arg : WITH_PRETTY_DOM) = let
+ structure Result = struct
+ (* <-- SML/NJ workaround *)
+ open TopLevel
+ infix 7 *`
+ infix 6 +`
+ infixr 6 <^> <+>
+ infixr 5 <$> <$$> </> <//>
+ infix 4 <\ \>
+ infixr 4 </ />
+ infix 2 >|
+ infixr 2 |<
+ infix 1 >>=
+ infix 0 &
+ infixr 0 -->
+ (* SML/NJ workaround --> *)
- structure Fixity = struct
- datatype t = ATOMIC | NONFIX | INFIXL of Int.t | INFIXR of Int.t
- end
+ structure Fixity = struct
+ datatype t = ATOMIC | NONFIX | INFIXL of Int.t | INFIXR of Int.t
+ end
- open Fixity
+ open Fixity
- fun mark f doc = (f, doc)
+ fun mark f doc = (f, doc)
- open Prettier
+ open Prettier
- val parens = (1, (lparen, rparen))
- val hashParens = (2, (txt "#(", rparen))
- val braces = (1, (lbrace, rbrace))
- val brackets = (1, (lbracket, rbracket))
- val hashBrackets = (2, (txt "#[", rbracket))
+ val parens = (1, (lparen, rparen))
+ val hashParens = (2, (txt "#(", rparen))
+ val braces = (1, (lbrace, rbrace))
+ val brackets = (1, (lbracket, rbracket))
+ val hashBrackets = (2, (txt "#[", rbracket))
- fun surround (n, p) = nest n o enclose p
- fun atomize (a, d) = if ATOMIC = a then d else surround parens d
+ fun surround (n, p) = nest n o enclose p
+ fun atomize (a, d) = if ATOMIC = a then d else surround parens d
- structure Fmt = struct
- datatype cont_string = datatype cont_string
+ structure Fmt = struct
+ structure Opts = MkOpts (type 'a t = 'a)
- structure Opts = MkOpts (type 'a t = 'a)
+ datatype t = T of Opts.t
- datatype t = T of Opts.t
+ val default =
+ T {conNest = SOME 1,
+ contString = true,
+ fieldNest = SOME 1,
+ intRadix = StringCvt.DEC,
+ maxDepth = NONE,
+ maxLength = NONE,
+ maxString = NONE,
+ realFmt = StringCvt.GEN NONE,
+ wordRadix = StringCvt.HEX}
- val default =
- T {conNest = SOME 1,
- contString = AT_NL_TO_FIT,
- fieldNest = SOME 1,
- intRadix = StringCvt.DEC,
- maxDepth = NONE,
- maxLength = NONE,
- maxString = NONE,
- realFmt = StringCvt.GEN NONE,
- wordRadix = StringCvt.HEX}
+ structure RefOpts = MkOpts (Ref)
- structure RefOpts = MkOpts (Ref)
+ datatype 'a opt =
+ O of {get : Opts.t -> 'a,
+ set : RefOpts.t -> 'a Ref.t,
+ chk : 'a Effect.t}
- datatype 'a opt =
- O of {get : Opts.t -> 'a,
- set : RefOpts.t -> 'a Ref.t,
- chk : 'a Effect.t}
+ 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
+ | StringCvt.FIX (SOME i) => i < 0
+ | StringCvt.GEN (SOME i) => i < 1
+ | _ => false
+ 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
- | StringCvt.FIX (SOME i) => i < 0
- | StringCvt.GEN (SOME i) => i < 1
- | _ => false
- then raise Size
- else ()
+ val conNest = O {get = #conNest, set = #conNest, chk = notNegOpt}
+ val contString = O {get = #contString, set = #contString, chk = ignore}
+ val fieldNest = O {get = #fieldNest, set = #fieldNest, chk = notNegOpt}
+ val intRadix = O {get = #intRadix, set = #intRadix, chk = ignore}
+ 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}
+ val realFmt = O {get = #realFmt, set = #realFmt, chk = chkRealFmt}
+ val wordRadix = O {get = #wordRadix, set = #wordRadix, chk = ignore}
- val conNest = O {get = #conNest, set = #conNest, chk = notNegOpt}
- val contString = O {get = #contString, set = #contString, chk = ignore}
- val fieldNest = O {get = #fieldNest, set = #fieldNest, chk = notNegOpt}
- val intRadix = O {get = #intRadix, set = #intRadix, chk = ignore}
- 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}
- val realFmt = O {get = #realFmt, set = #realFmt, chk = chkRealFmt}
- val wordRadix = O {get = #wordRadix, set = #wordRadix, chk = ignore}
+ 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 = !)
- 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 = !)
+ fun op & (T opts, (O {set, chk, ...}, v)) =
+ (chk v
+ ; case I.map opts
+ of refOpts => (set refOpts := v ; T (P.map refOpts)))
- fun op & (T opts, (O {set, chk, ...}, v)) =
- (chk v
- ; case I.map opts
- of refOpts => (set refOpts := v ; T (P.map refOpts)))
+ fun op := x = x
- fun op := x = x
+ fun ! (O {get, ...}) (T opts) = get opts
+ end
- fun ! (O {get, ...}) (T opts) = get opts
- end
+ type c = {map : (HashUniv.t, Prettier.t Option.t) HashMap.t,
+ cnt : Int.t Ref.t,
+ fmt : Fmt.t}
+ type v = {maxDepth : OptInt.t}
+ datatype e = E of c * v
+ type 'a t = e * 'a -> Fixity.t * Prettier.t
+ type 'a p = e * 'a -> Prettier.t
- type c = {map : (HashUniv.t, Prettier.t Option.t) HashMap.t,
- cnt : Int.t Ref.t,
- fmt : Fmt.t}
- type v = {maxDepth : OptInt.t}
- datatype e = E of c * v
- 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)
- fun inj b a2b = b o Pair.map (id, a2b)
+ val txt0b = txt "0b"
+ val txt0o = txt "0o"
+ val txt0w = txt "0w"
+ val txt0wb = txt "0wb"
+ val txt0wo = txt "0wo"
+ val txt0wx = txt "0wx"
+ val txt0x = txt "0x"
+ val txtDots = txt "..."
+ val txtFalse = txt "false"
+ val txtFn = txt "#fn"
+ val txtHash = txt "#"
+ val txtHashDQuote = txt "#\""
+ val txtNlBs = txt "\\n\\"
+ val txtBsDots = txt "\\..."
+ val txtTrue = txt "true"
+ val txtUnit = txt "()"
- val txt0b = txt "0b"
- val txt0o = txt "0o"
- val txt0w = txt "0w"
- val txt0wb = txt "0wb"
- val txt0wo = txt "0wo"
- val txt0wx = txt "0wx"
- val txt0x = txt "0x"
- val txtDots = txt "..."
- val txtFalse = txt "false"
- val txtFn = txt "#fn"
- val txtHash = txt "#"
- val txtHashDQuote = txt "#\""
- val txtNlBs = txt "\\n\\"
- val txtBsDots = txt "\\..."
- val txtTrue = txt "true"
- val txtUnit = txt "()"
+ val ctorRef = Generics.C "ref"
- val ctorRef = Generics.C "ref"
+ fun cyclic aT aP =
+ case HashUniv.new {eq = op =, hash = Arg.hash aT}
+ of (to, _) =>
+ fn (e as E ({map, cnt, ...}, _), v) =>
+ case to v
+ of vD =>
+ case HashMap.find map vD
+ of SOME (SOME u) => (ATOMIC, u)
+ | SOME NONE => let
+ val u = txtHash <^>
+ txt (Int.toString (cnt := !cnt + 1 ; !cnt))
+ in
+ HashMap.insert map (vD, SOME u)
+ ; (ATOMIC, u)
+ end
+ | NONE =>
+ (HashMap.insert map (vD, NONE)
+ ; case aP (e, v)
+ of (f, d) =>
+ (f,
+ lazy (fn () =>
+ case HashMap.find map vD
+ of SOME (SOME u) => u <^> equals
+ | _ => empty) <^> d))
- fun cyclic aT aP =
- case HashUniv.new {eq = op =, hash = Arg.hash aT}
- of (to, _) =>
- fn (e as E ({map, cnt, ...}, _), v) =>
- case to v
- of vD =>
- case HashMap.find map vD
- of SOME (SOME u) => (ATOMIC, u)
- | SOME NONE => let
- val u = txtHash <^>
- txt (Int.toString (cnt := !cnt + 1 ; !cnt))
- in
- HashMap.insert map (vD, SOME u)
- ; (ATOMIC, u)
- end
- | NONE =>
- (HashMap.insert map (vD, NONE)
- ; case aP (e, v)
- of (f, d) =>
- (f,
- lazy (fn () => case HashMap.find map vD
- of SOME (SOME u) => u <^> equals
- | _ => empty) <^> d))
+ fun sequ style toSlice getItem aP
+ (e as E ({fmt = Fmt.T r, ...}, _), a) = let
+ fun lp (n, d, s) =
+ case getItem s
+ of NONE => surround style d
+ | SOME (a, s) => let
+ val d = d <^> comma
+ in
+ if SOME 0 = n
+ then surround style (d <$> txtDots)
+ else lp (OptInt.- (n, SOME 1), d <$> group (aP (e, a)), s)
+ end
+ open Fmt
+ in
+ (ATOMIC,
+ if SOME 0 = #maxLength r
+ then surround style txtDots
+ else case getItem (toSlice a)
+ of NONE => op <^> (#2 style)
+ | SOME (a, s) =>
+ lp (OptInt.- (#maxLength r, SOME 1), group (aP (e, a)), s))
+ end
- fun sequ style toSlice getItem aP (e as E ({fmt = Fmt.T r, ...}, _), a) = let
- fun lp (n, d, s) =
- case getItem s
- of NONE => surround style d
- | SOME (a, s) => let
- val d = d <^> comma
- in
- if SOME 0 = n
- then surround style (d <$> txtDots)
- else lp (OptInt.- (n, SOME 1), d <$> group (aP (e, a)), s)
- end
- open Fmt
- in
- (ATOMIC,
- if SOME 0 = #maxLength r
- then surround style txtDots
- else case getItem (toSlice a)
- of NONE => op <^> (#2 style)
- | SOME (a, s) =>
- lp (OptInt.- (#maxLength r, SOME 1), group (aP (e, a)), s))
- end
+ val intPrefix =
+ fn StringCvt.BIN => txt0b (* XXX HaMLet-S *)
+ | StringCvt.OCT => txt0o (* XXX non-standard *)
+ | StringCvt.DEC => empty
+ | StringCvt.HEX => txt0x
- val intPrefix =
- fn StringCvt.BIN => txt0b (* XXX HaMLet-S *)
- | StringCvt.OCT => txt0o (* XXX non-standard *)
- | StringCvt.DEC => empty
- | StringCvt.HEX => txt0x
+ fun mkInt fmt (E ({fmt = Fmt.T {intRadix, ...}, ...}, _), i) =
+ (ATOMIC, intPrefix intRadix <^> txt (fmt intRadix i))
- fun mkInt fmt (E ({fmt = Fmt.T {intRadix, ...}, ...}, _), i) =
- (ATOMIC, intPrefix intRadix <^> txt (fmt intRadix i))
+ val wordPrefix =
+ fn StringCvt.BIN => txt0wb (* XXX HaMLet-S *)
+ | StringCvt.OCT => txt0wo (* XXX non-standard *)
+ | StringCvt.DEC => txt0w
+ | StringCvt.HEX => txt0wx
- val wordPrefix =
- fn StringCvt.BIN => txt0wb (* XXX HaMLet-S *)
- | StringCvt.OCT => txt0wo (* XXX non-standard *)
- | StringCvt.DEC => txt0w
- | StringCvt.HEX => txt0wx
+ fun mkWord fmt (E ({fmt = Fmt.T {wordRadix, ...}, ...}, _), w) =
+ (ATOMIC, wordPrefix wordRadix <^> txt (fmt wordRadix w))
- fun mkWord fmt (E ({fmt = Fmt.T {wordRadix, ...}, ...}, _), w) =
- (ATOMIC, wordPrefix wordRadix <^> txt (fmt wordRadix w))
+ fun mkReal fmt (E ({fmt = Fmt.T {realFmt, ...}, ...}, _), r) =
+ (ATOMIC, txt (fmt realFmt r))
- fun mkReal fmt (E ({fmt = Fmt.T {realFmt, ...}, ...}, _), r) =
- (ATOMIC, txt (fmt realFmt r))
+ fun depth aP (E (c, {maxDepth}), v) =
+ if SOME 0 = maxDepth
+ then (ATOMIC, txtDots)
+ else aP (E (c, {maxDepth = OptInt.- (maxDepth, SOME 1)}), v)
- fun depth aP (E (c, {maxDepth}), v) =
- if SOME 0 = maxDepth
- then (ATOMIC, txtDots)
- else aP (E (c, {maxDepth = OptInt.- (maxDepth, SOME 1)}), v)
+ fun nested (m, lhs, frhs, s)
+ (ex as (E ({fmt = Fmt.T r, ...}, _), _)) = let
+ val rhs = frhs ex
+ fun next n = nest n (lhs <$> rhs)
+ fun same () = nest m (lhs <+> rhs)
+ in
+ group (case s r
+ of SOME n => if m <= n then same () else next n
+ | NONE => same ())
+ end
- fun nested (m, lhs, frhs, s) (ex as (E ({fmt = Fmt.T r, ...}, _), _)) = let
- val rhs = frhs ex
- fun next n = nest n (lhs <$> rhs)
- fun same () = nest m (lhs <+> rhs)
- in
- group (case s r
- of SOME n => if m <= n then same () else next n
- | NONE => same ())
- end
+ val exnHandler : Exn.t t Ref.t =
+ ref (mark ATOMIC o txtHash <\ op <^> o txt o General.exnName o #2)
+ fun regExn aP e2a =
+ Ref.modify (fn exnHandler => fn (env, e) =>
+ case e2a e
+ of NONE => exnHandler (env, e)
+ | SOME a => aP (env, a))
+ exnHandler
- val exnHandler : Exn.t t Ref.t =
- ref (mark ATOMIC o txtHash <\ op <^> o txt o General.exnName o #2)
- fun regExn aP e2a =
- Ref.modify (fn exnHandler => fn (env, e) =>
- case e2a e
- of NONE => exnHandler (env, e)
- | SOME a => aP (env, a))
- exnHandler
+ fun iso' bP = inj bP o Iso.to
- fun iso' bP = inj bP o Iso.to
+ structure PrettyRep = LayerRep
+ (open Arg
+ structure Rep = struct
+ type 'a t = 'a t and 'a s = 'a t and ('a, 'k) p = 'a p
+ end)
- structure PrettyRep = LayerRep
- (open Arg
- structure Rep = struct
- type 'a t = 'a t and 'a s = 'a t and ('a, 'k) p = 'a p
- end)
+ open PrettyRep.This
- 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)
- 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 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 remDepth =
+ (Fmt.notNegOpt remDepth
+ ; fn (E (c, _)) => ((), E (c, {maxDepth = remDepth})))
- fun getRemDepth (e as E (_, {maxDepth})) = (maxDepth, e)
- fun setRemDepth remDepth =
- (Fmt.notNegOpt remDepth
- ; fn (E (c, _)) => ((), E (c, {maxDepth = remDepth})))
+ structure Fixity = Fixity
- structure Fixity = Fixity
+ type 'a t = 'a -> (Fixity.t * Prettier.t) monad
- 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
- 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
- fn c => case txt (Generics.Con.toString c) of c =>
- fn (aT, bT) => case getT aT & getT bT of aP & bP =>
- (mapS o const)
- (fn (e, (a, b)) => let
- val (aF, aS) = aP (e, a)
- val (bF, bS) = bP (e, b)
- val aS = if cmpL aF
- then surround parens aS
- else aS
- val bS = if cmpR bF
- then surround parens bS
- else bS
- in
- (con n, aS <$> c </> bS)
- end)
- in
- fun infixL n =
- mk INFIXL n
- (fn INFIXL l => l < n | INFIXR r => r <= n | _ => false)
- (fn INFIXL l => l <= n | INFIXR r => r <= n | _ => false)
- fun infixR n =
- mk INFIXR n
- (fn INFIXL l => l <= n | INFIXR r => r <= n | _ => false)
- (fn INFIXL l => l <= n | INFIXR r => r < n | _ => false)
+ local
+ fun mk con n cmpL cmpR =
+ if n < 0 orelse 9 < n then raise Domain else
+ fn c => case txt (Generics.Con.toString c) of c =>
+ fn (aT, bT) => case getT aT & getT bT of aP & bP =>
+ (mapS o const)
+ (fn (e, (a, b)) => let
+ val (aF, aS) = aP (e, a)
+ val (bF, bS) = bP (e, b)
+ val aS = if cmpL aF
+ then surround parens aS
+ else aS
+ val bS = if cmpR bF
+ then surround parens bS
+ else bS
+ in
+ (con n, aS <$> c </> bS)
+ end)
+ in
+ fun infixL n =
+ mk INFIXL n
+ (fn INFIXL l => l < n | INFIXR r => r <= n | _ => false)
+ (fn INFIXL l => l <= n | INFIXR r => r <= n | _ => false)
+ fun infixR n =
+ mk INFIXR n
+ (fn INFIXL l => l <= n | INFIXR r => r <= n | _ => false)
+ (fn INFIXL l => l <= n | INFIXR r => r < n | _ => false)
+ end
end
- end
- fun fmt t =
- case getT t
- of p => fn fmt => fn x =>
- group (#2 (p (E ({map = HashMap.new {eq = HashUniv.eq,
- hash = HashUniv.hash},
- cnt = ref ~1,
- fmt = fmt},
- {maxDepth = Fmt.! Fmt.maxDepth fmt}),
- x)))
- fun pretty t = fmt t Fmt.default
- fun show t = Prettier.render NONE o pretty t
+ fun fmt t =
+ case getT t
+ of p => fn fmt => fn x =>
+ group (#2 (p (E ({map = HashMap.new {eq = HashUniv.eq,
+ hash = HashUniv.hash},
+ cnt = ref ~1,
+ fmt = fmt},
+ {maxDepth = Fmt.! Fmt.maxDepth fmt}),
+ x)))
+ fun pretty t = fmt t Fmt.default
+ fun show t = Prettier.render NONE o pretty t
- structure Open = LayerDepCases
- (fun iso aT = iso' (getT aT)
- fun isoProduct aP = iso' (getP aP)
- fun isoSum aS = iso' (getS aS)
+ structure Open = LayerDepCases
+ (fun iso aT = iso' (getT aT)
+ fun isoProduct aP = iso' (getP aP)
+ fun isoSum aS = iso' (getS aS)
- fun aP *` bP = let
- val aP = getP aP
- val bP = getP bP
- in
- fn (e, a & b) => aP (e, a) <^> comma <$> bP (e, b)
- end
- fun T t = group o #2 o getT t
- fun R l = let
- val s = Generics.Label.toString l
- val t = txt s <+> equals
- val m = String.length s + 2
- in
- fn aT => nested (m, t, T aT, #fieldNest)
- end
- fun tuple aP = mark ATOMIC o surround parens o getP aP
- fun record aP = mark ATOMIC o surround braces o getP aP
+ fun aP *` bP = let
+ val aP = getP aP
+ val bP = getP bP
+ in
+ fn (e, a & b) => aP (e, a) <^> comma <$> bP (e, b)
+ end
+ fun T t = group o #2 o getT t
+ fun R l = let
+ val s = Generics.Label.toString l
+ val t = txt s <+> equals
+ val m = String.length s + 2
+ in
+ fn aT => nested (m, t, T aT, #fieldNest)
+ end
+ fun tuple aP = mark ATOMIC o surround parens o getP aP
+ fun record aP = mark ATOMIC o surround braces o getP aP
- fun aS +` bS = let
- val aP = getS aS
- val bP = getS bS
- in
- fn (e, INL a) => aP (e, a)
- | (e, INR b) => bP (e, b)
- end
- fun unit _ = (ATOMIC, txtUnit)
- fun C0 c = const (ATOMIC, txt (Generics.Con.toString c))
- fun C1 c = let
- val s = Generics.Con.toString c
- val t = txt s
- val m = String.length s + 1
- in
- fn aT => mark NONFIX o nested (m, t, atomize o getT aT, #conNest)
- end
- fun data aS = depth (getS aS)
+ fun aS +` bS = let
+ val aP = getS aS
+ val bP = getS bS
+ in
+ fn (e, INL a) => aP (e, a)
+ | (e, INR b) => bP (e, b)
+ end
+ fun unit _ = (ATOMIC, txtUnit)
+ fun C0 c = const (ATOMIC, txt (Generics.Con.toString c))
+ fun C1 c = let
+ val s = Generics.Con.toString c
+ val t = txt s
+ val m = String.length s + 1
+ in
+ fn aT => mark NONFIX o nested (m, t, atomize o getT aT, #conNest)
+ end
+ fun data aS = depth (getS aS)
- val Y = Tie.function
+ val Y = Tie.function
- fun exn ? = depth (!exnHandler) ?
- fun regExn0 c = case C0 c of uP => regExn uP o Pair.snd
- fun regExn1 c aT = case C1 c aT of aP => regExn aP o Pair.snd
+ fun exn ? = depth (!exnHandler) ?
+ fun regExn0 c = case C0 c of uP => regExn uP o Pair.snd
+ fun regExn1 c aT = case C1 c aT of aP => regExn aP o Pair.snd
- fun refc aT =
- cyclic (Arg.Open.refc ignore aT) o flip inj ! |< C1 ctorRef aT
- fun array aT =
- cyclic (Arg.Open.array ignore aT) |<
- sequ hashParens ArraySlice.full ArraySlice.getItem (T aT)
- fun vector aT =
- sequ hashBrackets VectorSlice.full VectorSlice.getItem (T aT)
- fun list aT = sequ brackets id List.getItem (T aT)
+ fun refc aT =
+ cyclic (Arg.Open.refc ignore aT) o flip inj ! |< C1 ctorRef aT
+ fun array aT =
+ cyclic (Arg.Open.array ignore aT) |<
+ sequ hashParens ArraySlice.full ArraySlice.getItem (T aT)
+ fun vector aT =
+ sequ hashBrackets VectorSlice.full VectorSlice.getItem (T aT)
+ fun list aT = sequ brackets id List.getItem (T aT)
- fun op --> _ = const (ATOMIC, txtFn)
+ fun op --> _ = const (ATOMIC, txtFn)
- local
- val toLit = txt o Substring.translate Char.toString
- in
- fun string (E ({fmt = Fmt.T r, ...}, _), s) = let
- val l = size s
- val n = Int.min (getOpt (#maxString r, l), l)
- val suf = if n < l then txtBsDots else empty
- val s = Substring.substring (s, 0, n)
- fun wide () = toLit s
- fun narrow () =
- List.foldl1
- (fn (x, s) => s <^> txtNlBs <$> backslash <^> x)
- (List.map toLit (Substring.fields (#"\n" <\ op =) s))
+ local
+ val toLit = txt o Substring.translate Char.toString
in
- (ATOMIC,
- dquotes ((case #contString r
- of ALWAYS_AT_NL => narrow ()
- | AT_NL_TO_FIT =>
- choice {wide = wide (), narrow = lazy narrow}
- | NEVER_CONT => wide ())
- <^> suf))
+ fun string (E ({fmt = Fmt.T r, ...}, _), s) = let
+ val l = size s
+ val n = Int.min (getOpt (#maxString r, l), l)
+ val suf = if n < l then txtBsDots else empty
+ val s = Substring.substring (s, 0, n)
+ fun wide () = toLit s
+ fun narrow () =
+ List.foldl1
+ (fn (x, s) => s <^> txtNlBs <$> backslash <^> x)
+ (List.map toLit (Substring.fields (#"\n" <\ op =) s))
+ in
+ (ATOMIC,
+ dquotes ((if #contString r
+ then choice {wide = wide (), narrow = lazy narrow}
+ else wide ())
+ <^> suf))
+ end
end
- end
- fun bool (_, b) = (ATOMIC, if b then txtTrue else txtFalse)
- fun char (_, x) =
- (ATOMIC, txtHashDQuote <^> txt (Char.toString x) <^> dquote)
- val int = mkInt Int.fmt
- val real = mkReal Real.fmt
- val word = mkWord Word.fmt
+ fun bool (_, b) = (ATOMIC, if b then txtTrue else txtFalse)
+ fun char (_, x) =
+ (ATOMIC, txtHashDQuote <^> txt (Char.toString x) <^> dquote)
+ val int = mkInt Int.fmt
+ val real = mkReal Real.fmt
+ val word = mkWord Word.fmt
- val fixedInt = mkInt FixedInt.fmt
- val largeInt = mkInt LargeInt.fmt
+ val fixedInt = mkInt FixedInt.fmt
+ val largeInt = mkInt LargeInt.fmt
- val largeReal = mkReal LargeReal.fmt
- val largeWord = mkWord LargeWord.fmt
+ val largeReal = mkReal LargeReal.fmt
+ val largeWord = mkWord LargeWord.fmt
- val word8 = mkWord Word8.fmt
- val word32 = mkWord Word32.fmt
- val word64 = mkWord Word64.fmt
+ val word8 = mkWord Word8.fmt
+ val word32 = mkWord Word32.fmt
+ val word64 = mkWord Word64.fmt
- open Arg PrettyRep)
+ open Arg PrettyRep)
+ end
+in
+ Result :> PRETTY_CASES
+ where type ('a, 'x) Open.Rep.t = ('a, 'x) Result.Open.Rep.t
+ where type ('a, 'x) Open.Rep.s = ('a, 'x) Result.Open.Rep.s
+ where type ('a, 'k, 'x) Open.Rep.p = ('a, 'k, 'x) Result.Open.Rep.p
end
Modified: mltonlib/trunk/com/ssh/generic/unstable/public/value/pretty.sig
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/public/value/pretty.sig 2007-10-19 22:17:22 UTC (rev 6075)
+++ mltonlib/trunk/com/ssh/generic/unstable/public/value/pretty.sig 2007-10-21 12:32:07 UTC (rev 6076)
@@ -8,6 +8,30 @@
* Signature for a generic function for pretty-printing values of
* arbitrary Standard ML types.
*
+ * Example:
+ *
+ *> - val t = iso (record (R' "id" int *` R' "text" string))
+ *> = (fn {id=a, text=b} => a & b,
+ *> = fn a & b => {id=a, text=b}) ;
+ *> val t = - : {id : Int.t, text : String.t} Rep.t
+ *> - val v = {id = 0xF00BAA, text = "Text that spans\nmultiple lines."} ;
+ *> val v = {id = 15731626, text = "Text that spans\nmultiple lines."}
+ *> : {id : Int.t, text : String.t}
+ *> - println |< show t v ;
+ *> {id = 15731626, text = "Text that spans\nmultiple lines."}
+ *> - val opts = let
+ *> = open Fmt
+ *> = in
+ *> = default & intRadix := StringCvt.HEX
+ *> = & fieldNest := SOME 4
+ *> = end ;
+ *> val fmtOpts = - : Fmt.t
+ *> - println o Prettier.render (SOME 20) |< fmt t opts v ;
+ *> {id = 0xF00BAA,
+ *> text =
+ *> "Text that spans\n\
+ *> \multiple lines."}
+ *
* Features:
* - The result is a document that can be rendered to a desired width
* (number of columns).
@@ -19,6 +43,9 @@
* "..." otherwise.
* - The default formatting of integers, words, and reals can be
* specified.
+ * - Can use line continuations in strings.
+ * - The nesting (or indentation) of record fields and datatype
+ * constructor can be specified.
* - The radix of integers and words is shown in the output with a "b"
* (binary ; HaMLet-S), "o" (octal ; non-standard), or "x" prefix.
* - Sharing of mutable objects is shown in the output. Each shared
@@ -133,16 +160,11 @@
(** === String Formatting Options === *)
- datatype cont_string =
- ALWAYS_AT_NL
- | AT_NL_TO_FIT
- | NEVER_CONT
-
- val contString : cont_string opt
+ val contString : Bool.t opt
(**
- * How to use line continuations.
+ * Whether to use line continuations in strings or not.
*
- * default: {AT_NL_TO_FIT}
+ * default: {true}
*)
(** === Datatype Formatting Options == *)
More information about the MLton-commit
mailing list