[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