[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