[MLton-commit] r5629
Vesa Karvonen
vesak at mlton.org
Sat Jun 16 03:35:57 PDT 2007
Committed *unfinished* generic Hash function to make working with the
repository easier.
----------------------------------------------------------------------
U mltonlib/trunk/com/ssh/generic/unstable/detail/generic.sml
U mltonlib/trunk/com/ssh/generic/unstable/detail/ml/smlnj/unsealed.cm
A mltonlib/trunk/com/ssh/generic/unstable/detail/value/hash.sml
U mltonlib/trunk/com/ssh/generic/unstable/lib.mlb
U mltonlib/trunk/com/ssh/generic/unstable/public/export.sml
----------------------------------------------------------------------
Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/generic.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/generic.sml 2007-06-16 10:26:40 UTC (rev 5628)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/generic.sml 2007-06-16 10:35:56 UTC (rev 5629)
@@ -9,6 +9,7 @@
include ARBITRARY sharing Open.Rep = Arbitrary
include DUMMY sharing Open.Rep = Dummy
include EQ sharing Open.Rep = Eq
+ include HASH sharing Open.Rep = Hash
include ORD sharing Open.Rep = Ord
include SHOW sharing Open.Rep = Show
include TYPE_INFO sharing Open.Rep = TypeInfo
@@ -29,9 +30,17 @@
structure Open = WithArbitrary (Open) open Open
+ structure Open = struct
+ open TypeInfo Open
+ structure TypeInfo = Rep
+ end
+
+ structure Open = WithHash (Open) open Open
+
structure Arbitrary = Open.Rep
structure Dummy = Open.Rep
structure Eq = Open.Rep
+ structure Hash = Open.Rep
structure Ord = Open.Rep
structure Show = Open.Rep
structure TypeInfo = Open.Rep
Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/ml/smlnj/unsealed.cm
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/ml/smlnj/unsealed.cm 2007-06-16 10:26:40 UTC (rev 5628)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/ml/smlnj/unsealed.cm 2007-06-16 10:35:56 UTC (rev 5629)
@@ -34,6 +34,7 @@
../../value/arbitrary.sml
../../value/dummy.sml
../../value/eq.sml
+ ../../value/hash.sml
../../value/ord.sml
../../value/show.sml
../../value/type-info.sml
Added: mltonlib/trunk/com/ssh/generic/unstable/detail/value/hash.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/value/hash.sml 2007-06-16 10:26:40 UTC (rev 5628)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/value/hash.sml 2007-06-16 10:35:56 UTC (rev 5629)
@@ -0,0 +1,144 @@
+(* 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.
+ *)
+
+(* XXX UNFINISHED! NOTE THE USES OF `undefined` BELOW. *)
+
+functor WithHash (Arg : WITH_HASH_DOM) : HASH_GENERIC = struct
+ (* <-- SML/NJ workaround *)
+ open TopLevel
+ infix 7 *`
+ infix 6 +`
+ infix 4 <\ \>
+ infixr 4 </ />
+ infix 2 >| andAlso
+ infixr 2 |<
+ infix 1 orElse >>=
+ infix 0 &
+ infixr 0 -->
+ (* SML/NJ workaround --> *)
+
+ structure W = Word
+
+ fun mac word hash =
+ hash * 0w19 + word
+
+ datatype 'a t =
+ IN of 'a -> {maxWidth : Int.t, maxDepth : Int.t} -> Word.t UnOp.t
+
+ structure Rep =
+ JoinGenericReps
+ (structure Outer = Arg.Rep
+ structure Inner =
+ OpenGenericRep (MkClosedGenericRep (type 'a t = 'a t)))
+
+ structure Hash = Rep
+
+ fun hash t v =
+ case Pair.fst (Arg.Rep.getT t) of
+ IN h => h v {maxWidth = 200, maxDepth = 10} 0wx2CA4B13
+
+ fun iso' (IN bH) (a2b, _) = IN (bH o a2b)
+
+ fun morph outer f = outer (fn (a, x) => fn i => (iso' a i, f x i))
+ fun nullary outer t x = outer (t, x)
+ fun bop outer f g = outer (Pair.map (f, g) o Pair.swizzle)
+ fun uop outer f g = outer (Pair.map (f, g))
+
+ fun iso ? = morph Arg.iso ?
+ fun isoProduct ? = morph Arg.isoProduct ?
+ fun isoSum ? = morph Arg.isoSum ?
+
+ fun op *` xy2z (aT, bT) =
+ bop Arg.*`
+ (fn (IN aH, IN bH) =>
+ IN (fn a & b => fn {maxWidth, maxDepth} => let
+ val aN = Arg.numElems aT
+ val bN = Arg.numElems bT
+ val aW = Int.quot (maxWidth * aN, aN + bN)
+ val bW = maxWidth - aW
+ in
+ bH b {maxWidth = bW, maxDepth = maxDepth} o
+ aH a {maxWidth = aW, maxDepth = maxDepth}
+ end))
+ xy2z (aT, bT)
+
+ fun op +` ? =
+ bop Arg.+`
+ (fn (IN aH, IN bH) =>
+ IN (Sum.sum (aH, bH))) ?
+
+ fun Y y = Arg.Y (let open Tie in iso (function *` y) end
+ (fn (IN a, b) => a & b,
+ fn a & b => (IN a, b)))
+
+ fun op --> ? = bop Arg.--> (fn _ => IN (failing "Hash.--> unsupported")) ?
+
+ fun exn ? = let
+ val e = Fail "Hash.exn unsupported"
+ in
+ nullary Arg.exn (IN (raising e))
+ end ?
+ fun regExn ef = Arg.regExn (ef o Pair.snd)
+
+ fun refc ? =
+ uop Arg.refc
+ (fn IN aH => IN (fn a => fn p => mac 0w87 o aH (!a) p)) ?
+
+ fun list ? = uop Arg.list (fn _ => IN undefined) ?
+
+ fun array ? = uop Arg.array (fn _ => IN undefined) ?
+ fun vector ? = uop Arg.vector (fn _ => IN undefined) ?
+
+ fun string ? = nullary Arg.string (IN undefined) ?
+
+ val unit' = IN (fn () => fn _ => mac 0w75)
+ fun unit ? = nullary Arg.unit unit' ?
+
+ local
+ fun mk outer toWord ? =
+ nullary outer (IN (fn x => fn _ => mac (toWord x))) ?
+ in
+ fun largeInt ? =
+ mk Arg.largeInt
+ (W.fromLargeInt o LargeInt.rem /> W.toLargeInt W.maxValue) ?
+ fun largeReal ? = mk Arg.largeReal undefined ?
+ fun largeWord ? =
+ mk Arg.largeWord
+ (W.fromLarge o LargeWord.mod /> W.toLarge W.maxValue) ?
+ fun word8 ? = mk Arg.word8 Word8.toWord ?
+ (* fun word16 ? = mk Arg.word16 Word16.toWord ?
+ (* Word16 not provided by SML/NJ *) *)
+ fun word32 ? = mk Arg.word32 (Word.fromLarge o Word32.toLarge) ?
+ fun word64 ? = mk Arg.word64 (Word.fromLarge o Word64.toLarge) ?
+ fun bool ? = mk Arg.bool (fn true => 0wx2DA745 | false => 0wx3C24A62) ?
+ fun char ? = mk Arg.char (Word.fromInt o ord) ?
+ fun int ? = mk Arg.int Word.fromInt ?
+ fun real ? = mk Arg.real undefined ?
+ fun word ? = mk Arg.word id ?
+ end
+
+ (* Trivialities *)
+
+ fun T ? = uop Arg.T id ?
+ fun R f = Arg.R (fn l => Pair.map (id, f l))
+
+ local
+ fun width (IN h) =
+ IN (fn a => fn p => if #maxWidth p = 0 then id else h a p)
+ in
+ fun tuple ? = uop Arg.tuple width ?
+ fun record ? = uop Arg.record width ?
+ end
+
+ fun C0 f = Arg.C0 (fn l => (unit', f l))
+ fun C1 f = Arg.C1 (fn l => Pair.map (id, f l))
+ fun data ? =
+ uop Arg.data
+ (fn IN h => IN (fn a => fn {maxDepth, maxWidth} =>
+ if maxDepth = 0 then id
+ else h a {maxDepth = maxDepth-1,
+ maxWidth = Int.quot (maxWidth, 2)})) ?
+end
Property changes on: mltonlib/trunk/com/ssh/generic/unstable/detail/value/hash.sml
___________________________________________________________________
Name: svn:eol-style
+ native
Modified: mltonlib/trunk/com/ssh/generic/unstable/lib.mlb
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/lib.mlb 2007-06-16 10:26:40 UTC (rev 5628)
+++ mltonlib/trunk/com/ssh/generic/unstable/lib.mlb 2007-06-16 10:35:56 UTC (rev 5629)
@@ -24,9 +24,6 @@
detail/generics.sml
end
- public/generics-util.sig
- detail/generics-util.sml
-
(* Concepts *)
public/closed-generic-rep.sig
@@ -38,6 +35,11 @@
public/generic.sig
public/generic-extra.sig
+ (* Utilities *)
+
+ public/generics-util.sig
+ detail/generics-util.sml
+
(* Framework *)
detail/with-extra.fun
@@ -71,6 +73,7 @@
detail/value/show.sml
public/value/hash.sig
+ detail/value/hash.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-06-16 10:26:40 UTC (rev 5628)
+++ mltonlib/trunk/com/ssh/generic/unstable/public/export.sml 2007-06-16 10:35:56 UTC (rev 5629)
@@ -95,7 +95,6 @@
(** === Value Functors === *)
signature WITH_ARBITRARY_DOM = WITH_ARBITRARY_DOM
-
functor WithArbitrary (Arg : WITH_ARBITRARY_DOM) : ARBITRARY_GENERIC =
WithArbitrary (Arg)
@@ -103,6 +102,9 @@
functor WithEq (Arg : OPEN_GENERIC) : EQ_GENERIC = WithEq (Arg)
+signature WITH_HASH_DOM = WITH_HASH_DOM
+functor WithHash (Arg : WITH_HASH_DOM) : HASH_GENERIC = WithHash (Arg)
+
functor WithOrd (Arg : OPEN_GENERIC) : ORD_GENERIC = WithOrd (Arg)
functor WithShow (Arg : OPEN_GENERIC) : SHOW_GENERIC = WithShow (Arg)
More information about the MLton-commit
mailing list