[MLton-commit] r5051
Vesa Karvonen
vesak at mlton.org
Fri Jan 12 04:34:33 PST 2007
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
More information about the MLton-commit
mailing list