wide-word 0.1.0.8 → 0.1.0.9
raw patch · 8 files changed
+277/−147 lines, 8 filesdep ~QuickCheckdep ~basedep ~hedgehog
Dependency ranges changed: QuickCheck, base, hedgehog, primitive, quickcheck-classes, semirings
Files
- ChangeLog.md +4/−0
- src/Data/WideWord/Int128.hs +38/−27
- src/Data/WideWord/Word128.hs +62/−44
- test/Test/Data/WideWord/Gen.hs +26/−28
- test/Test/Data/WideWord/Int128.hs +69/−25
- test/Test/Data/WideWord/Word128.hs +60/−10
- test/laws.hs +6/−3
- wide-word.cabal +12/−10
ChangeLog.md view
@@ -1,5 +1,9 @@ # Revision history for wide-word +## 0.1.0.9 -- 2019-02-06++* Fix `Prim` instance for `Int128`+ ## 0.1.0.8 -- 2019-01-31 * Improve implementation of succ/pred.
src/Data/WideWord/Int128.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE StrictData #-}@@ -33,6 +34,8 @@ import Control.DeepSeq (NFData (..)) import Data.Bits (Bits (..), FiniteBits (..), shiftL)+import Data.Data (Data, Typeable)+import Data.Ix (Ix) import Data.WideWord.Word128 @@ -55,7 +58,7 @@ { int128Hi64 :: {-# UNPACK #-} !Word64 , int128Lo64 :: {-# UNPACK #-} !Word64 }- deriving (Eq)+ deriving (Eq, Data, Ix, Typeable) byteSwapInt128 :: Int128 -> Int128 byteSwapInt128 (Int128 a1 a0) = Int128 (byteSwap64 a0) (byteSwap64 a1)@@ -386,28 +389,28 @@ quotRem128 :: Int128 -> Int128 -> (Int128, Int128) quotRem128 numer denom- | numerIsNegative && denomIsNegative = (word128ToInt128 wq, word128ToInt128 (negate wr))- | numerIsNegative = (word128ToInt128 (negate wq), word128ToInt128 (negate wr))- | denomIsNegative = (word128ToInt128 (negate wq), word128ToInt128 wr)+ | isNeg numer && isNeg denom = (word128ToInt128 wq, word128ToInt128 (negate wr))+ | isNeg numer = (word128ToInt128 (negate wq), word128ToInt128 (negate wr))+ | isNeg denom = (word128ToInt128 (negate wq), word128ToInt128 wr) | otherwise = (word128ToInt128 wq, word128ToInt128 wr) where (wq, wr) = quotRem absNumerW absDenomW absNumerW = int128ToWord128 $ abs128 numer absDenomW = int128ToWord128 $ abs128 denom- numerIsNegative = topBitSetWord64 $ int128Hi64 numer- denomIsNegative = topBitSetWord64 $ int128Hi64 denom+ isNeg = topBitSetWord64 . int128Hi64 divMod128 :: Int128 -> Int128 -> (Int128, Int128) divMod128 numer denom- | numerIsNegative && denomIsNegative = (word128ToInt128 wq, word128ToInt128 (negate wr))- | numerIsNegative = (word128ToInt128 (negate $ wq + 1), word128ToInt128 (absDenomW - wr))- | denomIsNegative = (word128ToInt128 (negate $ wq + 1), word128ToInt128 (negate $ absDenomW - wr))+ | isNeg numer && isNeg denom = (word128ToInt128 wq, word128ToInt128 (negate wr))+ | isNeg numer && wr == 0 = (word128ToInt128 (negate wq), 0)+ | isNeg numer = (word128ToInt128 (negate $ wq + 1), word128ToInt128 (absDenomW - wr))+ | isNeg denom && wr == 0 = (word128ToInt128 (negate wq), 0)+ | isNeg denom = (word128ToInt128 (negate $ wq + 1), word128ToInt128 (negate $ absDenomW - wr)) | otherwise = (word128ToInt128 wq, word128ToInt128 wr) where (wq, wr) = quotRem absNumerW absDenomW- numerIsNegative = topBitSetWord64 $ int128Hi64 numer- denomIsNegative = topBitSetWord64 $ int128Hi64 denom+ isNeg = topBitSetWord64 . int128Hi64 absNumerW = int128ToWord128 $ abs128 numer absDenomW = int128ToWord128 $ abs128 denom @@ -429,8 +432,9 @@ peekElemOff128 :: Ptr Int128 -> Int -> IO Int128 peekElemOff128 ptr idx =- Int128 <$> peekElemOff (castPtr ptr) (2 * idx + index1)- <*> peekElemOff (castPtr ptr) (2 * idx + index0)+ Int128 <$> peekElemOff (castPtr ptr) (idx2 + index1)+ <*> peekElemOff (castPtr ptr) (idx2 + index0)+ where idx2 = 2 * idx poke128 :: Ptr Int128 -> Int128 -> IO () poke128 ptr (Int128 a1 a0) =@@ -438,8 +442,9 @@ pokeElemOff128 :: Ptr Int128 -> Int -> Int128 -> IO () pokeElemOff128 ptr idx (Int128 a1 a0) = do- pokeElemOff (castPtr ptr) (2 * idx + index0) a0- pokeElemOff (castPtr ptr) (2 * idx + index1) a1+ let idx2 = 2 * idx+ pokeElemOff (castPtr ptr) (idx2 + index0) a0+ pokeElemOff (castPtr ptr) (idx2 + index1) a1 -- ----------------------------------------------------------------------------- -- Helpers.@@ -470,23 +475,26 @@ {-# INLINE indexByteArray128# #-} indexByteArray128# :: ByteArray# -> Int# -> Int128 indexByteArray128# arr# i# =- let x = indexByteArray# arr# (2# *# (unInt index1))- y = indexByteArray# arr# (2# *# i# +# (unInt index0))+ let i2# = 2# *# i#+ x = indexByteArray# arr# (i2# +# unInt index1)+ y = indexByteArray# arr# (i2# +# unInt index0) in Int128 x y {-# INLINE readByteArray128# #-} readByteArray128# :: MutableByteArray# s -> Int# -> State# s -> (# State# s, Int128 #) readByteArray128# arr# i# =- \s0 -> case readByteArray# arr# (2# *# (unInt index1)) s0 of- (# s1, x #) -> case readByteArray# arr# (2# *# i# +# (unInt index0)) s1 of+ \s0 -> case readByteArray# arr# (i2# +# unInt index1) s0 of+ (# s1, x #) -> case readByteArray# arr# (i2# +# unInt index0) s1 of (# s2, y #) -> (# s2, Int128 x y #)+ where i2# = 2# *# i# {-# INLINE writeByteArray128# #-} writeByteArray128# :: MutableByteArray# s -> Int# -> Int128 -> State# s -> State# s writeByteArray128# arr# i# (Int128 a b) =- \s0 -> case writeByteArray# arr# (2# *# i# +# (unInt index1)) a s0 of- s1 -> case writeByteArray# arr# (2# *# i# +# (unInt index0)) b s1 of+ \s0 -> case writeByteArray# arr# (i2# +# unInt index1) a s0 of+ s1 -> case writeByteArray# arr# (i2# +# unInt index0) b s1 of s2 -> s2+ where i2# = 2# *# i# {-# INLINE setByteArray128# #-} setByteArray128# :: MutableByteArray# s -> Int# -> Int# -> Int128 -> State# s -> State# s@@ -495,23 +503,26 @@ {-# INLINE indexOffAddr128# #-} indexOffAddr128# :: Addr# -> Int# -> Int128 indexOffAddr128# addr# i# =- let x = indexOffAddr# addr# (2# *# i# +# (unInt index1))- y = indexOffAddr# addr# (2# *# i# +# (unInt index0))+ let i2# = 2# *# i#+ x = indexOffAddr# addr# (i2# +# unInt index1)+ y = indexOffAddr# addr# (i2# +# unInt index0) in Int128 x y {-# INLINE readOffAddr128# #-} readOffAddr128# :: Addr# -> Int# -> State# s -> (# State# s, Int128 #) readOffAddr128# addr# i# =- \s0 -> case readOffAddr# addr# (2# *# i# +# (unInt index1)) s0 of- (# s1, x #) -> case readOffAddr# addr# (2# *# i# +# (unInt index0)) s1 of+ \s0 -> case readOffAddr# addr# (i2# +# unInt index1) s0 of+ (# s1, x #) -> case readOffAddr# addr# (i2# +# unInt index0) s1 of (# s2, y #) -> (# s2, Int128 x y #)+ where i2# = 2# *# i# {-# INLINE writeOffAddr128# #-} writeOffAddr128# :: Addr# -> Int# -> Int128 -> State# s -> State# s writeOffAddr128# addr# i# (Int128 a b) =- \s0 -> case writeOffAddr# addr# (2# *# i# +# (unInt index1)) a s0 of- s1 -> case writeOffAddr# addr# (2# *# i# +# (unInt index0)) b s1 of+ \s0 -> case writeOffAddr# addr# (i2# +# unInt index1) a s0 of+ s1 -> case writeOffAddr# addr# (i2# +# unInt index0) b s1 of s2 -> s2+ where i2# = 2# *# i# {-# INLINE setOffAddr128# #-} setOffAddr128# :: Addr# -> Int# -> Int# -> Int128 -> State# s -> State# s
src/Data/WideWord/Word128.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE StrictData #-} {-# LANGUAGE UnboxedTuples #-}@@ -32,6 +33,8 @@ import Control.DeepSeq (NFData (..)) import Data.Bits (Bits (..), FiniteBits (..), shiftL)+import Data.Data (Data, Typeable)+import Data.Ix (Ix) import Foreign.Ptr (Ptr, castPtr) import Foreign.Storable (Storable (..))@@ -52,7 +55,7 @@ { word128Hi64 :: {-# UNPACK #-} !Word64 , word128Lo64 :: {-# UNPACK #-} !Word64 }- deriving (Eq)+ deriving (Eq, Data, Ix, Typeable) byteSwapWord128 :: Word128 -> Word128 byteSwapWord128 (Word128 a1 a0) = Word128 (byteSwap64 a0) (byteSwap64 a1)@@ -379,48 +382,51 @@ | n1 == 0 && d1 == 0 = quotRemTwo n0 d0 | n1 < d1 = (zeroWord128, num) | d1 == 0 = quotRemThree num d0+ | n1 == d1 =+ case compare n0 d0 of+ LT -> (zeroWord128, num)+ EQ -> (oneWord128, zeroWord128)+ GT -> (Word128 0 1, Word128 0 (n0 - d0)) | otherwise = quotRemFour num den -+{-# INLINE quotRemFour #-} quotRemFour :: Word128 -> Word128 -> (Word128, Word128)-quotRemFour num@(Word128 n1 _) den@(Word128 d1 d0)- | n1 == d1 = quotRemFourX num d0- | otherwise = (q, r)- where- qtest = quot n1 d1- diff = times128 den (Word128 0 qtest)- (q, r) = case compare128 num diff of- EQ -> (Word128 0 qtest, zeroWord128)- GT -> (Word128 0 qtest, minus128 num diff)- LT -> let qx = Word128 0 (qtest - 1)- diffx = times128 den qx- in (qx, minus128 num diffx)---{-# INLINE quotRemFourX #-}-quotRemFourX :: Word128 -> Word64 -> (Word128, Word128)-quotRemFourX num@(Word128 _ n0) d0 =- case compare n0 d0 of- LT -> (zeroWord128, num)- EQ -> (oneWord128, zeroWord128)- GT -> (Word128 0 1, Word128 0 (n0 - d0))+quotRemFour num@(Word128 n1 _) den@(Word128 d1 _)+ | remain < den = (Word128 0 qest, remain)+ -- The above is correct in most cases, but for the case where is not+ -- we have the following. While the following is correct, it is rather+ -- suboptimal. Would be nice to find something better.+ | otherwise =+ mapPair fromInteger128 $ quotRem (toInteger num) (toInteger den)+ where+ qest = quot n1 d1+ prod = halfTimes128 den qest+ remain = minus128 num prod +{-# INLINE halfTimes128 #-}+halfTimes128 :: Word128 -> Word64 -> Word128+halfTimes128 (Word128 (W64# a1) (W64# a0)) (W64# b0) =+ Word128 (W64# p1) (W64# p0)+ where+ !(# c1, p0 #) = timesWord2# a0 b0+ p1a = timesWord# a1 b0+ p1 = plusWord# p1a c1 {-# INLINE quotRemThree #-} quotRemThree :: Word128 -> Word64 -> (Word128, Word128) quotRemThree num@(Word128 n1 n0) den | den == 0 = divZeroError | den == 1 = (num, zeroWord128)- | n1 < den = case quotRemWord2 n1 n0 den of+ | n1 < den = case quotRemWord64 n1 n0 den of (q, r) -> (Word128 0 q, Word128 0 r) | otherwise = case quotRem n1 den of- (q1, r1) -> case quotRemWord2 r1 n0 den of+ (q1, r1) -> case quotRemWord64 r1 n0 den of (q0, r0) -> (Word128 q1 q0, Word128 0 r0) -{-# INLINE quotRemWord2 #-}-quotRemWord2 :: Word64 -> Word64 -> Word64 -> (Word64, Word64)-quotRemWord2 (W64# n1) (W64# n0) (W64# d) =+{-# INLINE quotRemWord64 #-}+quotRemWord64 :: Word64 -> Word64 -> Word64 -> (Word64, Word64)+quotRemWord64 (W64# n1) (W64# n0) (W64# d) = case quotRemWord2# n1 n0 d of (# q, r #) -> (W64# q, W64# r) @@ -431,6 +437,7 @@ case quotRem n0 d0 of (q, r) -> (Word128 0 q, Word128 0 r) +{-# INLINE toInteger128 #-} toInteger128 :: Word128 -> Integer toInteger128 (Word128 a1 a0) = fromIntegral a1 `shiftL` 64 + fromIntegral a0 @@ -443,8 +450,9 @@ peekElemOff128 :: Ptr Word128 -> Int -> IO Word128 peekElemOff128 ptr idx =- Word128 <$> peekElemOff (castPtr ptr) (2 * idx + index1)- <*> peekElemOff (castPtr ptr) (2 * idx + index0)+ Word128 <$> peekElemOff (castPtr ptr) (idx2 + index1)+ <*> peekElemOff (castPtr ptr) (idx2 + index0)+ where idx2 = 2 * idx poke128 :: Ptr Word128 -> Word128 -> IO () poke128 ptr (Word128 a1 a0) =@@ -452,8 +460,9 @@ pokeElemOff128 :: Ptr Word128 -> Int -> Word128 -> IO () pokeElemOff128 ptr idx (Word128 a1 a0) = do- pokeElemOff (castPtr ptr) (2 * idx + index0) a0- pokeElemOff (castPtr ptr) (2 * idx + index1) a1+ let idx2 = 2 * idx+ pokeElemOff (castPtr ptr) (idx2 + index0) a0+ pokeElemOff (castPtr ptr) (idx2 + index1) a1 -- ----------------------------------------------------------------------------- -- Functions for `Prim` instance.@@ -469,23 +478,26 @@ {-# INLINE indexByteArray128# #-} indexByteArray128# :: ByteArray# -> Int# -> Word128 indexByteArray128# arr# i# =- let x = indexByteArray# arr# (2# *# i# +# (unInt index1))- y = indexByteArray# arr# (2# *# i# +# (unInt index0))+ let i2# = 2# *# i#+ x = indexByteArray# arr# (i2# +# unInt index1)+ y = indexByteArray# arr# (i2# +# unInt index0) in Word128 x y {-# INLINE readByteArray128# #-} readByteArray128# :: MutableByteArray# s -> Int# -> State# s -> (# State# s, Word128 #) readByteArray128# arr# i# =- \s0 -> case readByteArray# arr# (2# *# i# +# (unInt index1)) s0 of- (# s1, x #) -> case readByteArray# arr# (2# *# i# +# (unInt index0)) s1 of+ \s0 -> case readByteArray# arr# (i2# +# unInt index1) s0 of+ (# s1, x #) -> case readByteArray# arr# (i2# +# unInt index0) s1 of (# s2, y #) -> (# s2, Word128 x y #)+ where i2# = 2# *# i# {-# INLINE writeByteArray128# #-} writeByteArray128# :: MutableByteArray# s -> Int# -> Word128 -> State# s -> State# s writeByteArray128# arr# i# (Word128 a b) =- \s0 -> case writeByteArray# arr# (2# *# i# +# (unInt index1)) a s0 of- s1 -> case writeByteArray# arr# (2# *# i# +# (unInt index0)) b s1 of+ \s0 -> case writeByteArray# arr# (i2# +# unInt index1) a s0 of+ s1 -> case writeByteArray# arr# (i2# +# unInt index0) b s1 of s2 -> s2+ where i2# = 2# *# i# {-# INLINE setByteArray128# #-} setByteArray128# :: MutableByteArray# s -> Int# -> Int# -> Word128 -> State# s -> State# s@@ -494,27 +506,33 @@ {-# INLINE indexOffAddr128# #-} indexOffAddr128# :: Addr# -> Int# -> Word128 indexOffAddr128# addr# i# =- let x = indexOffAddr# addr# (2# *# i# +# (unInt index1))- y = indexOffAddr# addr# (2# *# i# +# (unInt index0))+ let i2# = 2# *# i#+ x = indexOffAddr# addr# (i2# +# unInt index1)+ y = indexOffAddr# addr# (i2# +# unInt index0) in Word128 x y {-# INLINE readOffAddr128# #-} readOffAddr128# :: Addr# -> Int# -> State# s -> (# State# s, Word128 #) readOffAddr128# addr# i# =- \s0 -> case readOffAddr# addr# (2# *# i# +# (unInt index1)) s0 of- (# s1, x #) -> case readOffAddr# addr# (2# *# i# +# (unInt index0)) s1 of+ \s0 -> case readOffAddr# addr# (i2# +# unInt index1) s0 of+ (# s1, x #) -> case readOffAddr# addr# (i2# +# unInt index0) s1 of (# s2, y #) -> (# s2, Word128 x y #)+ where i2# = 2# *# i# {-# INLINE writeOffAddr128# #-} writeOffAddr128# :: Addr# -> Int# -> Word128 -> State# s -> State# s writeOffAddr128# addr# i# (Word128 a b) =- \s0 -> case writeOffAddr# addr# (2# *# i# +# (unInt index1)) a s0 of- s1 -> case writeOffAddr# addr# (2# *# i# +# (unInt index0)) b s1 of+ \s0 -> case writeOffAddr# addr# (i2# +# unInt index1) a s0 of+ s1 -> case writeOffAddr# addr# (i2# +# unInt index0) b s1 of s2 -> s2+ where i2# = 2# *# i# {-# INLINE setOffAddr128# #-} setOffAddr128# :: Addr# -> Int# -> Int# -> Word128 -> State# s -> State# s setOffAddr128# = defaultSetOffAddr#++mapPair :: (a -> b) -> (a, a) -> (b, b)+mapPair f (a, b) = (f a, f b) -- ----------------------------------------------------------------------------- -- Constants.
test/Test/Data/WideWord/Gen.hs view
@@ -1,41 +1,17 @@ module Test.Data.WideWord.Gen where -import Data.Int (Int8, Int16, Int32, Int64)+import Data.Bits (shiftL) import Data.WideWord-import Data.Word (Word8, Word16, Word32, Word64)+import Data.Word (Word32, Word64) import Hedgehog (Gen) import qualified Hedgehog.Gen as Gen import qualified Hedgehog.Range as Range -genInt8 :: Gen Int8-genInt8 =- Gen.int8 Range.constantBounded--genInt16 :: Gen Int16-genInt16 =- Gen.int16 Range.constantBounded--genInt32 :: Gen Int32-genInt32 =- Gen.int32 Range.constantBounded--genInt64 :: Gen Int64-genInt64 =- Gen.int64 Range.constantBounded- genInt128 :: Gen Int128 genInt128 =- Int128 <$> genWord64 <*> genWord64--genWord8 :: Gen Word8-genWord8 =- Gen.word8 Range.constantBounded--genWord16 :: Gen Word16-genWord16 =- Gen.word16 Range.constantBounded+ Int128 <$> genBiasedWord64 <*> genBiasedWord64 genWord32 :: Gen Word32 genWord32 =@@ -45,6 +21,28 @@ genWord64 = Gen.word64 Range.constantBounded +-- | Generate 'Word64' in one of five categories;+-- * the full range+-- * small values near zero+-- * large values near maxBound :: Word64+-- * values near maxBound / 2 :: Word64+-- * values near maxBound :: Word32+genBiasedWord64 :: Gen Word64+genBiasedWord64 =+ Gen.choice+ [ Gen.word64 (Range.linear 0 maxBound)+ , Gen.word64 (Range.linear 0 100)+ , (-) maxBound <$> Gen.word64 (Range.linear 0 100)+ , Gen.word64 (Range.linear (halfMax - 100) (halfMax + 100))+ , Gen.word64 (Range.linear (bits32 - 100) (bits32 + 100))+ ]+ where+ bits32 :: Word64+ bits32 = 1 `shiftL` 32++ halfMax :: Word64+ halfMax = maxBound `div` 2+ genWord128 :: Gen Word128 genWord128 =- Word128 <$> genWord64 <*> genWord64+ Word128 <$> genBiasedWord64 <*> genBiasedWord64
test/Test/Data/WideWord/Int128.hs view
@@ -3,13 +3,16 @@ ( tests ) where -import Control.Exception (ArithException, evaluate, try)+import Control.Exception (SomeException, evaluate, try)+import Control.Monad (unless) import Control.Monad.IO.Class (liftIO) -import Data.Bifunctor (bimap)+import Data.Bifunctor (first) import Data.Bits ((.&.), (.|.), bit, complement, countLeadingZeros, countTrailingZeros , popCount, rotateL, rotateR, shiftL, shiftR, testBit, xor)-import Data.Word (Word64, byteSwap64)+import Data.Primitive.PrimArray+import Data.Primitive.Ptr+import Data.Word (Word8, Word64, byteSwap64) import Data.WideWord import Foreign (allocaBytes)@@ -31,15 +34,15 @@ prop_constructor_and_accessors :: Property prop_constructor_and_accessors = propertyCount $ do- (h, l) <- H.forAll $ (,) <$> genWord64 <*> genWord64+ (h, l) <- H.forAll $ (,) <$> genBiasedWord64 <*> genBiasedWord64 let i128 = Int128 h l (int128Hi64 i128, int128Lo64 i128) === (h, l) prop_byte_swap :: Property prop_byte_swap = propertyCount $ do- h <- H.forAll genWord64- l <- H.forAll $ Gen.filter (/= h) genWord64+ h <- H.forAll genBiasedWord64+ l <- H.forAll $ Gen.filter (/= h) genBiasedWord64 let w128 = Int128 h l swapped = byteSwapInt128 w128 (byteSwapInt128 swapped, byteSwap64 (fromIntegral h), byteSwap64 (fromIntegral l))@@ -48,8 +51,8 @@ prop_derivied_eq_instance :: Property prop_derivied_eq_instance = propertyCount $ do- (a1, a0) <- H.forAll $ (,) <$> genWord64 <*> genWord64- (b1, b0) <- H.forAll $ (,) <$> genWord64 <*> genWord64+ (a1, a0) <- H.forAll $ (,) <$> genBiasedWord64 <*> genBiasedWord64+ (b1, b0) <- H.forAll $ (,) <$> genBiasedWord64 <*> genBiasedWord64 (Int128 a1 a0 == Int128 b1 b0) === (a1 == b1 && a0 == b0) prop_ord_instance :: Property@@ -67,29 +70,34 @@ prop_read_instance :: Property prop_read_instance = propertyCount $ do- (a1, a0) <- H.forAll $ (,) <$> genWord64 <*> genWord64+ (a1, a0) <- H.forAll $ (,) <$> genBiasedWord64 <*> genBiasedWord64 read (show $ Int128 a1 a0) === Int128 a1 a0 prop_succ :: Property prop_succ = propertyCount $ do i128 <- H.forAll genInt128- res <- liftIO . try $ evaluate (succ i128)- bimap showArithException toInteger128 res- === if i128 == maxBound+ res <- liftIO (fmap toInteger128 <$> tryEvaluate (succ i128))+ res === if i128 == maxBound then Left "Enum.succ{Int128}: tried to take `succ' of maxBound"- else Right $ succ (toInteger128 i128)+ else Right (succ $ toInteger128 i128) prop_pred :: Property prop_pred = propertyCount $ do i128 <- H.forAll genInt128- res <- liftIO . try $ evaluate (pred i128)- bimap showArithException toInteger128 res- === if i128 == 0+ res <- liftIO (fmap toInteger128 <$> tryEvaluate (pred i128))+ res === if i128 == minBound then Left "Enum.pred{Int128}: tried to take `pred' of minBound" else Right $ pred (toInteger128 i128) +tryEvaluate :: a -> IO (Either String a)+tryEvaluate x = do+ first renderException <$> try (evaluate x)+ where+ renderException :: SomeException -> String+ renderException = show+ prop_toEnum_fromEnum :: Property prop_toEnum_fromEnum = propertyCount $ do@@ -141,7 +149,7 @@ prop_fromInteger :: Property prop_fromInteger = propertyCount $ do- (a1, a0) <- H.forAll $ (,) <$> genWord64 <*> genWord64+ (a1, a0) <- H.forAll $ (,) <$> genBiasedWord64 <*> genBiasedWord64 let i128 = fromInteger $ mkInteger a1 a0 (int128Hi64 i128, int128Lo64 i128) === (a1, a0) @@ -187,14 +195,14 @@ prop_logical_rotate_left :: Property prop_logical_rotate_left = propertyCount $ do- (a1, a0) <- H.forAll $ (,) <$> genWord64 <*> genWord64+ (a1, a0) <- H.forAll $ (,) <$> genBiasedWord64 <*> genBiasedWord64 rot <- H.forAll $ Gen.int (Range.linearFrom 0 (-20000) 20000) toInteger (rotateL (Int128 a1 a0) rot) === correctInt128 (toInteger $ rotateL (Word128 a1 a0) rot) prop_logical_rotate_right :: Property prop_logical_rotate_right = propertyCount $ do- (a1, a0) <- H.forAll $ (,) <$> genWord64 <*> genWord64+ (a1, a0) <- H.forAll $ (,) <$> genBiasedWord64 <*> genBiasedWord64 rot <- H.forAll $ Gen.int (Range.linearFrom 0 (-20000) 20000) toInteger (rotateR (Int128 a1 a0) rot) === correctInt128 (toInteger $ rotateR (Word128 a1 a0) rot) @@ -224,13 +232,13 @@ prop_popCount :: Property prop_popCount = propertyCount $ do- (a1, a0) <- H.forAll $ (,) <$> genWord64 <*> genWord64+ (a1, a0) <- H.forAll $ (,) <$> genBiasedWord64 <*> genBiasedWord64 popCount (Int128 a1 a0) === popCount a1 + popCount a0 prop_countLeadingZeros :: Property prop_countLeadingZeros = propertyCount $ do- (a1, a0) <- H.forAll $ (,) <$> genWord64 <*> genWord64+ (a1, a0) <- H.forAll $ (,) <$> genBiasedWord64 <*> genBiasedWord64 let expected = if a1 == 0 then 64 + countLeadingZeros a0 else countLeadingZeros a1@@ -239,7 +247,7 @@ prop_countTrailingZeros :: Property prop_countTrailingZeros = propertyCount $ do- (a1, a0) <- H.forAll $ (,) <$> genWord64 <*> genWord64+ (a1, a0) <- H.forAll $ (,) <$> genBiasedWord64 <*> genBiasedWord64 let expected = if a0 == 0 then 64 + countTrailingZeros a1 else countTrailingZeros a0@@ -285,7 +293,46 @@ (,) <$> peekElemOff ptr 0 <*> peekElemOff ptr 1 (toInteger128 ar, toInteger128 br) === (toInteger128 a128, toInteger128 b128) +prop_ToFromPrimArray :: Property+prop_ToFromPrimArray =+ propertyCount $ do+ as <- H.forAll $+ Gen.list (fromIntegral <$> (Range.linearBounded :: Range.Range Word8)) genInt128+ as === primArrayToList (primArrayFromList as) +prop_WriteReadPrimArray :: Property+prop_WriteReadPrimArray =+ propertyCount $ do+ as <- H.forAll $ Gen.list (Range.linear 1 256) genInt128+ unless (null as) $ do+ let len = length as+ arr = primArrayFromList as+ i <- (`mod` len) <$> H.forAll (Gen.int (Range.linear 0 (len - 1)))+ new <- H.forAll genInt128+ props <- liftIO $ do+ marr <- unsafeThawPrimArray arr+ prev <- readPrimArray marr i+ let prevProp = prev === (as !! i)+ writePrimArray marr i new+ cur <- readPrimArray marr i+ setPrimArray marr i 1 prev+ arr' <- unsafeFreezePrimArray marr+ return [prevProp, cur === new, arr === arr']+ sequence_ props+++prop_readOffPtr_writeOffPtr :: Property+prop_readOffPtr_writeOffPtr =+ propertyCount $ do+ a128 <- H.forAll genInt128+ b128 <- H.forAll genInt128+ (ar, br) <- liftIO $+ allocaBytes (2 * sizeOf zeroInt128) $ \ ptr -> do+ writeOffPtr ptr 0 a128+ writeOffPtr ptr 1 b128+ (,) <$> readOffPtr ptr 0 <*> readOffPtr ptr 1+ (ar, br) === (a128, b128)+ -- ----------------------------------------------------------------------------- mkInteger :: Word64 -> Word64 -> Integer@@ -303,9 +350,6 @@ toInteger128 :: Int128 -> Integer toInteger128 = toInteger--showArithException :: ArithException -> String-showArithException = show -- -----------------------------------------------------------------------------
test/Test/Data/WideWord/Word128.hs view
@@ -3,13 +3,16 @@ ( tests ) where -import Control.Exception (ArithException, evaluate, try)+import Control.Exception (ArithException, SomeException, evaluate, try) import Control.Monad.IO.Class (liftIO)+import Control.Monad (unless) -import Data.Bifunctor (bimap)+import Data.Bifunctor (first) import Data.Bits ((.&.), (.|.), bit, complement, countLeadingZeros, countTrailingZeros , popCount, rotateL, rotateR, shiftL, shiftR, testBit, xor)-import Data.Word (Word64, byteSwap64)+import Data.Primitive.PrimArray+import Data.Primitive.Ptr+import Data.Word (Word8, Word64, byteSwap64) import Data.WideWord import Foreign (allocaBytes)@@ -80,22 +83,27 @@ prop_succ = propertyCount $ do w128 <- H.forAll genWord128- res <- liftIO . try $ evaluate (succ w128)- bimap showArithException toInteger128 res- === if w128 == maxBound+ res <- liftIO (fmap toInteger128 <$> tryEvaluate (succ w128))+ res === if w128 == maxBound then Left "Enum.succ{Word128}: tried to take `succ' of maxBound"- else Right $ succ (toInteger128 w128)+ else Right (succ $ toInteger128 w128) prop_pred :: Property prop_pred = propertyCount $ do w128 <- H.forAll genWord128- res <- liftIO . try $ evaluate (pred w128)- bimap showArithException toInteger128 res- === if w128 == 0+ res <- liftIO (fmap toInteger128 <$> tryEvaluate (pred w128))+ res === if w128 == 0 then Left "Enum.pred{Word128}: tried to take `pred' of minBound" else Right $ pred (toInteger128 w128) +tryEvaluate :: a -> IO (Either String a)+tryEvaluate x = do+ first renderException <$> try (evaluate x)+ where+ renderException :: SomeException -> String+ renderException = show+ prop_toEnum_fromEnum :: Property prop_toEnum_fromEnum = propertyCount $ do@@ -304,6 +312,48 @@ pokeElemOff ptr 1 b128 (,) <$> peekElemOff ptr 0 <*> peekElemOff ptr 1 (toInteger128 ar, toInteger128 br) === (toInteger128 a128, toInteger128 b128)+++prop_ToFromPrimArray :: Property+prop_ToFromPrimArray =+ propertyCount $ do+ as <- H.forAll $+ Gen.list (fromIntegral <$> (Range.linearBounded :: Range.Range Word8)) genWord128+ as === primArrayToList (primArrayFromList as)+++prop_WriteReadPrimArray :: Property+prop_WriteReadPrimArray =+ propertyCount $ do+ as <- H.forAll $ Gen.list (Range.linear 1 256) genWord128+ unless (null as) $ do+ let len = length as+ arr = primArrayFromList as+ i <- (`mod` len) <$> H.forAll (Gen.int (Range.linear 0 (len - 1)))+ new <- H.forAll genWord128+ props <- liftIO $ do+ marr <- unsafeThawPrimArray arr+ prev <- readPrimArray marr i+ let prevProp = prev === (as !! i)+ writePrimArray marr i new+ cur <- readPrimArray marr i+ setPrimArray marr i 1 prev+ arr' <- unsafeFreezePrimArray marr+ return [prevProp, cur === new, arr === arr']+ sequence_ props++prop_readOffPtr_writeOffPtr :: Property+prop_readOffPtr_writeOffPtr =+ propertyCount $ do+ a128 <- H.forAll genWord128+ b128 <- H.forAll genWord128+ (ar, br) <- liftIO $+ allocaBytes (2 * sizeOf zeroWord128) $ \ ptr -> do+ writeOffPtr ptr 0 a128+ writeOffPtr ptr 1 b128+ (,) <$> readOffPtr ptr 0 <*> readOffPtr ptr 1+ (ar, br) === (a128, b128)+ -- -----------------------------------------------------------------------------
test/laws.hs view
@@ -7,6 +7,7 @@ import Data.Proxy (Proxy(Proxy)) import Data.Bits import Foreign.Storable+import Data.Primitive.Types (Prim) main :: IO () main = lawsCheckMany allPropsApplied@@ -19,17 +20,18 @@ allLaws :: ( Arbitrary a+ , Bits a , Bounded a , Enum a , Eq a+ , FiniteBits a , Integral a , Ord a+ , Prim a , Read a+ , Semiring a , Show a , Storable a- , Bits a- , FiniteBits a- , Semiring a ) => Proxy a -> [Laws] allLaws p = map ($ p) [ bitsLaws@@ -39,6 +41,7 @@ , ordLaws , semiringLaws , storableLaws+ , primLaws ] instance Arbitrary Word128 where
wide-word.cabal view
@@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: wide-word-version: 0.1.0.8+version: 0.1.0.9 synopsis: Data types for large but fixed width signed and unsigned integers description: A library to provide data types for large (ie > 64 bits) but fixed width signed@@ -23,7 +23,7 @@ build-type: Simple extra-source-files: ChangeLog.md stability: provisional-cabal-version: >=1.10+cabal-version: >= 1.10 library default-language: Haskell2010@@ -35,9 +35,9 @@ Data.WideWord.Word128 Data.WideWord.Int128 - build-depends: base >= 4.8 && < 5.0+ build-depends: base >= 4.8 && < 4.13 , deepseq >= 1.3 && < 1.5- , primitive >= 0.6.4.0 && < 0.7.0.0+ , primitive >= 0.6.4.0 && < 0.8 test-suite test default-language: Haskell2010@@ -51,10 +51,11 @@ Test.Data.WideWord.Int128 Test.Data.WideWord.Word128 - build-depends: base >= 4.8 && < 5.0+ build-depends: base , bytestring >= 0.10 , ghc-prim- , hedgehog == 0.6.*+ , hedgehog == 1.0.*+ , primitive , wide-word test-suite laws@@ -65,8 +66,9 @@ main-is: laws.hs hs-source-dirs: test - build-depends: base >= 4.8 && < 5.0- , QuickCheck >= 2.9.2 && < 2.13- , quickcheck-classes >= 0.4.0 && < 0.7.0- , semirings >= 0.2 && < 0.3+ build-depends: base+ , QuickCheck >= 2.9.2 && < 2.14+ , quickcheck-classes >= 0.4.0 && < 0.6.3+ , primitive+ , semirings >= 0.2 && < 0.6 , wide-word