[MLton-commit] r5582
Vesa Karvonen
vesak at mlton.org
Sun Jun 3 22:35:55 PDT 2007
Using fold from extended-basis.
----------------------------------------------------------------------
D mltonlib/trunk/com/ssh/misc-util/unstable/fold-pair.sml
D mltonlib/trunk/com/ssh/misc-util/unstable/fold.sml
D mltonlib/trunk/com/ssh/misc-util/unstable/fold01n.sml
U 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
----------------------------------------------------------------------
Deleted: mltonlib/trunk/com/ssh/misc-util/unstable/fold-pair.sml
===================================================================
--- mltonlib/trunk/com/ssh/misc-util/unstable/fold-pair.sml 2007-06-04 05:33:36 UTC (rev 5581)
+++ mltonlib/trunk/com/ssh/misc-util/unstable/fold-pair.sml 2007-06-04 05:35:54 UTC (rev 5582)
@@ -1,62 +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.
- *)
-
-(*
- * Utility module for pairing folds (see fold.sml).
- *)
-
-(* XXX create FoldProduct for tupling an arbitrary number of folds easily *)
-
-structure FoldPair = struct
- type ('a, 'b, 'c, 'd, 'e, 'f) t =
- ('a * 'b, 'c * 'd, 'e, 'f) Fold.t
- type ('a, 'b, 'c, 'd, 'e, 'f, 'g) step0 =
- ('a * 'c, 'b * 'd, 'e, 'f, 'g) Fold.step0
- type ('a, 'b, 'c, 'd, 'e, 'f, 'g, 'h) step1 =
- ('a, 'b * 'd, 'c * 'e, 'f, 'g, 'h) Fold.step1
-end
-
-signature FOLD_PAIR = sig
- type ('a, 'b, 'c, 'd, 'e, 'f) t =
- ('a, 'b, 'c, 'd, 'e, 'f) FoldPair.t
- type ('a, 'b, 'c, 'd, 'e, 'f, 'g) step0 =
- ('a, 'b, 'c, 'd, 'e, 'f, 'g) FoldPair.step0
- type ('a, 'b, 'c, 'd, 'e, 'f, 'g, 'h) step1 =
- ('a, 'b, 'c, 'd, 'e, 'f, 'g, 'h) FoldPair.step1
-
- val fold : ('a, 'b, 'c, 'a * ('b -> 'c)) Fold.t
- * ('d, 'e, 'f, 'd * ('e -> 'f)) Fold.t
- -> ('c * 'f -> 'g)
- -> ('a, 'd, 'b, 'e, 'g, 'h) t
- val step0 : ('a, 'b, 'b, 'b, 'b) Fold.step0
- * ('c, 'd, 'd, 'd, 'd) Fold.step0
- -> ('a, 'b, 'c, 'd, 'e, 'f, 'g) step0
- val step1 : ('a, 'b, 'c, 'c, 'c, 'c) Fold.step1
- * ('a, 'd, 'e, 'e, 'e, 'e) Fold.step1
- -> ('a, 'b, 'c, 'd, 'e, 'f, 'g, 'h) step1
-end
-
-structure FoldPair :> FOLD_PAIR = struct
- open FoldPair
-
- fun fold (l, r) f = let
- val (la, lf) = Fold.unfold l
- val (ra, rf) = Fold.unfold r
- in
- Fold.fold ((la, ra), f o Pair.map (lf, rf))
- end
-
- fun step0 (l, r) =
- Fold.step0 (Pair.map (Fold.unstep0 l,
- Fold.unstep0 r))
-
- fun step1 (l, r) =
- Fold.step1 (Pair.map (Fold.unstep1 l,
- Fold.unstep1 r)
- o (fn (a11, (a12l, a12r)) =>
- ((a11, a12l),
- (a11, a12r))))
-end
Deleted: mltonlib/trunk/com/ssh/misc-util/unstable/fold.sml
===================================================================
--- mltonlib/trunk/com/ssh/misc-util/unstable/fold.sml 2007-06-04 05:33:36 UTC (rev 5581)
+++ mltonlib/trunk/com/ssh/misc-util/unstable/fold.sml 2007-06-04 05:35:54 UTC (rev 5582)
@@ -1,87 +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.
- *)
-
-(*
- * Utility module for defining "variadic" type-indexed functions in SML.
- *
- * See
- *
- * http://mlton.org/Fold
- *
- * for extensive discussion of the subject.
- *)
-
-structure Fold = struct
- type ('a, 'b, 'c, 'd) step =
- 'a * ('b -> 'c) -> 'd
- type ('a, 'b, 'c, 'd) t =
- ('a, 'b, 'c, 'd) step -> 'd
- type ('a, 'b, 'c, 'd, 'e) step0 =
- ('a, 'c, 'd, ('b, 'c, 'd, 'e) t) step
- type ('a, 'b, 'c, 'd, 'e, 'f) step1 =
- ('b, 'd, 'e, 'a -> ('c, 'd, 'e, 'f) t) step
-end
-
-signature FOLD = sig
- type ('a, 'b, 'c, 'd) step =
- ('a, 'b, 'c, 'd) Fold.step
- type ('a, 'b, 'c, 'd) t =
- ('a, 'b, 'c, 'd) Fold.t
- type ('a, 'b, 'c, 'd, 'e) step0 =
- ('a, 'b, 'c, 'd, 'e) Fold.step0
- type ('a, 'b, 'c, 'd, 'e, 'f) step1 =
- ('a, 'b, 'c, 'd, 'e, 'f) Fold.step1
-
- val fold : 'a * ('b -> 'c) -> ('a, 'b, 'c, 'd) t
- val unfold : ('a, 'b, 'c, 'a * ('b -> 'c)) t
- -> 'a * ('b -> 'c)
- val lift : ('a, 'b, 'c, 'a * ('b -> 'c)) t
- -> ('a, 'b, 'c, 'd) t
-
- val post : ('a -> 'd)
- -> ('b, 'c, 'a, 'b * ('c -> 'a)) t
- -> ('b, 'c, 'd, 'e) t
-
- val step0 : ('a -> 'b)
- -> ('a, 'b, 'c, 'd, 'e) step0
- val step1 : ('a * 'b -> 'c)
- -> ('a, 'b, 'c, 'd, 'e, 'f) step1
-
- val unstep0 : ('a, 'b, 'b, 'b, 'b) step0
- -> 'a -> 'b
- val unstep1 : ('a, 'b, 'c, 'c, 'c, 'c) step1
- -> 'a * 'b -> 'c
-
- val lift0 : ('a, 'b, 'b, 'b, 'b) step0
- -> ('a, 'b, 'c, 'd, 'e) step0
- val lift1 : ('a, 'b, 'c, 'c, 'c, 'c) step1
- -> ('a, 'b, 'c, 'd, 'e, 'f) step1
- val lift0to1 : ('b, 'c, 'c, 'c, 'c) step0
- -> ('a, 'b, 'c, 'd, 'e, 'f) step1
-end
-
-fun $ (x, f) = f x
-
-structure Fold :> FOLD = struct
- open Fold
-
- val fold = pass
- fun unfold f = f id
- fun lift ? = (fold o unfold) ?
-
- fun post g = fold o Pair.map (id, fn f => g o f) o unfold
-
- fun step0 h (a1, f) = fold (h a1, f)
- fun step1 h (a2, f) a1 = fold (h (a1, a2), f)
-
- fun unstep0 s a1 = fold (a1, id) s $
- fun unstep1 s (a1, a2) = fold (a2, id) s a1 $
-
- fun lift0 ? = (step0 o unstep0) ?
- fun lift1 ? = (step1 o unstep1) ?
-
- fun lift0to1 s = step1 (unstep0 s o Pair.snd)
-end
Deleted: mltonlib/trunk/com/ssh/misc-util/unstable/fold01n.sml
===================================================================
--- mltonlib/trunk/com/ssh/misc-util/unstable/fold01n.sml 2007-06-04 05:33:36 UTC (rev 5581)
+++ mltonlib/trunk/com/ssh/misc-util/unstable/fold01n.sml 2007-06-04 05:35:54 UTC (rev 5582)
@@ -1,59 +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.
- *)
-
-(*
- * Utility module for creating folds (see fold.sml) that need to treat the
- * cases of 0 and 1 or more steps differently.
- *
- * See
- *
- * http://mlton.org/Fold01N
- *
- * for discussion.
- *)
-
-signature FOLD01N = sig
- type ('a, 'b, 'c, 'd, 'e, 'f, 'g) ac
-
- val fold : {none: 'a -> 'b,
- some: 'c -> 'd,
- zero: 'e}
- -> (('e, 'f, 'g, 'h, 'i, 'f, 'g) ac,
- ('j, 'a, 'b, 'c, 'd, 'j, 'k) ac,
- 'k, 'l) Fold.t
- val step0 : {none: 'a -> 'b,
- some: 'c -> 'd}
- -> (('e, 'a, 'b, 'c, 'd, 'e, 'f) ac,
- ('f, 'g, 'h, 'i, 'j, 'i, 'j) ac,
- 'k, 'l, 'm) Fold.step0
- val step1 : {none: 'a -> 'b,
- some: 'c -> 'd}
- -> ('e,
- ('f, 'a, 'b, 'c, 'd, 'e * 'f, 'g) ac,
- ('g, 'h, 'i, 'j, 'k, 'j, 'k) ac,
- 'l, 'm, 'n) Fold.step1
-end
-
-structure Fold01N :> FOLD01N = struct
- datatype ('a, 'b, 'c, 'd, 'e, 'f, 'g) ac =
- IN of 'a * (('b -> 'c) * ('d -> 'e) -> 'f -> 'g)
-
- fun fold {zero, none, some} =
- Fold.fold (IN (zero, Pair.fst),
- fn IN (ac, pick) =>
- pick (none, some) ac)
-
- fun step0 {none, some} =
- Fold.step0 (fn IN (ac, pick) =>
- IN (pick (none, some) ac,
- Pair.snd))
-
- fun step1 {none, some} =
- Fold.step1 (fn (x, IN (ac, pick)) =>
- IN (pick (none, some)
- (x, ac),
- Pair.snd))
-end
Modified: mltonlib/trunk/com/ssh/misc-util/unstable/fru.sml
===================================================================
--- mltonlib/trunk/com/ssh/misc-util/unstable/fru.sml 2007-06-04 05:33:36 UTC (rev 5581)
+++ mltonlib/trunk/com/ssh/misc-util/unstable/fru.sml 2007-06-04 05:35:54 UTC (rev 5582)
@@ -15,36 +15,27 @@
*)
structure FRU = struct
- local
- fun pathFold ? = Fold01N.fold {zero = const (), none = id, some = id} ?
- fun pathStep ? =
- Fold01N.step0
- {none = const id,
- some = fn m =>
- fn p =>
- m (p o INL) &
- (p o INR)} ?
-
- fun setFold ? = Fold01N.fold {zero = id, none = id, some = id} ?
- fun setStep ? =
- Fold01N.step0
- {none = const const,
- some = fn u =>
- fn INL p =>
- (fn l & r => u p l & r)
- | INR v =>
- (fn l & _ => l & v)} ?
+ 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
- fun make ? =
- FoldPair.fold
- (pathFold, setFold)
- (fn (m, u) =>
- fn iso : ('r1, 'p1) Iso.t =>
- fn (_, p2r') : ('r2, 'p2) Iso.t =>
- p2r' (m (Fn.map iso o u))) ?
+ Fold.NSZ.wrap {none = fin, some = fin,
+ zero = (const (), id)}
+ end ?
- fun A ? = FoldPair.step0 (pathStep, setStep) ?
- 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
@@ -65,13 +56,13 @@
fun A14 ? = pass ? A8 A6
fun A15 ? = pass ? A8 A7
- fun updData iso u = Fold.fold ((id, u), Fn.map iso o Pair.fst)
+ 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.step0 (fn (f, u) => (s u v o f, u))
+ 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 2007-06-04 05:33:36 UTC (rev 5581)
+++ mltonlib/trunk/com/ssh/misc-util/unstable/lib.mlb 2007-06-04 05:35:54 UTC (rev 5582)
@@ -27,11 +27,6 @@
bit-flags.sml
- (* variable argument fold *)
- fold.sml
- fold01n.sml
- fold-pair.sml
-
fru.sml
glob.sml
Modified: mltonlib/trunk/com/ssh/misc-util/unstable/unit-test.sml
===================================================================
--- mltonlib/trunk/com/ssh/misc-util/unstable/unit-test.sml 2007-06-04 05:33:36 UTC (rev 5581)
+++ mltonlib/trunk/com/ssh/misc-util/unstable/unit-test.sml 2007-06-04 05:35:54 UTC (rev 5582)
@@ -12,12 +12,12 @@
type t
(** Type of unit test fold state. *)
- type 'a s = (t, t, t, Unit.t, 'a) Fold.step0
+ type 'a s = (t, t, Unit.t, t, t, Unit.t, 'a) Fold.s
(** Type of a unit test fold step. *)
(** == TEST SPECIFICATION INTERFACE == *)
- val unitTests : (t, t, Unit.t, 'a) Fold.t
+ val unitTests : (t, t, Unit.t, 'a) Fold.f
(** Begins test specification. *)
val title : String.t -> 'a s
@@ -203,7 +203,7 @@
size : Int.t UnOp.t,
passM : Int.t,
skipM : Int.t}
- type 'a s = (t, t, t, Unit.t, 'a) Fold.step0
+ type 'a s = (t, t, Unit.t, t, t, Unit.t, 'a) Fold.s
exception Failure of Prettier.t
val failure = Exn.throw o Failure
@@ -229,7 +229,7 @@
val i2s = I.toString
fun runTest safeTest =
- Fold.step0 (fn cfg as IN {idx, ...} =>
+ Fold.mapSt (fn cfg as IN {idx, ...} =>
((if safeTest cfg then succeeded else failed) += 1
; updCfg (U#idx (idx + 1)) $ cfg))
@@ -255,8 +255,8 @@
(* TEST SPECIFICATION INTERFACE *)
- fun unitTests ? = Fold.fold (defaultCfg, ignore) ?
- fun title title = Fold.step0 (updCfg (U #idx 1) (U #title (SOME title)) $)
+ fun unitTests ? = Fold.wrap (defaultCfg, ignore) ?
+ fun title title = Fold.mapSt (updCfg (U #idx 1) (U #title (SOME title)) $)
(* AD HOC TESTING HELPERS *)
@@ -317,7 +317,7 @@
type law = (Bool.t Option.t * String.t List.t * Prettier.t List.t) G.t
local
- fun mk field value = Fold.step0 (updCfg (U field value) $)
+ fun mk field value = Fold.mapSt (updCfg (U field value) $)
in
fun sizeFn ? = mk #size ?
fun maxPass ? = mk #passM ?
More information about the MLton-commit
mailing list