Commit be46cd1a authored by Lennart Kolmodin's avatar Lennart Kolmodin
Browse files

Merge pull request #84 from phadej/fixed

Data.Fixed instance
parents 91529586 a58e8ccf
......@@ -11,10 +11,18 @@
#define HAS_VOID
#endif
#if MIN_VERSION_base(4,7,0)
#define HAS_FIXED_CONSTRUCTOR
#endif
#if __GLASGOW_HASKELL__ >= 704
#define HAS_GHC_FINGERPRINT
#endif
#ifndef HAS_FIXED_CONSTRUCTOR
{-# LANGUAGE ScopedTypeVariables #-}
#endif
-----------------------------------------------------------------------------
-- |
-- Module : Data.Binary.Class
......@@ -82,6 +90,9 @@ import GHC.Generics
#ifdef HAS_NATURAL
import Numeric.Natural
#endif
import qualified Data.Fixed as Fixed
--
-- This isn't available in older Hugs or older GHC
--
......@@ -265,6 +276,18 @@ instance Binary Integer where
let v = roll bytes
return $! if sign == (1 :: Word8) then v else - v
-- | /Since: 0.8.0.0/
#ifdef HAS_FIXED_CONSTRUCTOR
instance Binary (Fixed.Fixed a) where
put (Fixed.MkFixed a) = put a
get = Fixed.MkFixed `liftM` get
#else
instance forall a. Fixed.HasResolution a => Binary (Fixed.Fixed a) where
-- Using undefined :: Maybe a as a proxy, as Data.Proxy is introduced only in base-4.7
put x = put (truncate (x * fromInteger (Fixed.resolution (undefined :: Maybe a))) :: Integer)
get = (\x -> fromInteger x / fromInteger (Fixed.resolution (undefined :: Maybe a))) `liftM` get
#endif
--
-- Fold and unfold an Integer to and from a list of its bytes
--
......
......@@ -5,6 +5,10 @@ module Main ( main ) where
#define HAS_NATURAL
#endif
#if MIN_VERSION_base(4,7,0)
#define HAS_FIXED_CONSTRUCTOR
#endif
#if __GLASGOW_HASKELL__ >= 704
#define HAS_GHC_FINGERPRINT
#endif
......@@ -28,6 +32,8 @@ import Numeric.Natural
import GHC.Fingerprint
#endif
import qualified Data.Fixed as Fixed
import Test.Framework
import Test.Framework.Providers.QuickCheck2
import Test.QuickCheck
......@@ -398,6 +404,30 @@ instance Show Fingerprint where
------------------------------------------------------------------------
#ifdef HAS_FIXED_CONSTRUCTOR
fixedPut :: forall a. Fixed.HasResolution a => Fixed.Fixed a -> Put
fixedPut x = put (truncate (x * fromInteger (Fixed.resolution (undefined :: Maybe a))) :: Integer)
fixedGet :: forall a. Fixed.HasResolution a => Get (Fixed.Fixed a)
fixedGet = (\x -> fromInteger x / fromInteger (Fixed.resolution (undefined :: Maybe a))) `liftA` get
-- | Serialise using base >=4.7 and <4.7 methods agree
prop_fixed_ser :: Fixed.Fixed Fixed.E3 -> Bool
prop_fixed_ser x = runPut (put x) == runPut (fixedPut x)
-- | Serialised with base >=4.7, unserialised with base <4.7 method roundtrip
prop_fixed_constr_resolution :: Fixed.Fixed Fixed.E3 -> Bool
prop_fixed_constr_resolution x = runGet fixedGet (runPut (put x)) == x
-- | Serialised with base <4.7, unserialised with base >=4.7 method roundtrip
prop_fixed_resolution_constr :: Fixed.Fixed Fixed.E3 -> Bool
prop_fixed_resolution_constr x = runGet get (runPut (fixedPut x)) == x
#endif
------------------------------------------------------------------------
type T a = a -> Property
type B a = a -> Bool
......@@ -475,6 +505,7 @@ tests =
, ("Word", p (test :: T Word ))
, ("Int", p (test :: T Int ))
, ("Integer", p (test :: T Integer ))
, ("Fixed", p (test :: T (Fixed.Fixed Fixed.E3) ))
#ifdef HAS_NATURAL
, ("Natural", prop_test_Natural )
#endif
......@@ -536,4 +567,11 @@ tests =
, ("L.ByteString invariant", p (prop_invariant :: B L.ByteString ))
, ("[L.ByteString] invariant", p (prop_invariant :: B [L.ByteString] ))
]
#ifdef HAS_FIXED_CONSTRUCTOR
, testGroup "Fixed"
[ testProperty "Serialisation same" $ p prop_fixed_ser
, testProperty "MkFixed -> HasResolution" $ p prop_fixed_constr_resolution
, testProperty "HasResolution -> MkFixed" $ p prop_fixed_resolution_constr
]
#endif
]
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment