[MLton-commit] r6080
Vesa Karvonen
vesak at mlton.org
Wed Oct 24 05:29:48 PDT 2007
Experimental, proof-of-feasibility, implementation of a Fmap (Functor)
generic. The Fmap generic is similar to the Transform generic, but allows
transforms that cannot be typed with Transform. (The current
implementation of Fmap is otherwise limited when compared to Transform.)
To implement Fmap, a new, unsafe, structural case "hole", which is
essentially an undefined type rep, was introduced. Whether or not Fmap is
worth the added complexity and unsafety (which probably isn't a practical
problem) is not clear and Fmap might be removed in the future.
----------------------------------------------------------------------
U mltonlib/trunk/com/ssh/generic/unstable/detail/layer-generic.fun
A mltonlib/trunk/com/ssh/generic/unstable/detail/ml/smlnj/sigs.cm
U mltonlib/trunk/com/ssh/generic/unstable/detail/ml/smlnj/unsealed.cm
U mltonlib/trunk/com/ssh/generic/unstable/detail/root-generic.sml
U mltonlib/trunk/com/ssh/generic/unstable/detail/value/arbitrary.sml
U mltonlib/trunk/com/ssh/generic/unstable/detail/value/data-rec-info.sml
U mltonlib/trunk/com/ssh/generic/unstable/detail/value/debug.sml
U mltonlib/trunk/com/ssh/generic/unstable/detail/value/dynamic.sml
U mltonlib/trunk/com/ssh/generic/unstable/detail/value/eq.sml
A mltonlib/trunk/com/ssh/generic/unstable/detail/value/fmap.sml
U mltonlib/trunk/com/ssh/generic/unstable/detail/value/hash.sml
U mltonlib/trunk/com/ssh/generic/unstable/detail/value/ord.sml
U mltonlib/trunk/com/ssh/generic/unstable/detail/value/pickle.sml
U mltonlib/trunk/com/ssh/generic/unstable/detail/value/pretty.sml
U mltonlib/trunk/com/ssh/generic/unstable/detail/value/reduce.sml
U mltonlib/trunk/com/ssh/generic/unstable/detail/value/seq.sml
U mltonlib/trunk/com/ssh/generic/unstable/detail/value/shrink.sml
U mltonlib/trunk/com/ssh/generic/unstable/detail/value/size.sml
U mltonlib/trunk/com/ssh/generic/unstable/detail/value/some.sml
U mltonlib/trunk/com/ssh/generic/unstable/detail/value/transform.sml
U mltonlib/trunk/com/ssh/generic/unstable/detail/value/type-exp.sml
U mltonlib/trunk/com/ssh/generic/unstable/detail/value/type-hash.sml
U mltonlib/trunk/com/ssh/generic/unstable/detail/value/type-info.sml
U mltonlib/trunk/com/ssh/generic/unstable/lib.mlb
U mltonlib/trunk/com/ssh/generic/unstable/public/export.sml
U mltonlib/trunk/com/ssh/generic/unstable/public/layer-cases-fun.sig
U mltonlib/trunk/com/ssh/generic/unstable/public/layer-dep-cases-fun.sig
U mltonlib/trunk/com/ssh/generic/unstable/public/open-cases.sig
A mltonlib/trunk/com/ssh/generic/unstable/public/value/fmap.sig
A mltonlib/trunk/com/ssh/generic/unstable/test/fmap.sml
U mltonlib/trunk/com/ssh/generic/unstable/test/generic.sml
U mltonlib/trunk/com/ssh/generic/unstable/test.mlb
A mltonlib/trunk/com/ssh/generic/unstable/with/fmap.sml
----------------------------------------------------------------------
Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/layer-generic.fun
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/layer-generic.fun 2007-10-24 09:23:59 UTC (rev 6079)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/layer-generic.fun 2007-10-24 12:29:43 UTC (rev 6080)
@@ -118,6 +118,8 @@
fun real ? = op0t Open.real Arg.real ?
fun string ? = op0t Open.string Arg.string ?
fun word ? = op0t Open.word Arg.word ?
+
+ fun hole ? = Open.hole (This.mkT (Arg.hole (), ?))
end
functor LayerCases (Arg : LAYER_CASES_DOM) :>
Added: mltonlib/trunk/com/ssh/generic/unstable/detail/ml/smlnj/sigs.cm
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/ml/smlnj/sigs.cm 2007-10-24 09:23:59 UTC (rev 6079)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/ml/smlnj/sigs.cm 2007-10-24 12:29:43 UTC (rev 6080)
@@ -0,0 +1,45 @@
+(* 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.
+ *)
+
+group is
+ ../../../../../extended-basis/unstable/basis.cm
+ ../../../../../prettier/unstable/lib.cm
+ ../../../../../random/unstable/lib.cm
+ ../../../public/cases.sig
+ ../../../public/closed-cases.sig
+ ../../../public/closed-rep.sig
+ ../../../public/generic-extra.sig
+ ../../../public/generic.sig
+ ../../../public/generics-util.sig
+ ../../../public/generics.sig
+ ../../../public/layer-cases-fun.sig
+ ../../../public/layer-dep-cases-fun.sig
+ ../../../public/layer-rep-fun.sig
+ ../../../public/layered-rep.sig
+ ../../../public/open-cases.sig
+ ../../../public/open-rep.sig
+ ../../../public/ty.sig
+ ../../../public/value/arbitrary.sig
+ ../../../public/value/data-rec-info.sig
+ ../../../public/value/dynamic.sig
+ ../../../public/value/eq.sig
+ ../../../public/value/fmap.sig
+ ../../../public/value/hash.sig
+ ../../../public/value/ord.sig
+ ../../../public/value/pickle.sig
+ ../../../public/value/pretty.sig
+ ../../../public/value/reduce.sig
+ ../../../public/value/seq.sig
+ ../../../public/value/shrink.sig
+ ../../../public/value/size.sig
+ ../../../public/value/some.sig
+ ../../../public/value/transform.sig
+ ../../../public/value/type-exp.sig
+ ../../../public/value/type-hash.sig
+ ../../../public/value/type-info.sig
+ ../../generics.sml
+ ../../sml-syntax.sml
+ ../../ty.sml
Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/ml/smlnj/unsealed.cm
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/ml/smlnj/unsealed.cm 2007-10-24 09:23:59 UTC (rev 6079)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/ml/smlnj/unsealed.cm 2007-10-24 12:29:43 UTC (rev 6080)
@@ -4,45 +4,16 @@
* See the LICENSE file or http://mlton.org/License for details.
*)
-group is
+group
+ group(sigs.cm) - signature MK_FMAP_DOM - signature FMAP_CASES
+ source(-)
+is
../../../../../extended-basis/unstable/basis.cm
../../../../../prettier/unstable/lib.cm
../../../../../random/unstable/lib.cm
- ../../../public/cases.sig
- ../../../public/closed-cases.sig
- ../../../public/closed-rep.sig
- ../../../public/generic-extra.sig
- ../../../public/generic.sig
- ../../../public/generics-util.sig
- ../../../public/generics.sig
- ../../../public/layer-cases-fun.sig
- ../../../public/layer-dep-cases-fun.sig
- ../../../public/layer-rep-fun.sig
- ../../../public/layered-rep.sig
- ../../../public/open-cases.sig
- ../../../public/open-rep.sig
- ../../../public/ty.sig
- ../../../public/value/arbitrary.sig
- ../../../public/value/data-rec-info.sig
- ../../../public/value/dynamic.sig
- ../../../public/value/eq.sig
- ../../../public/value/hash.sig
- ../../../public/value/ord.sig
- ../../../public/value/pickle.sig
- ../../../public/value/pretty.sig
- ../../../public/value/reduce.sig
- ../../../public/value/seq.sig
- ../../../public/value/shrink.sig
- ../../../public/value/size.sig
- ../../../public/value/some.sig
- ../../../public/value/transform.sig
- ../../../public/value/type-exp.sig
- ../../../public/value/type-hash.sig
- ../../../public/value/type-info.sig
../../close-generic.fun
../../close-pretty-with-extra.fun
../../generics-util.sml
- ../../generics.sml
../../hash-map.sml
../../hash-univ.sml
../../layer-generic.fun
@@ -51,13 +22,12 @@
../../opt-int.sml
../../reg-basis-exns.fun
../../root-generic.sml
- ../../sml-syntax.sml
- ../../ty.sml
../../value/arbitrary.sml
../../value/data-rec-info.sml
../../value/debug.sml
../../value/dynamic.sml
../../value/eq.sml
+ ../../value/fmap.sml
../../value/hash.sml
../../value/ord.sml
../../value/pickle.sml
@@ -74,3 +44,4 @@
../../with-extra.fun
extensions.cm
hash-table.cm
+ sigs.cm
Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/root-generic.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/root-generic.sml 2007-10-24 09:23:59 UTC (rev 6079)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/root-generic.sml 2007-10-24 12:29:43 UTC (rev 6080)
@@ -58,4 +58,6 @@
val real = id
val string = id
val word = id
+
+ val hole = id
end
Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/value/arbitrary.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/value/arbitrary.sml 2007-10-24 09:23:59 UTC (rev 6079)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/value/arbitrary.sml 2007-10-24 12:29:43 UTC (rev 6080)
@@ -156,5 +156,7 @@
val word32 = mkWord Word32.wordSize Word32.fromLargeInt Arg.Open.word32
val word64 = mkWord Word64.wordSize Word64.fromLargeInt Arg.Open.word64
+ fun hole () = IN {gen = G.lift undefined, cog = undefined}
+
open Arg ArbitraryRep)
end
Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/value/data-rec-info.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/value/data-rec-info.sml 2007-10-24 09:23:59 UTC (rev 6079)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/value/data-rec-info.sml 2007-10-24 12:29:43 UTC (rev 6080)
@@ -111,5 +111,7 @@
val word32 = base
val word64 = base
+ fun hole () = base
+
open Arg DataRecInfoRep)
end
Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/value/debug.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/value/debug.sml 2007-10-24 09:23:59 UTC (rev 6079)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/value/debug.sml 2007-10-24 12:29:43 UTC (rev 6080)
@@ -78,6 +78,8 @@
val word32 = ()
val word64 = ()
+ fun hole () = ()
+
open Arg DebugRep)
open Layered
Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/value/dynamic.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/value/dynamic.sml 2007-10-24 09:23:59 UTC (rev 6079)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/value/dynamic.sml 2007-10-24 12:29:43 UTC (rev 6080)
@@ -106,6 +106,8 @@
val word32 = (WORD32, fn WORD32 ? => ? | _ => raise Dynamic)
val word64 = (WORD64, fn WORD64 ? => ? | _ => raise Dynamic)
+ fun hole () = (undefined, undefined)
+
open Arg DynamicRep)
end
in
Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/value/eq.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/value/eq.sml 2007-10-24 09:23:59 UTC (rev 6079)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/value/eq.sml 2007-10-24 12:29:43 UTC (rev 6080)
@@ -89,5 +89,7 @@
val word32 = op = : Word32.t t
val word64 = op = : Word64.t t
+ fun hole () = undefined
+
open Arg EqRep)
end
Added: mltonlib/trunk/com/ssh/generic/unstable/detail/value/fmap.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/value/fmap.sml 2007-10-24 09:23:59 UTC (rev 6079)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/value/fmap.sml 2007-10-24 12:29:43 UTC (rev 6080)
@@ -0,0 +1,151 @@
+(* 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 FmapAux = struct
+ datatype u =
+ PRODUCT of (u, u) Product.t
+ | SUM of (u, u) Sum.t
+ | UNIT
+ | ARROW of u UnOp.t
+ | EXN of Exn.t
+ | LIST of u List.t
+ | VECTOR of u Vector.t
+ | FIXED_INT of FixedInt.t
+ | LARGE_INT of LargeInt.t
+ | LARGE_WORD of LargeWord.t
+ | LARGE_REAL of LargeReal.t
+ | BOOL of Bool.t
+ | CHAR of Char.t
+ | INT of Int.t
+ | REAL of Real.t
+ | STRING of String.t
+ | WORD of Word.t
+ | WORD8 of Word8.t
+ | WORD32 of Word32.t
+ | WORD64 of Word64.t
+ | ARGUMENT of Univ.t
+ datatype 'a i = ISO of ('a, u) Iso.t
+ datatype 'a t = IN of 'a
+end
+
+signature FMAP_CASES = FMAP_CASES
+ where type 'a Fmap.i = 'a FmapAux.i
+ where type 'a Fmap.t = 'a FmapAux.t
+
+signature MK_FMAP_DOM = MK_FMAP_DOM
+ where type 'a Fmap.i = 'a FmapAux.i
+ where type 'a Fmap.t = 'a FmapAux.t
+
+functor WithFmap (Arg : WITH_FMAP_DOM) = let
+ structure Result = struct
+ (* <-- SML/NJ workaround *)
+ open TopLevel
+ infix <-->
+ (* SML/NJ workaround --> *)
+
+ val op <--> = Iso.<-->
+
+ structure FmapRep = LayerRep
+ (open Arg
+ structure Rep = MkClosedRep (type 'a t = 'a FmapAux.i))
+
+ structure Fmap = struct
+ open FmapAux
+ val get = IN FmapRep.This.getT
+ val map = IN FmapRep.This.mapT
+ end
+
+ open Fmap
+
+ fun isoUnsupported text = ISO (failing text, failing text)
+
+ structure Open = LayerCases
+ (fun iso (ISO bId) aIb = ISO (bId <--> aIb)
+ val isoProduct = iso
+ val isoSum = iso
+
+ fun op *` (ISO a, ISO b) =
+ ISO ((PRODUCT, fn PRODUCT ? => ? | _ => raise Empty)
+ <--> Product.iso (a, b))
+ val T = id
+ fun R _ = id
+ val tuple = id
+ val record = id
+
+ fun op +` (ISO a, ISO b) =
+ ISO ((SUM, fn SUM ? => ? | _ => raise Empty) <--> Sum.iso (a, b))
+ val unit = ISO (fn () => UNIT, fn UNIT => () | _ => raise Empty)
+ fun C0 _ = unit
+ fun C1 _ = id
+ val data = id
+
+ fun Y ? = let open Tie in iso (tuple2 (function, function)) end
+ (fn ISO ? => ?, ISO) ?
+
+ fun op --> (ISO a, ISO b) =
+ ISO ((ARROW, fn ARROW ? => ? | _ => raise Empty) <--> Fn.iso (a, b))
+
+ val exn = ISO (EXN, fn EXN ? => ? | _ => raise Empty)
+ fun regExn0 _ _ = ()
+ fun regExn1 _ _ _ = ()
+
+ fun list (ISO i) =
+ ISO ((LIST, fn LIST ? => ? | _ => raise Empty) <--> List.iso i)
+ fun vector (ISO i) =
+ ISO ((VECTOR, fn VECTOR ? => ? | _ => raise Empty) <--> Vector.iso i)
+
+ fun array _ = isoUnsupported "Fmap.array unsupported"
+ fun refc _ = isoUnsupported "Fmap.refc unsupported"
+
+ val fixedInt = ISO (FIXED_INT, fn FIXED_INT ? => ? | _ => raise Empty)
+ val largeInt = ISO (LARGE_INT, fn LARGE_INT ? => ? | _ => raise Empty)
+
+ val largeWord = ISO (LARGE_WORD, fn LARGE_WORD ? => ? | _ => raise Empty)
+ val largeReal = ISO (LARGE_REAL, fn LARGE_REAL ? => ? | _ => raise Empty)
+
+ val bool = ISO (BOOL, fn BOOL ? => ? | _ => raise Empty)
+ val char = ISO (CHAR, fn CHAR ? => ? | _ => raise Empty)
+ val int = ISO (INT, fn INT ? => ? | _ => raise Empty)
+ val real = ISO (REAL, fn REAL ? => ? | _ => raise Empty)
+ val string = ISO (STRING, fn STRING ? => ? | _ => raise Empty)
+ val word = ISO (WORD, fn WORD ? => ? | _ => raise Empty)
+
+ val word8 = ISO (WORD8, fn WORD8 ? => ? | _ => raise Empty)
+ val word32 = ISO (WORD32, fn WORD32 ? => ? | _ => raise Empty)
+ val word64 = ISO (WORD64, fn WORD64 ? => ? | _ => raise Empty)
+
+ fun hole () = ISO (undefined, undefined)
+
+ open Arg FmapRep)
+ end
+in
+ Result :> FMAP_CASES
+ where type ('a, 'x) Open.Rep.t = ('a, 'x) Result.Open.Rep.t
+ where type ('a, 'x) Open.Rep.s = ('a, 'x) Result.Open.Rep.s
+ where type ('a, 'k, 'x) Open.Rep.p = ('a, 'k, 'x) Result.Open.Rep.p
+end
+
+functor MkFmap (Arg : MK_FMAP_DOM) : sig
+ val map : ('a -> 'b) -> 'a Arg.t -> 'b Arg.t
+end = struct
+ (* <-- SML/NJ workaround *)
+ open TopLevel
+ (* SML/NJ workaround --> *)
+
+ open FmapAux Arg
+
+ fun map a2b = let
+ val (fromB, toB) = Univ.Iso.new ()
+ val IN get = Fmap.get and IN map = Fmap.map
+ fun mk i = get (t (map (const (ISO i)) (Open.hole ())))
+ val ISO (fromA, _) = mk (ARGUMENT o fromB o a2b, undefined)
+ val ISO (_, toB) = mk (undefined, fn ARGUMENT ? => toB ? | _ => raise Empty)
+ in
+ toB o fromA
+ end
+end
+
+structure FmapAux : sig type 'a i and 'a t end = FmapAux
Property changes on: mltonlib/trunk/com/ssh/generic/unstable/detail/value/fmap.sml
___________________________________________________________________
Name: svn:eol-style
+ native
Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/value/hash.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/value/hash.sml 2007-10-24 09:23:59 UTC (rev 6079)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/value/hash.sml 2007-10-24 12:29:43 UTC (rev 6080)
@@ -177,5 +177,7 @@
val word32 = prim Word32.toWord
val word64 = viaWord id op mod Word64.isoWord
+ fun hole () = undefined
+
open Arg HashRep)
end
Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/value/ord.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/value/ord.sml 2007-10-24 09:23:59 UTC (rev 6079)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/value/ord.sml 2007-10-24 12:29:43 UTC (rev 6080)
@@ -143,5 +143,7 @@
val word32 = lift Word32.compare
val word64 = lift Word64.compare
+ fun hole () = undefined
+
open Arg OrdRep)
end
Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/value/pickle.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/value/pickle.sml 2007-10-24 09:23:59 UTC (rev 6079)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/value/pickle.sml 2007-10-24 12:29:43 UTC (rev 6080)
@@ -683,6 +683,9 @@
val word32 = word32
val word64 = bits false Word64Ops.ops Iso.id
+ fun hole () = P {rd = let open I in return () >>= undefined end,
+ wr = undefined, sz = NONE}
+
open Arg PickleRep)
end
in
Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/value/pretty.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/value/pretty.sml 2007-10-24 09:23:59 UTC (rev 6079)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/value/pretty.sml 2007-10-24 12:29:43 UTC (rev 6080)
@@ -423,6 +423,8 @@
val word32 = mkWord Word32.fmt
val word64 = mkWord Word64.fmt
+ fun hole () = undefined
+
open Arg PrettyRep)
end
in
Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/value/reduce.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/value/reduce.sml 2007-10-24 09:23:59 UTC (rev 6079)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/value/reduce.sml 2007-10-24 12:29:43 UTC (rev 6080)
@@ -91,5 +91,7 @@
val word32 = default
val word64 = default
+ fun hole () = undefined
+
open Arg ReduceRep)
end
Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/value/seq.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/value/seq.sml 2007-10-24 09:23:59 UTC (rev 6079)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/value/seq.sml 2007-10-24 12:29:43 UTC (rev 6080)
@@ -135,5 +135,7 @@
val word32 = lift op = : Word32.t t
val word64 = lift op = : Word64.t t
+ fun hole () = undefined
+
open Arg SeqRep)
end
Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/value/shrink.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/value/shrink.sml 2007-10-24 09:23:59 UTC (rev 6079)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/value/shrink.sml 2007-10-24 12:29:43 UTC (rev 6080)
@@ -197,5 +197,7 @@
val word32 = mkWord Word32Ops.ops
val word64 = mkWord Word64Ops.ops
+ fun hole () = IN {kids = undefined, shrink = undefined}
+
open Arg ShrinkRep)
end
Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/value/size.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/value/size.sml 2007-10-24 09:23:59 UTC (rev 6079)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/value/size.sml 2007-10-24 12:29:43 UTC (rev 6080)
@@ -166,5 +166,7 @@
val word32 = mkWord Word32.wordSize : Word32.t t
val word64 = mkWord Word64.wordSize : Word64.t t
+ fun hole () = DYNAMIC undefined
+
open Arg SizeRep)
end
Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/value/some.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/value/some.sml 2007-10-24 09:23:59 UTC (rev 6079)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/value/some.sml 2007-10-24 12:29:43 UTC (rev 6080)
@@ -88,5 +88,7 @@
val word32 = fn () => 0w0 : Word32.t
val word64 = fn () => 0w0 : Word64.t
+ fun hole () = undefined
+
open Arg SomeRep)
end
Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/value/transform.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/value/transform.sml 2007-10-24 09:23:59 UTC (rev 6079)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/value/transform.sml 2007-10-24 12:29:43 UTC (rev 6080)
@@ -115,5 +115,7 @@
val word32 = default
val word64 = default
+ fun hole () = (CUSTOM, undefined)
+
open Arg TransformRep)
end
Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/value/type-exp.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/value/type-exp.sml 2007-10-24 09:23:59 UTC (rev 6079)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/value/type-exp.sml 2007-10-24 12:29:43 UTC (rev 6080)
@@ -83,6 +83,8 @@
val word32 = CON0 WORD32
val word64 = CON0 WORD64
+ fun hole () = CON0 UNIT
+
open Arg TypeExpRep)
end
in
Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/value/type-hash.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/value/type-hash.sml 2007-10-24 09:23:59 UTC (rev 6079)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/value/type-hash.sml 2007-10-24 12:29:43 UTC (rev 6080)
@@ -76,5 +76,7 @@
val word32 = 0wxCDB6D501 : Word32.t
val word64 = 0wxDB6DB101 : Word32.t
+ fun hole () = 0w0 : Word32.t
+
open Arg TypeHashRep)
end
Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/value/type-info.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/value/type-info.sml 2007-10-24 09:23:59 UTC (rev 6079)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/value/type-info.sml 2007-10-24 12:29:43 UTC (rev 6080)
@@ -84,5 +84,7 @@
val word32 = base
val word64 = base
+ fun hole () = base
+
open Arg TypeInfoRep)
end
Modified: mltonlib/trunk/com/ssh/generic/unstable/lib.mlb
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/lib.mlb 2007-10-24 09:23:59 UTC (rev 6079)
+++ mltonlib/trunk/com/ssh/generic/unstable/lib.mlb 2007-10-24 12:29:43 UTC (rev 6080)
@@ -110,6 +110,9 @@
public/value/eq.sig
detail/value/eq.sml
+ public/value/fmap.sig
+ detail/value/fmap.sml
+
public/value/ord.sig
detail/value/ord.sml
Modified: mltonlib/trunk/com/ssh/generic/unstable/public/export.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/public/export.sml 2007-10-24 09:23:59 UTC (rev 6079)
+++ mltonlib/trunk/com/ssh/generic/unstable/public/export.sml 2007-10-24 12:29:43 UTC (rev 6080)
@@ -146,6 +146,15 @@
signature EQ = EQ and EQ_CASES = EQ_CASES and WITH_EQ_DOM = WITH_EQ_DOM
functor WithEq (Arg : WITH_EQ_DOM) : EQ_CASES = WithEq (Arg)
+structure FmapAux = FmapAux
+signature FMAP = FMAP and FMAP_CASES = FMAP_CASES
+ and WITH_FMAP_DOM = WITH_FMAP_DOM
+functor WithFmap (Arg : WITH_FMAP_DOM) : FMAP_CASES = WithFmap (Arg)
+signature MK_FMAP_DOM = MK_FMAP_DOM
+functor MkFmap (Arg : MK_FMAP_DOM) : sig
+ val map : ('a -> 'b) -> 'a Arg.t -> 'b Arg.t
+end = MkFmap (Arg)
+
signature HASH = HASH and HASH_CASES = HASH_CASES
and WITH_HASH_DOM = WITH_HASH_DOM
functor WithHash (Arg : WITH_HASH_DOM) : HASH_CASES = WithHash (Arg)
Modified: mltonlib/trunk/com/ssh/generic/unstable/public/layer-cases-fun.sig
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/public/layer-cases-fun.sig 2007-10-24 09:23:59 UTC (rev 6079)
+++ mltonlib/trunk/com/ssh/generic/unstable/public/layer-cases-fun.sig 2007-10-24 12:29:43 UTC (rev 6080)
@@ -11,4 +11,5 @@
include CASES LAYERED_REP CLOSED_CASES
sharing Open.Rep = Outer
sharing Rep = This
+ val hole : 'a Rep.t Thunk.t
end
Modified: mltonlib/trunk/com/ssh/generic/unstable/public/layer-dep-cases-fun.sig
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/public/layer-dep-cases-fun.sig 2007-10-24 09:23:59 UTC (rev 6079)
+++ mltonlib/trunk/com/ssh/generic/unstable/public/layer-dep-cases-fun.sig 2007-10-24 12:29:43 UTC (rev 6080)
@@ -45,4 +45,5 @@
val real : Real.t This.t
val string : String.t This.t
val word : Word.t This.t
+ val hole : 'a This.t Thunk.t
end
Modified: mltonlib/trunk/com/ssh/generic/unstable/public/open-cases.sig
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/public/open-cases.sig 2007-10-24 09:23:59 UTC (rev 6079)
+++ mltonlib/trunk/com/ssh/generic/unstable/public/open-cases.sig 2007-10-24 12:29:43 UTC (rev 6080)
@@ -46,4 +46,5 @@
val real : 'x -> (Real.t, 'x) Rep.t
val string : 'x -> (String.t, 'x) Rep.t
val word : 'x -> (Word.t, 'x) Rep.t
+ val hole : 'x -> ('a, 'x) Rep.t
end
Added: mltonlib/trunk/com/ssh/generic/unstable/public/value/fmap.sig
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/public/value/fmap.sig 2007-10-24 09:23:59 UTC (rev 6079)
+++ mltonlib/trunk/com/ssh/generic/unstable/public/value/fmap.sig 2007-10-24 12:29:43 UTC (rev 6080)
@@ -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.
+ *)
+
+signature FMAP = sig
+ structure FmapRep : OPEN_REP
+
+ structure Fmap : sig
+ type 'a i and 'a t
+ val get : (('a, 'x) FmapRep.t -> 'a i) t
+ val map : ('a i UnOp.t -> ('a, 'x) FmapRep.t UnOp.t) t
+ end
+end
+
+signature FMAP_CASES = sig
+ include CASES FMAP
+ sharing Open.Rep = FmapRep
+end
+
+signature WITH_FMAP_DOM = CASES
+
+signature MK_FMAP_DOM = sig
+ include FMAP_CASES
+ type 'a t
+ val t : ('a, Unit.t) Open.Rep.t -> ('a t, Unit.t) Open.Rep.t
+end
Property changes on: mltonlib/trunk/com/ssh/generic/unstable/public/value/fmap.sig
___________________________________________________________________
Name: svn:eol-style
+ native
Added: mltonlib/trunk/com/ssh/generic/unstable/test/fmap.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/test/fmap.sml 2007-10-24 09:23:59 UTC (rev 6079)
+++ mltonlib/trunk/com/ssh/generic/unstable/test/fmap.sml 2007-10-24 12:29:43 UTC (rev 6080)
@@ -0,0 +1,39 @@
+(* 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.
+ *)
+
+local
+ open Generic UnitTest
+
+ structure BinTree = MkBinTree (Generic)
+
+ structure ListF = MkFmap (open Generic List val t = list)
+ structure BinTreeF = MkFmap (open Generic BinTree)
+in
+ val () =
+ unitTests
+ (title "Generic.Fmap")
+
+ (testEq (list word)
+ (fn () =>
+ {expect = [0w1, 0w2, 0w3],
+ actual = ListF.map Word.fromInt [1, 2, 3]}))
+
+ let
+ open BinTree BinTreeF
+ in
+ testEq (t word)
+ (fn () =>
+ {expect = BR (BR (LF, 0w0, LF),
+ 0w1,
+ BR (LF, 0w2, BR (LF, 0w3, LF))),
+ actual = map Word.fromInt
+ (BR (BR (LF, 0, LF),
+ 1,
+ BR (LF, 2, BR (LF, 3, LF))))})
+ end
+
+ $
+end
Property changes on: mltonlib/trunk/com/ssh/generic/unstable/test/fmap.sml
___________________________________________________________________
Name: svn:eol-style
+ native
Modified: mltonlib/trunk/com/ssh/generic/unstable/test/generic.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/test/generic.sml 2007-10-24 09:23:59 UTC (rev 6079)
+++ mltonlib/trunk/com/ssh/generic/unstable/test/generic.sml 2007-10-24 12:29:43 UTC (rev 6080)
@@ -93,6 +93,20 @@
MkGeneric (structure Open = WithTransform (Generic)
open Generic Open)
+signature Generic = sig
+ include Generic FMAP
+end
+
+functor MkGeneric (Arg : Generic) = struct
+ structure Open = MkGeneric (Arg)
+ open Arg Open
+ structure FmapRep = Open.Rep
+end
+
+structure Generic =
+ MkGeneric (structure Open = WithFmap (Generic)
+ open Generic Open)
+
structure Generic = struct
structure Rep = ClosePrettyWithExtra
(open Generic
Modified: mltonlib/trunk/com/ssh/generic/unstable/test.mlb
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/test.mlb 2007-10-24 09:23:59 UTC (rev 6079)
+++ mltonlib/trunk/com/ssh/generic/unstable/test.mlb 2007-10-24 12:29:43 UTC (rev 6080)
@@ -22,11 +22,13 @@
with/seq.sml
with/reduce.sml
with/transform.sml
+ with/fmap.sml
with/close-pretty-with-extra.sml
with/reg-basis-exns.sml
test/utils.fun
in
+ test/fmap.sml
test/pickle.sml
test/pretty.sml
test/reduce.sml
Added: mltonlib/trunk/com/ssh/generic/unstable/with/fmap.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/with/fmap.sml 2007-10-24 09:23:59 UTC (rev 6079)
+++ mltonlib/trunk/com/ssh/generic/unstable/with/fmap.sml 2007-10-24 12:29:43 UTC (rev 6080)
@@ -0,0 +1,19 @@
+(* 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 Generic = sig
+ include Generic FMAP
+end
+
+functor MkGeneric (Arg : Generic) = struct
+ structure Open = MkGeneric (Arg)
+ open Arg Open
+ structure FmapRep = Open.Rep
+end
+
+structure Generic =
+ MkGeneric (structure Open = WithFmap (Generic)
+ open Generic Open)
Property changes on: mltonlib/trunk/com/ssh/generic/unstable/with/fmap.sml
___________________________________________________________________
Name: svn:eol-style
+ native
More information about the MLton-commit
mailing list