[MLton-commit] r6319
Vesa Karvonen
vesak at mlton.org
Sun Jan 13 08:18:00 PST 2008
Moved FRU to extended-basis. Added a CPS module to extended-basis.
Changed the type abbreviations of Fold to make them more "compositional".
----------------------------------------------------------------------
U mltonlib/trunk/com/ssh/extended-basis/unstable/detail/bootstrap.sml
U mltonlib/trunk/com/ssh/extended-basis/unstable/detail/control/with.sml
A mltonlib/trunk/com/ssh/extended-basis/unstable/detail/fn/cps.sml
U mltonlib/trunk/com/ssh/extended-basis/unstable/detail/fn/fn.sml
U mltonlib/trunk/com/ssh/extended-basis/unstable/detail/fold/fold.sml
A mltonlib/trunk/com/ssh/extended-basis/unstable/detail/fold/fru.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
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/fn/cps.sig
U mltonlib/trunk/com/ssh/extended-basis/unstable/public/fn/fn.sig
U mltonlib/trunk/com/ssh/extended-basis/unstable/public/fold/fold.sig
A mltonlib/trunk/com/ssh/extended-basis/unstable/public/fold/fru.sig
D mltonlib/trunk/com/ssh/misc-util/unstable/fru.sml
U mltonlib/trunk/com/ssh/misc-util/unstable/lib.mlb
U mltonlib/trunk/com/ssh/misc-util/unstable/unit-test.sml
D mltonlib/trunk/com/ssh/unit-test/unstable/detail/fru.sml
U mltonlib/trunk/com/ssh/unit-test/unstable/detail/mk-unit-test.fun
U mltonlib/trunk/com/ssh/unit-test/unstable/detail/ml/smlnj/unsealed.cm
U mltonlib/trunk/com/ssh/unit-test/unstable/lib.mlb
U mltonlib/trunk/com/ssh/unit-test/unstable/lib.use
U mltonlib/trunk/com/ssh/unit-test/unstable/public/unit-test.sig
----------------------------------------------------------------------
Modified: mltonlib/trunk/com/ssh/extended-basis/unstable/detail/bootstrap.sml
===================================================================
--- mltonlib/trunk/com/ssh/extended-basis/unstable/detail/bootstrap.sml 2008-01-13 16:09:10 UTC (rev 6318)
+++ mltonlib/trunk/com/ssh/extended-basis/unstable/detail/bootstrap.sml 2008-01-13 16:17:55 UTC (rev 6319)
@@ -51,7 +51,7 @@
structure Ref = struct type 'a t = 'a ref end
structure Sum = struct
datatype ('a, 'b) sum = INL of 'a | INR of 'b
- type('a, 'b) t = ('a, 'b) sum
+ type ('a, 'b) t = ('a, 'b) sum
end
structure Sq = struct type 'a t = 'a * 'a end
structure Thunk = struct type 'a t = Unit.t -> 'a end
@@ -69,3 +69,4 @@
structure BinFn = struct type ('a, 'b) t = 'a Sq.t -> 'b end
structure IEEEReal = BasisIEEEReal
structure Time = struct open BasisTime type t = time end
+structure CPS = struct type ('a, 'b) t = ('a -> 'b) -> 'b end
Modified: mltonlib/trunk/com/ssh/extended-basis/unstable/detail/control/with.sml
===================================================================
--- mltonlib/trunk/com/ssh/extended-basis/unstable/detail/control/with.sml 2008-01-13 16:09:10 UTC (rev 6318)
+++ mltonlib/trunk/com/ssh/extended-basis/unstable/detail/control/with.sml 2008-01-13 16:17:55 UTC (rev 6319)
@@ -5,13 +5,13 @@
*)
structure With :> WITH = struct
- type 'a t = 'a Effect.t Effect.t
+ type 'a t = ('a, Unit.t) CPS.t
infix >>=
structure Monad =
MkMonad (type 'a monad = 'a t
- val return = Fn.pass
+ val return = CPS.pass
fun (aM >>= a2bM) f = aM (fn a => a2bM a f))
open Monad
Added: mltonlib/trunk/com/ssh/extended-basis/unstable/detail/fn/cps.sml
===================================================================
--- mltonlib/trunk/com/ssh/extended-basis/unstable/detail/fn/cps.sml 2008-01-13 16:09:10 UTC (rev 6318)
+++ mltonlib/trunk/com/ssh/extended-basis/unstable/detail/fn/cps.sml 2008-01-13 16:17:55 UTC (rev 6319)
@@ -0,0 +1,10 @@
+(* 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 CPS :> CPS = struct
+ open CPS
+ fun pass x f = f x
+end
Property changes on: mltonlib/trunk/com/ssh/extended-basis/unstable/detail/fn/cps.sml
___________________________________________________________________
Name: svn:eol-style
+ native
Modified: mltonlib/trunk/com/ssh/extended-basis/unstable/detail/fn/fn.sml
===================================================================
--- mltonlib/trunk/com/ssh/extended-basis/unstable/detail/fn/fn.sml 2008-01-13 16:09:10 UTC (rev 6318)
+++ mltonlib/trunk/com/ssh/extended-basis/unstable/detail/fn/fn.sml 2008-01-13 16:17:55 UTC (rev 6319)
@@ -14,7 +14,6 @@
fun id x = x
fun map (f, g) h = g o h o f
fun iso ((a2c, c2a), (b2d, d2b)) = (map (c2a, b2d), map (a2c, d2b))
- fun pass x f = f x
fun seal f x () = f x
fun uncurry f (x, y) = f x y
val op o = op o
Modified: mltonlib/trunk/com/ssh/extended-basis/unstable/detail/fold/fold.sml
===================================================================
--- mltonlib/trunk/com/ssh/extended-basis/unstable/detail/fold/fold.sml 2008-01-13 16:09:10 UTC (rev 6318)
+++ mltonlib/trunk/com/ssh/extended-basis/unstable/detail/fold/fold.sml 2008-01-13 16:17:55 UTC (rev 6319)
@@ -5,17 +5,15 @@
*)
structure Fold :> FOLD = struct
- open Fn
+ open Fn CPS
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
+ type ('s1, 's2, 'r) s = 's1 -> ('s2, 'r) CPS.t
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
+ type ('a, 's1, 's2, 'r) s1 = 's1 -> 'a -> ('s2, 'r) CPS.t
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) ?
@@ -35,7 +33,7 @@
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 =
+ 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)
Copied: mltonlib/trunk/com/ssh/extended-basis/unstable/detail/fold/fru.sml (from rev 6285, mltonlib/trunk/com/ssh/unit-test/unstable/detail/fru.sml)
===================================================================
--- mltonlib/trunk/com/ssh/unit-test/unstable/detail/fru.sml 2007-12-19 13:49:59 UTC (rev 6285)
+++ mltonlib/trunk/com/ssh/extended-basis/unstable/detail/fold/fru.sml 2008-01-13 16:17:55 UTC (rev 6319)
@@ -0,0 +1,44 @@
+(* 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 FRU :> FRU = struct
+ datatype ('rec, 'upds) t' = IN of 'rec UnOp.t * 'upds
+ type ('rec, 'upds, 'data) t =
+ (('rec, 'upds) t', ('rec, 'upds) t', 'data UnOp.t) Fold.t
+
+ local
+ datatype product = datatype Product.product
+ datatype sum = datatype Sum.sum
+ infix &
+
+ fun fin (m, u) iso (_, p2r) =
+ p2r (m (Fn.map iso o u))
+
+ fun make ? =
+ Fold.NSZ.wrap {none = fin, some = fin, zero = (Fn.const (), Fn.id)} ?
+
+ fun out (IN ?) = ?
+
+ fun updData iso u =
+ Fold.wrap (IN (Fn.id, u), Fn.map iso o Pair.fst o out)
+ in
+ fun A ? =
+ Fold.NSZ.mapSt
+ {none = Pair.map (Fn.const Fn.id, Fn.const Fn.const),
+ some = Pair.map (fn m => fn p => m (p o INL) & (p o INR),
+ fn u => fn INL p => (fn l & r => u p l & r)
+ | INR v => (fn l & _ => l & v))} ?
+
+ fun fruData (iso : ('data, 'rec) Iso.t) =
+ Fold.post (fn f => fn ~ => updData iso o f ~) make
+
+ fun fru ? =
+ fruData Iso.id ?
+
+ fun U s v =
+ Fold.mapSt (fn IN (f, u) => IN (s u v o f, u))
+ end
+end
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-01-13 16:09:10 UTC (rev 6318)
+++ mltonlib/trunk/com/ssh/extended-basis/unstable/detail/ml/smlnj/sigs.cm 2008-01-13 16:17:55 UTC (rev 6319)
@@ -47,6 +47,7 @@
../../../public/fn/bin-op.sig
../../../public/fn/bin-pr.sig
../../../public/fn/cmp.sig
+ ../../../public/fn/cps.sig
../../../public/fn/effect.sig
../../../public/fn/fn.sig
../../../public/fn/shift-op.sig
@@ -54,6 +55,7 @@
../../../public/fn/un-op.sig
../../../public/fn/un-pr.sig
../../../public/fold/fold.sig
+ ../../../public/fold/fru.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 2008-01-13 16:09:10 UTC (rev 6318)
+++ mltonlib/trunk/com/ssh/extended-basis/unstable/detail/ml/smlnj/unsealed.cm 2008-01-13 16:17:55 UTC (rev 6319)
@@ -33,12 +33,14 @@
../../../detail/fn/bin-op.sml
../../../detail/fn/bin-pr.sml
../../../detail/fn/cmp.sml
+ ../../../detail/fn/cps.sml
../../../detail/fn/effect.sml
../../../detail/fn/fn.sml
../../../detail/fn/thunk.sml
../../../detail/fn/un-op.sml
../../../detail/fn/un-pr.sml
../../../detail/fold/fold.sml
+ ../../../detail/fold/fru.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 2008-01-13 16:09:10 UTC (rev 6318)
+++ mltonlib/trunk/com/ssh/extended-basis/unstable/extensions.mlb 2008-01-13 16:17:55 UTC (rev 6319)
@@ -94,6 +94,10 @@
public/fn/fn.sig
detail/fn/fn.sml
+ (* CPS *)
+ public/fn/cps.sig
+ detail/fn/cps.sml
+
(* Basic *)
public/basic.sig
detail/basic.sml
@@ -174,10 +178,6 @@
public/data/product.sig
detail/data/product.sml
- (* Fold *)
- public/fold/fold.sig
- detail/fold/fold.sml
-
(* MkMonad *)
detail/concept/mk-monad.fun
@@ -201,6 +201,13 @@
public/generic/iso.sig
detail/generic/iso.sml
+ (* Fold *)
+ public/fold/fold.sig
+ detail/fold/fold.sml
+
+ public/fold/fru.sig
+ detail/fold/fru.sml
+
(* Tie *)
public/generic/tie.sig
detail/generic/tie.sml
Modified: mltonlib/trunk/com/ssh/extended-basis/unstable/extensions.use
===================================================================
--- mltonlib/trunk/com/ssh/extended-basis/unstable/extensions.use 2008-01-13 16:09:10 UTC (rev 6318)
+++ mltonlib/trunk/com/ssh/extended-basis/unstable/extensions.use 2008-01-13 16:17:55 UTC (rev 6319)
@@ -38,6 +38,8 @@
"public/data/void.sig",
"public/fn/fn.sig",
"detail/fn/fn.sml",
+ "public/fn/cps.sig",
+ "detail/fn/cps.sml",
"public/basic.sig",
"detail/basic.sml",
"public/data/unit.sig",
@@ -77,8 +79,6 @@
"detail/data/pair.sml",
"public/data/product.sig",
"detail/data/product.sml",
- "public/fold/fold.sig",
- "detail/fold/fold.sml",
"detail/concept/mk-monad.fun",
"public/control/with.sig",
"detail/control/with.sml",
@@ -90,6 +90,10 @@
"detail/generic/emb.sml",
"public/generic/iso.sig",
"detail/generic/iso.sml",
+ "public/fold/fold.sig",
+ "detail/fold/fold.sml",
+ "public/fold/fru.sig",
+ "detail/fold/fru.sml",
"public/generic/tie.sig",
"detail/generic/tie.sml",
"public/sequence/array.sig",
Modified: mltonlib/trunk/com/ssh/extended-basis/unstable/public/export/common.sml
===================================================================
--- mltonlib/trunk/com/ssh/extended-basis/unstable/public/export/common.sml 2008-01-13 16:09:10 UTC (rev 6318)
+++ mltonlib/trunk/com/ssh/extended-basis/unstable/public/export/common.sml 2008-01-13 16:17:55 UTC (rev 6319)
@@ -65,6 +65,7 @@
signature BUFFER = BUFFER
signature CHAR = CHAR
signature CMP = CMP
+signature CPS = CPS
signature CVT = CVT
signature EFFECT = EFFECT
signature EMB = EMB
@@ -73,6 +74,7 @@
signature FIX = FIX
signature FN = FN
signature FOLD = FOLD
+signature FRU = FRU
signature INTEGER = INTEGER
signature INT_INF = INT_INF
signature IOS_MONAD = IOS_MONAD
@@ -143,6 +145,7 @@
structure BinPr : BIN_PR = BinPr
structure Bool : BOOL = Bool
structure Buffer : BUFFER = Buffer
+structure CPS : CPS = CPS
structure Char : CHAR = Char
structure CharArray : MONO_ARRAY = CharArray
structure CharArraySlice : MONO_ARRAY_SLICE = CharArraySlice
@@ -154,6 +157,7 @@
structure Emb : EMB = Emb
structure Exit : EXIT = Exit
structure Exn : EXN = Exn
+structure FRU : FRU = FRU
structure Fix : FIX = Fix
structure FixedInt : INTEGER = FixedInt
structure Fn : FN = Fn
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 2008-01-13 16:09:10 UTC (rev 6318)
+++ mltonlib/trunk/com/ssh/extended-basis/unstable/public/export/top-level.sml 2008-01-13 16:17:55 UTC (rev 6319)
@@ -37,7 +37,6 @@
val eta = Fn.eta
val flip = Fn.flip
val id = Fn.id
- val pass = Fn.pass
val seal = Fn.seal
val uncurry = Fn.uncurry
@@ -48,10 +47,18 @@
val op \> = Fn.\>
val op |< = Fn.|<
+ (** == CPS == *)
+
+ val pass = CPS.pass
+
(** == Fold == *)
val $ = Fold.$
+ (** == FRU == *)
+
+ val U = FRU.U
+
(** == Lazy == *)
type 'a lazy = 'a Lazy.t
Added: mltonlib/trunk/com/ssh/extended-basis/unstable/public/fn/cps.sig
===================================================================
--- mltonlib/trunk/com/ssh/extended-basis/unstable/public/fn/cps.sig 2008-01-13 16:09:10 UTC (rev 6318)
+++ mltonlib/trunk/com/ssh/extended-basis/unstable/public/fn/cps.sig 2008-01-13 16:17:55 UTC (rev 6319)
@@ -0,0 +1,13 @@
+(* 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.
+ *)
+
+(** Utilities for programming in continuation passing -style. *)
+signature CPS = sig
+ type ('a, 'b) t = ('a -> 'b) -> 'b
+
+ val pass : 'a -> ('a, 'b) t
+ (** Pass to continuation ({pass x f = f x}). *)
+end
Property changes on: mltonlib/trunk/com/ssh/extended-basis/unstable/public/fn/cps.sig
___________________________________________________________________
Name: svn:eol-style
+ native
Modified: mltonlib/trunk/com/ssh/extended-basis/unstable/public/fn/fn.sig
===================================================================
--- mltonlib/trunk/com/ssh/extended-basis/unstable/public/fn/fn.sig 2008-01-13 16:09:10 UTC (rev 6318)
+++ mltonlib/trunk/com/ssh/extended-basis/unstable/public/fn/fn.sig 2008-01-13 16:17:55 UTC (rev 6319)
@@ -39,9 +39,6 @@
val o : ('a -> 'b) * ('c -> 'a) -> 'c -> 'b
(** Function composition ({(g o f) x = f (g x)}). *)
- val pass : 'a -> ('a -> 'b) -> 'b
- (** Pass to continuation ({pass x f = f x}). *)
-
val seal : ('a -> 'b) -> 'a -> 'b Thunk.t
(**
* {seal f x} is equivalent to {fn () => f x} assuming {f} and {x} are
Modified: mltonlib/trunk/com/ssh/extended-basis/unstable/public/fold/fold.sig
===================================================================
--- mltonlib/trunk/com/ssh/extended-basis/unstable/public/fold/fold.sig 2008-01-13 16:09:10 UTC (rev 6318)
+++ mltonlib/trunk/com/ssh/extended-basis/unstable/public/fold/fold.sig 2008-01-13 16:17:55 UTC (rev 6319)
@@ -11,62 +11,62 @@
*)
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
+ type ('s1, 's2, 'r) s = 's1 -> ('s2, 'r) CPS.t
+ type ('a, 's1, 's2, 'r) s1 = 's1 -> 'a -> ('s2, 'r) CPS.t
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 wrap : 'a * ('b -> 'c) -> (('a, 'b, 'c) t, 'd) CPS.t
+ val unwrap : (('a, 'b, 'c) t, 'a * ('b -> 'c)) CPS.t -> 'a * ('b -> 'c)
+ val rewrap : (('a, 'b, 'c) t, 'a * ('b -> 'c)) CPS.t ->
+ (('a, 'b, 'c) t, 'd) CPS.t
val post : ('a -> 'b)
- -> ('c, 'd, 'a, 'c * ('d -> 'a)) f
- -> ('c, 'd, 'b, 'e) f
+ -> (('c, 'd, 'a) t, 'c * ('d -> 'a)) CPS.t
+ -> (('c, 'd, 'b) t, 'e) CPS.t
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) t, ('d, 'e, 'f) t, 'g) s
+ val unmap : (('a, 'b, 'c) t, ('d, 'd, 'd * ('e -> 'f)) t, '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 remap : (('a, 'b, 'c) t, ('d, 'd, 'd * ('e -> 'f)) t, 'd * ('e -> 'f)) s
+ -> (('a, 'b, 'c) t, ('d, 'e, 'f) t, '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) t, ('e, 'f, 'g) t, 'h) s1
+ val unmap1 : ('a, ('b, 'c, 'd) t, ('e, 'e, 'e * ('f -> 'g)) t, '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 remap1 : ('a, ('b, 'c, 'd) t, ('e, 'e, 'e * ('f -> 'g)) t, 'e * ('f -> 'g)) s1
+ -> ('a, ('b, 'c, 'd) t, ('e, 'f, 'g) t, '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 mapFin : (('a -> 'b) -> 'c -> 'd) -> (('e, 'a, 'b) t, ('e, 'c, 'd) t, 'f) s
- 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 mapSt : ('a -> 'b) -> (('a, 'c, 'd) t, ('b, 'c, 'd) t, 'e) s
+ val mapSt1 : ('a -> 'b1 -> 'b2) -> ('a, ('b1, 'c, 'd) t, ('b2, 'c, 'd) t, 'e) s1
- 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 comFinL : ('a -> 'b) -> (('c, 'd, 'a) t, ('c, 'd, 'b) t, 'e) s
+ val comFinR : ('a -> 'b) -> (('c, 'b, 'd) t, ('c, 'a, 'd) t, 'e) s
+ val comStL : ('a -> 'b) -> (('c -> 'a, 'd, 'e) t, ('c -> 'b, 'd, 'e) t, 'f) s
+ val comStR : ('a -> 'b) -> (('b -> 'c, 'd, 'e) t, ('a -> 'c, 'd, 'e) t, 'f) s
+
val comStL1 : ('a -> 'b -> 'c)
- -> ('a, 'd -> 'b, 'e, 'f, 'd -> 'c, 'e, 'f, 'g) s1
+ -> ('a, ('d -> 'b, 'e, 'f) t, ('d -> 'c, 'e, 'f) t, 'g) s1
val comStR1 : ('a -> 'b -> 'c)
- -> ('a, 'c -> 'd, 'e, 'f, 'b -> 'd, 'e, 'f, 'g) s1
+ -> ('a, ('c -> 'd, 'e, 'f) t, ('b -> 'd, 'e, 'f) t, 'g) s1
structure NSZ : sig
- type ('a, 'b, 'c, 'd, 'e, 'f, 'g) t
+ 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
+ -> ((('e, 'f, 'g, 'h, 'i, 'f, 'g) t',
+ ('j, 'a, 'b, 'c, 'd, 'j, 'k) t',
+ 'k) t, 'l) CPS.t
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
+ -> ((('e, 'a, 'b, 'c, 'd, 'e, 'f) t', 'g, 'h) t,
+ (('f, 'i, 'j, 'k, 'l, 'k, 'l) t', 'g, 'h) t, '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
+ (('f, 'a, 'b, 'c, 'd, 'e, 'f -> 'g) t', 'h, 'i) t,
+ (('g, 'j, 'k, 'l, 'm, 'l, 'm) t', 'h, 'i) t, 'n) s1
end
end
Added: mltonlib/trunk/com/ssh/extended-basis/unstable/public/fold/fru.sig
===================================================================
--- mltonlib/trunk/com/ssh/extended-basis/unstable/public/fold/fru.sig 2008-01-13 16:09:10 UTC (rev 6318)
+++ mltonlib/trunk/com/ssh/extended-basis/unstable/public/fold/fru.sig 2008-01-13 16:17:55 UTC (rev 6319)
@@ -0,0 +1,63 @@
+(* 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.
+ *)
+
+(**
+ * Support for functional record update.
+ *
+ * See [http://mlton.org/FunctionalRecordUpdate FRU] for further
+ * information.
+ *)
+signature FRU = sig
+ type ('rec, 'upds) t'
+ type ('rec, 'upds, 'data) t =
+ (('rec, 'upds) t', ('rec, 'upds) t', 'data UnOp.t) Fold.t
+
+ val fru :
+ (((('a -> unit) * 'b UnOp.t, 'c, 'd, 'e, 'f, 'c, 'd) Fold.NSZ.t',
+ ('g,
+ (('h -> 'i UnOp.t) -> 'j) * ('h -> 'k UnOp.t),
+ ('i, 'k) Iso.t -> ('l, 'j) Iso.t -> 'l,
+ (('m -> 'n UnOp.t) -> 'o) * ('m -> 'p UnOp.t),
+ ('n, 'p) Iso.t -> ('q, 'o) Iso.t -> 'q,
+ 'g,
+ 'r -> 's -> 'upds) Fold.NSZ.t',
+ 'r -> 's ->
+ (('rec, 'upds, 'rec) t, 'v) CPS.t) Fold.t,
+ 'w) CPS.t
+
+ val fruData :
+ ('data, 'rec) Iso.t ->
+ (((('c -> unit) * 'd UnOp.t, 'e, 'f, 'g, 'h, 'e, 'f) Fold.NSZ.t',
+ ('i,
+ (('j -> 'k UnOp.t) -> 'l) * ('j -> 'm UnOp.t),
+ ('k, 'm) Iso.t -> ('n, 'l) Iso.t -> 'n,
+ (('o -> 'p UnOp.t) -> 'q) * ('o -> 'r UnOp.t),
+ ('p, 'r) Iso.t -> ('s, 'q) Iso.t -> 's,
+ 'i,
+ 't -> 'u -> 'upds) Fold.NSZ.t',
+ 't -> 'u ->
+ (('rec, 'upds, 'data) t, 'w) CPS.t) Fold.t,
+ 'x) CPS.t
+
+ val A :
+ ((('a,
+ 'b * 'c,
+ 'd UnOp.t * ('e -> 'f -> 'e),
+ (('g -> 'h) -> 'i) * ('j -> 'k UnOp.t),
+ ((('g, 'l) Sum.t -> 'h) -> ('i, 'l -> 'h) Product.t) *
+ (('j, 'm) Sum.t -> ('k, 'm) Product.t UnOp.t),
+ 'a,
+ 'n) Fold.NSZ.t',
+ 'o,
+ 'p) Fold.t,
+ (('n, 'q, 'r, 's, 't, 's, 't) Fold.NSZ.t', 'o, 'p) Fold.t, 'u) Fold.s
+
+ val U :
+ ('upds -> 'val -> 'rec UnOp.t) ->
+ 'val ->
+ (('rec, 'upds, 'data) t,
+ ('rec, 'upds, 'data) t, 'k) Fold.s
+end
Property changes on: mltonlib/trunk/com/ssh/extended-basis/unstable/public/fold/fru.sig
___________________________________________________________________
Name: svn:eol-style
+ native
Deleted: mltonlib/trunk/com/ssh/misc-util/unstable/fru.sml
===================================================================
--- mltonlib/trunk/com/ssh/misc-util/unstable/fru.sml 2008-01-13 16:09:10 UTC (rev 6318)
+++ mltonlib/trunk/com/ssh/misc-util/unstable/fru.sml 2008-01-13 16:17:55 UTC (rev 6319)
@@ -1,68 +0,0 @@
-(* 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.
- *)
-
-(*
- * Support for functional record update.
- *
- * See
- *
- * http://mlton.org/FunctionalRecordUpdate
- *
- * for further information.
- *)
-
-structure FRU = struct
- fun make ? = let
- fun fin (m, u) =
- fn iso : ('r1, 'p1) Iso.t =>
- fn (_, p2r') : ('r2, 'p2) Iso.t =>
- p2r' (m (Fn.map iso o u))
- in
- Fold.NSZ.wrap {none = fin, some = fin,
- zero = (const (), id)}
- end ?
-
- fun A ? =
- Fold.NSZ.mapSt
- {none = Pair.map (const id, const const),
- some = Pair.map (fn m =>
- fn p =>
- m (p o INL) & (p o INR),
- fn u =>
- fn INL p =>
- (fn l & r => u p l & r)
- | INR v =>
- (fn l & _ => l & v))} ?
-
- (* 2^n *)
- val A1 = A
- fun A2 ? = pass ? A1 A1
- fun A4 ? = pass ? A2 A2
- fun A8 ? = pass ? A4 A4
-
- (* 2^i + j where j < 2^i *)
- fun A3 ? = pass ? A2 A1
- fun A5 ? = pass ? A4 A1
- fun A6 ? = pass ? A4 A2
- fun A7 ? = pass ? A4 A3
- fun A9 ? = pass ? A8 A1
- fun A10 ? = pass ? A8 A2
- fun A11 ? = pass ? A8 A3
- fun A12 ? = pass ? A8 A4
- fun A13 ? = pass ? A8 A5
- fun A14 ? = pass ? A8 A6
- fun A15 ? = pass ? A8 A7
-
- fun updData iso u = Fold.wrap ((id, u), Fn.map iso o Pair.fst)
- fun fruData iso = Fold.post (fn f => fn ~ => updData iso o f ~) make
-
- fun upd ? = updData Iso.id ?
- fun fru ? = fruData Iso.id ?
-
- fun U s v = Fold.mapSt (fn (f, u) => (s u v o f, u))
-end
-
-val U = FRU.U
Modified: mltonlib/trunk/com/ssh/misc-util/unstable/lib.mlb
===================================================================
--- mltonlib/trunk/com/ssh/misc-util/unstable/lib.mlb 2008-01-13 16:09:10 UTC (rev 6318)
+++ mltonlib/trunk/com/ssh/misc-util/unstable/lib.mlb 2008-01-13 16:17:55 UTC (rev 6319)
@@ -27,8 +27,6 @@
bit-flags.sml
- fru.sml
-
glob.sml
sorted-list.sml
Modified: mltonlib/trunk/com/ssh/misc-util/unstable/unit-test.sml
===================================================================
--- mltonlib/trunk/com/ssh/misc-util/unstable/unit-test.sml 2008-01-13 16:09:10 UTC (rev 6318)
+++ mltonlib/trunk/com/ssh/misc-util/unstable/unit-test.sml 2008-01-13 16:17:55 UTC (rev 6319)
@@ -12,12 +12,13 @@
type t
(** Type of unit test fold state. *)
- type 'a s = (t, t, Unit.t, t, t, Unit.t, 'a) Fold.s
+ type 'a s = ((t, t, Unit.t) Fold.t,
+ (t, t, Unit.t) Fold.t, 'a) Fold.s
(** Type of a unit test fold step. *)
(** == TEST SPECIFICATION INTERFACE == *)
- val unitTests : (t, t, Unit.t, 'a) Fold.f
+ val unitTests : ((t, t, Unit.t) Fold.t, 'a) CPS.t
(** Begins test specification. *)
val title : String.t -> 'a s
@@ -203,7 +204,7 @@
size : Int.t UnOp.t,
passM : Int.t,
skipM : Int.t}
- type 'a s = (t, t, Unit.t, t, t, Unit.t, 'a) Fold.s
+ type 'a s = ((t, t, Unit.t) Fold.t, (t, t, Unit.t) Fold.t, 'a) Fold.s
exception Failure of Prettier.t
val failure = Exn.throw o Failure
@@ -220,7 +221,7 @@
fn a&b&c&d&e => {title=a, idx=b, size=c, passM=d, skipM=e})
open FRU
in
- fun updCfg ? = fruData (fn IN ? => ?, IN) A5 $ ~ ~ ?
+ fun updCfg ? = fruData (fn IN ? => ?, IN) A A A A A $ ~ ~ ?
end
val succeeded = ref 0
Deleted: mltonlib/trunk/com/ssh/unit-test/unstable/detail/fru.sml
===================================================================
--- mltonlib/trunk/com/ssh/unit-test/unstable/detail/fru.sml 2008-01-13 16:09:10 UTC (rev 6318)
+++ mltonlib/trunk/com/ssh/unit-test/unstable/detail/fru.sml 2008-01-13 16:17:55 UTC (rev 6319)
@@ -1,71 +0,0 @@
-(* 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.
- *)
-
-(*
- * Support for functional record update.
- *
- * See
- *
- * http://mlton.org/FunctionalRecordUpdate
- *
- * for further information.
- *)
-
-structure FRU = struct
- (* <-- SML/NJ workaround *)
- open TopLevel
- infix &
- (* SML/NJ workaround --> *)
-
- fun make ? = let
- fun fin (m, u) =
- fn iso : ('r1, 'p1) Iso.t =>
- fn (_, p2r') : ('r2, 'p2) Iso.t =>
- p2r' (m (Fn.map iso o u))
- in
- Fold.NSZ.wrap {none = fin, some = fin,
- zero = (const (), id)}
- end ?
-
- fun A ? =
- Fold.NSZ.mapSt
- {none = Pair.map (const id, const const),
- some = Pair.map (fn m =>
- fn p =>
- m (p o INL) & (p o INR),
- fn u =>
- fn INL p =>
- (fn l & r => u p l & r)
- | INR v =>
- (fn l & _ => l & v))} ?
-
- (* 2^n *)
- val A1 = A
- fun A2 ? = pass ? A1 A1
- fun A4 ? = pass ? A2 A2
- fun A8 ? = pass ? A4 A4
-
- (* 2^i + j where j < 2^i *)
- fun A3 ? = pass ? A2 A1
- fun A5 ? = pass ? A4 A1
- fun A6 ? = pass ? A4 A2
- fun A7 ? = pass ? A4 A3
- fun A9 ? = pass ? A8 A1
- fun A10 ? = pass ? A8 A2
- fun A11 ? = pass ? A8 A3
- fun A12 ? = pass ? A8 A4
- fun A13 ? = pass ? A8 A5
- fun A14 ? = pass ? A8 A6
- fun A15 ? = pass ? A8 A7
-
- fun updData iso u = Fold.wrap ((id, u), Fn.map iso o Pair.fst)
- fun fruData iso = Fold.post (fn f => fn ~ => updData iso o f ~) make
-
- fun upd ? = updData Iso.id ?
- fun fru ? = fruData Iso.id ?
-
- fun U s v = Fold.mapSt (fn (f, u) => (s u v o f, u))
-end
Modified: mltonlib/trunk/com/ssh/unit-test/unstable/detail/mk-unit-test.fun
===================================================================
--- mltonlib/trunk/com/ssh/unit-test/unstable/detail/mk-unit-test.fun 2008-01-13 16:09:10 UTC (rev 6318)
+++ mltonlib/trunk/com/ssh/unit-test/unstable/detail/mk-unit-test.fun 2008-01-13 16:17:55 UTC (rev 6319)
@@ -16,10 +16,13 @@
infixr @` |<
(* SML/NJ workaround --> *)
- open Arg Prettier
+ open Cvt Arg Prettier
structure Rep = Open.Rep
+ val format = let open Fmt in default & realFmt := StringCvt.GEN (SOME 16) end
+ fun pretty t = fmt t format
+
fun named t n v = group (nest 2 (str n <$> pretty t v))
val strs = str o concat
local
@@ -30,12 +33,11 @@
val println = println (get cols)
end
- val i2s = Int.toString
-
- datatype t =
+ datatype t' =
IN of {title : String.t Option.t,
idx : Int.t}
- type 'a s = (t, t, Unit.t, t, t, Unit.t, 'a) Fold.s
+ type t = (t', t', Unit.t) Fold.t
+ type 'a s = (t, t, 'a) Fold.s
exception Failure of Prettier.t
fun failure d = raise Failure d
@@ -58,11 +60,11 @@
OS.Process.atExit
(fn () =>
if 0 = !failed then
- printlnStrs ["All ", i2s (!succeeded), " tests succeeded."]
+ printlnStrs ["All ", D (!succeeded), " tests succeeded."]
else
- (printlnStrs [i2s (!succeeded + !failed), " tests of which\n",
- i2s (!succeeded), " succeeded and\n",
- i2s (!failed), " failed."]
+ (printlnStrs [D (!succeeded + !failed), " tests of which\n",
+ D (!succeeded), " succeeded and\n",
+ D (!failed), " failed."]
; OS.Process.terminate OS.Process.failure))
fun namedExn label e =
@@ -100,7 +102,7 @@
(fn IN {title, idx} =>
(printlnStrs (case title
of NONE => ["An untitled test"]
- | SOME t => [i2s idx, ". ", t, " test"])
+ | SOME t => [D idx, ". ", t, " test"])
; try (body,
fn () =>
inc succeeded,
@@ -167,7 +169,7 @@
if maxPass <= passN then
()
else if maxSkip <= skipN then
- println (indent 2 (strs ["Arguments exhausted after ", i2s passN,
+ println (indent 2 (strs ["Arguments exhausted after ", D passN,
" tests."]))
else
case genTest (size passN)
@@ -194,7 +196,7 @@
val n = length t
in
punctuate comma o
- map (fn (n, m) => str (concat [i2s n, "% ", m])) o
+ map (fn (n, m) => str (concat [D n, "% ", m])) o
List.sort (Int.compare o Pair.swap o Pair.map (Sq.mk Pair.fst)) o
map (Pair.map (fn l => Int.quot (100 * length l, n), hd) o Sq.mk) o
List.divideByEq op = |< List.map (render NONE) t
Modified: mltonlib/trunk/com/ssh/unit-test/unstable/detail/ml/smlnj/unsealed.cm
===================================================================
--- mltonlib/trunk/com/ssh/unit-test/unstable/detail/ml/smlnj/unsealed.cm 2008-01-13 16:09:10 UTC (rev 6318)
+++ mltonlib/trunk/com/ssh/unit-test/unstable/detail/ml/smlnj/unsealed.cm 2008-01-13 16:17:55 UTC (rev 6319)
@@ -11,7 +11,6 @@
../../../../../random/unstable/lib.cm
../../../public/mk-unit-test-fun.sig
../../../public/unit-test.sig
- ../../fru.sml
../../maybe.sml
../../mk-unit-test.fun
../../sorted-list.cm
Modified: mltonlib/trunk/com/ssh/unit-test/unstable/lib.mlb
===================================================================
--- mltonlib/trunk/com/ssh/unit-test/unstable/lib.mlb 2008-01-13 16:09:10 UTC (rev 6318)
+++ mltonlib/trunk/com/ssh/unit-test/unstable/lib.mlb 2008-01-13 16:17:55 UTC (rev 6319)
@@ -27,7 +27,6 @@
"sequenceNonUnit warn"
"warnUnused true"
in
- detail/fru.sml
detail/maybe.sml
end
in
Modified: mltonlib/trunk/com/ssh/unit-test/unstable/lib.use
===================================================================
--- mltonlib/trunk/com/ssh/unit-test/unstable/lib.use 2008-01-13 16:09:10 UTC (rev 6318)
+++ mltonlib/trunk/com/ssh/unit-test/unstable/lib.use 2008-01-13 16:17:55 UTC (rev 6319)
@@ -11,7 +11,6 @@
"detail/sorted-list.sml",
"public/unit-test.sig",
"public/mk-unit-test-fun.sig",
- "detail/fru.sml",
"detail/maybe.sml",
"detail/mk-unit-test.fun",
"public/export.sml"] ;
Modified: mltonlib/trunk/com/ssh/unit-test/unstable/public/unit-test.sig
===================================================================
--- mltonlib/trunk/com/ssh/unit-test/unstable/public/unit-test.sig 2008-01-13 16:09:10 UTC (rev 6318)
+++ mltonlib/trunk/com/ssh/unit-test/unstable/public/unit-test.sig 2008-01-13 16:17:55 UTC (rev 6319)
@@ -11,15 +11,16 @@
structure Rep : OPEN_REP
(** Substructure specifying the representation of generics. *)
- type t
+ type t'
+ type t = (t', t', Unit.t) Fold.t
(** Type of unit test fold state. *)
- type 'a s = (t, t, Unit.t, t, t, Unit.t, 'a) Fold.s
+ type 'a s = (t, t, 'a) Fold.s
(** Type of a unit test fold step. *)
(** == Test Specification Interface == *)
- val unitTests : (t, t, Unit.t, 'a) Fold.f
+ val unitTests : (t, 'a) CPS.t
(** Begins test specification. *)
val title : String.t -> 'a s
More information about the MLton-commit
mailing list