[MLton-commit] r6485

Vesa Karvonen vesak at mlton.org
Sat Mar 15 19:39:44 PST 2008


Another example.
----------------------------------------------------------------------

A   mltonlib/trunk/com/ssh/unit-test/unstable/example/sms-test.sml
U   mltonlib/trunk/com/ssh/unit-test/unstable/example.mlb
U   mltonlib/trunk/com/ssh/unit-test/unstable/example.use

----------------------------------------------------------------------

Added: mltonlib/trunk/com/ssh/unit-test/unstable/example/sms-test.sml
===================================================================
--- mltonlib/trunk/com/ssh/unit-test/unstable/example/sms-test.sml	2008-03-16 03:32:10 UTC (rev 6484)
+++ mltonlib/trunk/com/ssh/unit-test/unstable/example/sms-test.sml	2008-03-16 03:39:43 UTC (rev 6485)
@@ -0,0 +1,139 @@
+(* Copyright (C) 2008 Vesa Karvonen
+ *
+ * This code is released under the MLton license, a BSD-style license.
+ * See the LICENSE file or http://mlton.org/License for details.
+ *)
+
+(* This is a translation of the Haskell code from
+ *
+ *   [http://www.foomongers.org.uk/videos/spj-typedriventestinginhaskell.html]
+ *)
+
+val () = let
+   open Generic UnitTest
+
+   local
+      open Word8
+   in
+      val op << = op <<
+      val op >> = op >>
+      val op orb = op orb
+      val op andb = op andb
+   end
+
+   val rec pack =
+    fn []                         => []
+     | [a]                        => [a << 0w1]
+     | [a, b]                     => [a << 0w1 orb b >> 0w6,
+                                      b << 0w2]
+     | [a, b, c]                  => [a << 0w1 orb b >> 0w6,
+                                      b << 0w2 orb c >> 0w5,
+                                      c << 0w3]
+     | [a, b, c, d]               => [a << 0w1 orb b >> 0w6,
+                                      b << 0w2 orb c >> 0w5,
+                                      c << 0w3 orb d >> 0w4,
+                                      d << 0w4]
+     | [a, b, c, d, e]            => [a << 0w1 orb b >> 0w6,
+                                      b << 0w2 orb c >> 0w5,
+                                      c << 0w3 orb d >> 0w4,
+                                      d << 0w4 orb e >> 0w3,
+                                      e << 0w5]
+     | [a, b, c, d, e, f]         => [a << 0w1 orb b >> 0w6,
+                                      b << 0w2 orb c >> 0w5,
+                                      c << 0w3 orb d >> 0w4,
+                                      d << 0w4 orb e >> 0w3,
+                                      e << 0w5 orb f >> 0w2,
+                                      f << 0w6]
+     | [a, b, c, d, e, f, g]      => [a << 0w1 orb b >> 0w6,
+                                      b << 0w2 orb c >> 0w5,
+                                      c << 0w3 orb d >> 0w4,
+                                      d << 0w4 orb e >> 0w3,
+                                      e << 0w5 orb f >> 0w2,
+                                      f << 0w6 orb g >> 0w1,
+                                      g << 0w7]
+     | a::b::c::d::e::f::g::h::rs => [a << 0w1 orb b >> 0w6,
+                                      b << 0w2 orb c >> 0w5,
+                                      c << 0w3 orb d >> 0w4,
+                                      d << 0w4 orb e >> 0w3,
+                                      e << 0w5 orb f >> 0w2,
+                                      f << 0w6 orb g >> 0w1,
+                                      g << 0w7 orb h]
+                                     @ pack rs
+
+   fun mask7 w = w andb 0w127
+
+   val rec unpack =
+    fn [] => []
+     | [a]                     => [mask7 (a >> 0w1)]
+     | [a, b]                  => [mask7 (a >> 0w1),
+                                   mask7 (b >> 0w2 orb a << 0w6)]
+     | [a, b, c]               => [mask7 (a >> 0w1),
+                                   mask7 (b >> 0w2 orb a << 0w6),
+                                   mask7 (c >> 0w3 orb b << 0w5)]
+     | [a, b, c, d]            => [mask7 (a >> 0w1),
+                                   mask7 (b >> 0w2 orb a << 0w6),
+                                   mask7 (c >> 0w3 orb b << 0w5),
+                                   mask7 (d >> 0w4 orb c << 0w4)]
+     | [a, b, c, d, e]         => [mask7 (a >> 0w1),
+                                   mask7 (b >> 0w2 orb a << 0w6),
+                                   mask7 (c >> 0w3 orb b << 0w5),
+                                   mask7 (d >> 0w4 orb c << 0w4),
+                                   mask7 (e >> 0w5 orb d << 0w3)]
+     | [a, b, c, d, e, f]      => [mask7 (a >> 0w1),
+                                   mask7 (b >> 0w2 orb a << 0w6),
+                                   mask7 (c >> 0w3 orb b << 0w5),
+                                   mask7 (d >> 0w4 orb c << 0w4),
+                                   mask7 (e >> 0w5 orb d << 0w3),
+                                   mask7 (f >> 0w6 orb e << 0w2)]
+     | a::b::c::d::e::f::g::rs => if mask7 g = 0w0
+                                  then [mask7 (a >> 0w1),
+                                        mask7 (b >> 0w2 orb a << 0w6),
+                                        mask7 (c >> 0w3 orb b << 0w5),
+                                        mask7 (d >> 0w4 orb c << 0w4),
+                                        mask7 (e >> 0w5 orb d << 0w3),
+                                        mask7 (f >> 0w6 orb e << 0w2),
+                                        mask7 (g >> 0w7 orb f << 0w1)]
+                                  else [mask7 (a >> 0w1),
+                                        mask7 (b >> 0w2 orb a << 0w6),
+                                        mask7 (c >> 0w3 orb b << 0w5),
+                                        mask7 (d >> 0w4 orb c << 0w4),
+                                        mask7 (e >> 0w5 orb d << 0w3),
+                                        mask7 (f >> 0w6 orb e << 0w2),
+                                        mask7 (g >> 0w7 orb f << 0w1),
+                                        mask7 g]
+                                       @ unpack rs
+
+   fun thatId t f x = thatEq t {expect = x, actual = f x}
+   val propPack = thatId (list word8) (unpack o pack) o map mask7
+in
+   unitTests
+      (title "SMS.Manual")
+
+      (test (fn () => let
+          val isoBytes =
+              Word8Vector.isoList <--> (Byte.stringToBytes, Byte.bytesToString)
+          val testString = thatId string (Fn.map isoBytes (unpack o pack))
+       in
+          app testString
+              ["",
+               "1",
+               "12",
+               "123",
+               "1234",
+               "12345",
+               "123456",
+               "1234567",
+               "12345678",
+               "123456789",
+               "1234567890"]
+       end))
+
+      (title "SMS.Generated")
+
+      (testAll (list word8) propPack)
+      (testAll (withGen let open RandomGen in list word8 8 end
+                        (list word8))
+               propPack)
+
+      $
+end


Property changes on: mltonlib/trunk/com/ssh/unit-test/unstable/example/sms-test.sml
___________________________________________________________________
Name: svn:eol-style
   + native

Modified: mltonlib/trunk/com/ssh/unit-test/unstable/example.mlb
===================================================================
--- mltonlib/trunk/com/ssh/unit-test/unstable/example.mlb	2008-03-16 03:32:10 UTC (rev 6484)
+++ mltonlib/trunk/com/ssh/unit-test/unstable/example.mlb	2008-03-16 03:39:43 UTC (rev 6485)
@@ -21,6 +21,7 @@
       example/assoc-test.sml
       example/qc-test.sml
       example/rev-test.sml
+      example/sms-test.sml
    end
 in
 end

Modified: mltonlib/trunk/com/ssh/unit-test/unstable/example.use
===================================================================
--- mltonlib/trunk/com/ssh/unit-test/unstable/example.use	2008-03-16 03:32:10 UTC (rev 6484)
+++ mltonlib/trunk/com/ssh/unit-test/unstable/example.use	2008-03-16 03:39:43 UTC (rev 6485)
@@ -11,4 +11,5 @@
      "detail/sorted-list.use",
      "example/assoc-test.sml",
      "example/qc-test.sml",
-     "example/rev-test.sml"] ;
+     "example/rev-test.sml",
+     "example/sms-test.sml"] ;




More information about the MLton-commit mailing list