[MLton-commit] r5996
Vesa Karvonen
vesak at mlton.org
Sun Sep 2 09:13:58 PDT 2007
Using HashMap environment in Pretty, which also now shows some sharing of
mutable objects.
----------------------------------------------------------------------
U mltonlib/trunk/com/ssh/generic/unstable/detail/generic.sml
U mltonlib/trunk/com/ssh/generic/unstable/detail/value/pretty.sml
U mltonlib/trunk/com/ssh/generic/unstable/public/export.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/generic.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/generic.sml 2007-09-02 13:24:46 UTC (rev 5995)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/generic.sml 2007-09-02 16:13:56 UTC (rev 5996)
@@ -21,18 +21,11 @@
(* Add generics not depending on any other generic: *)
structure Open = WithEq (Open) open Open structure Eq=Open
- structure Open = WithPretty (Open) open Open
structure Open = WithTypeHash (Open) open Open structure TypeHash=Open
structure Open = WithTypeInfo (Open) open Open structure TypeInfo=Open
structure Open = WithDataRecInfo (Open) open Open structure DataRecInfo=Open
(* Add generics depending on other generics: *)
- structure Open = struct
- open TypeInfo Open
- structure TypeInfo = Rep
- structure RandomGen = RanQD1Gen
- end
- structure Open = WithArbitrary (Open) open Open
structure Open = struct
open TypeHash TypeInfo Open
@@ -43,15 +36,28 @@
structure Open = WithOrd (Open) open Open
structure Open = struct
+ open Hash Open
+ structure Hash = Rep
+ end
+ structure Open = WithPretty (Open) open Open
+
+ structure Open = struct
+ open Hash TypeInfo Open
+ structure Hash = Rep and TypeInfo = Rep
+ structure RandomGen = RanQD1Gen
+ end
+ structure Open = WithArbitrary (Open) open Open
+
+ structure Open = struct
open TypeInfo Open
structure TypeInfo = Rep
end
structure Open = WithSome (Open) open Open structure Some=Open
structure Open = struct
- open DataRecInfo Eq Hash TypeHash TypeInfo Some
- structure DataRecInfo = Rep and Eq = Rep and Hash = Rep and TypeHash = Rep
- and TypeInfo = Rep
+ open DataRecInfo Eq Hash Some TypeHash TypeInfo Open
+ structure DataRecInfo = Rep and Eq = Rep and Hash = Rep and Some = Rep
+ and TypeHash = Rep and TypeInfo = Rep
end
structure Open = WithPickle (Open) open Open
Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/value/pretty.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/value/pretty.sml 2007-09-02 13:24:46 UTC (rev 5995)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/value/pretty.sml 2007-09-02 16:13:56 UTC (rev 5996)
@@ -4,12 +4,11 @@
* See the LICENSE file or http://mlton.org/License for details.
*)
-(* 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 *)
-functor WithPretty (Arg : OPEN_CASES) : PRETTY_CASES = struct
+functor WithPretty (Arg : WITH_PRETTY_DOM) : PRETTY_CASES = struct
(* <-- SML/NJ workaround *)
open TopLevel
infix 7 *`
@@ -27,7 +26,6 @@
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 =
@@ -35,6 +33,8 @@
in
type u = u
+ fun atomic doc = (true, doc)
+
val parens = (1, (lparen, rparen))
val hashParens = (2, (txt "#(", rparen))
val braces = (1, (lbrace, rbrace))
@@ -56,106 +56,120 @@
val op </> = bop op </>
end
- local
- open Generics
- in
- val C = C
- val l2s = Label.toString
- val c2s = Con.toString
- end
+ type e = (HashUniv.t, Prettier.t Option.t) HashMap.t * Int.t Ref.t
+ type 'a t = e * 'a -> u
fun inj b a2b = b o Pair.map (id, a2b)
- val txtAs = txt "as"
val txtFn = txt "#fn"
- val ctorRef = C "ref"
+ val ctorRef = Generics.C "ref"
- fun cyclic t =
- case Univ.Emb.new ()
- of (to, from) =>
- fn (e, v : ''a) => let
- val idx = Int.toString o length
- fun lp [] = let
- val c = ref true
- val r = t (to (v, c)::e, v)
- in
- if !c then r else txt ("#"^idx e) </> txtAs </> r
- end
- | lp (u::e) =
- case from u
- of NONE => lp e
- | SOME (x, c) =>
- if x <> v then lp e else (c := false ; txt ("#"^idx e))
- in
- lp e
- end
+ fun cyclic aT aP =
+ case HashUniv.new {eq = op =, hash = Arg.hash aT}
+ of (to, _) =>
+ fn ((e, c), v) =>
+ case to v
+ of vD =>
+ case HashMap.find e vD
+ of SOME (SOME u) => atomic u
+ | SOME NONE => let
+ val u = Prettier.txt ("#"^Int.toString (c := !c + 1 ; !c))
+ in
+ HashMap.insert e (vD, SOME u)
+ ; atomic u
+ end
+ | NONE =>
+ (HashMap.insert e (vD, NONE)
+ ; (true,
+ let open Prettier in
+ lazy (fn () => case HashMap.find e vD
+ of SOME (SOME u) => u <^> equals
+ | _ => empty)
+ end) <^>
+ aP ((e, c), v))
fun sequ style toL t (e, a) =
surround style o fill o punctuate comma o List.map (curry t e) |< toL a
- type 'a t = Univ.t List.t * 'a -> u
-
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 exnHandler : Exn.t t Ref.t =
ref (txt o "#" <\ op ^ 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' getX bX = inj (getX bX) o Iso.to
+
structure Pretty = LayerRep
(structure Outer = Arg.Rep
structure Closed = MkClosedRep (type 'a t = 'a t))
open Pretty.This
- fun layout t = Pair.snd o [] <\ getT t
+ fun layout t =
+ case getT t
+ of p => fn x => #2 (p ((HashMap.new {eq = HashUniv.eq,
+ hash = HashUniv.hash}, ref ~1), x))
fun pretty m t = Prettier.pretty m o layout t
fun show t = pretty NONE t
- structure Layered = LayerCases
- (structure Outer = Arg and Result = Pretty and Rep = Pretty.Closed
+ structure Layered = LayerDepCases
+ (structure Outer = Arg and Result = Pretty
- fun iso b = inj b o Iso.to
- val isoProduct = iso
- val isoSum = iso
+ fun iso ? = iso' getT ?
+ fun isoProduct ? = iso' getP ?
+ fun isoSum ? = iso' getS ?
- fun (l *` r) (e, a & b) = l (e, a) <^> comma <$> r (e, b)
- val T = id
- fun R l = case txt (l2s l)
- of l => fn t => fn ? => group (nest 1 (l </> equals </> t ?))
- fun tuple t = surround parens o t
- fun record t = surround braces o t
+ 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
+ val T = getT
+ fun R l =
+ case txt (Generics.Label.toString l)
+ of l =>
+ fn aT => case getT aT
+ of aP => fn ? => group (nest 1 (l </> equals </> aP ?))
+ fun tuple aP = surround parens o getP aP
+ fun record aP = surround braces o getP aP
- fun l +` r = fn (e, INL a) => l (e, a)
- | (e, INR b) => r (e, b)
+ 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
val unit = mk (Thunk.mk "()")
- fun C0 c = const (txt (c2s c))
- fun C1 c = case txt (c2s c)
- of c => fn t => fn ? => nest 1 (group (c <$> atomize (t ?)))
- val data = id
+ fun C0 c = const (txt (Generics.Con.toString c))
+ fun C1 c =
+ case txt (Generics.Con.toString c)
+ of c =>
+ fn aT => case getT aT
+ of aP => fn ? => nest 1 (group (c <$> atomize (aP ?)))
+ val data = getS
val Y = Tie.function
fun exn ? = !exnHandler ?
- fun regExn0 c (_, prj) =
- Ref.modify (fn exnHandler => fn (env, e) =>
- case prj e
- of NONE => exnHandler (env, e)
- | SOME () => txt (c2s c)) exnHandler
- fun regExn1 c t (_, prj) =
- Ref.modify (fn exnHandler => fn (env, e) =>
- case prj e
- of NONE => exnHandler (env, e)
- | SOME x =>
- nest 1 (group (txt (c2s c) <$>
- atomize (t (env, x))))) 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 ? = cyclic o flip inj ! |< C1 ctorRef ?
- fun array ? = cyclic |< sequ hashParens Array.toList ?
+ fun refc aT = cyclic (Arg.refc ignore aT) o flip inj ! |< C1 ctorRef aT
+ fun array aT = cyclic (Arg.array ignore aT) |<
+ sequ hashParens Array.toList (getT aT)
- fun vector ? = sequ hashBrackets Vector.toList ?
- fun list ? = sequ brackets id ?
+ fun vector aT = sequ hashBrackets Vector.toList (getT aT)
+ fun list aT = sequ brackets id (getT aT)
fun op --> _ = const txtFn
Modified: mltonlib/trunk/com/ssh/generic/unstable/public/export.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/public/export.sml 2007-09-02 13:24:46 UTC (rev 5995)
+++ mltonlib/trunk/com/ssh/generic/unstable/public/export.sml 2007-09-02 16:13:56 UTC (rev 5996)
@@ -135,7 +135,8 @@
functor WithPickle (Arg : WITH_PICKLE_DOM) : PICKLE_CASES = WithPickle (Arg)
signature PRETTY = PRETTY and PRETTY_CASES = PRETTY_CASES
-functor WithPretty (Arg : OPEN_CASES) : PRETTY_CASES = WithPretty (Arg)
+ and WITH_PRETTY_DOM = WITH_PRETTY_DOM
+functor WithPretty (Arg : WITH_PRETTY_DOM) : PRETTY_CASES = WithPretty (Arg)
signature REDUCE = REDUCE and REDUCE_CASES = REDUCE_CASES
functor WithReduce (Arg : OPEN_CASES) : REDUCE_CASES = WithReduce (Arg)
Modified: mltonlib/trunk/com/ssh/generic/unstable/public/value/pretty.sig
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/public/value/pretty.sig 2007-09-02 13:24:46 UTC (rev 5995)
+++ mltonlib/trunk/com/ssh/generic/unstable/public/value/pretty.sig 2007-09-02 16:13:56 UTC (rev 5996)
@@ -25,3 +25,5 @@
include OPEN_CASES PRETTY
sharing Rep = Pretty
end
+
+signature WITH_PRETTY_DOM = HASH_CASES
Modified: mltonlib/trunk/com/ssh/generic/unstable/test/pretty.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/test/pretty.sml 2007-09-02 13:24:46 UTC (rev 5995)
+++ mltonlib/trunk/com/ssh/generic/unstable/test/pretty.sml 2007-09-02 16:13:56 UTC (rev 5996)
@@ -4,93 +4,127 @@
* See the LICENSE file or http://mlton.org/License for details.
*)
-val () = let
+local
open Generic UnitTest
infix |`
fun tst n t s v =
testEq string (fn () => {expect = s, actual = pretty n t v})
+
+ structure Graph = MkGraph (Generic)
in
- unitTests
- (title "Generic.Pretty")
+ val () =
+ unitTests
+ (title "Generic.Pretty")
- (tst NONE unit "()" ())
+ (tst NONE unit "()" ())
- (tst NONE word "0wx15" 0wx15)
+ (tst NONE word "0wx15" 0wx15)
- (tst (SOME 6) (list int)
- "[1,\n 2,\n 3]"
- [1, 2, 3])
+ (tst (SOME 6) (list int)
+ "[1,\n 2,\n 3]"
+ [1, 2, 3])
- (tst (SOME 2) (vector bool)
- "#[true,\n\
- \ false]"
- (Vector.fromList [true, false]))
+ (tst (SOME 2) (vector bool)
+ "#[true,\n\
+ \ false]"
+ (Vector.fromList [true, false]))
- (tst (SOME 15) (tuple3 (option unit, string, exn))
- "(NONE,\n\
- \ \"a\",\n\
- \ Empty)"
- (NONE, "a", Empty))
+ (tst (SOME 15) (tuple3 (option unit, string, exn))
+ "(NONE,\n\
+ \ \"a\",\n\
+ \ Empty)"
+ (NONE, "a", Empty))
- (tst NONE (array unit) "#()" (Array.array (0, ())))
+ (tst NONE (array unit) "#()" (Array.array (0, ())))
- (tst NONE real "~3.141" ~3.141)
+ (tst NONE real "~3.141" ~3.141)
- (tst (SOME 22)
- ((order |` unit) &` order &` (unit |` order))
- "&\n\
- \ (& (INL LESS, EQUAL),\n\
- \ INR GREATER)"
- (INL LESS & EQUAL & INR GREATER))
+ (tst (SOME 22)
+ ((order |` unit) &` order &` (unit |` order))
+ "&\n\
+ \ (& (INL LESS, EQUAL),\n\
+ \ INR GREATER)"
+ (INL LESS & EQUAL & INR GREATER))
- let
- fun chk s e = tst (SOME 11) string e s
- in
- fn ? =>
- (pass ?)
- (chk "does not fit" "\"does not fit\"")
- (chk "does\nnot\nfit" "\"does\\n\\\n\\not\\n\\\n\\fit\"")
- (chk "does fit" "\"does fit\"")
- (chk "does\nfit" "\"does\\nfit\"")
- end
+ let
+ fun chk s e = tst (SOME 11) string e s
+ in
+ fn ? =>
+ (pass ?)
+ (chk "does not fit" "\"does not fit\"")
+ (chk "does\nnot\nfit" "\"does\\n\\\n\\not\\n\\\n\\fit\"")
+ (chk "does fit" "\"does fit\"")
+ (chk "does\nfit" "\"does\\nfit\"")
+ end
- let
- exception Unknown
- in
- tst NONE exn "#Unknown" Unknown
- end
+ let
+ exception Unknown
+ in
+ tst NONE exn "#Unknown" Unknown
+ end
- (tst (SOME 9)
- (iso (record (R' "1" int
- *` R' "+" (unOp int)
- *` R' "c" char))
- (fn {1 = a, + = b, c = c} => a & b & c,
- fn a & b & c => {1 = a, + = b, c = c}))
- "{1 = 2,\n\
- \ + = #fn,\n\
- \ c =\n\
- \ #\"d\"}"
- {1 = 2, + = id, c = #"d"})
+ (tst (SOME 9)
+ (iso (record (R' "1" int
+ *` R' "+" (unOp int)
+ *` R' "c" char))
+ (fn {1 = a, + = b, c = c} => a & b & c,
+ fn a & b & c => {1 = a, + = b, c = c}))
+ "{1 = 2,\n\
+ \ + = #fn,\n\
+ \ c =\n\
+ \ #\"d\"}"
+ {1 = 2, + = id, c = #"d"})
- let
- datatype s = S of s Option.t Ref.t Sq.t
- val x as S (l, r) = S (ref NONE, ref NONE)
- val () = (l := SOME x ; r := SOME x)
- in
- tst (SOME 50)
- (Tie.fix Y
- (fn s =>
- iso (data (C1' "S" (sq (refc (option s)))))
- (fn S ? => ?, S)))
- "S\n\
- \ (#0 as ref\n\
- \ (SOME (S (#0, #1 as ref (SOME (S (#0, #1)))))),\n\
- \ #0 as ref\n\
- \ (SOME (S (#1 as ref (SOME (S (#1, #0))), #0))))"
- x
- end
+ let
+ datatype s = S of s Option.t Ref.t Sq.t
+ val x as S (l, r) = S (ref NONE, ref NONE)
+ val () = (l := SOME x ; r := SOME x)
+ in
+ tst (SOME 50)
+ (Tie.fix Y
+ (fn s =>
+ iso (data (C1' "S" (sq (refc (option s)))))
+ (fn S ? => ?, S)))
+ "S\n\
+ \ (#0=ref\n\
+ \ (SOME (S (#0, #1=ref (SOME (S (#0, #1)))))),\n\
+ \ #1)"
+ x
+ end
- $
+ (tst (SOME 50)
+ (Graph.t int)
+ "ref\n\
+ \ [VTX\n\
+ \ (1,\n\
+ \ #0=ref\n\
+ \ [VTX\n\
+ \ (2,\n\
+ \ #4=ref\n\
+ \ [VTX\n\
+ \ (3,\n\
+ \ #5=ref\n\
+ \ [VTX (1, #0),\n\
+ \ VTX\n\
+ \ (6,\n\
+ \ #1=ref\n\
+ \ [VTX\n\
+ \ (5,\n\
+ \ #2=ref\n\
+ \ [VTX\n\
+ \ (4,\n\
+ \ #3=ref\n\
+ \ [VTX (6, #1)])])])]),\n\
+ \ VTX (5, #2)]),\n\
+ \ VTX (4, #3)]),\n\
+ \ VTX (2, #4),\n\
+ \ VTX (3, #5),\n\
+ \ VTX (4, #3),\n\
+ \ VTX (5, #2),\n\
+ \ VTX (6, #1)]"
+ Graph.intGraph1)
+
+ $
end
More information about the MLton-commit
mailing list