[MLton-commit] r5581
Vesa Karvonen
vesak at mlton.org
Sun Jun 3 22:33:38 PDT 2007
Fold.
----------------------------------------------------------------------
A mltonlib/trunk/com/ssh/extended-basis/unstable/detail/fold/
A mltonlib/trunk/com/ssh/extended-basis/unstable/detail/fold/fold.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/public/export/common.sml
U mltonlib/trunk/com/ssh/extended-basis/unstable/public/export/top-level.sml
A mltonlib/trunk/com/ssh/extended-basis/unstable/public/fold/
A mltonlib/trunk/com/ssh/extended-basis/unstable/public/fold/fold.sig
----------------------------------------------------------------------
Added: mltonlib/trunk/com/ssh/extended-basis/unstable/detail/fold/fold.sml
===================================================================
--- mltonlib/trunk/com/ssh/extended-basis/unstable/detail/fold/fold.sml 2007-06-03 16:15:21 UTC (rev 5580)
+++ mltonlib/trunk/com/ssh/extended-basis/unstable/detail/fold/fold.sml 2007-06-04 05:33:36 UTC (rev 5581)
@@ -0,0 +1,47 @@
+(* 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 Fold :> FOLD = struct
+ open Fn
+ datatype ('a, 'b, 'c) t = T of 'a * ('b -> 'c)
+ type ('a, 'b, 'c, 'd) f = (('a, 'b, 'c) t -> 'd) -> 'd
+ type ('a, 'b, 'c, 'd, 'e, 'f, 'g) s = ('a, 'b, 'c) t -> ('d, 'e, 'f, 'g) f
+ fun $ (T (t, f)) = f t
+ fun wrap (t, f) = pass (T (t, f))
+ fun unwrap f = f (fn T t => t)
+ fun map g (T t) = pass (T (g t))
+ (* The rest are not-primitive. *)
+ type ('a, 'b, 'c, 'd, 'e, 'f, 'g, 'h) s1 =
+ ('b, 'c, 'd) t -> 'a -> ('e, 'f, 'g, 'h) f
+ fun post g = wrap o Pair.map (id, fn f => g o f) o unwrap
+ fun unmap s t = wrap t s $
+ fun map1 g ? x = map (g x) ?
+ fun unmap1 s1 x t = wrap t s1 x $
+ fun rewrap f = wrap (unwrap f)
+ fun remap s = map (unmap s)
+ fun remap1 s1 = map1 (unmap1 s1)
+ fun mapFin g = map (Pair.map (id, g))
+ fun mapSt g = map (Pair.map (g, id))
+ fun mapSt1 g = map1 (fn x => Pair.map (g x, id))
+ fun l f t = f o t
+ fun r f t = t o f
+ fun comFinL g = mapFin (l g)
+ fun comFinR g = mapFin (r g)
+ fun comStL g = mapSt (l g)
+ fun comStR g = mapSt (r g)
+ fun comStL1 g = mapSt1 (l o g)
+ fun comStR1 g = mapSt1 (r o g)
+ structure NSZ = struct
+ datatype ('a, 'b, 'c, 'd, 'e, 'f, 'g) t =
+ T of 'a * (('b -> 'c) * ('d -> 'e) -> 'f -> 'g)
+ val wrap = fn {zero, none, some} =>
+ wrap (T (zero, Pair.fst), fn T (ac, get) => get (none, some) ac)
+ val mapSt = fn {none, some} =>
+ mapSt (fn T (ac, get) => T (get (none, some) ac, Pair.snd))
+ val mapSt1 = fn {none, some} =>
+ mapSt1 (fn x => fn T (ac, get) => T (get (none, some) x ac, Pair.snd))
+ end
+end
Property changes on: mltonlib/trunk/com/ssh/extended-basis/unstable/detail/fold/fold.sml
___________________________________________________________________
Name: svn:eol-style
+ native
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 2007-06-03 16:15:21 UTC (rev 5580)
+++ mltonlib/trunk/com/ssh/extended-basis/unstable/detail/ml/smlnj/sigs.cm 2007-06-04 05:33:36 UTC (rev 5581)
@@ -51,6 +51,7 @@
../../../public/fn/thunk.sig
../../../public/fn/un-op.sig
../../../public/fn/un-pr.sig
+ ../../../public/fold/fold.sig
../../../public/generic/emb.sig
../../../public/generic/fix.sig
../../../public/generic/iso.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 2007-06-03 16:15:21 UTC (rev 5580)
+++ mltonlib/trunk/com/ssh/extended-basis/unstable/detail/ml/smlnj/unsealed.cm 2007-06-04 05:33:36 UTC (rev 5581)
@@ -38,6 +38,7 @@
../../../detail/fn/thunk.sml
../../../detail/fn/un-op.sml
../../../detail/fn/un-pr.sml
+ ../../../detail/fold/fold.sml
../../../detail/generic/emb.sml
../../../detail/generic/fix.sml
../../../detail/generic/iso.sml
Modified: mltonlib/trunk/com/ssh/extended-basis/unstable/extensions.mlb
===================================================================
--- mltonlib/trunk/com/ssh/extended-basis/unstable/extensions.mlb 2007-06-03 16:15:21 UTC (rev 5580)
+++ mltonlib/trunk/com/ssh/extended-basis/unstable/extensions.mlb 2007-06-04 05:33:36 UTC (rev 5581)
@@ -166,6 +166,10 @@
public/data/product.sig
detail/data/product.sml
+ (* Fold *)
+ public/fold/fold.sig
+ detail/fold/fold.sml
+
(* MkMonad *)
detail/concept/mk-monad.fun
Modified: mltonlib/trunk/com/ssh/extended-basis/unstable/public/export/common.sml
===================================================================
--- mltonlib/trunk/com/ssh/extended-basis/unstable/public/export/common.sml 2007-06-03 16:15:21 UTC (rev 5580)
+++ mltonlib/trunk/com/ssh/extended-basis/unstable/public/export/common.sml 2007-06-04 05:33:36 UTC (rev 5581)
@@ -69,6 +69,7 @@
signature EXN = EXN
signature FIX = FIX
signature FN = FN
+signature FOLD = FOLD
signature INTEGER = INTEGER
signature INT_INF = INT_INF
signature ISO = ISO
@@ -143,6 +144,7 @@
structure Exn : EXN = Exn
structure Fix : FIX = Fix
structure Fn : FN = Fn
+structure Fold : FOLD = Fold
structure Int : INTEGER = Int
structure Iso : ISO = Iso
structure Iso : ISO = Iso
Modified: mltonlib/trunk/com/ssh/extended-basis/unstable/public/export/top-level.sml
===================================================================
--- mltonlib/trunk/com/ssh/extended-basis/unstable/public/export/top-level.sml 2007-06-03 16:15:21 UTC (rev 5580)
+++ mltonlib/trunk/com/ssh/extended-basis/unstable/public/export/top-level.sml 2007-06-04 05:33:36 UTC (rev 5581)
@@ -39,6 +39,10 @@
val op \> = Fn.\>
val op |< = Fn.|<
+(** === Fold === *)
+
+val $ = Fold.$
+
(** === Lazy === *)
type 'a lazy = 'a Lazy.t
Added: mltonlib/trunk/com/ssh/extended-basis/unstable/public/fold/fold.sig
===================================================================
--- mltonlib/trunk/com/ssh/extended-basis/unstable/public/fold/fold.sig 2007-06-03 16:15:21 UTC (rev 5580)
+++ mltonlib/trunk/com/ssh/extended-basis/unstable/public/fold/fold.sig 2007-06-04 05:33:36 UTC (rev 5581)
@@ -0,0 +1,72 @@
+(* 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 for combinators for defining variable arity functions.
+ *
+ * See also: [http://mlton.org/Fold]
+ *)
+signature FOLD = sig
+ type ('a, 'b, 'c) t
+ type ('a, 'b, 'c, 'd) f = (('a, 'b, 'c) t -> 'd) -> 'd
+ type ('a, 'b, 'c, 'd, 'e, 'f, 'g) s = ('a, 'b, 'c) t -> ('d, 'e, 'f, 'g) f
+ type ('a, 'b, 'c, 'd, 'e, 'f, 'g, 'h) s1 =
+ ('b, 'c, 'd) t -> 'a -> ('e, 'f, 'g, 'h) f
+
+ val $ : ('a, 'a, 'b) t -> 'b
+
+ val wrap : 'a * ('b -> 'c) -> ('a, 'b, 'c, 'd) f
+ val unwrap : ('a, 'b, 'c, 'a * ('b -> 'c)) f -> 'a * ('b -> 'c)
+ val rewrap : ('a, 'b, 'c, 'a * ('b -> 'c)) f -> ('a, 'b, 'c, 'd) f
+
+ val post : ('a -> 'b)
+ -> ('c, 'd, 'a, 'c * ('d -> 'a)) f
+ -> ('c, 'd, 'b, 'e) f
+
+ val map : ('a * ('b -> 'c) -> 'd * ('e -> 'f))
+ -> ('a, 'b, 'c, 'd, 'e, 'f, 'g) s
+ val unmap : ('a, 'b, 'c, 'd, 'd, 'd * ('e -> 'f), 'd * ('e -> 'f)) s
+ -> 'a * ('b -> 'c) -> 'd * ('e -> 'f)
+ val remap : ('a, 'b, 'c, 'd, 'd, 'd * ('e -> 'f), 'd * ('e -> 'f)) s
+ -> ('a, 'b, 'c, 'd, 'e, 'f, 'g) s
+
+ val map1 : ('a -> 'b * ('c -> 'd) -> 'e * ('f -> 'g))
+ -> ('a, 'b, 'c, 'd, 'e, 'f, 'g, 'h) s1
+ val unmap1 : ('a, 'b, 'c, 'd, 'e, 'e, 'e * ('f -> 'g), 'e * ('f -> 'g)) s1
+ -> 'a -> 'b * ('c -> 'd) -> 'e * ('f -> 'g)
+ val remap1 : ('a, 'b, 'c, 'd, 'e, 'e, 'e * ('f -> 'g), 'e * ('f -> 'g)) s1
+ -> ('a, 'b, 'c, 'd, 'e, 'f, 'g, 'h) s1
+
+ val mapFin : (('a -> 'b) -> 'c -> 'd) -> ('e, 'a, 'b, 'e, 'c, 'd, 'f) s
+ val mapSt : ('a -> 'b) -> ('a, 'c, 'd, 'b, 'c, 'd, 'e) s
+ val mapSt1 : ('a -> 'b1 -> 'b2) -> ('a, 'b1, 'c, 'd, 'b2, 'c, 'd, 'e) s1
+
+ val comFinL : ('a -> 'b) -> ('c, 'd, 'a, 'c, 'd, 'b, 'e) s
+ val comFinR : ('a -> 'b) -> ('c, 'b, 'd, 'c, 'a, 'd, 'e) s
+
+ val comStL : ('a -> 'b) -> ('c -> 'a, 'd, 'e, 'c -> 'b, 'd, 'e, 'f) s
+ val comStR : ('a -> 'b) -> ('b -> 'c, 'd, 'e, 'a -> 'c, 'd, 'e, 'f) s
+
+ val comStL1 : ('a -> 'b -> 'c)
+ -> ('a, 'd -> 'b, 'e, 'f, 'd -> 'c, 'e, 'f, 'g) s1
+ val comStR1 : ('a -> 'b -> 'c)
+ -> ('a, 'c -> 'd, 'e, 'f, 'b -> 'd, 'e, 'f, 'g) s1
+
+ structure NSZ : sig
+ type ('a, 'b, 'c, 'd, 'e, 'f, 'g) t
+ val wrap : {none : 'a -> 'b, some : 'c -> 'd, zero : 'e}
+ -> (('e, 'f, 'g, 'h, 'i, 'f, 'g) t,
+ ('j, 'a, 'b, 'c, 'd, 'j, 'k) t,
+ 'k, 'l) f
+ val mapSt : {none : 'a -> 'b, some : 'c -> 'd}
+ -> (('e, 'a, 'b, 'c, 'd, 'e, 'f) t, 'g, 'h,
+ ('f, 'i, 'j, 'k, 'l, 'k, 'l) t, 'g, 'h, 'm) s
+ val mapSt1 : {none : 'a -> 'b, some : 'c -> 'd}
+ -> ('e,
+ ('f, 'a, 'b, 'c, 'd, 'e, 'f -> 'g) t, 'h, 'i,
+ ('g, 'j, 'k, 'l, 'm, 'l, 'm) t, 'h, 'i, 'n) s1
+ end
+end
Property changes on: mltonlib/trunk/com/ssh/extended-basis/unstable/public/fold/fold.sig
___________________________________________________________________
Name: svn:eol-style
+ native
More information about the MLton-commit
mailing list