[commit: packages/binary] master: Add instance for Natural. (74b2c01)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/binary

On branch  : master
Link       : http://git.haskell.org/packages/binary.git/commitdiff/74b2c01c64709ccdb4df2103cf931f1390f6b632

>---------------------------------------------------------------

commit 74b2c01c64709ccdb4df2103cf931f1390f6b632
Author: Lennart Kolmodin <kolmodin at gmail.com>
Date:   Thu Jan 1 21:26:18 2015 +0300

    Add instance for Natural.
    
    Natural is a new data type that comes with base-4.8 (GHC 7.10).
    We serialize it in the same way as we do with Integer.
    Since this is a new data type there are some ugly CPPs to handle whether
    Natural is there or not.
    Serialization tests have been added as well. Since QuickCheck doesn't yet
    implement instance Arbitrary Natural we do a workaround here.
    This fixes #63.


>---------------------------------------------------------------

74b2c01c64709ccdb4df2103cf931f1390f6b632
 src/Data/Binary/Class.hs | 37 +++++++++++++++++++++++++++++++++++--
 tests/Arbitrary.hs       | 23 +++++++++++++++++++++++
 tests/QC.hs              | 20 ++++++++++++++++++--
 3 files changed, 76 insertions(+), 4 deletions(-)

diff --git a/src/Data/Binary/Class.hs b/src/Data/Binary/Class.hs
index e5e59e8..8a4bc25 100644
--- a/src/Data/Binary/Class.hs
+++ b/src/Data/Binary/Class.hs
@@ -5,6 +5,11 @@
 #ifdef GENERICS
 {-# LANGUAGE DefaultSignatures #-}
 #endif
+
+#if MIN_VERSION_base(4,8,0)
+#define HAS_NATURAL
+#endif
+
 -----------------------------------------------------------------------------
 -- |
 -- Module      : Data.Binary.Class
@@ -61,6 +66,9 @@ import Data.Array.Unboxed
 import GHC.Generics
 #endif
 
+#ifdef HAS_NATURAL
+import Numeric.Natural
+#endif
 --
 -- This isn't available in older Hugs or older GHC
 --
@@ -225,17 +233,42 @@ instance Binary Integer where
 --
 -- Fold and unfold an Integer to and from a list of its bytes
 --
-unroll :: Integer -> [Word8]
+unroll :: (Integral a, Num a, Bits a) => a -> [Word8]
 unroll = unfoldr step
   where
     step 0 = Nothing
     step i = Just (fromIntegral i, i `shiftR` 8)
 
-roll :: [Word8] -> Integer
+roll :: (Integral a, Num a, Bits a) => [Word8] -> a
 roll   = foldr unstep 0
   where
     unstep b a = a `shiftL` 8 .|. fromIntegral b
 
+#ifdef HAS_NATURAL
+-- Fixed-size type for a subset of Natural
+type NaturalWord = Word64
+
+instance Binary Natural where
+    {-# INLINE put #-}
+    put n | n <= hi = do
+        putWord8 0
+        put (fromIntegral n :: NaturalWord)  -- fast path
+     where
+        hi = fromIntegral (maxBound :: NaturalWord) :: Natural
+
+    put n = do
+        putWord8 1
+        put (unroll (abs n))         -- unroll the bytes
+
+    {-# INLINE get #-}
+    get = do
+        tag <- get :: Get Word8
+        case tag of
+            0 -> liftM fromIntegral (get :: Get NaturalWord)
+            _ -> do bytes <- get
+                    return $! roll bytes
+#endif
+
 {-
 
 --
diff --git a/tests/Arbitrary.hs b/tests/Arbitrary.hs
index 99725af..c19a192 100644
--- a/tests/Arbitrary.hs
+++ b/tests/Arbitrary.hs
@@ -1,5 +1,10 @@
+{-# LANGUAGE CPP #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 
+#if MIN_VERSION_base(4,8,0)
+#define HAS_NATURAL
+#endif
+
 module Arbitrary where
 
 import Test.QuickCheck
@@ -7,6 +12,10 @@ import Test.QuickCheck
 import qualified Data.ByteString as B
 import qualified Data.ByteString.Lazy as L
 
+#ifdef HAS_NATURAL
+import Numeric.Natural
+#endif
+
 instance Arbitrary L.ByteString where
   arbitrary = fmap L.fromChunks arbitrary
 
@@ -52,3 +61,17 @@ instance (Arbitrary a, Arbitrary b, Arbitrary c, Arbitrary d, Arbitrary e,
     (a,b,c,d,e) <- arbitrary
     (f,g,h,i,j) <- arbitrary
     return (a,b,c,d,e,f,g,h,i,j)
+
+
+#ifdef HAS_NATURAL
+-- | Generates a natural number. The number must be positive
+-- and its maximum value depends on the size parameter.
+arbitrarySizedNatural :: Gen Natural
+arbitrarySizedNatural =
+  sized $ \n0 ->
+  let n = toInteger n0 in
+  inBounds fromInteger (choose (0, n*n))
+
+inBounds :: Integral a => (Integer -> a) -> Gen Integer -> Gen a
+inBounds fi g = fmap fi (g `suchThat` (\x -> toInteger (fi x) == x))
+#endif
\ No newline at end of file
diff --git a/tests/QC.hs b/tests/QC.hs
index fbaded1..2a08b3b 100644
--- a/tests/QC.hs
+++ b/tests/QC.hs
@@ -1,6 +1,10 @@
-{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE CPP, ScopedTypeVariables #-}
 module Main ( main ) where
 
+#if MIN_VERSION_base(4,8,0)
+#define HAS_NATURAL
+#endif
+
 import           Control.Applicative
 import           Control.Exception                    as C (SomeException,
                                                             catch, evaluate)
@@ -17,7 +21,7 @@ import           Test.Framework.Providers.QuickCheck2
 import           Test.QuickCheck
 
 import qualified Action                               (tests)
-import           Arbitrary                            ()
+import           Arbitrary                            (arbitrarySizedNatural)
 import           Data.Binary
 import           Data.Binary.Get
 import           Data.Binary.Put
@@ -349,6 +353,15 @@ main = defaultMain tests
 
 ------------------------------------------------------------------------
 
+#ifdef HAS_NATURAL
+-- | Until the QuickCheck library implements instance Arbitrary Natural,
+-- we need this test.
+prop_test_Natural :: Property
+prop_test_Natural = forAll arbitrarySizedNatural test
+#endif
+
+------------------------------------------------------------------------
+
 type T a = a -> Property
 type B a = a -> Bool
 
@@ -426,6 +439,9 @@ tests =
             , ("Word",       p (test :: T Word                   ))
             , ("Int",        p (test :: T Int                    ))
             , ("Integer",    p (test :: T Integer                ))
+#ifdef HAS_NATURAL
+            , ("Natural",      (prop_test_Natural :: Property    ))
+#endif
 
             , ("Float",      p (test :: T Float                  ))
             , ("Double",     p (test :: T Double                 ))