[MLton-commit] r5974
Vesa Karvonen
vesak at mlton.org
Tue Aug 28 05:44:55 PDT 2007
Added convenience function show to Pretty. Changed implementation to use
Univ rather than exceptions. Moved definitions other than structural
cases outside the LayerCases argument.
----------------------------------------------------------------------
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-08-28 12:19:10 UTC (rev 5973)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/value/pretty.sml 2007-08-28 12:44:54 UTC (rev 5974)
@@ -56,142 +56,131 @@
val op </> = bop op </>
end
+ local
+ open Generics
+ in
+ val C = C
+ val l2s = Label.toString
+ val c2s = Con.toString
+ end
+
+ fun inj b a2b = b o Pair.map (id, a2b)
+
+ val txtAs = txt "as"
+ val txtFn = txt "#fn"
+
+ val ctorRef = 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 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)
+
structure Pretty = LayerRep
(structure Outer = Arg.Rep
- structure Closed = MkClosedRep (type 'a t = exn list * 'a -> u))
+ structure Closed = MkClosedRep (type 'a t = 'a t))
open Pretty.This
fun layout t = Pair.snd o [] <\ getT t
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
- local
- open Generics
- in
- val C = C
- val l2s = Label.toString
- val c2s = Con.toString
- end
-
- 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)
-
+ fun (l *` r) (e, a & b) = l (e, a) <^> comma <$> r (e, 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 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 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
-
+ fun l +` r = fn (e, INL a) => l (e, a)
+ | (e, INR b) => r (e, b)
+ 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
val Y = Tie.function
- val exn : Exn.t Rep.t ref =
- ref (txt o "#" <\ op ^ o General.exnName o #2)
+ fun exn ? = !exnHandler ?
fun regExn0 c (_, prj) =
- Ref.modify (fn exn => fn (env, e) =>
+ Ref.modify (fn exnHandler => fn (env, e) =>
case prj e
- of NONE => exn (env, e)
- | SOME () => txt (c2s c)) exn
+ of NONE => exnHandler (env, e)
+ | SOME () => txt (c2s c)) exnHandler
fun regExn1 c t (_, prj) =
- Ref.modify (fn exn => fn (env, e) =>
+ Ref.modify (fn exnHandler => fn (env, e) =>
case prj e
- of NONE => exn (env, e)
+ of NONE => exnHandler (env, e)
| SOME x =>
nest 1 (group (txt (c2s c) <$>
- atomize (t (env, x))))) exn
+ atomize (t (env, x))))) exnHandler
+ fun refc ? = cyclic o flip inj ! |< C1 ctorRef ?
+ fun array ? = cyclic |< sequ hashParens Array.toList ?
- val exn = fn ? => !exn ?
+ fun vector ? = sequ hashBrackets Vector.toList ?
+ fun list ? = sequ brackets id ?
- 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 List.map (curry t env) |< toL a
+ fun op --> _ = const txtFn
- 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\\"
+ val txtNlBs = 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)
- (List.map toLit
- (String.fields
- (#"\n" <\ op =) s)))})
+ fun string (_, s) =
+ (true,
+ group o dquotes |< choice
+ {wide = toLit s,
+ narrow = lazy (fn () =>
+ List.foldl1
+ (fn (x, s) =>
+ s <^> txtNlBs <$> backslash <^> x)
+ (List.map toLit
+ (String.fields
+ (#"\n" <\ op =) s)))})
end
- fun mk toS : 'a Rep.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 fixedInt = mk FixedInt.toString
Modified: mltonlib/trunk/com/ssh/generic/unstable/public/value/pretty.sig
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/public/value/pretty.sig 2007-08-28 12:19:10 UTC (rev 5973)
+++ mltonlib/trunk/com/ssh/generic/unstable/public/value/pretty.sig 2007-08-28 12:44:54 UTC (rev 5974)
@@ -15,7 +15,10 @@
(** Extracts the prettifying function. *)
val pretty : Int.t Option.t -> ('a, 'x) Pretty.t -> 'a -> String.t
- (** {pretty m t = Prettier.pretty m o layout t} *)
+ (** {pretty m t} is equivalent to {Prettier.pretty m o layout t}. *)
+
+ val show : ('a, 'x) Pretty.t -> 'a -> String.t
+ (** {show t} is equivalent to {pretty NONE t}. *)
end
signature PRETTY_CASES = sig
More information about the MLton-commit
mailing list