[MLton-commit] r5828
Vesa Karvonen
vesak at mlton.org
Mon Aug 6 23:35:16 PDT 2007
Added an experimental generic for making reduce operations.
----------------------------------------------------------------------
U mltonlib/trunk/com/ssh/generic/unstable/detail/ml/smlnj/unsealed.cm
A mltonlib/trunk/com/ssh/generic/unstable/detail/value/reduce.sml
U mltonlib/trunk/com/ssh/generic/unstable/lib.mlb
U mltonlib/trunk/com/ssh/generic/unstable/public/export.sml
A mltonlib/trunk/com/ssh/generic/unstable/public/value/reduce.sig
----------------------------------------------------------------------
Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/ml/smlnj/unsealed.cm
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/ml/smlnj/unsealed.cm 2007-08-06 21:48:33 UTC (rev 5827)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/ml/smlnj/unsealed.cm 2007-08-07 06:35:15 UTC (rev 5828)
@@ -29,6 +29,7 @@
../../../public/value/ord.sig
../../../public/value/pickle.sig
../../../public/value/pretty.sig
+ ../../../public/value/reduce.sig
../../../public/value/some.sig
../../../public/value/type-info.sig
../../close-generic.fun
@@ -46,6 +47,7 @@
../../value/ord.sml
../../value/pickle.sml
../../value/pretty.sml
+ ../../value/reduce.sml
../../value/some.sml
../../value/type-info.sml
../../with-extra.fun
Added: mltonlib/trunk/com/ssh/generic/unstable/detail/value/reduce.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/value/reduce.sml 2007-08-06 21:48:33 UTC (rev 5827)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/value/reduce.sml 2007-08-07 06:35:15 UTC (rev 5828)
@@ -0,0 +1,84 @@
+(* 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.
+ *)
+
+functor WithReduce (Arg : OPEN_GENERIC) : REDUCE_GENERIC = struct
+ (* <-- SML/NJ workaround *)
+ open TopLevel
+ infix 0 &
+ (* SML/NJ workaround --> *)
+
+ fun seq fold rA (c as {zero, +}) = let
+ val rA = rA c
+ in
+ fold (fn (a, r) => rA a + r) zero
+ end
+
+ fun default {zero, + = _} = const zero
+
+ structure Reduce = LayerGenericRep
+ (structure Outer = Arg.Rep
+ structure Closed = MkClosedRep
+ (type 'a t = {zero : Univ.t, + : Univ.t BinOp.t} -> 'a -> Univ.t))
+
+ fun makeReduce zero op + a2r tA tA2tB = let
+ val (to, from) = Univ.Iso.new ()
+ val c = {zero = to zero, + = BinOp.map (from, to) op +}
+ val tA = Reduce.This.mapT (const (const (to o a2r))) tA
+ val tB = tA2tB tA
+ in
+ from o Reduce.This.getT tB c
+ end
+
+ structure Layered = LayerGeneric
+ (structure Outer = Arg and Result = Reduce and Rep = Reduce.Closed
+
+ fun iso rB (a2b, _) c = rB c o a2b
+ val isoProduct = iso
+ val isoSum = iso
+
+ fun op *` (rA, rB) (c as {zero = _, +}) =
+ op + o Pair.map (rA c, rB c) o Product.toTuple2
+ val T = id
+ fun R _ = id
+ val tuple = id
+ val record = id
+
+ fun op +` (rA, rB) c = Sum.sum (rA c, rB c)
+ val unit = default
+ fun C0 _ = unit
+ fun C1 _ = id
+ val data = id
+
+ val Y = Tie.function
+
+ fun op --> _ = failing "Reduce.--> has no default"
+
+ fun regExn _ _ = ()
+ fun exn _ = fail "Reduce.exn not yet implemented"
+
+ fun list ? = seq List.foldl ?
+ fun vector ? = seq Vector.foldl ?
+ fun array ? = seq Array.foldl ?
+
+ fun refc rA c = rA c o !
+
+ val largeInt = default
+ val largeReal = default
+ val largeWord = default
+
+ val bool = default
+ val char = default
+ val int = default
+ val real = default
+ val string = default
+ val word = default
+
+ val word8 = default
+ val word32 = default
+ val word64 = default)
+
+ open Layered
+end
Property changes on: mltonlib/trunk/com/ssh/generic/unstable/detail/value/reduce.sml
___________________________________________________________________
Name: svn:eol-style
+ native
Modified: mltonlib/trunk/com/ssh/generic/unstable/lib.mlb
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/lib.mlb 2007-08-06 21:48:33 UTC (rev 5827)
+++ mltonlib/trunk/com/ssh/generic/unstable/lib.mlb 2007-08-07 06:35:15 UTC (rev 5828)
@@ -91,6 +91,9 @@
public/value/pretty.sig
detail/value/pretty.sml
+
+ public/value/reduce.sig
+ detail/value/reduce.sml
in
public/export.sml
end
Modified: mltonlib/trunk/com/ssh/generic/unstable/public/export.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/public/export.sml 2007-08-06 21:48:33 UTC (rev 5827)
+++ mltonlib/trunk/com/ssh/generic/unstable/public/export.sml 2007-08-07 06:35:15 UTC (rev 5828)
@@ -47,6 +47,9 @@
signature PRETTY = PRETTY
signature PRETTY_GENERIC = PRETTY_GENERIC
+signature REDUCE = REDUCE
+signature REDUCE_GENERIC = REDUCE_GENERIC
+
signature SOME = SOME
signature SOME_GENERIC = SOME_GENERIC
@@ -157,6 +160,8 @@
functor WithPretty (Arg : OPEN_GENERIC) : PRETTY_GENERIC = WithPretty (Arg)
+functor WithReduce (Arg : OPEN_GENERIC) : REDUCE_GENERIC = WithReduce (Arg)
+
signature WITH_SOME_DOM = WITH_SOME_DOM
functor WithSome (Arg : WITH_SOME_DOM) : SOME_GENERIC = WithSome (Arg)
Added: mltonlib/trunk/com/ssh/generic/unstable/public/value/reduce.sig
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/public/value/reduce.sig 2007-08-06 21:48:33 UTC (rev 5827)
+++ mltonlib/trunk/com/ssh/generic/unstable/public/value/reduce.sig 2007-08-07 06:35:15 UTC (rev 5828)
@@ -0,0 +1,28 @@
+(* 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.
+ *)
+
+(**
+ * A generic for making reduce operations.
+ *
+ * This design is experimental.
+ *)
+signature REDUCE = sig
+ structure Reduce : OPEN_GENERIC_REP
+
+ val makeReduce :
+ 'r
+ -> 'r BinOp.t
+ -> ('a -> 'r)
+ -> ('a, 'x) Reduce.t
+ -> (('a, 'x) Reduce.t -> ('b, 'y) Reduce.t)
+ -> 'b -> 'r
+ (** Creates a reduce operation. *)
+end
+
+signature REDUCE_GENERIC = sig
+ include OPEN_GENERIC REDUCE
+ sharing Rep = Reduce
+end
Property changes on: mltonlib/trunk/com/ssh/generic/unstable/public/value/reduce.sig
___________________________________________________________________
Name: svn:eol-style
+ native
More information about the MLton-commit
mailing list