[MLton-commit] r6491

Vesa Karvonen vesak at mlton.org
Mon Mar 17 13:56:50 PST 2008


Added iterator/loop combinators, Iter : ITER.
----------------------------------------------------------------------

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

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

Modified: mltonlib/trunk/com/ssh/extended-basis/unstable/detail/bootstrap.sml
===================================================================
--- mltonlib/trunk/com/ssh/extended-basis/unstable/detail/bootstrap.sml	2008-03-16 19:07:04 UTC (rev 6490)
+++ mltonlib/trunk/com/ssh/extended-basis/unstable/detail/bootstrap.sml	2008-03-17 21:56:48 UTC (rev 6491)
@@ -1,4 +1,4 @@
-(* Copyright (C) 2006-2007 SSH Communications Security, Helsinki, Finland
+(* Copyright (C) 2006-2008 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.
@@ -20,7 +20,9 @@
 structure ArraySlice = struct open BasisArraySlice type 'a t = 'a slice end
 structure Char = struct open BasisChar type t = char end
 structure CharArray = struct open BasisCharArray type t = array end
+structure CharArraySlice = struct open BasisCharArraySlice type t = slice end
 structure CharVector = struct open BasisCharVector type t = vector end
+structure CharVectorSlice = struct open BasisCharVectorSlice type t = slice end
 structure Effect = struct type 'a t = 'a -> Unit.t end
 structure FixedInt = struct open BasisFixedInt type t = int end
 structure Int = struct open BasisInt type t = int end
@@ -41,7 +43,9 @@
 structure Word = struct open BasisWord type t = word end
 structure Word8 = struct open BasisWord8 type t = word end
 structure Word8Array = struct open BasisWord8Array type t = array end
+structure Word8ArraySlice = struct open BasisWord8ArraySlice type t = slice end
 structure Word8Vector = struct open BasisWord8Vector type t = vector end
+structure Word8VectorSlice = struct open BasisWord8VectorSlice type t = slice end
 structure Pair = struct
    type ('a, 'b) pair = 'a * 'b
    type ('a, 'b) t = ('a, 'b) pair

Added: mltonlib/trunk/com/ssh/extended-basis/unstable/detail/control/iter.sml
===================================================================
--- mltonlib/trunk/com/ssh/extended-basis/unstable/detail/control/iter.sml	2008-03-16 19:07:04 UTC (rev 6490)
+++ mltonlib/trunk/com/ssh/extended-basis/unstable/detail/control/iter.sml	2008-03-17 21:56:48 UTC (rev 6491)
@@ -0,0 +1,78 @@
+(* Copyright (C) 2008 Vesa Karvonen
+ *
+ * This code is released under the MLton license, a BSD-style license.
+ * See the LICENSE file or http://mlton.org/License for details.
+ *)
+
+structure Iter :> ITER = struct
+   infix 1 <|> until when by
+   infix 0 >>= &
+
+   datatype product = datatype Product.product
+
+   type 'a t = ('a, Unit.t) CPS.t
+
+   structure Monad =
+      MkMonadP (type 'a monad = 'a t
+                open CPS
+                val zero = ignore
+                fun a <|> b = b o Effect.obs a)
+   open Monad
+
+   fun unfold g s f =
+       case g s of NONE => () | SOME (x, s) => (f x : Unit.t ; unfold g s f)
+
+   exception S
+   fun (m until p) f = m (fn x => if p x then raise S else f x) handle S => ()
+
+   fun index m f = (fn i => m (fn a => f (a & !i before i := !i+1))) (ref 0)
+
+   fun iterate f = unfold (fn x => SOME (x, f x))
+
+   fun m when p = m >>= (fn x => if p x then return x else zero)
+   fun m by f = map f m
+
+   fun subscript b = if b then () else raise Subscript
+
+   val up = iterate (fn x => x+1)
+   fun upToBy l u d =
+       (subscript (l <= u andalso 0 < d)
+      ; unfold (fn l => if l<u then SOME (l, l+d) else NONE) l)
+   fun upTo l u = upToBy l u 1
+
+   val down = unfold (fn x => SOME (x-1, x-1))
+   fun downToBy u l d =
+       (subscript (l <= u andalso 0 < d)
+      ; unfold (fn u => if l<u then SOME (u-d, u-d) else NONE) u)
+   fun downTo u l = downToBy u l 1
+
+   fun inList s = unfold List.getItem s
+
+   fun inArraySlice s = unfold BasisArraySlice.getItem s
+   fun inVectorSlice s = unfold BasisVectorSlice.getItem s
+
+   fun inArray s = Fn.flip Array.app s
+   fun inVector s = Fn.flip Vector.app s
+
+   val inCharArraySlice = unfold BasisCharArraySlice.getItem
+   val inCharVectorSlice = unfold BasisCharVectorSlice.getItem
+   val inSubstring = inCharVectorSlice
+   val inWord8ArraySlice = unfold BasisWord8ArraySlice.getItem
+   val inWord8VectorSlice = unfold BasisWord8VectorSlice.getItem
+
+   val inCharArray = Fn.flip CharArray.app
+   val inCharVector = Fn.flip CharVector.app
+   val inString = inCharVector
+   val inWord8Array = Fn.flip Word8Array.app
+   val inWord8Vector = Fn.flip Word8Vector.app
+
+   val for = Fn.id
+   fun fold f s m = (fn s => (m (fn x => s := f (x, !s)) : Unit.t ; !s)) (ref s)
+   fun reduce zero plus one = fold plus zero o map one
+   fun find p m = let
+      exception S of 'a
+   in
+      NONE before m (fn x => if p x then raise S x else ()) handle S x => SOME x
+   end
+   fun collect m = rev (fold op :: [] m)
+end


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

Modified: mltonlib/trunk/com/ssh/extended-basis/unstable/detail/ml/common/basis.sml
===================================================================
--- mltonlib/trunk/com/ssh/extended-basis/unstable/detail/ml/common/basis.sml	2008-03-16 19:07:04 UTC (rev 6490)
+++ mltonlib/trunk/com/ssh/extended-basis/unstable/detail/ml/common/basis.sml	2008-03-17 21:56:48 UTC (rev 6491)
@@ -83,7 +83,9 @@
 structure BasisByte = Byte
 structure BasisChar = Char
 structure BasisCharArray = CharArray
+structure BasisCharArraySlice = CharArraySlice
 structure BasisCharVector = CharVector
+structure BasisCharVectorSlice = CharVectorSlice
 structure BasisCommandLine = CommandLine
 structure BasisDate = Date
 structure BasisGeneral = General

Modified: mltonlib/trunk/com/ssh/extended-basis/unstable/detail/ml/smlnj/sigs.cm
===================================================================
--- mltonlib/trunk/com/ssh/extended-basis/unstable/detail/ml/smlnj/sigs.cm	2008-03-16 19:07:04 UTC (rev 6490)
+++ mltonlib/trunk/com/ssh/extended-basis/unstable/detail/ml/smlnj/sigs.cm	2008-03-17 21:56:48 UTC (rev 6491)
@@ -30,6 +30,7 @@
    ../../../public/concept/wordable.sig
    ../../../public/control/exit.sig
    ../../../public/control/exn.sig
+   ../../../public/control/iter.sig
    ../../../public/control/with.sig
    ../../../public/data/bool.sig
    ../../../public/data/option.sig

Modified: mltonlib/trunk/com/ssh/extended-basis/unstable/detail/ml/smlnj/unsealed.cm
===================================================================
--- mltonlib/trunk/com/ssh/extended-basis/unstable/detail/ml/smlnj/unsealed.cm	2008-03-16 19:07:04 UTC (rev 6490)
+++ mltonlib/trunk/com/ssh/extended-basis/unstable/detail/ml/smlnj/unsealed.cm	2008-03-17 21:56:48 UTC (rev 6491)
@@ -19,6 +19,7 @@
    ../../../detail/concept/mk-word-flags.fun
    ../../../detail/control/exit.sml
    ../../../detail/control/exn.sml
+   ../../../detail/control/iter.sml
    ../../../detail/control/with.sml
    ../../../detail/data/bool.sml
    ../../../detail/data/option.sml

Modified: mltonlib/trunk/com/ssh/extended-basis/unstable/extensions.mlb
===================================================================
--- mltonlib/trunk/com/ssh/extended-basis/unstable/extensions.mlb	2008-03-16 19:07:04 UTC (rev 6490)
+++ mltonlib/trunk/com/ssh/extended-basis/unstable/extensions.mlb	2008-03-17 21:56:48 UTC (rev 6491)
@@ -302,6 +302,10 @@
          public/sequence/stream.sig
          detail/sequence/stream.sml
 
+         (* Iter *)
+         public/control/iter.sig
+         detail/control/iter.sml
+
          (* Lazy *)
          public/lazy/lazy.sig
          detail/lazy/lazy.sml

Modified: mltonlib/trunk/com/ssh/extended-basis/unstable/extensions.use
===================================================================
--- mltonlib/trunk/com/ssh/extended-basis/unstable/extensions.use	2008-03-16 19:07:04 UTC (rev 6490)
+++ mltonlib/trunk/com/ssh/extended-basis/unstable/extensions.use	2008-03-17 21:56:48 UTC (rev 6491)
@@ -160,6 +160,8 @@
      "detail/ml/${SML_COMPILER}/texts.sml",
      "public/sequence/stream.sig",
      "detail/sequence/stream.sml",
+     "public/control/iter.sig",
+     "detail/control/iter.sml",
      "public/lazy/lazy.sig",
      "detail/lazy/lazy.sml",
      "public/fn/shift-op.sig",

Added: mltonlib/trunk/com/ssh/extended-basis/unstable/public/control/iter.sig
===================================================================
--- mltonlib/trunk/com/ssh/extended-basis/unstable/public/control/iter.sig	2008-03-16 19:07:04 UTC (rev 6490)
+++ mltonlib/trunk/com/ssh/extended-basis/unstable/public/control/iter.sig	2008-03-17 21:56:48 UTC (rev 6491)
@@ -0,0 +1,125 @@
+(* Copyright (C) 2008 Vesa Karvonen
+ *
+ * This code is released under the MLton license, a BSD-style license.
+ * See the LICENSE file or http://mlton.org/License for details.
+ *)
+
+(** Signature for iterator or loop combinators. *)
+signature ITER = sig
+   type 'a t = ('a, Unit.t) CPS.t
+   (** The type of iterator functions. *)
+
+   (** == Running Iterators == *)
+
+   val for : 'a t -> ('a, Unit.t) CPS.t
+   (**
+    *> for [<>]                f = ()
+    *> for [<x(0), x(1), ...>] f = (f x(0) ; for [<x(1), ...>] f)
+    *
+    * This is actually the identity function and is provided purely for
+    * syntactic sugar.
+    *)
+
+   val fold : ('a * 'b -> 'b) -> 'b -> 'a t -> 'b
+   (**
+    *> fold f s [<>]                      = s
+    *> fold f s [<x(0), x(1), ..., x(n)>] =
+    *>    fold f (f (x(0), s)) [<x(1), ..., x(n)>]
+    *)
+
+   val find : 'a UnPr.t -> 'a t -> 'a Option.t
+   (**
+    *> find p [<>]                = NONE
+    *> find p [<x(0), x(1), ...>] =
+    *>    if p x(0) then SOME x(n) else find p [<x(1), ...>]
+    *)
+
+   val reduce : 'b -> 'b BinOp.t -> ('a -> 'b) -> 'a t -> 'b
+   (** {reduce zero plus one = fold plus zero o Monad.map one} *)
+
+   val collect : 'a t -> 'a List.t
+   (** {collect [<x(0), x(1), ..., x(n)>] = [x(0), x(1), ..., x(n)]} *)
+
+   (** == Combinators == *)
+
+   include MONADP_CORE where type 'a monad = 'a t
+   structure Monad : MONADP where type 'a monad = 'a t
+
+   val unfold : ('a, 's) Reader.t -> 's -> 'a t
+   (**
+    *> unfold g s f =
+    *>    case g s of NONE        => ()
+    *>              | SOME (x, s) => (f x ; unfold g s f)
+    *)
+
+   val until : 'a t * 'a UnPr.t -> 'a t
+   (**
+    * {[<x(0), x(1), ...>] until p = [<x(0), x(1), ..., x(n)>]} where {p
+    * x(i) = false} for all {0<=i<=n} and {p x(n+1) = true}.
+    *)
+
+   val index : 'a t -> ('a, Int.t) Product.t t
+   (** {index [<x(0), x(1), ...>] = [<x(0) & 0, x(1) & 1, ...>]} *)
+
+   val iterate : 'a UnOp.t -> 'a -> 'a t
+   (** {iterate f x = [<x, f x, f (f x), ...>]} *)
+
+   val when : 'a t * 'a UnPr.t -> 'a t
+
+   val by : 'a t * ('a -> 'b) -> 'b t
+   (**
+    *> [<x(0), x(1), ...>] by f = [<f x(0), f x(1), ...>]
+    *
+    * {s by f} is the same as {Monad.map f s}.
+    *)
+
+   val >< : 'a t * 'b t -> ('a, 'b) Product.t t
+   (**
+    *> [<x(0), x(1), ...>] >< [<y(0), y(1), ..., y(n)>] =
+    *>    [<x(0) & y(0), x(0) & y(1), ..., x(0) & y(n),
+    *>      x(1) & y(0), x(1) & y(1), ..., x(1) & y(n),
+    *>      ...>]
+    *
+    * This is the same as {Monad.><}.
+    *)
+
+   (** == Iterating over Integers == *)
+
+   val up : Int.t -> Int.t t
+   (** {up l = [<l, l+1, ...>]} *)
+
+   val upTo : Int.t -> Int.t -> Int.t t
+   (** {upTo l u = [<l, l+1, ..., u-1>]} *)
+
+   val upToBy : Int.t -> Int.t -> Int.t -> Int.t t
+   (** {upToBy l u d = [<l+0*d, l+1*d, ..., l + (u-l) div d * d>]} *)
+
+   val down : Int.t -> Int.t t
+   (** {down u = [<u-1, u-2, ...>]} *)
+
+   val downTo : Int.t -> Int.t -> Int.t t
+   (** {downTo u l = [<u-1, u-2, ..., l>]} *)
+
+   val downToBy : Int.t -> Int.t -> Int.t -> Int.t t
+   (** {downToBy u l d = [<u-1*d, u-2*d, ..., u - (u-l+d-1) div d * d>]} *)
+
+   (** == Iterators Over Standard Sequences == *)
+
+   val inList : 'a List.t -> 'a t
+
+   val inArray : 'a Array.t -> 'a t
+   val inArraySlice : 'a ArraySlice.t -> 'a t
+   val inVector : 'a Vector.t -> 'a t
+   val inVectorSlice : 'a VectorSlice.t -> 'a t
+
+   val inCharArray : CharArray.t -> Char.t t
+   val inCharArraySlice : CharArraySlice.t -> Char.t t
+   val inCharVector : CharVector.t -> Char.t t
+   val inCharVectorSlice : CharVectorSlice.t -> Char.t t
+   val inString : String.t -> Char.t t
+   val inSubstring : Substring.t -> Char.t t
+   val inWord8Array : Word8Array.t -> Word8.t t
+   val inWord8ArraySlice : Word8ArraySlice.t -> Word8.t t
+   val inWord8Vector : Word8Vector.t -> Word8.t t
+   val inWord8VectorSlice : Word8VectorSlice.t -> Word8.t t
+end


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




More information about the MLton-commit mailing list