[MLton-commit] r5948
Vesa Karvonen
vesak at mlton.org
Sat Aug 25 09:23:58 PDT 2007
Committed some experimental changes that have been pending for a while.
Added whenSeq and whenArb for committing to a list of events.
Added a binary choice combinator <|> and a never (zero) event and
reimplemented choose using them.
Changed the tests to use the new generic and unit-test libraries instead
of the mist-util library, which is on its way out.
----------------------------------------------------------------------
U mltonlib/trunk/com/ssh/async/unstable/detail/async.sml
U mltonlib/trunk/com/ssh/async/unstable/example/actor/counter-example.mlb
U mltonlib/trunk/com/ssh/async/unstable/example/smlbot/smlbot.mlb
U mltonlib/trunk/com/ssh/async/unstable/example/smlbot/smlbot.sml
U mltonlib/trunk/com/ssh/async/unstable/public/async.sig
U mltonlib/trunk/com/ssh/async/unstable/test/async.sml
U mltonlib/trunk/com/ssh/async/unstable/test.mlb
----------------------------------------------------------------------
Modified: mltonlib/trunk/com/ssh/async/unstable/detail/async.sml
===================================================================
--- mltonlib/trunk/com/ssh/async/unstable/detail/async.sml 2007-08-25 14:52:34 UTC (rev 5947)
+++ mltonlib/trunk/com/ssh/async/unstable/detail/async.sml 2007-08-25 16:23:56 UTC (rev 5948)
@@ -29,34 +29,56 @@
INL (fn h => let
val h = Handler.prepend f h
in
- case t () of
- INL ef => ef h
- | INR v =>
- (Handler.schedule () (Handler.prepend (const v) h)
- ; true)
+ case t ()
+ of INL ef => ef h
+ | INR v =>
+ (Handler.schedule
+ ()
+ (Handler.prepend (const v) h)
+ ; true)
end))
- fun choose es =
+ fun (E l) <|> (E r) =
E (fn () =>
- recur (es & []) (fn lp =>
- fn [] & efs =>
- INL (fn h =>
- recur efs (fn lp =>
- fn [] => false
- | ef::efs =>
- ef h orelse lp efs))
- | E e::es & efs =>
- case e () of
- INL ef => lp (es & ef::efs)
- | result => result))
+ case l ()
+ of INR v => INR v
+ | INL lEf =>
+ case r ()
+ of INR v => INR v
+ | INL rEf =>
+ INL (fn h => lEf h orelse rEf h))
+ val never = E (fn () => INL (const false))
fun once (E t) =
- case t () of
- INL ef => ignore (ef (Handler.new ()))
- | INR () => ()
+ case t ()
+ of INL ef => ignore (ef (Handler.new ()))
+ | INR () => ()
+ (* Non primitive functions: *)
+ val choose = fn [] => never | e::es => foldl op <|> e es
fun when ? = once o on ?
fun each e = when e (fn () => each e)
fun every ? = each o on ?
val any = once o choose
val all = each o choose
+ fun whenSeq es done = let
+ fun lp rs =
+ fn [] => done (rev rs)
+ | e::es => when e (fn r => lp (r::rs) es)
+ in
+ lp [] es
+ end
+ fun whenArb es done = let
+ val n = ref (length es)
+ val rs = Array.array (!n, NONE)
+ in
+ List.appi
+ (fn (i, e) =>
+ when e (fn v =>
+ (Array.update (rs, i, SOME v)
+ ; n := !n - 1
+ ; if 0 = !n
+ then done (map valOf (Array.toList rs))
+ else ())))
+ es
+ end
end
open Event
@@ -68,20 +90,20 @@
fun new () = T {ts = UnlinkableList.new (), gs = UnlinkableList.new ()}
fun take (T {gs, ts}) =
E (fn () =>
- case UnlinkableList.popBack gs of
- NONE => INL (Handler.pushFront ts)
- | SOME {handler, value} =>
- (Handler.schedule () handler ; INR value))
+ case UnlinkableList.popBack gs
+ of NONE => INL (Handler.pushFront ts)
+ | SOME {handler, value} =>
+ (Handler.schedule () handler ; INR value))
fun give (T {ts, gs}) v =
E (fn () =>
- case UnlinkableList.popBack ts of
- SOME th => (Handler.schedule v th ; INR ())
- | NONE =>
- INL (fn h as Handler.T t =>
- (List.push (#unlink t)
- (UnlinkableList.pushFront
- gs {handler = h, value = v})
- ; false)))
+ case UnlinkableList.popBack ts
+ of SOME th => (Handler.schedule v th ; INR ())
+ | NONE =>
+ INL (fn h as Handler.T t =>
+ (List.push (#unlink t)
+ (UnlinkableList.pushFront
+ gs {handler = h, value = v})
+ ; false)))
end
structure Mailbox = struct
@@ -89,17 +111,17 @@
fun new () = T {ts = UnlinkableList.new (), vs = Queue.new ()}
fun take (T {ts, vs}) =
E (fn () =>
- case Queue.deque vs of
- NONE => INL (Handler.pushFront ts)
- | SOME v => INR v)
+ case Queue.deque vs
+ of NONE => INL (Handler.pushFront ts)
+ | SOME v => INR v)
fun send (T {ts, vs}) v =
(Queue.enque vs v
- ; case UnlinkableList.popBack ts of
- NONE => ()
- | SOME th =>
- case Queue.deque vs of
- NONE => fail "impossible"
- | SOME v => Handler.schedule v th)
+ ; case UnlinkableList.popBack ts
+ of NONE => ()
+ | SOME th =>
+ case Queue.deque vs
+ of NONE => fail "impossible"
+ | SOME v => Handler.schedule v th)
end
structure IVar = struct
@@ -108,18 +130,18 @@
fun new () = T {rs = UnlinkableList.new (), st = ref NONE}
fun read (T {rs, st}) =
E (fn () =>
- case !st of
- SOME v => INR v
- | NONE => INL (Handler.pushFront rs))
+ case !st
+ of SOME v => INR v
+ | NONE => INL (Handler.pushFront rs))
fun whileSome getSome from doSome =
- case getSome from of
- NONE => ()
- | SOME v => (doSome v : Unit.t ; whileSome getSome from doSome)
+ case getSome from
+ of NONE => ()
+ | SOME v => (doSome v : Unit.t ; whileSome getSome from doSome)
fun fill (T {rs, st}) v =
- case !st of
- SOME _ => raise Full
- | NONE => (st := SOME v
- ; whileSome UnlinkableList.popBack rs (Handler.schedule v))
+ case !st
+ of SOME _ => raise Full
+ | NONE => (st := SOME v
+ ; whileSome UnlinkableList.popBack rs (Handler.schedule v))
end
structure MVar = struct
@@ -128,21 +150,21 @@
fun new () = T {ts = UnlinkableList.new (), st = ref NONE}
fun take (T {ts, st}) =
E (fn () =>
- case !st of
- SOME v => (st := NONE ; INR v)
- | NONE => INL (Handler.pushFront ts))
+ case !st
+ of SOME v => (st := NONE ; INR v)
+ | NONE => INL (Handler.pushFront ts))
fun give (T {ts, st}) v =
- case UnlinkableList.popBack ts of
- NONE => st := SOME v
- | SOME h => Handler.schedule v h
+ case UnlinkableList.popBack ts
+ of NONE => st := SOME v
+ | SOME h => Handler.schedule v h
fun fill (t as T {st, ...}) v =
- case !st of
- SOME _ => raise Full
- | NONE => give t v
+ case !st
+ of SOME _ => raise Full
+ | NONE => give t v
fun send (t as T {st, ...}) v =
- case !st of
- SOME _ => st := SOME v
- | NONE => give t v
+ case !st
+ of SOME _ => st := SOME v
+ | NONE => give t v
end
structure SkipCh = MVar
Modified: mltonlib/trunk/com/ssh/async/unstable/example/actor/counter-example.mlb
===================================================================
--- mltonlib/trunk/com/ssh/async/unstable/example/actor/counter-example.mlb 2007-08-25 14:52:34 UTC (rev 5947)
+++ mltonlib/trunk/com/ssh/async/unstable/example/actor/counter-example.mlb 2007-08-25 16:23:56 UTC (rev 5948)
@@ -6,7 +6,6 @@
local
$(MLTON_LIB)/com/ssh/extended-basis/unstable/basis.mlb
- $(MLTON_LIB)/com/ssh/misc-util/unstable/lib.mlb
../../lib.mlb
ann
Modified: mltonlib/trunk/com/ssh/async/unstable/example/smlbot/smlbot.mlb
===================================================================
--- mltonlib/trunk/com/ssh/async/unstable/example/smlbot/smlbot.mlb 2007-08-25 14:52:34 UTC (rev 5947)
+++ mltonlib/trunk/com/ssh/async/unstable/example/smlbot/smlbot.mlb 2007-08-25 16:23:56 UTC (rev 5948)
@@ -6,7 +6,6 @@
local
$(MLTON_LIB)/com/ssh/extended-basis/unstable/basis.mlb
- $(MLTON_LIB)/com/ssh/misc-util/unstable/lib.mlb
../../lib.mlb
../poll-loop/lib.mlb
Modified: mltonlib/trunk/com/ssh/async/unstable/example/smlbot/smlbot.sml
===================================================================
--- mltonlib/trunk/com/ssh/async/unstable/example/smlbot/smlbot.sml 2007-08-25 14:52:34 UTC (rev 5947)
+++ mltonlib/trunk/com/ssh/async/unstable/example/smlbot/smlbot.sml 2007-08-25 16:23:56 UTC (rev 5948)
@@ -4,7 +4,7 @@
* See the LICENSE file or http://mlton.org/License for details.
*)
-(* XXX consider supporting HaMLet S and possibly Alice ML as evaluators *)
+(* XXX consider supporting Alice ML as an evaluator *)
structure SMLBot :> sig
val run : {host : String.t, port : String.t, pass : String.t,
Modified: mltonlib/trunk/com/ssh/async/unstable/public/async.sig
===================================================================
--- mltonlib/trunk/com/ssh/async/unstable/public/async.sig 2007-08-25 14:52:34 UTC (rev 5947)
+++ mltonlib/trunk/com/ssh/async/unstable/public/async.sig 2007-08-25 16:23:56 UTC (rev 5948)
@@ -47,7 +47,7 @@
(** == Combinators ==
*
- * Event combinators work in such away that committing to the returned
+ * Event combinators work in such a way that committing to the returned
* event also commits to a given event. However, committing to a given
* event does not commit to the returned event.
*)
@@ -59,6 +59,15 @@
* usually referred to as either a handler or an action.
*)
+ val <|> : 'a Event.t BinOp.t
+ (**
+ * Creates an event that chooses, in an unspecified manner, an enabled
+ * even from the given pair of events to commit to.
+ *)
+
+ val never : 'a Event.t
+ (** An event that is never enabled. *)
+
val choose : 'a Event.t List.t -> 'a Event.t
(**
* Creates an event that chooses, in an unspecified manner, an enabled
@@ -102,6 +111,16 @@
val all : Unit.t Event.t List.t Effect.t
(** {all = each o choose} *)
+ val whenSeq : 'a Event.t List.t -> 'a List.t Effect.t Effect.t
+ (**
+ * Commit to given events sequentially from first to last. Make a
+ * list of the results. When all events have been committed to,
+ * perform the given action.
+ *)
+
+ val whenArb : 'a Event.t List.t -> 'a List.t Effect.t Effect.t
+ (** Like {whenSeq}, but commit to given events in any order. *)
+
(** == Communication Mechanisms ==
*
* The names of operations have been chosen to communicate the semantics:
Modified: mltonlib/trunk/com/ssh/async/unstable/test/async.sml
===================================================================
--- mltonlib/trunk/com/ssh/async/unstable/test/async.sml 2007-08-25 14:52:34 UTC (rev 5947)
+++ mltonlib/trunk/com/ssh/async/unstable/test/async.sml 2007-08-25 16:23:56 UTC (rev 5948)
@@ -8,11 +8,11 @@
* Ad hoc tests against the Async module.
*)
val () = let
- open UnitTest Async Async.Handler
- fun eq ex ac = verifyEq Type.int {actual = ac, expect = ex}
- fun eql ex ac = verifyEq (Type.list Type.int) {actual = ac, expect = ex}
+ open Generic UnitTest Async Async.Handler
+ fun eq ex ac = verifyEq int {actual = ac, expect = ex}
+ fun eql ex ac = verifyEq (list int) {actual = ac, expect = ex}
val full = verifyFailsWith (fn Full => true | _ => false)
- fun inc v () = v += 1
+ fun inc v () = v := !v + 1
val push = List.push
in
unitTests
Modified: mltonlib/trunk/com/ssh/async/unstable/test.mlb
===================================================================
--- mltonlib/trunk/com/ssh/async/unstable/test.mlb 2007-08-25 14:52:34 UTC (rev 5947)
+++ mltonlib/trunk/com/ssh/async/unstable/test.mlb 2007-08-25 16:23:56 UTC (rev 5948)
@@ -5,10 +5,10 @@
*)
local
- $(MLTON_LIB)/com/ssh/misc-util/unstable/unit-test.mlb
+ $(MLTON_LIB)/com/ssh/generic/unstable/lib-with-default.mlb
+ $(MLTON_LIB)/com/ssh/unit-test/unstable/lib-with-default.mlb
$(MLTON_LIB)/com/ssh/extended-basis/unstable/basis.mlb
- $(MLTON_LIB)/com/ssh/misc-util/unstable/lib.mlb
lib.mlb
More information about the MLton-commit
mailing list