[MLton-commit] r5335
Vesa Karvonen
vesak at mlton.org
Mon Feb 26 11:06:01 PST 2007
Initial commit. Untested.
----------------------------------------------------------------------
A mltonlib/trunk/com/ssh/async/
A mltonlib/trunk/com/ssh/async/unstable/
A mltonlib/trunk/com/ssh/async/unstable/LICENSE
A mltonlib/trunk/com/ssh/async/unstable/README
A mltonlib/trunk/com/ssh/async/unstable/detail/
A mltonlib/trunk/com/ssh/async/unstable/detail/async.sml
A mltonlib/trunk/com/ssh/async/unstable/lib.mlb
A mltonlib/trunk/com/ssh/async/unstable/public/
A mltonlib/trunk/com/ssh/async/unstable/public/async.sig
A mltonlib/trunk/com/ssh/async/unstable/public/export.sml
----------------------------------------------------------------------
Copied: mltonlib/trunk/com/ssh/async/unstable/LICENSE (from rev 5333, mltonlib/trunk/com/ssh/misc-util/unstable/LICENSE)
Added: mltonlib/trunk/com/ssh/async/unstable/README
===================================================================
--- mltonlib/trunk/com/ssh/async/unstable/README 2007-02-26 16:45:11 UTC (rev 5334)
+++ mltonlib/trunk/com/ssh/async/unstable/README 2007-02-26 19:06:00 UTC (rev 5335)
@@ -0,0 +1,51 @@
+Library for Asynchronous Programming in SML
+-------------------------------------------
+
+ This library implements a simple and portable library for asynchronous
+ programming in SML. The design of this library is heavily based on
+ [1], which is a library posted by Stephen Weeks to the MLton-user
+ mailing list.
+
+
+Info
+----
+
+ License: MLton license (a BSD-style license)
+ Portability: portable
+ Stability: experimental
+ Maintainer: Vesa Karvonen <vesa.karvonen at cs.helsinki.fi>
+
+
+About Library Organization
+--------------------------
+
+ public/
+
+ This directory contains the documented signature definitions (*.sig)
+ and listings of all top-level bindings exported by this library
+ (export*.sml). The contents of this directory should be sufficient
+ to understand how to use the functionality provided by this library.
+
+ lib.mlb
+
+ This build file defines the library. See the file for further
+ instructions.
+
+ detail/
+
+ This directory contains the implementation details of the library.
+
+
+About Motivation and Scope
+--------------------------
+
+ See [1] for starters.
+
+
+References
+----------
+
+ [1] Simple, portable, asynchronous programming in SML.
+ Stephen Weeks.
+ Posted on the mlton-user at mlton.org mailing list on July 19th, 2006.
+ [http://mlton.org/pipermail/mlton-user/2006-July/000856.html]
Property changes on: mltonlib/trunk/com/ssh/async/unstable/README
___________________________________________________________________
Name: svn:eol-style
+ native
Added: mltonlib/trunk/com/ssh/async/unstable/detail/async.sml
===================================================================
--- mltonlib/trunk/com/ssh/async/unstable/detail/async.sml 2007-02-26 16:45:11 UTC (rev 5334)
+++ mltonlib/trunk/com/ssh/async/unstable/detail/async.sml 2007-02-26 19:06:00 UTC (rev 5335)
@@ -0,0 +1,133 @@
+(* Copyright (C) 2007 SSH Communications Security, Helsinki, Finland
+ *
+ * This code is released under the MLton license, a BSD-style license.
+ * See the LICENSE file or http://mlton.org/License for details.
+ *)
+
+structure Async :> ASYNC = struct
+ exception Put
+
+ structure Queue = struct
+ open Queue
+ fun find p q =
+ case Queue.deque q of
+ NONE => NONE
+ | SOME t => if p t then find p q else SOME t
+ end
+
+ structure Handler = struct
+ datatype 'a t = T of {scheduled : Bool.t Ref.t, effect : 'a Effect.t}
+ fun new () = T {scheduled = ref false, effect = id}
+ fun scheduled (T t) = !(#scheduled t)
+ fun prepend f (T t) = T {scheduled = #scheduled t, effect = #effect t o f}
+ local
+ val handlers = Queue.new ()
+ in
+ fun schedule a (T {scheduled, effect}) =
+ if !scheduled then ()
+ else (scheduled := true ; Queue.enque handlers (fn () => effect a))
+ fun runAll () = Queue.appClear (pass ()) handlers
+ end
+ end
+
+ structure Event = struct
+ datatype 'a t = T of ('a Handler.t Effect.t, 'a Thunk.t) Sum.t Thunk.t
+ fun on (T t, f) = T (Sum.map (op o /> Handler.prepend f, f <\ op o) o t)
+ fun choose es =
+ T (fn () =>
+ recur (es & []) (fn lp =>
+ fn [] & efs =>
+ INL (fn h =>
+ recur efs (fn lp =>
+ fn [] => ()
+ | ef::efs =>
+ (ef h
+ ; if Handler.scheduled h then ()
+ else lp efs)))
+ | T 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 ()), pass ()) (t ())
+ fun each e = once (on (e, fn () => each e))
+ fun when ? = once (on ?)
+ fun every ? = each (on ?)
+ val any = once o choose
+ end
+
+ 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.find (not o Handler.scheduled o #handler) gs of
+ NONE => INL (Queue.enque ts)
+ | SOME {handler, value} =>
+ INR (fn () => (Handler.schedule () handler ; value)))
+ fun give (T {ts, gs}) v =
+ Event.T (fn () =>
+ case Queue.find (not o Handler.scheduled) ts of
+ SOME th => INR (fn () => Handler.schedule v th)
+ | NONE =>
+ INL (fn h => Queue.enque gs {handler = h, value = v}))
+ fun send m = Event.once o give m
+ end
+
+ structure Mailbox = Ch
+
+ structure IVar = struct
+ 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 (const v)
+ | NONE => INL (Queue.enque rs))
+ fun put (T {rs, st}) v =
+ case !st of
+ SOME _ => raise Put
+ | NONE => (st := SOME v ; Queue.appClear (Handler.schedule v) rs)
+ end
+
+ structure MVar = struct
+ 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 => INR (fn () => (st := NONE ; v))
+ | NONE => INL (Queue.enque ts))
+ fun put (T {ts, st}) v =
+ case !st of
+ SOME _ => raise Put
+ | NONE =>
+ case Queue.find (not o Handler.scheduled) ts of
+ NONE => st := SOME v
+ | SOME h => Handler.schedule v h
+ end
+
+ structure Multicast = struct
+ datatype 'a n = N of 'a * 'a n IVar.t
+ datatype 'a t = T of 'a n IVar.t Ref.t
+ fun new () = T (ref (IVar.new ()))
+ fun taker (T st) = let
+ val ch = Ch.new ()
+ in
+ recur (!st) (fn lp =>
+ fn st =>
+ Event.when (IVar.read st,
+ fn N (v, st) =>
+ Event.when (Ch.give ch v,
+ fn () => lp st)))
+ ; Ch.take ch
+ end
+ fun send (T st) v = let
+ val ost = !st
+ val nst = IVar.new ()
+ in
+ st := nst ; IVar.put ost (N (v, nst))
+ end
+ end
+end
Property changes on: mltonlib/trunk/com/ssh/async/unstable/detail/async.sml
___________________________________________________________________
Name: svn:eol-style
+ native
Added: mltonlib/trunk/com/ssh/async/unstable/lib.mlb
===================================================================
--- mltonlib/trunk/com/ssh/async/unstable/lib.mlb 2007-02-26 16:45:11 UTC (rev 5334)
+++ mltonlib/trunk/com/ssh/async/unstable/lib.mlb 2007-02-26 19:06:00 UTC (rev 5335)
@@ -0,0 +1,21 @@
+(* Copyright (C) 2007 SSH Communications Security, Helsinki, Finland
+ *
+ * This code is released under the MLton license, a BSD-style license.
+ * See the LICENSE file or http://mlton.org/License for details.
+ *)
+
+local
+ $(MLTON_LIB)/com/ssh/extended-basis/unstable/basis.mlb
+ $(MLTON_LIB)/com/ssh/misc-util/unstable/lib.mlb
+
+ ann
+ "forceUsed"
+ "sequenceNonUnit warn"
+ "warnUnused true"
+ in
+ public/async.sig
+ detail/async.sml
+ end
+in
+ public/export.sml
+end
Property changes on: mltonlib/trunk/com/ssh/async/unstable/lib.mlb
___________________________________________________________________
Name: svn:eol-style
+ native
Added: mltonlib/trunk/com/ssh/async/unstable/public/async.sig
===================================================================
--- mltonlib/trunk/com/ssh/async/unstable/public/async.sig 2007-02-26 16:45:11 UTC (rev 5334)
+++ mltonlib/trunk/com/ssh/async/unstable/public/async.sig 2007-02-26 19:06:00 UTC (rev 5335)
@@ -0,0 +1,79 @@
+(* Copyright (C) 2007 SSH Communications Security, Helsinki, Finland
+ *
+ * This code is released under the MLton license, a BSD-style license.
+ * See the LICENSE file or http://mlton.org/License for details.
+ *)
+
+signature ASYNC = sig
+ exception Put
+
+ (** == Handlers == *)
+
+ structure Handler : sig
+ val runAll : Unit.t Effect.t
+ end
+
+ (** == Events == *)
+
+ structure Event : sig
+ type 'a t
+
+ (** == Combinators == *)
+
+ val on : 'a t * ('a -> 'b) -> 'b t
+ val choose : 'a t List.t -> 'a t
+
+ (** == Handling Events == *)
+
+ val once : Unit.t t Effect.t
+ val each : Unit.t t Effect.t
+
+ (** == Utilities == *)
+
+ val when : ('a 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 any : Unit.t t List.t Effect.t
+ (** {any = once o choose} *)
+ end
+
+ (** == Communication Mechanisms == *)
+
+ structure Ch : sig
+ type 'a t
+ val new : 'a t Thunk.t
+ val take : 'a t -> 'a Event.t
+ val give : 'a t -> 'a -> Unit.t Event.t
+ end
+
+ structure IVar : sig
+ type 'a t
+ val new : 'a t Thunk.t
+ val read : 'a t -> 'a Event.t
+ val put : 'a t -> 'a Effect.t
+ end
+
+ structure MVar : sig
+ type 'a t
+ val new : 'a t Thunk.t
+ val take : 'a t -> 'a Event.t
+ val put : 'a t -> 'a Effect.t
+ end
+
+ structure Mailbox : sig
+ type 'a t
+ val new : 'a t Thunk.t
+ val take : 'a t -> 'a Event.t
+ val send : 'a t -> 'a Effect.t
+ end
+
+ structure Multicast : sig
+ type 'a t
+ val new : 'a t Thunk.t
+ val taker : 'a t -> 'a Event.t
+ val send : 'a t -> 'a Effect.t
+ end
+end
Property changes on: mltonlib/trunk/com/ssh/async/unstable/public/async.sig
___________________________________________________________________
Name: svn:eol-style
+ native
Added: mltonlib/trunk/com/ssh/async/unstable/public/export.sml
===================================================================
--- mltonlib/trunk/com/ssh/async/unstable/public/export.sml 2007-02-26 16:45:11 UTC (rev 5334)
+++ mltonlib/trunk/com/ssh/async/unstable/public/export.sml 2007-02-26 19:06:00 UTC (rev 5335)
@@ -0,0 +1,9 @@
+(* Copyright (C) 2007 SSH Communications Security, Helsinki, Finland
+ *
+ * This code is released under the MLton license, a BSD-style license.
+ * See the LICENSE file or http://mlton.org/License for details.
+ *)
+
+signature ASYNC = ASYNC
+
+structure Async : ASYNC = Async
Property changes on: mltonlib/trunk/com/ssh/async/unstable/public/export.sml
___________________________________________________________________
Name: svn:eol-style
+ native
More information about the MLton-commit
mailing list