[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