[MLton-commit] r5995
Vesa Karvonen
vesak at mlton.org
Sun Sep 2 06:24:47 PDT 2007
Using HashMap environment.
----------------------------------------------------------------------
U mltonlib/trunk/com/ssh/generic/unstable/detail/value/transform.sml
U mltonlib/trunk/com/ssh/generic/unstable/public/export.sml
U mltonlib/trunk/com/ssh/generic/unstable/public/value/transform.sig
U mltonlib/trunk/com/ssh/generic/unstable/test/transform.sml
----------------------------------------------------------------------
Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/value/transform.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/value/transform.sml 2007-09-02 12:36:20 UTC (rev 5994)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/value/transform.sml 2007-09-02 13:24:46 UTC (rev 5995)
@@ -4,10 +4,9 @@
* See the LICENSE file or http://mlton.org/License for details.
*)
-functor WithTransform (Arg : OPEN_CASES) : TRANSFORM_CASES = struct
+functor WithTransform (Arg : WITH_TRANSFORM_DOM) : TRANSFORM_CASES = struct
(* <-- SML/NJ workaround *)
open TopLevel
- infix 4 <\
infixr 4 />
infix 0 &
(* SML/NJ workaround --> *)
@@ -16,23 +15,26 @@
val ID = 0w0 and REC = 0w1 and CUSTOM = 0w2
val join = Word.orb
- type e = Univ.t List.t
- type 'a t = c * ('a * e) UnOp.t
+ type e = (HashUniv.t, Unit.t) HashMap.t
+ type 'a t = c * ('a * e -> 'a)
- fun lift f = Pair.map (f, id)
+ fun lift f = f o Pair.fst
- val default = (ID, id)
+ val default : 'a t = (ID, #1)
fun un f2f (c, f) = if ID = c then default else (c, f2f f)
fun bin fs2f ((aC, aT), (bC, bT)) =
case join (aC, bC) of c => if ID = c then default else (c, fs2f (aT, bT))
- fun cyclic t =
- case Univ.Emb.new ()
- of (to, from) => fn (x, e) => if List.exists (SOME x <\ op = o from) e
- then (x, e)
- else t (x, to x::e)
+ fun cyclic aT aF =
+ case HashUniv.new {eq = op =, hash = Arg.hash aT}
+ of (to, _) =>
+ fn (x, e) =>
+ case to x of xD => if isSome (HashMap.find e xD) then x
+ else (HashMap.insert e (xD, ()) ; aF (x, e))
+ fun iso' getX bX (a2b, b2a) = un (Fn.map (Pair.map (a2b, id), b2a)) (getX bX)
+
structure Transform = LayerRep
(structure Outer = Arg.Rep
structure Closed = MkClosedRep (type 'a t = 'a t))
@@ -40,34 +42,33 @@
open Transform.This
fun makeTransform a2a t t2u =
- #1 o #2 (getT (t2u (mapT (const (CUSTOM, lift a2a)) t))) o id /> []
+ case getT (t2u (mapT (const (CUSTOM, lift a2a)) t))
+ of (_, f) =>
+ fn x => f (x, HashMap.new {eq = HashUniv.eq, hash = HashUniv.hash})
- structure Layered = LayerCases
- (structure Outer = Arg and Result = Transform and Rep = Transform.Closed
+ structure Layered = LayerDepCases
+ (structure Outer = Arg and Result = Transform
- fun iso ? (a2b, b2a) = un (Fn.map (lift a2b, lift b2a)) ?
- val isoProduct = iso
- val isoSum = iso
+ fun iso ? = iso' getT ?
+ fun isoProduct ? = iso' getP ?
+ fun isoSum ? = iso' getS ?
- fun op *` ? =
- bin (fn (aT, bT) => fn (a & b, e) => let
- val (a, e) = aT (a, e)
- val (b, e) = bT (b, e)
- in
- (a & b, e)
- end) ?
- val T = id
- fun R _ = id
- val tuple = id
- val record = id
+ fun op *` (aP, bP) =
+ bin (fn (aT, bT) => fn (a & b, e) => aT (a, e) & bT (b, e))
+ (getP aP, getP bP)
+ val T = getT
+ fun R _ = getT
+ val tuple = getP
+ val record = getP
- fun op +` ? =
- bin (fn (aT, bT) => fn (INL a, e) => lift INL (aT (a, e))
- | (INR b, e) => lift INR (bT (b, e))) ?
+ fun op +` (aS, bS) =
+ bin (fn (aT, bT) => fn (INL a, e) => INL (aT (a, e))
+ | (INR b, e) => INR (bT (b, e)))
+ (getS aS, getS bS)
val unit = default
fun C0 _ = unit
- fun C1 _ = id
- val data = id
+ fun C1 _ = getT
+ val data = getS
fun Y ? = Tie.pure (fn () => let
val r = ref (raising Fix.Fix)
@@ -85,36 +86,19 @@
fun regExn0 _ _ = ()
fun regExn1 _ _ _ = ()
- fun list ? =
- un (fn xT =>
- Pair.map (id, Pair.snd) o
- List.unfoldr'
- (fn ([], _) => NONE
- | (x::xs, e) =>
- case xT (x, e) of (y, e) => SOME (y, (xs, e)))) ?
+ fun list aT = un (fn xF => fn (l, e) => map (xF /> e) l) (getT aT)
- fun vector ? =
- un (fn xT => fn (v, e) =>
- Vector.unfoldi
- (xT o lift (v <\ Vector.sub)) (Vector.length v, e)) ?
+ fun vector aT = un (fn xF => fn (v, e) => Vector.map (xF /> e) v) (getT aT)
- fun array ? =
- un (fn aT =>
- cyclic (fn (aA, e) => let
- fun lp (i, e) =
- if i = Array.length aA then e else
- case aT (Array.sub (aA, i), e)
- of (a, e) => (Array.update (aA, i, a)
- ; lp (i+1, e))
- in
- (aA, lp (0, e))
- end)) ?
+ fun array aT =
+ un (fn xF => cyclic (Arg.array ignore aT)
+ (fn (a, e) => (Array.modify (xF /> e) a ; a)))
+ (getT aT)
- fun refc ? =
- un (fn aT =>
- cyclic
- (fn (r, e) =>
- case aT (!r, e) of (a, e) => (r := a ; (r, e)))) ?
+ fun refc aT =
+ un (fn xF => cyclic (Arg.refc ignore aT)
+ (fn (r, e) => (r := xF (!r, e) ; r)))
+ (getT aT)
val fixedInt = default
val largeInt = default
Modified: mltonlib/trunk/com/ssh/generic/unstable/public/export.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/public/export.sml 2007-09-02 12:36:20 UTC (rev 5994)
+++ mltonlib/trunk/com/ssh/generic/unstable/public/export.sml 2007-09-02 13:24:46 UTC (rev 5995)
@@ -148,7 +148,9 @@
functor WithSome (Arg : WITH_SOME_DOM) : SOME_CASES = WithSome (Arg)
signature TRANSFORM = TRANSFORM and TRANSFORM_CASES = TRANSFORM_CASES
-functor WithTransform (Arg : OPEN_CASES) : TRANSFORM_CASES = WithTransform (Arg)
+ and WITH_TRANSFORM_DOM = WITH_TRANSFORM_DOM
+functor WithTransform (Arg : WITH_TRANSFORM_DOM) : TRANSFORM_CASES =
+ WithTransform (Arg)
signature TYPE_HASH = TYPE_HASH and TYPE_HASH_CASES = TYPE_HASH_CASES
functor WithTypeHash (Arg : OPEN_CASES) : TYPE_HASH_CASES = WithTypeHash (Arg)
Modified: mltonlib/trunk/com/ssh/generic/unstable/public/value/transform.sig
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/public/value/transform.sig 2007-09-02 12:36:20 UTC (rev 5994)
+++ mltonlib/trunk/com/ssh/generic/unstable/public/value/transform.sig 2007-09-02 13:24:46 UTC (rev 5995)
@@ -35,3 +35,5 @@
include OPEN_CASES TRANSFORM
sharing Rep = Transform
end
+
+signature WITH_TRANSFORM_DOM = HASH_CASES
Modified: mltonlib/trunk/com/ssh/generic/unstable/test/transform.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/test/transform.sml 2007-09-02 12:36:20 UTC (rev 5994)
+++ mltonlib/trunk/com/ssh/generic/unstable/test/transform.sml 2007-09-02 13:24:46 UTC (rev 5995)
@@ -8,7 +8,7 @@
structure Generic = struct
open Generic
local
- structure Open = WithTransform (Open)
+ structure Open = WithTransform (open Generic Open)
structure Extra = CloseWithExtra (Open)
in
open Open Extra
More information about the MLton-commit
mailing list