[MLton-commit] r4893

[Vesa K. <ve...@ml...>]

Added scoped resource management combinators.
----------------------------------------------------------------------

U   mltonlib/trunk/com/ssh/extended-basis/unstable/basis.use
U   mltonlib/trunk/com/ssh/extended-basis/unstable/detail/bootstrap.sml
U   mltonlib/trunk/com/ssh/extended-basis/unstable/detail/smlnj/sigs.cm
U   mltonlib/trunk/com/ssh/extended-basis/unstable/detail/smlnj/unsealed.cm
A   mltonlib/trunk/com/ssh/extended-basis/unstable/detail/with.sml
U   mltonlib/trunk/com/ssh/extended-basis/unstable/extensions.mlb
U   mltonlib/trunk/com/ssh/extended-basis/unstable/extensions.use
U   mltonlib/trunk/com/ssh/extended-basis/unstable/public/export.sml
A   mltonlib/trunk/com/ssh/extended-basis/unstable/public/with.sig

----------------------------------------------------------------------

Modified: mltonlib/trunk/com/ssh/extended-basis/unstable/basis.use
===================================================================
--- mltonlib/trunk/com/ssh/extended-basis/unstable/basis.use	2006-12-01 09:50:48 UTC (rev 4892)
+++ mltonlib/trunk/com/ssh/extended-basis/unstable/basis.use	2006-12-01 12:32:07 UTC (rev 4893)
@@ -4,4 +4,8 @@
  * See the LICENSE file or http://mlton.org/License for details.
  *)
 
+(* The use files of this library assume that they are used from the root
+ * directory of this library (the directory of this file).
+ *)
+
 val () = use "extensions.use"

Modified: mltonlib/trunk/com/ssh/extended-basis/unstable/detail/bootstrap.sml
===================================================================
--- mltonlib/trunk/com/ssh/extended-basis/unstable/detail/bootstrap.sml	2006-12-01 09:50:48 UTC (rev 4892)
+++ mltonlib/trunk/com/ssh/extended-basis/unstable/detail/bootstrap.sml	2006-12-01 12:32:07 UTC (rev 4893)
@@ -50,3 +50,4 @@
 structure BinPr = struct type 'a t = 'a Sq.t UnPr.t end
 structure Emb = struct type ('a, 'b) t = ('a -> 'b) * ('b -> 'a Option.t) end
 structure Iso = struct type ('a, 'b) t = ('a -> 'b) * ('b -> 'a) end
+structure With = struct type ('a, 'b) t = ('a -> 'b) -> 'b end

Modified: mltonlib/trunk/com/ssh/extended-basis/unstable/detail/smlnj/sigs.cm
===================================================================
--- mltonlib/trunk/com/ssh/extended-basis/unstable/detail/smlnj/sigs.cm	2006-12-01 09:50:48 UTC (rev 4892)
+++ mltonlib/trunk/com/ssh/extended-basis/unstable/detail/smlnj/sigs.cm	2006-12-01 12:32:07 UTC (rev 4893)
@@ -51,6 +51,7 @@
    ../../public/univ.sig
    ../../public/vector-slice.sig
    ../../public/vector.sig
+   ../../public/with.sig
    ../../public/word.sig
    ../../public/writer.sig
    funs.cm

Modified: mltonlib/trunk/com/ssh/extended-basis/unstable/detail/smlnj/unsealed.cm
===================================================================
--- mltonlib/trunk/com/ssh/extended-basis/unstable/detail/smlnj/unsealed.cm	2006-12-01 09:50:48 UTC (rev 4892)
+++ mltonlib/trunk/com/ssh/extended-basis/unstable/detail/smlnj/unsealed.cm	2006-12-01 12:32:07 UTC (rev 4893)
@@ -47,6 +47,7 @@
    ../univ.sml
    ../vector-slice.sml
    ../vector.sml
+   ../with.sml
    ../writer.sml
    ext.sml
    sigs.cm

Added: mltonlib/trunk/com/ssh/extended-basis/unstable/detail/with.sml
===================================================================
--- mltonlib/trunk/com/ssh/extended-basis/unstable/detail/with.sml	2006-12-01 09:50:48 UTC (rev 4892)
+++ mltonlib/trunk/com/ssh/extended-basis/unstable/detail/with.sml	2006-12-01 12:32:07 UTC (rev 4893)
@@ -0,0 +1,28 @@
+(* Copyright (C) 2006 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 With :> WITH = struct
+   open With
+
+   infix >>= >>&
+
+   val return = Fn.pass
+   fun (wA >>= a2wB) f = wA (fn a => a2wB a f)
+
+   fun alloc g a f = f (g a)
+   fun free ef x f = (f x handle e => (ef x ; raise e)) before ef x
+
+   fun (wA >>& wB) f = wA (fn a => wB (fn b => f (Product.& (a, b))))
+   fun around new del = alloc new () >>= free del
+   fun entry ef = alloc ef ()
+   fun exit ef = free ef ()
+   local
+      fun `f x () = f x
+   in
+      fun calling {entry, exit} v = around (`entry v) (`exit v)
+      fun passing ef {entry, exit} = around (`ef entry) (`ef exit)
+   end
+end


Property changes on: mltonlib/trunk/com/ssh/extended-basis/unstable/detail/with.sml
___________________________________________________________________
Name: svn:eol-style
   + native

Modified: mltonlib/trunk/com/ssh/extended-basis/unstable/extensions.mlb
===================================================================
--- mltonlib/trunk/com/ssh/extended-basis/unstable/extensions.mlb	2006-12-01 09:50:48 UTC (rev 4892)
+++ mltonlib/trunk/com/ssh/extended-basis/unstable/extensions.mlb	2006-12-01 12:32:07 UTC (rev 4893)
@@ -76,6 +76,11 @@
                detail/product.sml
             end
          end
+         basis With = let
+            open Fn Products
+         in
+            bas public/with.sig detail/with.sml end
+         end
          basis Sum = let open Fn in bas public/sum.sig detail/sum.sml end end
          basis Exn = let
             open Effect Ext Sum
@@ -186,7 +191,7 @@
          open Scalars Seqs Sq Sum
          open Thunk Tie
          open Unit Univ UnOp UnPr
-         open Writer
+         open With Writer
       in
          public/export-$(SML_COMPILER).sml
          public/export.sml

Modified: mltonlib/trunk/com/ssh/extended-basis/unstable/extensions.use
===================================================================
--- mltonlib/trunk/com/ssh/extended-basis/unstable/extensions.use	2006-12-01 09:50:48 UTC (rev 4892)
+++ mltonlib/trunk/com/ssh/extended-basis/unstable/extensions.use	2006-12-01 12:32:07 UTC (rev 4893)
@@ -34,6 +34,7 @@
         "detail/pair.sml",
         "public/product.sig",
         "detail/product.sml",
+        "public/with.sig", "detail/with.sml",
         "public/sum.sig", "detail/sum.sml",
         "public/exn.sig", "detail/exn.sml",
         "public/emb.sig", "detail/emb.sml",

Modified: mltonlib/trunk/com/ssh/extended-basis/unstable/public/export.sml
===================================================================
--- mltonlib/trunk/com/ssh/extended-basis/unstable/public/export.sml	2006-12-01 09:50:48 UTC (rev 4892)
+++ mltonlib/trunk/com/ssh/extended-basis/unstable/public/export.sml	2006-12-01 12:32:07 UTC (rev 4893)
@@ -50,6 +50,7 @@
 signature UN_PR = UN_PR
 signature VECTOR = VECTOR
 signature VECTOR_SLICE = VECTOR_SLICE
+signature WITH = WITH
 signature WORD = WORD
 signature WRITER = WRITER
 
@@ -99,6 +100,7 @@
 structure Univ : UNIV = Univ
 structure Vector : VECTOR = Vector
 structure VectorSlice : VECTOR_SLICE = VectorSlice
+structure With : WITH = With
 structure Word : WORD = Word
 structure Word8 : WORD = Word8
 structure Word8Array : MONO_ARRAY = Word8Array

Added: mltonlib/trunk/com/ssh/extended-basis/unstable/public/with.sig
===================================================================
--- mltonlib/trunk/com/ssh/extended-basis/unstable/public/with.sig	2006-12-01 09:50:48 UTC (rev 4892)
+++ mltonlib/trunk/com/ssh/extended-basis/unstable/public/with.sig	2006-12-01 12:32:07 UTC (rev 4893)
@@ -0,0 +1,83 @@
+(* Copyright (C) 2006 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.
+ *)
+
+(** Scoped resource management combinators. *)
+signature WITH = sig
+   type ('a, 'b) t = ('a -> 'b) -> 'b
+   (**
+    * Type for a form of continuation-passing style.
+    *
+    * In this context, a function of type {('a -> 'b) -> 'b} is referred
+    * to as a "with -procedure", and a continuation, of type {'a -> 'b},
+    * given to a with -procedure is called a "block".
+    *)
+
+   (** == Monad Interface == *)
+
+   val return : 'a -> ('a, 'r) t
+   (** Calls the block with the specified value.  Also see {alloc}. *)
+
+   val >>= : ('a, 'r) t * ('a -> ('b, 'r) t) -> ('b, 'r) t
+   (**
+    * Composes two with -procedures, passing any value produced by the
+    * first as an argument to the second.
+    *)
+
+   (** == Primitives == *)
+
+   val alloc : ('a -> 'b) -> 'a -> ('b, 'r) t
+   (**
+    * Apply the given function with the given value just before entry to
+    * the block.
+    *
+    * This is basically a lazy version of {return}.  Specifically, {alloc
+    * g a} is equivalent to {fn f => f (g a)}, assuming {g} and {a} are
+    * variables.
+    *)
+
+   val free : 'a Effect.t -> 'a -> ('a, 'r) t
+   (**
+    * Performs the effect with the given value after exit from the block.
+    * This is basically a variation of {finally}.  Specifically, {free ef
+    * x f} is equivalent to {finally (fn () => f x, fn () => ef x)}.
+    *)
+
+   (** == Useful Combinations == *)
+
+   val >>& : ('a, 'r) t * ('b, 'r) t -> (('a, 'b) Product.t, 'r) t
+   (** Product combinator. *)
+
+   val around : 'a Thunk.t -> 'a Effect.t -> ('a, 'r) t
+   (**
+    * Allocate resources with given thunk before entry to the block and
+    * release the resource with given effect after exit from the block.
+    * {around new del} is equivalent to {alloc new () >>= free del}.
+    *)
+
+   val entry : Unit.t Effect.t -> (Unit.t, 'r) t
+   (**
+    * Perform given effect before entry to the block.
+    *
+    * Note that the identifier {before} is already used in the Standard ML
+    * Basis Library.
+    *)
+
+   val exit : Unit.t Effect.t -> (Unit.t, 'r) t
+   (** Perform given effect after exit from the block. *)
+
+   val calling :
+       {entry : 'a Effect.t, exit : 'a Effect.t} -> 'a -> (Unit.t, 'r) t
+   (**
+    * Call given effects with the given value before entry to and after
+    * exit from the block.
+    *)
+
+   val passing : 'a Effect.t -> {entry : 'a, exit : 'a} -> (Unit.t, 'r) t
+   (**
+    * Call given effect with a given values before entry to and after exit
+    * from the block.
+    *)
+end


Property changes on: mltonlib/trunk/com/ssh/extended-basis/unstable/public/with.sig
___________________________________________________________________
Name: svn:eol-style
   + native