[MLton-commit] r5348
Vesa Karvonen
vesak at mlton.org
Tue Feb 27 04:15:28 PST 2007
Moved values from the Event substructure to the top-level of the ASYNC
signature for convenience.
----------------------------------------------------------------------
U mltonlib/trunk/com/ssh/async/unstable/detail/async.sml
U mltonlib/trunk/com/ssh/async/unstable/public/async.sig
U mltonlib/trunk/com/ssh/async/unstable/test/async.sml
----------------------------------------------------------------------
Modified: mltonlib/trunk/com/ssh/async/unstable/detail/async.sml
===================================================================
--- mltonlib/trunk/com/ssh/async/unstable/detail/async.sml 2007-02-27 10:04:30 UTC (rev 5347)
+++ mltonlib/trunk/com/ssh/async/unstable/detail/async.sml 2007-02-27 12:15:23 UTC (rev 5348)
@@ -28,9 +28,9 @@
end
structure Event = struct
- datatype 'a t = T of ('a Handler.t Effect.t, 'a) Sum.t Thunk.t
- fun on (T t, f) =
- T (fn () =>
+ datatype 'a t = E of ('a Handler.t Effect.t, 'a) Sum.t Thunk.t
+ fun on (E t, f) =
+ E (fn () =>
INL (fn h => let
val h = Handler.prepend f h
in
@@ -40,7 +40,7 @@
Handler.schedule () (Handler.prepend (const v) h)
end))
fun choose es =
- T (fn () =>
+ E (fn () =>
recur (es & []) (fn lp =>
fn [] & efs =>
INL (fn h =>
@@ -50,11 +50,11 @@
(ef h
; if Handler.scheduled h then ()
else lp efs)))
- | T e::es & efs =>
+ | E e::es & efs =>
case e () of
INL ef => lp (es & ef::efs)
| result => result))
- fun once (T t) = Sum.app (fn ef => ef (Handler.new ()),
+ fun once (E t) = Sum.app (fn ef => ef (Handler.new ()),
Queue.enque Handler.handlers o const) (t ())
fun when ? = once (on ?)
fun each e = when (e, fn () => each e)
@@ -63,23 +63,25 @@
val all = each o choose
end
+ open Event
+
structure Ch = struct
datatype 'a t
= T of {ts : 'a Handler.t Queue.t,
gs : {handler : Unit.t Handler.t, value : 'a} Queue.t}
fun new () = T {ts = Queue.new (), gs = Queue.new ()}
fun take (T {gs, ts}) =
- Event.T (fn () =>
- case Queue.dequeWhile (Handler.scheduled o #handler) gs of
- NONE => INL (Queue.enque ts)
- | SOME {handler, value} =>
- (Handler.schedule () handler ; INR value))
+ E (fn () =>
+ case Queue.dequeWhile (Handler.scheduled o #handler) gs of
+ NONE => INL (Queue.enque ts)
+ | SOME {handler, value} =>
+ (Handler.schedule () handler ; INR value))
fun give (T {ts, gs}) v =
- Event.T (fn () =>
- case Queue.dequeWhile Handler.scheduled ts of
- SOME th => (Handler.schedule v th ; INR ())
- | NONE =>
- INL (fn h => Queue.enque gs {handler = h, value = v}))
+ E (fn () =>
+ case Queue.dequeWhile Handler.scheduled ts of
+ SOME th => (Handler.schedule v th ; INR ())
+ | NONE =>
+ INL (fn h => Queue.enque gs {handler = h, value = v}))
fun send m = Event.once o give m
end
@@ -89,10 +91,10 @@
datatype 'a t = T of {rs : 'a Handler.t Queue.t, st : 'a Option.t Ref.t}
fun new () = T {rs = Queue.new (), st = ref NONE}
fun read (T {rs, st}) =
- Event.T (fn () =>
- case !st of
- SOME v => INR v
- | NONE => INL (Queue.enque rs))
+ E (fn () =>
+ case !st of
+ SOME v => INR v
+ | NONE => INL (Queue.enque rs))
fun fill (T {rs, st}) v =
case !st of
SOME _ => raise Full
@@ -103,10 +105,10 @@
datatype 'a t = T of {ts : 'a Handler.t Queue.t, st : 'a Option.t Ref.t}
fun new () = T {ts = Queue.new (), st = ref NONE}
fun take (T {ts, st}) =
- Event.T (fn () =>
- case !st of
- SOME v => (st := NONE ; INR v)
- | NONE => INL (Queue.enque ts))
+ E (fn () =>
+ case !st of
+ SOME v => (st := NONE ; INR v)
+ | NONE => INL (Queue.enque ts))
fun fill (T {ts, st}) v =
case !st of
SOME _ => raise Full
@@ -123,10 +125,10 @@
fun taker (T st) = let
val ch = Ch.new ()
fun lp st =
- Event.when (IVar.read st,
- fn N (v, st) =>
- Event.when (Ch.give ch v,
- fn () => lp st))
+ when (IVar.read st,
+ fn N (v, st) =>
+ when (Ch.give ch v,
+ fn () => lp st))
in
lp (!st) ; Ch.take ch
end
Modified: mltonlib/trunk/com/ssh/async/unstable/public/async.sig
===================================================================
--- mltonlib/trunk/com/ssh/async/unstable/public/async.sig 2007-02-27 10:04:30 UTC (rev 5347)
+++ mltonlib/trunk/com/ssh/async/unstable/public/async.sig 2007-02-27 12:15:23 UTC (rev 5348)
@@ -27,53 +27,54 @@
structure Event : sig
type 'a t
+ (** The type of asynchronous events. *)
+ end
- (** == Combinators == *)
+ (** == Combinators == *)
- val on : 'a t * ('a -> 'b) -> 'b t
- (**
- * Creates an event that acts like the given event and also executes
- * the given function on the event value when the created event is
- * committed.
- *)
+ val on : 'a Event.t * ('a -> 'b) -> 'b Event.t
+ (**
+ * Creates an event that acts like the given event and also executes
+ * the given function on the event value when the created event is
+ * committed.
+ *)
- val choose : 'a t List.t -> 'a t
- (**
- * Creates an event that chooses, in an unspecified manner, an
- * occured event from the given list of events to commit.
- *)
+ val choose : 'a Event.t List.t -> 'a Event.t
+ (**
+ * Creates an event that chooses, in an unspecified manner, an occured
+ * event from the given list of events to commit.
+ *)
- (** == Handling Events == *)
+ (** == Handling Events == *)
- val once : Unit.t t Effect.t
- (**
- * Commit to the given event once when it occurs. The handlers
- * attached to a committed event are executed when {Handler.runAll}
- * is called.
- *)
+ val once : Unit.t Event.t Effect.t
+ (**
+ * Commit to the given event once when it occurs. The handlers
+ * attached to a committed event are executed when {Handler.runAll} is
+ * called.
+ *)
- (** == Utilities == *)
+ (** == Utilities == *)
- val each : Unit.t t Effect.t
- (**
- * Commit to the given event each time it occurs. {each} can be
- * implemented as
- *
- *> fun each e = when (e, fn () => each e)
- *)
+ val each : Unit.t Event.t Effect.t
+ (**
+ * Commit to the given event each time it occurs. {each} can be
+ * implemented as
+ *
+ *> fun each e = when (e, fn () => each e)
+ *)
- val when : ('a t * 'a Effect.t) Effect.t
- (** {when (e, h) = once (on (e, h))} *)
+ val when : ('a Event.t * 'a Effect.t) Effect.t
+ (** {when (e, h) = once (on (e, h))} *)
- val every : ('a t * 'a Effect.t) Effect.t
- (** {every (e, h) = each (on (e, h))} *)
+ val every : ('a Event.t * 'a Effect.t) Effect.t
+ (** {every (e, h) = each (on (e, h))} *)
- val any : Unit.t t List.t Effect.t
- (** {any = once o choose} *)
+ val any : Unit.t Event.t List.t Effect.t
+ (** {any = once o choose} *)
- val all : Unit.t t List.t Effect.t
- (** {all = each o choose} *)
- end
+ val all : Unit.t Event.t List.t Effect.t
+ (** {all = each o choose} *)
(** == Communication Mechanisms ==
*
Modified: mltonlib/trunk/com/ssh/async/unstable/test/async.sml
===================================================================
--- mltonlib/trunk/com/ssh/async/unstable/test/async.sml 2007-02-27 10:04:30 UTC (rev 5347)
+++ mltonlib/trunk/com/ssh/async/unstable/test/async.sml 2007-02-27 12:15:23 UTC (rev 5348)
@@ -5,7 +5,7 @@
*)
val () = let
- open UnitTest Async Async.Event Async.Handler
+ open UnitTest Async Async.Handler
fun eq (ac, ex) = verifyEq Type.int {actual = ac, expect = ex}
fun eql (ac, ex) = verifyEq (Type.list Type.int) {actual = ac, expect = ex}
val full = verifyFailsWith (fn Full => true | _ => false)
More information about the MLton-commit
mailing list