|
From: Vesa K. <ve...@ml...> - 2007-01-12 04:34:39
|
Initial commit of a lib of misc utils to be refactored. ---------------------------------------------------------------------- A mltonlib/trunk/com/ssh/misc-util/unstable/show.sml ---------------------------------------------------------------------- Added: mltonlib/trunk/com/ssh/misc-util/unstable/show.sml =================================================================== --- mltonlib/trunk/com/ssh/misc-util/unstable/show.sml 2007-01-12 12:33:38 UTC (rev 5050) +++ mltonlib/trunk/com/ssh/misc-util/unstable/show.sml 2007-01-12 12:34:02 UTC (rev 5051) @@ -0,0 +1,219 @@ +(* Copyright (C) 2007 SSH Communications Security, Helsinki, Finland + * + * This code is released under the MLton license, a BSD-style license. + * See the LICENSE file or http://mlton.org/License for details. + *) + +(* + * An implementation of a type-indexed function for pretty printing values + * of arbitrary SML datatypes. See + * + * http://mlton.org/TypeIndexedValues + * + * for further discussion. + *) + +(* XXX show sharing *) +(* XXX pretty printing could use some tuning *) +(* XXX parameters for pretty printing? *) +(* XXX parameters for depth, length, etc... for showing only partial data *) + +signature SHOW = sig + type 'a show_t + type 'a show_s + type ('a, 'k) show_p + + val layout : 'a show_t -> 'a -> Prettier.t + (** Extracts the prettifying function. *) + + val show : Int.t Option.t -> 'a show_t -> 'a -> String.t + (** {show m t = Prettier.pretty m o layout t} *) +end + +functor LiftShow + (include SHOW + type 'a t + type 'a s + type ('a, 'k) p + val liftT : ('a show_t, 'a t) Lift.t Thunk.t) : SHOW = struct + type 'a show_t = 'a t + type 'a show_s = 'a s + type ('a, 'k) show_p = ('a, 'k) p + val layout = fn ? => Lift.get liftT layout ? + val show = fn m => Lift.get liftT (show m) +end + +structure Show :> sig + include TYPE + include SHOW + where type 'a show_t = 'a t + where type 'a show_s = 'a s + where type ('a, 'k) show_p = ('a, 'k) p +end = struct + local + open Prettier + type u = Bool.t * t + fun atomic doc = (true, doc) + fun nonAtomic doc = (false, doc) + val uop : t UnOp.t -> u UnOp.t = id <\ Pair.map + val bop : t BinOp.t -> u BinOp.t = + fn f => nonAtomic o f o Pair.map (Sq.mk Pair.snd) + in + type u = u + + 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 comma = atomic comma + val equals = atomic equals + + val txt = atomic o txt + fun surround (n, p) = atomic o group o nest n o enclose p o Pair.snd + fun atomize (d as (a, _)) = if a then d else surround parens d + val punctuate = fn (_, s) => punctuate s o map Pair.snd + val fill = fn ? => nonAtomic (vsep ?) + val group = uop group + val nest = uop o nest + val op <^> = fn ((al, dl), (ar, dr)) => (al andalso ar, dl <^> dr) + val op <$> = bop op <$> + val op </> = bop op </> + end + + local + open TypeSupport + in + val C = C + val l2s = labelToString + val c2s = constructorToString + end + + type 'a t = exn list * 'a -> u + type 'a s = 'a t + type ('a, 'k) p = 'a t + type 'a show_t = 'a t + type 'a show_s = 'a s + type ('a, 'k) show_p = ('a, 'k) p + + fun layout t x = Pair.snd (t ([], x)) + fun show m t = Prettier.pretty m o layout t + + fun inj b a2b = b o Pair.map (id, a2b) + fun iso b = inj b o Iso.to + val isoProduct = iso + val isoSum = iso + + fun (l *` r) (env, a & b) = l (env, a) <^> comma <$> r (env, b) + + val T = id + fun R label = let + val txtLabel = txt (l2s label) + fun fmt t ? = group (nest 1 (txtLabel </> equals </> t ?)) + in + fmt + end + + fun tuple t = surround parens o t + fun record t = surround braces o t + + fun l +` r = fn (env, INL a) => l (env, a) + | (env, INR b) => r (env, b) + + fun C0 ctor = const (txt (c2s ctor)) + fun C1 ctor = let + val txtCtor = txt (c2s ctor) + in + fn t => fn ? => nest 1 (group (txtCtor <$> atomize (t ?))) + end + + val data = id + + val Y = Tie.function + + val exn : exn t ref = + ref (txt o "#" <\ op ^ o General.exnName o #2) + fun regExn t (_, prj) = + Ref.modify (fn exn => fn (env, e) => + case prj e of + NONE => exn (env, e) + | SOME x => t (env, x)) exn + val exn = fn ? => !exn ? + + val txtAs = txt "as" + fun cyclic t = let + exception E of ''a * bool ref + in + fn (env, v : ''a) => let + val idx = Int.toString o length + fun lp (E (v', c)::env) = + if v' <> v then + lp env + else + (c := false ; txt ("#"^idx env)) + | lp (_::env) = lp env + | lp [] = let + val c = ref true + val r = t (E (v, c)::env, v) + in + if !c then + r + else + txt ("#"^idx env) </> txtAs </> r + end + in + lp env + end + end + fun aggregate style toL t (env, a) = + surround style o fill o punctuate comma o map (curry t env) |< toL a + + val ctorRef = C "ref" + fun refc ? = cyclic o flip inj ! |< C1 ctorRef ? + fun array ? = cyclic |< aggregate hashParens Array.toList ? + + fun vector ? = aggregate hashBrackets Vector.toList ? + + fun list ? = aggregate brackets id ? + + val txtFn = txt "#fn" + fun _ --> _ = const txtFn + + local + open Prettier + val toLit = txt o String.toString + val nlbs = txt "\\n\\" + in + fun string (_, s) = + (true, + group o dquotes |< choice + {wide = toLit s, + narrow = lazy (fn () => + List.foldl1 (fn (x, s) => + s <^> nlbs <$> backslash <^> x) + (map toLit + (String.fields + (#"\n" <\ op =) s)))}) + end + + fun mk toS : 'a t = txt o toS o Pair.snd + fun enc l r toS x = concat [l, toS x, r] + fun mkWord toString = mk ("0wx" <\ op ^ o toString) + + val bool = mk Bool.toString + val char = mk (enc "#\"" "\"" Char.toString) + val int = mk Int.toString + val real = mk Real.toString + val unit = mk (Thunk.mk "()") + val word = mkWord Word.toString + + val largeInt = mk LargeInt.toString + val largeReal = mk LargeReal.toString + val largeWord = mkWord LargeWord.toString + + val word8 = mkWord Word8.toString + val word16 = mkWord Word16.toString + val word32 = mkWord Word32.toString + val word64 = mkWord Word64.toString +end Property changes on: mltonlib/trunk/com/ssh/misc-util/unstable/show.sml ___________________________________________________________________ Name: svn:eol-style + native |