wide-word 0.1.0.6 → 0.1.0.7

raw patch · 12 files changed

+1480/−1190 lines, 12 filesdep +hedgehogdep −QuickCheckdep −hspecPVP ok

version bump matches the API change (PVP)

Dependencies added: hedgehog

Dependencies removed: QuickCheck, hspec

API changes (from Hackage documentation)

Files

• ChangeLog.md +4/−0
• Data/WideWord.hs +0/−6
• Data/WideWord/Int128.hs +0/−451
• Data/WideWord/Word128.hs +0/−454
• src/Data/WideWord.hs +6/−0
• src/Data/WideWord/Int128.hs +452/−0
• src/Data/WideWord/Word128.hs +454/−0
• test/Test/Data/WideWord/Gen.hs +50/−0
• test/Test/Data/WideWord/Int128.hs +249/−128
• test/Test/Data/WideWord/Word128.hs +243/−121
• test/test.hs +13/−21
• wide-word.cabal +9/−9

@@ -1,5 +1,9 @@ # Revision history for wide-word +## 0.1.0.7  -- 2018-11-16++* Switch to Hedgehog for testing.+ ## 0.1.0.3  -- 2017-04-05  * Make it build with ghc 8.2.

@@ -1,6 +0,0 @@-module Data.WideWord-  ( module X-  ) where--import Data.WideWord.Int128 as X-import Data.WideWord.Word128 as X

@@ -1,451 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE MagicHash #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE StrictData #-}-{-# LANGUAGE UnboxedTuples #-}-{-# OPTIONS_GHC -funbox-strict-fields #-}------------------------------------------------------------------------------------ |----- Module      :  Data.WideWord.Int128---------- Maintainer  :  erikd@mega-nerd.com----- Stability   :  experimental----- Portability :  non-portable (GHC extensions and primops)---------- This module provides an opaque signed 128 bit value with the usual set----- of typeclass instances one would expect for a fixed width unsigned integer----- type.----- Operations like addition, subtraction and multiplication etc provide a----- "modulo 2^128" result as one would expect from a fixed width unsigned word.----------------------------------------------------------------------------------#include <MachDeps.h>--module Data.WideWord.Int128-  ( Int128 (..)-  , byteSwapInt128-  , showHexInt128-  , zeroInt128-  ) where--import Control.DeepSeq (NFData (..))--import Data.Bits (Bits (..), FiniteBits (..), shiftL)--import Data.WideWord.Word128--import Numeric--import Foreign.Ptr (Ptr, castPtr)-import Foreign.Storable (Storable (..))--import GHC.Enum (predError, succError)-import GHC.Int-import GHC.Prim-import GHC.Real ((%))-import GHC.Word---data Int128 = Int128-  { int128Hi64 :: {-# UNPACK #-} !Word64-  , int128Lo64 :: {-# UNPACK #-} !Word64-  }-  deriving Eq---byteSwapInt128 :: Int128 -> Int128-byteSwapInt128 (Int128 a1 a0) = Int128 (byteSwap64 a1) (byteSwap64 a0)---showHexInt128 :: Int128 -> String-showHexInt128 (Int128 a1 a0)-  | a1 == 0 = showHex a0 ""-  | otherwise = showHex a1 zeros ++ showHex a0 ""-  where-    h0 = showHex a0 ""-    zeros = replicate (16 - length h0) '0'--instance Show Int128 where-  show = show . toInteger--instance Read Int128 where-  readsPrec p s = [(fromInteger128 (x :: Integer), r) | (x, r) <- readsPrec p s]--instance Ord Int128 where-  compare = compare128--instance Bounded Int128 where-  minBound = Int128 0x8000000000000000 0-  maxBound = Int128 0x7fffffffffffffff maxBound--instance Enum Int128 where-  succ = succ128-  pred = pred128-  toEnum = toEnum128-  fromEnum = fromEnum128--instance Num Int128 where-  (+) = plus128-  (-) = minus128-  (*) = times128-  negate = negate128-  abs = abs128-  signum = signum128-  fromInteger = fromInteger128--instance Bits Int128 where-  (.&.) = and128-  (.|.) = or128-  xor = xor128-  complement = complement128-  shiftL = shiftL128-  unsafeShiftL = shiftL128-  shiftR = shiftR128-  unsafeShiftR = shiftR128-  rotateL = rotateL128-  rotateR = rotateR128--  bitSize _ = 128-  bitSizeMaybe _ = Just 128-  isSigned _ = False--  testBit = testBit128-  bit = bit128--  popCount = popCount128--instance FiniteBits Int128 where-  finiteBitSize _ = 128-  countLeadingZeros = countLeadingZeros128-  countTrailingZeros = countTrailingZeros128--instance Real Int128 where-  toRational x = toInteger128 x % 1--instance Integral Int128 where-  quot n d = fst (quotRem128 n d)-  rem n d = snd (quotRem128 n d)-  div n d = fst (divMod128 n d)-  mod n d = snd (divMod128 n d)-  quotRem = quotRem128-  divMod = divMod128-  toInteger = toInteger128--instance Storable Int128 where-  sizeOf _ = 2 * sizeOf (0 :: Word64)-  alignment _ = 2 * alignment (0 :: Word64)-  peek = peek128-  peekElemOff = peekElemOff128-  poke = poke128-  pokeElemOff = pokeElemOff128--instance NFData Int128 where-  rnf (Int128 a1 a0) = rnf a1 `seq` rnf a0---- -------------------------------------------------------------------------------- Rewrite rules.--{-# RULES-"fromIntegral :: Int128 -> Int128" fromIntegral = id :: Int128 -> Int128-"fromIntegral :: Word128 -> Int128" fromIntegral = \(Word128 a1 a0) -> Int128 a1 a0-"fromIntegral :: Int128 -> Word128" fromIntegral = \(Int128 a1 a0) -> Word128 a1 a0-  #-}---- -------------------------------------------------------------------------------- Functions for `Ord` instance.--compare128 :: Int128 -> Int128 -> Ordering-compare128 (Int128 a1 a0) (Int128 b1 b0) =-  case compare (int64OfWord64 a1) (int64OfWord64 b1) of-    EQ -> compare a0 b0-    LT -> LT-    GT -> GT-  where-    int64OfWord64 (W64# w) = I64# (word2Int# w)---- -------------------------------------------------------------------------------- Functions for `Enum` instance.---succ128 :: Int128 -> Int128-succ128 (Int128 a1 a0)-  | a1 == 0x7fffffffffffffff && a0 == maxBound = succError "Int128"-  | otherwise =-      case a0 + 1 of-        0 -> Int128 (a1 + 1) 0-        s -> Int128 a1 s--pred128 :: Int128 -> Int128-pred128 (Int128 a1 a0)-  | a1 == 0x8000000000000000 && a0 == 0 = predError "Int128"-  | otherwise =-      case a0 of-        0 -> Int128 (a1 - 1) maxBound-        _ -> Int128 a1 (a0 - 1)--{-# INLINABLE toEnum128 #-}-toEnum128 :: Int -> Int128-toEnum128 i = Int128 0 (toEnum i)--{-# INLINABLE fromEnum128 #-}-fromEnum128 :: Int128 -> Int-fromEnum128 (Int128 _ a0) = fromEnum a0---- -------------------------------------------------------------------------------- Functions for `Num` instance.--{-# INLINABLE plus128 #-}-plus128 :: Int128 -> Int128 -> Int128-plus128 (Int128 (W64# a1) (W64# a0)) (Int128 (W64# b1) (W64# b0)) =-  Int128 (W64# s1) (W64# s0)-  where-    !(# c1, s0 #) = plusWord2# a0 b0-    s1a = plusWord# a1 b1-    s1 = plusWord# c1 s1a--{-# INLINABLE minus128 #-}-minus128 :: Int128 -> Int128 -> Int128-minus128 (Int128 (W64# a1) (W64# a0)) (Int128 (W64# b1) (W64# b0)) =-  Int128 (W64# d1) (W64# d0)-  where-    !(# d0, c1 #) = subWordC# a0 b0-    a1c = minusWord# a1 (int2Word# c1)-    d1 = minusWord# a1c b1--times128 :: Int128 -> Int128 -> Int128-times128 (Int128 (W64# a1) (W64# a0)) (Int128 (W64# b1) (W64# b0)) =-  Int128 (W64# p1) (W64# p0)-  where-    !(# c1, p0 #) = timesWord2# a0 b0-    p1a = timesWord# a1 b0-    p1b = timesWord# a0 b1-    p1c = plusWord# p1a p1b-    p1 = plusWord# p1c c1--{-# INLINABLE negate128 #-}-negate128 :: Int128 -> Int128-negate128 (Int128 (W64# a1) (W64# a0)) =-  case plusWord2# (not# a0) 1## of-    (# c, s #) -> Int128 (W64# (plusWord# (not# a1) c)) (W64# s)--{-# INLINABLE abs128 #-}-abs128 :: Int128 -> Int128-abs128 i@(Int128 a1 _)-  | testBit a1 63 = negate128 i-  | otherwise = i--{-# INLINABLE signum128 #-}-signum128 :: Int128 -> Int128-signum128 (Int128 a1 a0)-  | a1 == 0 && a0 == 0 = zeroInt128-  | testBit a1 63 = minusOneInt128-  | otherwise = oneInt128--{-# INLINABLE complement128 #-}-complement128 :: Int128 -> Int128-complement128 (Int128 a1 a0) = Int128 (complement a1) (complement a0)--fromInteger128 :: Integer -> Int128-fromInteger128 i =-  Int128 (fromIntegral $ i `shiftR` 64) (fromIntegral i)---- -------------------------------------------------------------------------------- Functions for `Bits` instance.--{-# INLINABLE and128 #-}-and128 :: Int128 -> Int128 -> Int128-and128 (Int128 (W64# a1) (W64# a0)) (Int128 (W64# b1) (W64# b0)) =-  Int128 (W64# (and# a1 b1)) (W64# (and# a0 b0))--{-# INLINABLE or128 #-}-or128 :: Int128 -> Int128 -> Int128-or128 (Int128 (W64# a1) (W64# a0)) (Int128 (W64# b1) (W64# b0)) =-  Int128 (W64# (or# a1 b1)) (W64# (or# a0 b0))--{-# INLINABLE xor128 #-}-xor128 :: Int128 -> Int128 -> Int128-xor128 (Int128 (W64# a1) (W64# a0)) (Int128 (W64# b1) (W64# b0)) =-  Int128 (W64# (xor# a1 b1)) (W64# (xor# a0 b0))---- Probably not worth inlining this.-shiftL128 :: Int128 -> Int -> Int128-shiftL128 w@(Int128 a1 a0) s-  | s == 0 = w-  | s < 0 = shiftL128 w (128 - (abs s `mod` 128))-  | s >= 128 = zeroInt128-  | s == 64 = Int128 a0 0-  | s > 64 = Int128 (a0 `shiftL` (s - 64)) 0-  | otherwise =-      Int128 s1 s0-      where-        s0 = a0 `shiftL` s-        s1 = a1 `shiftL` s + a0 `shiftR` (64 - s)---- Probably not worth inlining this.-shiftR128 :: Int128 -> Int -> Int128-shiftR128 i@(Int128 a1 a0) s-  | s < 0 = zeroInt128-  | s == 0 = i-  | topBitSetWord64 a1 = complement128 (shiftR128 (complement128 i) s)-  | s >= 128 = zeroInt128-  | s == 64 = Int128 0 a1-  | s > 64 = Int128 0 (a1 `shiftR` (s - 64))-  | otherwise = Int128 s1 s0-      where-        s1 = a1 `shiftR` s-        s0 = a0 `shiftR` s + a1 `shiftL` (64 - s)--rotateL128 :: Int128 -> Int -> Int128-rotateL128 w@(Int128 a1 a0) r-  | r < 0 = zeroInt128-  | r == 0 = w-  | r >= 128 = rotateL128 w (r `mod` 128)-  | r == 64 = Int128 a0 a1-  | r > 64 = rotateL128 (Int128 a0 a1) (r `mod` 64)-  | otherwise =-      Int128 s1 s0-      where-        s0 = a0 `shiftL` r + a1 `shiftR` (64 - r)-        s1 = a1 `shiftL` r + a0 `shiftR` (64 - r)--rotateR128 :: Int128 -> Int -> Int128-rotateR128 w@(Int128 a1 a0) r-  | r < 0 = rotateR128 w (128 - (abs r `mod` 128))-  | r == 0 = w-  | r >= 128 = rotateR128 w (r `mod` 128)-  | r == 64 = Int128 a0 a1-  | r > 64 = rotateR128 (Int128 a0 a1) (r `mod` 64)-  | otherwise =-      Int128 s1 s0-      where-        s0 = a0 `shiftR` r + a1 `shiftL` (64 - r)-        s1 = a1 `shiftR` r + a0 `shiftL` (64 - r)--testBit128 :: Int128 -> Int -> Bool-testBit128 (Int128 a1 a0) i-  | i < 0 = False-  | i >= 128 = False-  | i >= 64 = testBit a1 (i - 64)-  | otherwise = testBit a0 i--bit128 :: Int -> Int128-bit128 indx-  | indx < 0 = zeroInt128-  | indx >= 128 = zeroInt128-  | otherwise = shiftL128 oneInt128 indx--popCount128 :: Int128 -> Int-popCount128 (Int128 a1 a0) = popCount a1 + popCount a0---- -------------------------------------------------------------------------------- Functions for `FiniteBits` instance.--countLeadingZeros128 :: Int128 -> Int-countLeadingZeros128 (Int128 a1 a0) =-  case countLeadingZeros a1 of-    64 -> 64 +  countLeadingZeros a0-    res -> res--countTrailingZeros128 :: Int128 -> Int-countTrailingZeros128 (Int128 a1 a0) =-  case countTrailingZeros a0 of-    64 -> 64 + countTrailingZeros a1-    res -> res---- -------------------------------------------------------------------------------- Functions for `Integral` instance.--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)-  | 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---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))-  | otherwise = (word128ToInt128 wq, word128ToInt128 wr)-  where-    (wq, wr) = quotRem absNumerW absDenomW-    numerIsNegative = topBitSetWord64 $ int128Hi64 numer-    denomIsNegative = topBitSetWord64 $ int128Hi64 denom-    absNumerW = int128ToWord128 $ abs128 numer-    absDenomW = int128ToWord128 $ abs128 denom---toInteger128 :: Int128 -> Integer-toInteger128 i@(Int128 a1 a0)-  | popCount a1 == 64 && popCount a0 == 64 = -1-  | not (testBit a1 63) = fromIntegral a1 `shiftL` 64 + fromIntegral a0-  | otherwise =-      case negate128 i of-        Int128 n1 n0 -> negate (fromIntegral n1 `shiftL` 64 + fromIntegral n0)---- -------------------------------------------------------------------------------- Functions for `Integral` instance.--peek128 :: Ptr Int128 -> IO Int128-peek128 ptr =-  Int128 <$> peekElemOff (castPtr ptr) index1 <*> peekElemOff (castPtr ptr) index0--peekElemOff128 :: Ptr Int128 -> Int -> IO Int128-peekElemOff128 ptr idx =-  Int128 <$> peekElemOff (castPtr ptr) (2 * idx + index1)-            <*> peekElemOff (castPtr ptr) (2 * idx + index0)--poke128 :: Ptr Int128 -> Int128 -> IO ()-poke128 ptr (Int128 a1 a0) =-  pokeElemOff (castPtr ptr) index1 a1 >> pokeElemOff (castPtr ptr) index0 a0--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---- -------------------------------------------------------------------------------- Helpers.--{-# INLINE int128ToWord128 #-}-int128ToWord128 :: Int128 -> Word128-int128ToWord128 (Int128 a1 a0) = Word128 a1 a0--{-# INLINE topBitSetWord64 #-}-topBitSetWord64 :: Word64 -> Bool-topBitSetWord64 w = testBit w 63--{-# INLINE word128ToInt128 #-}-word128ToInt128 :: Word128 -> Int128-word128ToInt128 (Word128 a1 a0) = Int128 a1 a0---- -------------------------------------------------------------------------------- Constants.--zeroInt128 :: Int128-zeroInt128 = Int128 0 0--oneInt128 :: Int128-oneInt128 = Int128 0 1--minusOneInt128 :: Int128-minusOneInt128 = Int128 maxBound maxBound--index0, index1 :: Int-#if WORDS_BIGENDIAN-index0 = 1-index1 = 0-#else-index0 = 0-index1 = 1-#endif

@@ -1,454 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE MagicHash #-}-{-# LANGUAGE StrictData #-}-{-# LANGUAGE UnboxedTuples #-}-{-# OPTIONS_GHC -funbox-strict-fields #-}------------------------------------------------------------------------------------ |----- Module      :  Data.WideWord.Word128---------- Maintainer  :  erikd@mega-nerd.com----- Stability   :  experimental----- Portability :  non-portable (GHC extensions and primops)---------- This module provides an opaque unsigned 128 bit value with the usual set----- of typeclass instances one would expect for a fixed width unsigned integer----- type.----- Operations like addition, subtraction and multiplication etc provide a----- "modulo 2^128" result as one would expect from a fixed width unsigned word.----------------------------------------------------------------------------------#include <MachDeps.h>--module Data.WideWord.Word128-  ( Word128 (..)-  , byteSwapWord128-  , showHexWord128-  , zeroWord128-  ) where--import Control.DeepSeq (NFData (..))--import Data.Bits (Bits (..), FiniteBits (..), shiftL)--import Foreign.Ptr (Ptr, castPtr)-import Foreign.Storable (Storable (..))--import GHC.Base (Int (..), and#, int2Word#, minusWord#, not#, or#, plusWord#, plusWord2#-                , quotRemWord2#, subWordC#, timesWord#, timesWord2#, xor#)-import GHC.Enum (predError, succError)-import GHC.Real ((%), divZeroError)-import GHC.Word (Word64 (..), byteSwap64)--import Numeric (showHex)---data Word128 = Word128-  { word128Hi64 :: {-# UNPACK #-} !Word64-  , word128Lo64 :: {-# UNPACK #-} !Word64-  }-  deriving Eq---byteSwapWord128 :: Word128 -> Word128-byteSwapWord128 (Word128 a1 a0) = Word128 (byteSwap64 a1) (byteSwap64 a0)---showHexWord128 :: Word128 -> String-showHexWord128 (Word128 a1 a0)-  | a1 == 0 = showHex a0 ""-  | otherwise = showHex a1 zeros ++ showHex a0 ""-  where-    h0 = showHex a0 ""-    zeros = replicate (16 - length h0) '0'--instance Show Word128 where-  show = show . toInteger128--instance Read Word128 where-  readsPrec p s = [(fromInteger128 (x :: Integer), r) | (x, r) <- readsPrec p s]--instance Ord Word128 where-  compare = compare128--instance Bounded Word128 where-  minBound = zeroWord128-  maxBound = Word128 maxBound maxBound--instance Enum Word128 where-  succ = succ128-  pred = pred128-  toEnum = toEnum128-  fromEnum = fromEnum128--instance Num Word128 where-  (+) = plus128-  (-) = minus128-  (*) = times128-  negate = negate128-  abs = id-  signum = signum128-  fromInteger = fromInteger128--instance Bits Word128 where-  (.&.) = and128-  (.|.) = or128-  xor = xor128-  complement = complement128-  shiftL = shiftL128-  unsafeShiftL = shiftL128-  shiftR = shiftR128-  unsafeShiftR = shiftR128-  rotateL = rotateL128-  rotateR = rotateR128--  bitSize _ = 128-  bitSizeMaybe _ = Just 128-  isSigned _ = False--  testBit = testBit128-  bit = bit128--  popCount = popCount128--instance FiniteBits Word128 where-  finiteBitSize _ = 128-  countLeadingZeros = countLeadingZeros128-  countTrailingZeros = countTrailingZeros128--instance Real Word128 where-  toRational x = toInteger128 x % 1--instance Integral Word128 where-  quot n d = fst (quotRem128 n d)-  rem n d = snd (quotRem128 n d)-  div n d = fst (quotRem128 n d)-  mod n d = snd (quotRem128 n d)-  quotRem = quotRem128-  divMod = quotRem128-  toInteger = toInteger128--instance Storable Word128 where-  sizeOf _ = 2 * sizeOf (0 :: Word64)-  alignment _ = 2 * alignment (0 :: Word64)-  peek = peek128-  peekElemOff = peekElemOff128-  poke = poke128-  pokeElemOff = pokeElemOff128--instance NFData Word128 where-  rnf (Word128 a1 a0) = rnf a1 `seq` rnf a0---- -------------------------------------------------------------------------------- Rewrite rules.--{-# RULES-"fromIntegral :: Word128 -> Word128" fromIntegral = id :: Word128 -> Word128-  #-}--{-# RULES-"fromIntegral :: Int -> Word128"     fromIntegral = \(I# i#) -> Word128 (W64# 0##) (W64# (int2Word# i#))-"fromIntegral :: Word- > Word128"    fromIntegral = Word128 0 . fromIntegral-"fromIntegral :: Word32 -> Word128"  fromIntegral = Word128 0 . fromIntegral-"fromIntegral :: Word64 -> Word128"  fromIntegral = Word128 0--"fromIntegral :: Word128 -> Int"     fromIntegral = \(Word128 _ w) -> fromIntegral w-"fromIntegral :: Word128 -> Word"    fromIntegral = \(Word128 _ w) -> fromIntegral w-"fromIntegral :: Word128 -> Word32"  fromIntegral = \(Word128 _ w) -> fromIntegral w-"fromIntegral :: Word128 -> Word64"  fromIntegral = \(Word128 _ w) -> w-  #-}---- -------------------------------------------------------------------------------- Functions for `Ord` instance.--compare128 :: Word128 -> Word128 -> Ordering-compare128 (Word128 a1 a0) (Word128 b1 b0) =-  case compare a1 b1 of-    EQ -> compare a0 b0-    LT -> LT-    GT -> GT---- -------------------------------------------------------------------------------- Functions for `Enum` instance.--succ128 :: Word128 -> Word128-succ128 (Word128 a1 a0)-  | a1 == maxBound && a0 == maxBound = succError "Word128"-  | otherwise =-      case a0 + 1 of-        0 -> Word128 (a1 + 1) 0-        s -> Word128 a1 s--pred128 :: Word128 -> Word128-pred128 (Word128 a1 a0)-  | a1 == 0 && a0 == 0 = predError "Word128"-  | otherwise =-      case a0 of-        0 -> Word128 (a1 - 1) maxBound-        _ -> Word128 a1 (a0 - 1)--{-# INLINABLE toEnum128 #-}-toEnum128 :: Int -> Word128-toEnum128 i = Word128 0 (toEnum i)--{-# INLINABLE fromEnum128 #-}-fromEnum128 :: Word128 -> Int-fromEnum128 (Word128 _ a0) = fromEnum a0---- -------------------------------------------------------------------------------- Functions for `Num` instance.--{-# INLINABLE plus128 #-}-plus128 :: Word128 -> Word128 -> Word128-plus128 (Word128 (W64# a1) (W64# a0)) (Word128 (W64# b1) (W64# b0)) =-  Word128 (W64# s1) (W64# s0)-  where-    !(# c1, s0 #) = plusWord2# a0 b0-    s1a = plusWord# a1 b1-    s1 = plusWord# c1 s1a--{-# INLINABLE minus128 #-}-minus128 :: Word128 -> Word128 -> Word128-minus128 (Word128 (W64# a1) (W64# a0)) (Word128 (W64# b1) (W64# b0)) =-  Word128 (W64# d1) (W64# d0)-  where-    !(# d0, c1 #) = subWordC# a0 b0-    a1c = minusWord# a1 (int2Word# c1)-    d1 = minusWord# a1c b1--times128 :: Word128 -> Word128 -> Word128-times128 (Word128 (W64# a1) (W64# a0)) (Word128 (W64# b1) (W64# b0)) =-  Word128 (W64# p1) (W64# p0)-  where-    !(# c1, p0 #) = timesWord2# a0 b0-    p1a = timesWord# a1 b0-    p1b = timesWord# a0 b1-    p1c = plusWord# p1a p1b-    p1 = plusWord# p1c c1--{-# INLINABLE negate128 #-}-negate128 :: Word128 -> Word128-negate128 (Word128 (W64# a1) (W64# a0)) =-  case plusWord2# (not# a0) 1## of-    (# c, s #) -> Word128 (W64# (plusWord# (not# a1) c)) (W64# s)--{-# INLINABLE signum128 #-}-signum128 :: Word128 -> Word128-signum128 (Word128 (W64# 0##) (W64# 0##)) = zeroWord128-signum128 _ = oneWord128--fromInteger128 :: Integer -> Word128-fromInteger128 i =-  Word128 (fromIntegral $ i `shiftR` 64) (fromIntegral i)---- -------------------------------------------------------------------------------- Functions for `Bits` instance.--{-# INLINABLE and128 #-}-and128 :: Word128 -> Word128 -> Word128-and128 (Word128 (W64# a1) (W64# a0)) (Word128 (W64# b1) (W64# b0)) =-  Word128 (W64# (and# a1 b1)) (W64# (and# a0 b0))--{-# INLINABLE or128 #-}-or128 :: Word128 -> Word128 -> Word128-or128 (Word128 (W64# a1) (W64# a0)) (Word128 (W64# b1) (W64# b0)) =-  Word128 (W64# (or# a1 b1)) (W64# (or# a0 b0))--{-# INLINABLE xor128 #-}-xor128 :: Word128 -> Word128 -> Word128-xor128 (Word128 (W64# a1) (W64# a0)) (Word128 (W64# b1) (W64# b0)) =-  Word128 (W64# (xor# a1 b1)) (W64# (xor# a0 b0))--{-# INLINABLE complement128 #-}-complement128 :: Word128 -> Word128-complement128 (Word128 a1 a0) = Word128 (complement a1) (complement a0)---- Probably not worth inlining this.-shiftL128 :: Word128 -> Int -> Word128-shiftL128 w@(Word128 a1 a0) s-  | s == 0 = w-  | s < 0 = shiftL128 w (128 - (abs s `mod` 128))-  | s >= 128 = zeroWord128-  | s == 64 = Word128 a0 0-  | s > 64 = Word128 (a0 `shiftL` (s - 64)) 0-  | otherwise =-      Word128 s1 s0-      where-        s0 = a0 `shiftL` s-        s1 = a1 `shiftL` s + a0 `shiftR` (64 - s)---- Probably not worth inlining this.-shiftR128 :: Word128 -> Int -> Word128-shiftR128 w@(Word128 a1 a0) s-  | s < 0 = zeroWord128-  | s == 0 = w-  | s >= 128 = zeroWord128-  | s == 64 = Word128 0 a1-  | s > 64 = Word128 0 (a1 `shiftR` (s - 64))-  | otherwise =-      Word128 s1 s0-      where-        s1 = a1 `shiftR` s-        s0 = a0 `shiftR` s + a1 `shiftL` (64 - s)--rotateL128 :: Word128 -> Int -> Word128-rotateL128 w@(Word128 a1 a0) r-  | r < 0 = zeroWord128-  | r == 0 = w-  | r >= 128 = rotateL128 w (r `mod` 128)-  | r == 64 = Word128 a0 a1-  | r > 64 = rotateL128 (Word128 a0 a1) (r `mod` 64)-  | otherwise =-      Word128 s1 s0-      where-        s0 = a0 `shiftL` r + a1 `shiftR` (64 - r)-        s1 = a1 `shiftL` r + a0 `shiftR` (64 - r)--rotateR128 :: Word128 -> Int -> Word128-rotateR128 w@(Word128 a1 a0) r-  | r < 0 = rotateR128 w (128 - (abs r `mod` 128))-  | r == 0 = w-  | r >= 128 = rotateR128 w (r `mod` 128)-  | r == 64 = Word128 a0 a1-  | r > 64 = rotateR128 (Word128 a0 a1) (r `mod` 64)-  | otherwise =-      Word128 s1 s0-      where-        s0 = a0 `shiftR` r + a1 `shiftL` (64 - r)-        s1 = a1 `shiftR` r + a0 `shiftL` (64 - r)--testBit128 :: Word128 -> Int -> Bool-testBit128 (Word128 a1 a0) i-  | i < 0 = False-  | i >= 128 = False-  | i >= 64 = testBit a1 (i - 64)-  | otherwise = testBit a0 i--bit128 :: Int -> Word128-bit128 indx-  | indx < 0 = zeroWord128-  | indx >= 128 = zeroWord128-  | otherwise = shiftL128 oneWord128 indx--popCount128 :: Word128 -> Int-popCount128 (Word128 a1 a0) = popCount a1 + popCount a0---- -------------------------------------------------------------------------------- Functions for `FiniteBits` instance.--countLeadingZeros128 :: Word128 -> Int-countLeadingZeros128 (Word128 a1 a0) =-  case countLeadingZeros a1 of-    64 -> 64 +  countLeadingZeros a0-    res -> res--countTrailingZeros128 :: Word128 -> Int-countTrailingZeros128 (Word128 a1 a0) =-  case countTrailingZeros a0 of-    64 -> 64 + countTrailingZeros a1-    res -> res---- -------------------------------------------------------------------------------- Functions for `Integral` instance.--quotRem128 :: Word128 -> Word128 -> (Word128, Word128)-quotRem128 num@(Word128 n1 n0) den@(Word128 d1 d0)-  | n1 == 0 && d1 == 0 = quotRemTwo n0 d0-  | n1 < d1 = (zeroWord128, num)-  | d1 == 0 = quotRemThree num d0-  | otherwise = quotRemFour num den---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))---{-# 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-                (q, r) -> (Word128 0 q, Word128 0 r)-  | otherwise =-      case quotRem n1 den of-        (q1, r1) -> case quotRemWord2 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) =-  case quotRemWord2# n1 n0 d of-    (# q, r #) -> (W64# q, W64# r)---{-# INLINE quotRemTwo #-}-quotRemTwo :: Word64 -> Word64 -> (Word128, Word128)-quotRemTwo n0 d0 =-  case quotRem n0 d0 of-    (q, r) -> (Word128 0 q, Word128 0 r)--toInteger128 :: Word128 -> Integer-toInteger128 (Word128 a1 a0) = fromIntegral a1 `shiftL` 64 + fromIntegral a0---- -------------------------------------------------------------------------------- Functions for `Integral` instance.--peek128 :: Ptr Word128 -> IO Word128-peek128 ptr =-  Word128 <$> peekElemOff (castPtr ptr) index1 <*> peekElemOff (castPtr ptr) index0--peekElemOff128 :: Ptr Word128 -> Int -> IO Word128-peekElemOff128 ptr idx =-  Word128 <$> peekElemOff (castPtr ptr) (2 * idx + index1)-            <*> peekElemOff (castPtr ptr) (2 * idx + index0)--poke128 :: Ptr Word128 -> Word128 -> IO ()-poke128 ptr (Word128 a1 a0) =-  pokeElemOff (castPtr ptr) index1 a1 >> pokeElemOff (castPtr ptr) index0 a0--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---- -------------------------------------------------------------------------------- Constants.--zeroWord128 :: Word128-zeroWord128 = Word128 0 0--oneWord128 :: Word128-oneWord128 = Word128 0 1---- Use these indices to get the peek/poke ordering endian correct.-index0, index1 :: Int-#if WORDS_BIGENDIAN-index0 = 1-index1 = 0-#else-index0 = 0-index1 = 1-#endif

@@ -0,0 +1,6 @@+module Data.WideWord+  ( module X+  ) where++import Data.WideWord.Int128 as X+import Data.WideWord.Word128 as X

@@ -0,0 +1,452 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE StrictData #-}+{-# LANGUAGE UnboxedTuples #-}+{-# OPTIONS_GHC -funbox-strict-fields #-}++-----------------------------------------------------------------------------+---- |+---- Module      :  Data.WideWord.Int128+----+---- Maintainer  :  erikd@mega-nerd.com+---- Stability   :  experimental+---- Portability :  non-portable (GHC extensions and primops)+----+---- This module provides an opaque signed 128 bit value with the usual set+---- of typeclass instances one would expect for a fixed width unsigned integer+---- type.+---- Operations like addition, subtraction and multiplication etc provide a+---- "modulo 2^128" result as one would expect from a fixed width unsigned word.+-------------------------------------------------------------------------------++#include <MachDeps.h>++module Data.WideWord.Int128+  ( Int128 (..)+  , byteSwapInt128+  , showHexInt128+  , zeroInt128+  ) where++import Control.DeepSeq (NFData (..))++import Data.Bits (Bits (..), FiniteBits (..), shiftL)++import Data.WideWord.Word128++import Numeric++import Foreign.Ptr (Ptr, castPtr)+import Foreign.Storable (Storable (..))++import GHC.Base (Int (..), and#, int2Word#, minusWord#, not#, or#, plusWord#, plusWord2#+                , subWordC#, timesWord#, timesWord2#, word2Int#, xor#)+import GHC.Enum (predError, succError)+import GHC.Int (Int64 (..))+import GHC.Real ((%))+import GHC.Word (Word64 (..), byteSwap64)+++data Int128 = Int128+  { int128Hi64 :: {-# UNPACK #-} !Word64+  , int128Lo64 :: {-# UNPACK #-} !Word64+  }+  deriving Eq+++byteSwapInt128 :: Int128 -> Int128+byteSwapInt128 (Int128 a1 a0) = Int128 (byteSwap64 a0) (byteSwap64 a1)+++showHexInt128 :: Int128 -> String+showHexInt128 (Int128 a1 a0)+  | a1 == 0 = showHex a0 ""+  | otherwise = showHex a1 zeros ++ showHex a0 ""+  where+    h0 = showHex a0 ""+    zeros = replicate (16 - length h0) '0'++instance Show Int128 where+  show = show . toInteger++instance Read Int128 where+  readsPrec p s = [(fromInteger128 (x :: Integer), r) | (x, r) <- readsPrec p s]++instance Ord Int128 where+  compare = compare128++instance Bounded Int128 where+  minBound = Int128 0x8000000000000000 0+  maxBound = Int128 0x7fffffffffffffff maxBound++instance Enum Int128 where+  succ = succ128+  pred = pred128+  toEnum = toEnum128+  fromEnum = fromEnum128++instance Num Int128 where+  (+) = plus128+  (-) = minus128+  (*) = times128+  negate = negate128+  abs = abs128+  signum = signum128+  fromInteger = fromInteger128++instance Bits Int128 where+  (.&.) = and128+  (.|.) = or128+  xor = xor128+  complement = complement128+  shiftL = shiftL128+  unsafeShiftL = shiftL128+  shiftR = shiftR128+  unsafeShiftR = shiftR128+  rotateL = rotateL128+  rotateR = rotateR128++  bitSize _ = 128+  bitSizeMaybe _ = Just 128+  isSigned _ = False++  testBit = testBit128+  bit = bit128++  popCount = popCount128++instance FiniteBits Int128 where+  finiteBitSize _ = 128+  countLeadingZeros = countLeadingZeros128+  countTrailingZeros = countTrailingZeros128++instance Real Int128 where+  toRational x = toInteger128 x % 1++instance Integral Int128 where+  quot n d = fst (quotRem128 n d)+  rem n d = snd (quotRem128 n d)+  div n d = fst (divMod128 n d)+  mod n d = snd (divMod128 n d)+  quotRem = quotRem128+  divMod = divMod128+  toInteger = toInteger128++instance Storable Int128 where+  sizeOf _ = 2 * sizeOf (0 :: Word64)+  alignment _ = 2 * alignment (0 :: Word64)+  peek = peek128+  peekElemOff = peekElemOff128+  poke = poke128+  pokeElemOff = pokeElemOff128++instance NFData Int128 where+  rnf (Int128 a1 a0) = rnf a1 `seq` rnf a0++-- -----------------------------------------------------------------------------+-- Rewrite rules.++{-# RULES+"fromIntegral :: Int128 -> Int128" fromIntegral = id :: Int128 -> Int128+"fromIntegral :: Word128 -> Int128" fromIntegral = \(Word128 a1 a0) -> Int128 a1 a0+"fromIntegral :: Int128 -> Word128" fromIntegral = \(Int128 a1 a0) -> Word128 a1 a0+  #-}++-- -----------------------------------------------------------------------------+-- Functions for `Ord` instance.++compare128 :: Int128 -> Int128 -> Ordering+compare128 (Int128 a1 a0) (Int128 b1 b0) =+  case compare (int64OfWord64 a1) (int64OfWord64 b1) of+    EQ -> compare a0 b0+    LT -> LT+    GT -> GT+  where+    int64OfWord64 (W64# w) = I64# (word2Int# w)++-- -----------------------------------------------------------------------------+-- Functions for `Enum` instance.+++succ128 :: Int128 -> Int128+succ128 (Int128 a1 a0)+  | a1 == 0x7fffffffffffffff && a0 == maxBound = succError "Int128"+  | otherwise =+      case a0 + 1 of+        0 -> Int128 (a1 + 1) 0+        s -> Int128 a1 s++pred128 :: Int128 -> Int128+pred128 (Int128 a1 a0)+  | a1 == 0x8000000000000000 && a0 == 0 = predError "Int128"+  | otherwise =+      case a0 of+        0 -> Int128 (a1 - 1) maxBound+        _ -> Int128 a1 (a0 - 1)++{-# INLINABLE toEnum128 #-}+toEnum128 :: Int -> Int128+toEnum128 i = Int128 0 (toEnum i)++{-# INLINABLE fromEnum128 #-}+fromEnum128 :: Int128 -> Int+fromEnum128 (Int128 _ a0) = fromEnum a0++-- -----------------------------------------------------------------------------+-- Functions for `Num` instance.++{-# INLINABLE plus128 #-}+plus128 :: Int128 -> Int128 -> Int128+plus128 (Int128 (W64# a1) (W64# a0)) (Int128 (W64# b1) (W64# b0)) =+  Int128 (W64# s1) (W64# s0)+  where+    !(# c1, s0 #) = plusWord2# a0 b0+    s1a = plusWord# a1 b1+    s1 = plusWord# c1 s1a++{-# INLINABLE minus128 #-}+minus128 :: Int128 -> Int128 -> Int128+minus128 (Int128 (W64# a1) (W64# a0)) (Int128 (W64# b1) (W64# b0)) =+  Int128 (W64# d1) (W64# d0)+  where+    !(# d0, c1 #) = subWordC# a0 b0+    a1c = minusWord# a1 (int2Word# c1)+    d1 = minusWord# a1c b1++times128 :: Int128 -> Int128 -> Int128+times128 (Int128 (W64# a1) (W64# a0)) (Int128 (W64# b1) (W64# b0)) =+  Int128 (W64# p1) (W64# p0)+  where+    !(# c1, p0 #) = timesWord2# a0 b0+    p1a = timesWord# a1 b0+    p1b = timesWord# a0 b1+    p1c = plusWord# p1a p1b+    p1 = plusWord# p1c c1++{-# INLINABLE negate128 #-}+negate128 :: Int128 -> Int128+negate128 (Int128 (W64# a1) (W64# a0)) =+  case plusWord2# (not# a0) 1## of+    (# c, s #) -> Int128 (W64# (plusWord# (not# a1) c)) (W64# s)++{-# INLINABLE abs128 #-}+abs128 :: Int128 -> Int128+abs128 i@(Int128 a1 _)+  | testBit a1 63 = negate128 i+  | otherwise = i++{-# INLINABLE signum128 #-}+signum128 :: Int128 -> Int128+signum128 (Int128 a1 a0)+  | a1 == 0 && a0 == 0 = zeroInt128+  | testBit a1 63 = minusOneInt128+  | otherwise = oneInt128++{-# INLINABLE complement128 #-}+complement128 :: Int128 -> Int128+complement128 (Int128 a1 a0) = Int128 (complement a1) (complement a0)++fromInteger128 :: Integer -> Int128+fromInteger128 i =+  Int128 (fromIntegral $ i `shiftR` 64) (fromIntegral i)++-- -----------------------------------------------------------------------------+-- Functions for `Bits` instance.++{-# INLINABLE and128 #-}+and128 :: Int128 -> Int128 -> Int128+and128 (Int128 (W64# a1) (W64# a0)) (Int128 (W64# b1) (W64# b0)) =+  Int128 (W64# (and# a1 b1)) (W64# (and# a0 b0))++{-# INLINABLE or128 #-}+or128 :: Int128 -> Int128 -> Int128+or128 (Int128 (W64# a1) (W64# a0)) (Int128 (W64# b1) (W64# b0)) =+  Int128 (W64# (or# a1 b1)) (W64# (or# a0 b0))++{-# INLINABLE xor128 #-}+xor128 :: Int128 -> Int128 -> Int128+xor128 (Int128 (W64# a1) (W64# a0)) (Int128 (W64# b1) (W64# b0)) =+  Int128 (W64# (xor# a1 b1)) (W64# (xor# a0 b0))++-- Probably not worth inlining this.+shiftL128 :: Int128 -> Int -> Int128+shiftL128 w@(Int128 a1 a0) s+  | s == 0 = w+  | s < 0 = shiftL128 w (128 - (abs s `mod` 128))+  | s >= 128 = zeroInt128+  | s == 64 = Int128 a0 0+  | s > 64 = Int128 (a0 `shiftL` (s - 64)) 0+  | otherwise =+      Int128 s1 s0+      where+        s0 = a0 `shiftL` s+        s1 = a1 `shiftL` s + a0 `shiftR` (64 - s)++-- Probably not worth inlining this.+shiftR128 :: Int128 -> Int -> Int128+shiftR128 i@(Int128 a1 a0) s+  | s < 0 = zeroInt128+  | s == 0 = i+  | topBitSetWord64 a1 = complement128 (shiftR128 (complement128 i) s)+  | s >= 128 = zeroInt128+  | s == 64 = Int128 0 a1+  | s > 64 = Int128 0 (a1 `shiftR` (s - 64))+  | otherwise = Int128 s1 s0+      where+        s1 = a1 `shiftR` s+        s0 = a0 `shiftR` s + a1 `shiftL` (64 - s)++rotateL128 :: Int128 -> Int -> Int128+rotateL128 w@(Int128 a1 a0) r+  | r < 0 = zeroInt128+  | r == 0 = w+  | r >= 128 = rotateL128 w (r `mod` 128)+  | r == 64 = Int128 a0 a1+  | r > 64 = rotateL128 (Int128 a0 a1) (r `mod` 64)+  | otherwise =+      Int128 s1 s0+      where+        s0 = a0 `shiftL` r + a1 `shiftR` (64 - r)+        s1 = a1 `shiftL` r + a0 `shiftR` (64 - r)++rotateR128 :: Int128 -> Int -> Int128+rotateR128 w@(Int128 a1 a0) r+  | r < 0 = rotateR128 w (128 - (abs r `mod` 128))+  | r == 0 = w+  | r >= 128 = rotateR128 w (r `mod` 128)+  | r == 64 = Int128 a0 a1+  | r > 64 = rotateR128 (Int128 a0 a1) (r `mod` 64)+  | otherwise =+      Int128 s1 s0+      where+        s0 = a0 `shiftR` r + a1 `shiftL` (64 - r)+        s1 = a1 `shiftR` r + a0 `shiftL` (64 - r)++testBit128 :: Int128 -> Int -> Bool+testBit128 (Int128 a1 a0) i+  | i < 0 = False+  | i >= 128 = False+  | i >= 64 = testBit a1 (i - 64)+  | otherwise = testBit a0 i++bit128 :: Int -> Int128+bit128 indx+  | indx < 0 = zeroInt128+  | indx >= 128 = zeroInt128+  | otherwise = shiftL128 oneInt128 indx++popCount128 :: Int128 -> Int+popCount128 (Int128 a1 a0) = popCount a1 + popCount a0++-- -----------------------------------------------------------------------------+-- Functions for `FiniteBits` instance.++countLeadingZeros128 :: Int128 -> Int+countLeadingZeros128 (Int128 a1 a0) =+  case countLeadingZeros a1 of+    64 -> 64 +  countLeadingZeros a0+    res -> res++countTrailingZeros128 :: Int128 -> Int+countTrailingZeros128 (Int128 a1 a0) =+  case countTrailingZeros a0 of+    64 -> 64 + countTrailingZeros a1+    res -> res++-- -----------------------------------------------------------------------------+-- Functions for `Integral` instance.++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)+  | 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+++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))+  | otherwise = (word128ToInt128 wq, word128ToInt128 wr)+  where+    (wq, wr) = quotRem absNumerW absDenomW+    numerIsNegative = topBitSetWord64 $ int128Hi64 numer+    denomIsNegative = topBitSetWord64 $ int128Hi64 denom+    absNumerW = int128ToWord128 $ abs128 numer+    absDenomW = int128ToWord128 $ abs128 denom+++toInteger128 :: Int128 -> Integer+toInteger128 i@(Int128 a1 a0)+  | popCount a1 == 64 && popCount a0 == 64 = -1+  | not (testBit a1 63) = fromIntegral a1 `shiftL` 64 + fromIntegral a0+  | otherwise =+      case negate128 i of+        Int128 n1 n0 -> negate (fromIntegral n1 `shiftL` 64 + fromIntegral n0)++-- -----------------------------------------------------------------------------+-- Functions for `Integral` instance.++peek128 :: Ptr Int128 -> IO Int128+peek128 ptr =+  Int128 <$> peekElemOff (castPtr ptr) index1 <*> peekElemOff (castPtr ptr) index0++peekElemOff128 :: Ptr Int128 -> Int -> IO Int128+peekElemOff128 ptr idx =+  Int128 <$> peekElemOff (castPtr ptr) (2 * idx + index1)+            <*> peekElemOff (castPtr ptr) (2 * idx + index0)++poke128 :: Ptr Int128 -> Int128 -> IO ()+poke128 ptr (Int128 a1 a0) =+  pokeElemOff (castPtr ptr) index1 a1 >> pokeElemOff (castPtr ptr) index0 a0++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++-- -----------------------------------------------------------------------------+-- Helpers.++{-# INLINE int128ToWord128 #-}+int128ToWord128 :: Int128 -> Word128+int128ToWord128 (Int128 a1 a0) = Word128 a1 a0++{-# INLINE topBitSetWord64 #-}+topBitSetWord64 :: Word64 -> Bool+topBitSetWord64 w = testBit w 63++{-# INLINE word128ToInt128 #-}+word128ToInt128 :: Word128 -> Int128+word128ToInt128 (Word128 a1 a0) = Int128 a1 a0++-- -----------------------------------------------------------------------------+-- Constants.++zeroInt128 :: Int128+zeroInt128 = Int128 0 0++oneInt128 :: Int128+oneInt128 = Int128 0 1++minusOneInt128 :: Int128+minusOneInt128 = Int128 maxBound maxBound++index0, index1 :: Int+#if WORDS_BIGENDIAN+index0 = 1+index1 = 0+#else+index0 = 0+index1 = 1+#endif

@@ -0,0 +1,454 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE StrictData #-}+{-# LANGUAGE UnboxedTuples #-}+{-# OPTIONS_GHC -funbox-strict-fields #-}++-----------------------------------------------------------------------------+---- |+---- Module      :  Data.WideWord.Word128+----+---- Maintainer  :  erikd@mega-nerd.com+---- Stability   :  experimental+---- Portability :  non-portable (GHC extensions and primops)+----+---- This module provides an opaque unsigned 128 bit value with the usual set+---- of typeclass instances one would expect for a fixed width unsigned integer+---- type.+---- Operations like addition, subtraction and multiplication etc provide a+---- "modulo 2^128" result as one would expect from a fixed width unsigned word.+-------------------------------------------------------------------------------++#include <MachDeps.h>++module Data.WideWord.Word128+  ( Word128 (..)+  , byteSwapWord128+  , showHexWord128+  , zeroWord128+  ) where++import Control.DeepSeq (NFData (..))++import Data.Bits (Bits (..), FiniteBits (..), shiftL)++import Foreign.Ptr (Ptr, castPtr)+import Foreign.Storable (Storable (..))++import GHC.Base (Int (..), and#, int2Word#, minusWord#, not#, or#, plusWord#, plusWord2#+                , quotRemWord2#, subWordC#, timesWord#, timesWord2#, xor#)+import GHC.Enum (predError, succError)+import GHC.Real ((%), divZeroError)+import GHC.Word (Word64 (..), byteSwap64)++import Numeric (showHex)+++data Word128 = Word128+  { word128Hi64 :: {-# UNPACK #-} !Word64+  , word128Lo64 :: {-# UNPACK #-} !Word64+  }+  deriving Eq+++byteSwapWord128 :: Word128 -> Word128+byteSwapWord128 (Word128 a1 a0) = Word128 (byteSwap64 a0) (byteSwap64 a1)+++showHexWord128 :: Word128 -> String+showHexWord128 (Word128 a1 a0)+  | a1 == 0 = showHex a0 ""+  | otherwise = showHex a1 zeros ++ showHex a0 ""+  where+    h0 = showHex a0 ""+    zeros = replicate (16 - length h0) '0'++instance Show Word128 where+  show = show . toInteger128++instance Read Word128 where+  readsPrec p s = [(fromInteger128 (x :: Integer), r) | (x, r) <- readsPrec p s]++instance Ord Word128 where+  compare = compare128++instance Bounded Word128 where+  minBound = zeroWord128+  maxBound = Word128 maxBound maxBound++instance Enum Word128 where+  succ = succ128+  pred = pred128+  toEnum = toEnum128+  fromEnum = fromEnum128++instance Num Word128 where+  (+) = plus128+  (-) = minus128+  (*) = times128+  negate = negate128+  abs = id+  signum = signum128+  fromInteger = fromInteger128++instance Bits Word128 where+  (.&.) = and128+  (.|.) = or128+  xor = xor128+  complement = complement128+  shiftL = shiftL128+  unsafeShiftL = shiftL128+  shiftR = shiftR128+  unsafeShiftR = shiftR128+  rotateL = rotateL128+  rotateR = rotateR128++  bitSize _ = 128+  bitSizeMaybe _ = Just 128+  isSigned _ = False++  testBit = testBit128+  bit = bit128++  popCount = popCount128++instance FiniteBits Word128 where+  finiteBitSize _ = 128+  countLeadingZeros = countLeadingZeros128+  countTrailingZeros = countTrailingZeros128++instance Real Word128 where+  toRational x = toInteger128 x % 1++instance Integral Word128 where+  quot n d = fst (quotRem128 n d)+  rem n d = snd (quotRem128 n d)+  div n d = fst (quotRem128 n d)+  mod n d = snd (quotRem128 n d)+  quotRem = quotRem128+  divMod = quotRem128+  toInteger = toInteger128++instance Storable Word128 where+  sizeOf _ = 2 * sizeOf (0 :: Word64)+  alignment _ = 2 * alignment (0 :: Word64)+  peek = peek128+  peekElemOff = peekElemOff128+  poke = poke128+  pokeElemOff = pokeElemOff128++instance NFData Word128 where+  rnf (Word128 a1 a0) = rnf a1 `seq` rnf a0++-- -----------------------------------------------------------------------------+-- Rewrite rules.++{-# RULES+"fromIntegral :: Word128 -> Word128" fromIntegral = id :: Word128 -> Word128+  #-}++{-# RULES+"fromIntegral :: Int -> Word128"     fromIntegral = \(I# i#) -> Word128 (W64# 0##) (W64# (int2Word# i#))+"fromIntegral :: Word- > Word128"    fromIntegral = Word128 0 . fromIntegral+"fromIntegral :: Word32 -> Word128"  fromIntegral = Word128 0 . fromIntegral+"fromIntegral :: Word64 -> Word128"  fromIntegral = Word128 0++"fromIntegral :: Word128 -> Int"     fromIntegral = \(Word128 _ w) -> fromIntegral w+"fromIntegral :: Word128 -> Word"    fromIntegral = \(Word128 _ w) -> fromIntegral w+"fromIntegral :: Word128 -> Word32"  fromIntegral = \(Word128 _ w) -> fromIntegral w+"fromIntegral :: Word128 -> Word64"  fromIntegral = \(Word128 _ w) -> w+  #-}++-- -----------------------------------------------------------------------------+-- Functions for `Ord` instance.++compare128 :: Word128 -> Word128 -> Ordering+compare128 (Word128 a1 a0) (Word128 b1 b0) =+  case compare a1 b1 of+    EQ -> compare a0 b0+    LT -> LT+    GT -> GT++-- -----------------------------------------------------------------------------+-- Functions for `Enum` instance.++succ128 :: Word128 -> Word128+succ128 (Word128 a1 a0)+  | a1 == maxBound && a0 == maxBound = succError "Word128"+  | otherwise =+      case a0 + 1 of+        0 -> Word128 (a1 + 1) 0+        s -> Word128 a1 s++pred128 :: Word128 -> Word128+pred128 (Word128 a1 a0)+  | a1 == 0 && a0 == 0 = predError "Word128"+  | otherwise =+      case a0 of+        0 -> Word128 (a1 - 1) maxBound+        _ -> Word128 a1 (a0 - 1)++{-# INLINABLE toEnum128 #-}+toEnum128 :: Int -> Word128+toEnum128 i = Word128 0 (toEnum i)++{-# INLINABLE fromEnum128 #-}+fromEnum128 :: Word128 -> Int+fromEnum128 (Word128 _ a0) = fromEnum a0++-- -----------------------------------------------------------------------------+-- Functions for `Num` instance.++{-# INLINABLE plus128 #-}+plus128 :: Word128 -> Word128 -> Word128+plus128 (Word128 (W64# a1) (W64# a0)) (Word128 (W64# b1) (W64# b0)) =+  Word128 (W64# s1) (W64# s0)+  where+    !(# c1, s0 #) = plusWord2# a0 b0+    s1a = plusWord# a1 b1+    s1 = plusWord# c1 s1a++{-# INLINABLE minus128 #-}+minus128 :: Word128 -> Word128 -> Word128+minus128 (Word128 (W64# a1) (W64# a0)) (Word128 (W64# b1) (W64# b0)) =+  Word128 (W64# d1) (W64# d0)+  where+    !(# d0, c1 #) = subWordC# a0 b0+    a1c = minusWord# a1 (int2Word# c1)+    d1 = minusWord# a1c b1++times128 :: Word128 -> Word128 -> Word128+times128 (Word128 (W64# a1) (W64# a0)) (Word128 (W64# b1) (W64# b0)) =+  Word128 (W64# p1) (W64# p0)+  where+    !(# c1, p0 #) = timesWord2# a0 b0+    p1a = timesWord# a1 b0+    p1b = timesWord# a0 b1+    p1c = plusWord# p1a p1b+    p1 = plusWord# p1c c1++{-# INLINABLE negate128 #-}+negate128 :: Word128 -> Word128+negate128 (Word128 (W64# a1) (W64# a0)) =+  case plusWord2# (not# a0) 1## of+    (# c, s #) -> Word128 (W64# (plusWord# (not# a1) c)) (W64# s)++{-# INLINABLE signum128 #-}+signum128 :: Word128 -> Word128+signum128 (Word128 (W64# 0##) (W64# 0##)) = zeroWord128+signum128 _ = oneWord128++fromInteger128 :: Integer -> Word128+fromInteger128 i =+  Word128 (fromIntegral $ i `shiftR` 64) (fromIntegral i)++-- -----------------------------------------------------------------------------+-- Functions for `Bits` instance.++{-# INLINABLE and128 #-}+and128 :: Word128 -> Word128 -> Word128+and128 (Word128 (W64# a1) (W64# a0)) (Word128 (W64# b1) (W64# b0)) =+  Word128 (W64# (and# a1 b1)) (W64# (and# a0 b0))++{-# INLINABLE or128 #-}+or128 :: Word128 -> Word128 -> Word128+or128 (Word128 (W64# a1) (W64# a0)) (Word128 (W64# b1) (W64# b0)) =+  Word128 (W64# (or# a1 b1)) (W64# (or# a0 b0))++{-# INLINABLE xor128 #-}+xor128 :: Word128 -> Word128 -> Word128+xor128 (Word128 (W64# a1) (W64# a0)) (Word128 (W64# b1) (W64# b0)) =+  Word128 (W64# (xor# a1 b1)) (W64# (xor# a0 b0))++{-# INLINABLE complement128 #-}+complement128 :: Word128 -> Word128+complement128 (Word128 a1 a0) = Word128 (complement a1) (complement a0)++-- Probably not worth inlining this.+shiftL128 :: Word128 -> Int -> Word128+shiftL128 w@(Word128 a1 a0) s+  | s == 0 = w+  | s < 0 = shiftL128 w (128 - (abs s `mod` 128))+  | s >= 128 = zeroWord128+  | s == 64 = Word128 a0 0+  | s > 64 = Word128 (a0 `shiftL` (s - 64)) 0+  | otherwise =+      Word128 s1 s0+      where+        s0 = a0 `shiftL` s+        s1 = a1 `shiftL` s + a0 `shiftR` (64 - s)++-- Probably not worth inlining this.+shiftR128 :: Word128 -> Int -> Word128+shiftR128 w@(Word128 a1 a0) s+  | s < 0 = zeroWord128+  | s == 0 = w+  | s >= 128 = zeroWord128+  | s == 64 = Word128 0 a1+  | s > 64 = Word128 0 (a1 `shiftR` (s - 64))+  | otherwise =+      Word128 s1 s0+      where+        s1 = a1 `shiftR` s+        s0 = a0 `shiftR` s + a1 `shiftL` (64 - s)++rotateL128 :: Word128 -> Int -> Word128+rotateL128 w@(Word128 a1 a0) r+  | r < 0 = zeroWord128+  | r == 0 = w+  | r >= 128 = rotateL128 w (r `mod` 128)+  | r == 64 = Word128 a0 a1+  | r > 64 = rotateL128 (Word128 a0 a1) (r `mod` 64)+  | otherwise =+      Word128 s1 s0+      where+        s0 = a0 `shiftL` r + a1 `shiftR` (64 - r)+        s1 = a1 `shiftL` r + a0 `shiftR` (64 - r)++rotateR128 :: Word128 -> Int -> Word128+rotateR128 w@(Word128 a1 a0) r+  | r < 0 = rotateR128 w (128 - (abs r `mod` 128))+  | r == 0 = w+  | r >= 128 = rotateR128 w (r `mod` 128)+  | r == 64 = Word128 a0 a1+  | r > 64 = rotateR128 (Word128 a0 a1) (r `mod` 64)+  | otherwise =+      Word128 s1 s0+      where+        s0 = a0 `shiftR` r + a1 `shiftL` (64 - r)+        s1 = a1 `shiftR` r + a0 `shiftL` (64 - r)++testBit128 :: Word128 -> Int -> Bool+testBit128 (Word128 a1 a0) i+  | i < 0 = False+  | i >= 128 = False+  | i >= 64 = testBit a1 (i - 64)+  | otherwise = testBit a0 i++bit128 :: Int -> Word128+bit128 indx+  | indx < 0 = zeroWord128+  | indx >= 128 = zeroWord128+  | otherwise = shiftL128 oneWord128 indx++popCount128 :: Word128 -> Int+popCount128 (Word128 a1 a0) = popCount a1 + popCount a0++-- -----------------------------------------------------------------------------+-- Functions for `FiniteBits` instance.++countLeadingZeros128 :: Word128 -> Int+countLeadingZeros128 (Word128 a1 a0) =+  case countLeadingZeros a1 of+    64 -> 64 +  countLeadingZeros a0+    res -> res++countTrailingZeros128 :: Word128 -> Int+countTrailingZeros128 (Word128 a1 a0) =+  case countTrailingZeros a0 of+    64 -> 64 + countTrailingZeros a1+    res -> res++-- -----------------------------------------------------------------------------+-- Functions for `Integral` instance.++quotRem128 :: Word128 -> Word128 -> (Word128, Word128)+quotRem128 num@(Word128 n1 n0) den@(Word128 d1 d0)+  | n1 == 0 && d1 == 0 = quotRemTwo n0 d0+  | n1 < d1 = (zeroWord128, num)+  | d1 == 0 = quotRemThree num d0+  | otherwise = quotRemFour num den+++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))+++{-# 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+                (q, r) -> (Word128 0 q, Word128 0 r)+  | otherwise =+      case quotRem n1 den of+        (q1, r1) -> case quotRemWord2 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) =+  case quotRemWord2# n1 n0 d of+    (# q, r #) -> (W64# q, W64# r)+++{-# INLINE quotRemTwo #-}+quotRemTwo :: Word64 -> Word64 -> (Word128, Word128)+quotRemTwo n0 d0 =+  case quotRem n0 d0 of+    (q, r) -> (Word128 0 q, Word128 0 r)++toInteger128 :: Word128 -> Integer+toInteger128 (Word128 a1 a0) = fromIntegral a1 `shiftL` 64 + fromIntegral a0++-- -----------------------------------------------------------------------------+-- Functions for `Integral` instance.++peek128 :: Ptr Word128 -> IO Word128+peek128 ptr =+  Word128 <$> peekElemOff (castPtr ptr) index1 <*> peekElemOff (castPtr ptr) index0++peekElemOff128 :: Ptr Word128 -> Int -> IO Word128+peekElemOff128 ptr idx =+  Word128 <$> peekElemOff (castPtr ptr) (2 * idx + index1)+            <*> peekElemOff (castPtr ptr) (2 * idx + index0)++poke128 :: Ptr Word128 -> Word128 -> IO ()+poke128 ptr (Word128 a1 a0) =+  pokeElemOff (castPtr ptr) index1 a1 >> pokeElemOff (castPtr ptr) index0 a0++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++-- -----------------------------------------------------------------------------+-- Constants.++zeroWord128 :: Word128+zeroWord128 = Word128 0 0++oneWord128 :: Word128+oneWord128 = Word128 0 1++-- Use these indices to get the peek/poke ordering endian correct.+index0, index1 :: Int+#if WORDS_BIGENDIAN+index0 = 1+index1 = 0+#else+index0 = 0+index1 = 1+#endif

@@ -0,0 +1,50 @@+module Test.Data.WideWord.Gen where++import           Data.Int (Int8, Int16, Int32, Int64)+import           Data.WideWord+import           Data.Word (Word8, Word16, 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++genWord32 :: Gen Word32+genWord32 =+  Gen.word32 Range.constantBounded++genWord64 :: Gen Word64+genWord64 =+  Gen.word64 Range.constantBounded++genWord128 :: Gen Word128+genWord128 =+  Word128 <$> genWord64 <*> genWord64

@@ -1,178 +1,296 @@-{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-} module Test.Data.WideWord.Int128-  ( testInt128+  ( tests   ) where -import Control.Exception (evaluate)+import           Control.Exception (ArithException, evaluate, try)+import           Control.Monad.IO.Class (liftIO) -import Data.Bits ((.&.), (.|.), bit, complement, countLeadingZeros, countTrailingZeros, popCount, rotateL, rotateR, shiftL, shiftR, testBit, xor)-import Data.Int (Int16)-import Data.Word (Word32, Word64)-import Data.WideWord+import           Data.Bifunctor (bimap)+import           Data.Bits ((.&.), (.|.), bit, complement, countLeadingZeros, countTrailingZeros+                            , popCount, rotateL, rotateR, shiftL, shiftR, testBit, xor)+import           Data.Word (Word64, byteSwap64)+import           Data.WideWord -import Foreign (allocaBytes)-import Foreign.Storable (Storable (..))+import           Foreign (allocaBytes)+import           Foreign.Storable (Storable (..)) -import Test.Hspec (Spec, describe, errorCall, it, shouldBe, shouldThrow)-import Test.Hspec.QuickCheck (prop)-import Test.QuickCheck.Modifiers (NonZero (..))+import           Hedgehog (Property, (===), discover)+import qualified Hedgehog as H+import qualified Hedgehog.Gen as Gen+import qualified Hedgehog.Range as Range +import Test.Data.WideWord.Gen -testInt128 :: Spec-testInt128 = describe "Int128:" $ do-  prop "constructor and accessors" $ \ (h, l) ->-    let i128 = Int128 h l in-    (int128Hi64 i128, int128Lo64 i128) `shouldBe` (h, l) -  prop "byte swap" $ \ (h, l) ->-    let i128 = byteSwapInt128 $ byteSwapInt128 (Int128 h l) in-    (int128Hi64 i128, int128Lo64 i128) `shouldBe` (h, l)--  prop "derivied Eq instance" $ \ (a1, a0, b1, b0) ->-    (Int128 a1 a0 == Int128 b1 b0) `shouldBe` (a1 == b1 && a0 == b0)--  prop "toInteger" $ \ (a1, a0) ->-    toInteger (Int128 a1 a0) `shouldBe` mkInteger a1 a0+-- Set the number of times to run each property test here.+propertyCount :: H.PropertyT IO () -> Property+propertyCount =+  H.withTests 10000 . H.property -  prop "negate" $ \ (a1, a0) ->-    toInteger (negate (Int128 a1 a0)) `shouldBe` negate (mkInteger a1 a0)+prop_constructor_and_accessors :: Property+prop_constructor_and_accessors =+  propertyCount $ do+    (h, l) <- H.forAll $ (,) <$> genWord64 <*> genWord64+    let i128 = Int128 h l+    (int128Hi64 i128, int128Lo64 i128) === (h, l) -  prop "fromInteger" $ \ (a1, a0) -> do-    let i128 = fromInteger $ mkInteger a1 a0-    (int128Hi64 i128, int128Lo64 i128) `shouldBe` (a1, a0)+prop_byte_swap :: Property+prop_byte_swap =+  propertyCount $ do+    h <- H.forAll genWord64+    l <- H.forAll $ Gen.filter (/= h) genWord64+    let w128 = Int128 h l+        swapped = byteSwapInt128 w128+    (byteSwapInt128 swapped, byteSwap64 (fromIntegral h), byteSwap64 (fromIntegral l))+            === (w128, int128Lo64 swapped, int128Hi64 swapped) -  prop "Ord instance" $ \ (a1, a0, b1, b0) ->-    compare (Int128 a1 a0) (Int128 b1 b0) `shouldBe` compare (mkInteger a1 a0) (mkInteger b1 b0)+prop_derivied_eq_instance :: Property+prop_derivied_eq_instance =+  propertyCount $ do+    (a1, a0) <- H.forAll $ (,) <$> genWord64 <*> genWord64+    (b1, b0) <- H.forAll $ (,) <$> genWord64 <*> genWord64+    (Int128 a1 a0 == Int128 b1 b0) === (a1 == b1 && a0 == b0) -  prop "show / read" $ \ (a1, a0) ->-    toInteger (read (show $ Int128 a1 a0) :: Int128) `shouldBe` mkInteger a1 a0+prop_ord_instance :: Property+prop_ord_instance =+  propertyCount $ do+    (a, b) <- H.forAll $ (,) <$> genInt128 <*> genInt128+    compare a b === compare (toInteger128 a) (toInteger128 b) -  prop "succ" $ \ (a1, a0) -> do-    let i128 = Int128 a1 a0-    if i128 == maxBound-      then evaluate (succ i128) `shouldThrow` errorCall "Enum.succ{Int128}: tried to take `succ' of maxBound"-      else toInteger128 (succ i128) `shouldBe` succ (mkInteger a1 a0)+prop_show_instance :: Property+prop_show_instance =+  propertyCount $ do+    i128 <- H.forAll genInt128+    show i128 === show (toInteger128 i128) -  prop "pred" $ \ (a1, a0) -> do-    let i128 = Int128 a1 a0-    if i128 == minBound-      then evaluate (pred i128) `shouldThrow` errorCall "Enum.pred{Int128}: tried to take `pred' of minBound"-      else toInteger128 (pred i128) `shouldBe` pred (mkInteger a1 a0)+prop_read_instance :: Property+prop_read_instance =+  propertyCount $ do+    (a1, a0) <- H.forAll $ (,) <$> genWord64 <*> genWord64+    read (show $ Int128 a1 a0) === Int128 a1 a0 -  it "succ maxBound throws error" $-    evaluate (succ (maxBound :: Int128)) `shouldThrow` errorCall "Enum.succ{Int128}: tried to take `succ' of maxBound"+prop_succ :: Property+prop_succ =+  propertyCount $ do+    i128 <- H.forAll genInt128+    res <- liftIO . try $ evaluate (succ i128)+    bimap showArithException toInteger128 res+        === if i128 == maxBound+              then Left "Enum.succ{Int128}: tried to take `succ' of maxBound"+              else Right $ succ (toInteger128 i128) -  it "pred minBount throws error" $-    evaluate (pred (minBound :: Int128)) `shouldThrow` errorCall "Enum.pred{Int128}: tried to take `pred' of minBound"+prop_pred :: Property+prop_pred =+  propertyCount $ do+    i128 <- H.forAll genInt128+    res <- liftIO . try $ evaluate (pred i128)+    bimap showArithException toInteger128 res+        === if i128 == 0+              then Left "Enum.pred{Int128}: tried to take `pred' of minBound"+              else Right $ pred (toInteger128 i128) -  prop "toEnum / fromEnum" $ \ (a0 :: Word32) -> do+prop_toEnum_fromEnum :: Property+prop_toEnum_fromEnum =+  propertyCount $ do+    a0 <- H.forAll genWord32     let i128 = Int128 0 (fromIntegral a0)         e128 = fromEnum i128-    toInteger e128 `shouldBe` toInteger a0-    toInteger (toEnum e128 :: Int128) `shouldBe` toInteger a0+    toInteger e128 === toInteger a0+    toInteger128 (toEnum e128 :: Int128) === toInteger a0 -  prop "complement" $ \ (a1, a0) ->-    toInteger (complement $ Int128 a1 a0) `shouldBe` mkInteger (complement a1) (complement a0)+prop_addition :: Property+prop_addition =+  propertyCount $ do+    (a, b) <- H.forAll $ (,) <$> genInt128 <*> genInt128+    toInteger128 (a + b) === correctInt128 (toInteger128 a + toInteger128 b) -  prop "negate" $ \ (a1, a0) ->-    toInteger (negate (Int128 a1 a0)) `shouldBe` negate (mkInteger a1 a0)+prop_subtraction :: Property+prop_subtraction =+  propertyCount $ do+    (a, b) <- H.forAll $ (,) <$> genInt128 <*> genInt128+    let ai = toInteger128 a+        bi = toInteger128 b+        expected = ai + (1 `shiftL` 128) - bi+    toInteger128 (a - b) === correctInt128 expected -  prop "abs" $ \ (a1, a0) ->-    toInteger (abs (Int128 a1 a0)) `shouldBe` abs (mkInteger a1 a0)+prop_multiplication :: Property+prop_multiplication =+  propertyCount $ do+    (a, b) <- H.forAll $ (,) <$> genInt128 <*> genInt128+    toInteger128 (a * b) === correctInt128 (toInteger128 a * toInteger128 b) -  prop "signum" $ \ (a1, a0) ->-    toInteger (signum $ Int128 a1 a0) `shouldBe` signum (mkInteger a1 a0)+prop_negate :: Property+prop_negate =+  propertyCount $ do+    i128 <- H.forAll genInt128+    toInteger128 (negate i128) === correctInt128 (negate $ toInteger128 i128) -  prop "logical and/or/xor" $ \ (a1, a0, b1, b0) -> do-    toInteger (Int128 a1 a0 .&. Int128 b1 b0) `shouldBe` (mkInteger a1 a0 .&. mkInteger b1 b0)-    toInteger (Int128 a1 a0 .|. Int128 b1 b0) `shouldBe` (mkInteger a1 a0 .|. mkInteger b1 b0)-    toInteger (xor (Int128 a1 a0) (Int128 b1 b0)) `shouldBe` xor (mkInteger a1 a0) (mkInteger b1 b0)+prop_abs :: Property+prop_abs =+  propertyCount $ do+    i128 <- H.forAll genInt128+    toInteger128 (abs i128) === correctInt128 (abs $ toInteger128 i128) -  prop "testBit" $ \ (a1, a0) (b :: Int16) -> do-    let idx = fromIntegral b-        expected+prop_signum :: Property+prop_signum =+  propertyCount $ do+    i128 <- H.forAll genInt128+    toInteger128 (signum i128) === signum (toInteger128 i128)++prop_fromInteger :: Property+prop_fromInteger =+  propertyCount $ do+    (a1, a0) <- H.forAll $ (,) <$> genWord64 <*> genWord64+    let i128 = fromInteger $ mkInteger a1 a0+    (int128Hi64 i128, int128Lo64 i128) === (a1, a0)++prop_bitwise_and :: Property+prop_bitwise_and =+  propertyCount $ do+    (a, b) <- H.forAll $ (,) <$> genInt128 <*> genInt128+    toInteger128 (a .&. b) === (toInteger128 a .&. toInteger128 b)++prop_bitwise_or :: Property+prop_bitwise_or =+  propertyCount $ do+    (a, b) <- H.forAll $ (,) <$> genInt128 <*> genInt128+    toInteger128 (a .|. b) === (toInteger128 a .|. toInteger128 b)++prop_bitwise_xor :: Property+prop_bitwise_xor =+  propertyCount $ do+    (a, b) <- H.forAll $ (,) <$> genInt128 <*> genInt128+    toInteger128 (xor a b) === xor (toInteger128 a) (toInteger128 b)++prop_complement :: Property+prop_complement =+  propertyCount $ do+    i128 <- H.forAll genWord128+    H.assert $ complement i128 /= i128+    complement (complement i128) === i128++prop_logical_shift_left :: Property+prop_logical_shift_left =+  propertyCount $ do+    i128 <- H.forAll genInt128+    shift <- H.forAll $ Gen.int (Range.linear 0 130)+    toInteger128 (shiftL i128 shift) === correctInt128 (shiftL (toInteger128 i128) shift)++prop_logical_shift_right :: Property+prop_logical_shift_right =+  propertyCount $ do+    i128 <- H.forAll genInt128+    shift <- H.forAll $ Gen.int (Range.linear 0 130)+    toInteger128 (shiftR i128 shift) === shiftR (toInteger128 i128) shift++prop_logical_rotate_left :: Property+prop_logical_rotate_left =+  propertyCount $ do+    (a1, a0) <- H.forAll $ (,) <$> genWord64 <*> genWord64+    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+    rot <- H.forAll $ Gen.int (Range.linearFrom 0 (-20000) 20000)+    toInteger (rotateR (Int128 a1 a0) rot) === correctInt128 (toInteger $ rotateR (Word128 a1 a0) rot)++prop_testBit :: Property+prop_testBit =+  propertyCount $ do+    i128 <- H.forAll genInt128+    idx <- H.forAll $ Gen.int (Range.linearFrom 0 (-200) 200)+    let expected           | idx < 0 = False           | idx >= 128 = False-          | otherwise = testBit (mkInteger a1 a0) idx-    testBit (Int128 a1 a0) idx `shouldBe` expected+          | otherwise = testBit (toInteger128 i128) idx+    testBit i128 idx === expected -  prop "bit" $ \ (b :: Int16) -> do+prop_bit :: Property+prop_bit =+  propertyCount $ do+    b <- H.forAll $ Gen.int (Range.linearFrom 0 (-200) 200)     let idx = fromIntegral b         expected           | idx < 0 = 0           | idx >= 128 = 0           | idx == 127 = toInteger128 (minBound :: Int128)           | otherwise = bit idx-    toInteger (bit idx :: Int128) `shouldBe` expected+    toInteger128 (bit idx :: Int128) === expected -  prop "popCount" $ \ (a1, a0) ->-    popCount (Int128 a1 a0) `shouldBe` popCount a1 + popCount a0+prop_popCount :: Property+prop_popCount =+  propertyCount $ do+    (a1, a0) <- H.forAll $ (,) <$> genWord64 <*> genWord64+    popCount (Int128 a1 a0) === popCount a1 + popCount a0 -  prop "countLeadingZeros" $ \ (a1, a0) -> do+prop_countLeadingZeros :: Property+prop_countLeadingZeros =+  propertyCount $ do+    (a1, a0) <- H.forAll $ (,) <$> genWord64 <*> genWord64     let expected = if a1 == 0                     then 64 + countLeadingZeros a0                     else countLeadingZeros a1-    countLeadingZeros (Int128 a1 a0) `shouldBe` expected+    countLeadingZeros (Int128 a1 a0) === expected -  prop "countTrailingZeros" $ \ (a1, a0) -> do+prop_countTrailingZeros :: Property+prop_countTrailingZeros =+  propertyCount $ do+    (a1, a0) <- H.forAll $ (,) <$> genWord64 <*> genWord64     let expected = if a0 == 0                     then 64 + countTrailingZeros a1                     else countTrailingZeros a0-    countTrailingZeros (Int128 a1 a0) `shouldBe` expected---  prop "addition" $ \ (a1, a0, b1, b0) ->-    toInteger (Int128 a1 a0 + Int128 b1 b0) `shouldBe` correctInt128 (mkInteger a1 a0 + mkInteger b1 b0)--  prop "subtraction" $ \ (a1, a0, b1, b0) ->-    toInteger (Int128 a1 a0 - Int128 b1 b0) `shouldBe` correctInt128 (mkInteger a1 a0 - mkInteger b1 b0)--  prop "multiplication" $ \ (a1, a0, b1, b0) ->-    toInteger (Int128 a1 a0 * Int128 b1 b0) `shouldBe` correctInt128 (mkInteger a1 a0 * mkInteger b1 b0)--  prop "logical shiftL" $ \ (a1, a0) shift ->-    let safeShift = if shift < 0 then 128 - (abs shift `mod` 128) else shift in-    toInteger (shiftL (Int128 a1 a0) shift) `shouldBe` correctInt128 (shiftL (mkInteger a1 a0) safeShift)--  prop "logical shiftR" $ \ (a1, a0) shift ->-    let expected = if shift < 0 then 0 else correctInt128 (shiftR (mkInteger a1 a0) shift) in-    toInteger (shiftR (Int128 a1 a0) shift) `shouldBe` expected--  -- Use `Int16` here to force a uniform distribution across the `Int16` range-  -- (standard QuickCkeck generator for `Int` doesn't give an even distribution).-  prop "logical rotateL" $ \ (a1, a0) (r :: Int16) -> do-    let rot = fromIntegral r-    toInteger (rotateL (Int128 a1 a0) rot) `shouldBe` correctInt128 (toInteger $ rotateL (Word128 a1 a0) rot)--  prop "logical rotateR" $ \ (a1, a0) (r :: Int16) -> do-    let rot = fromIntegral r-    toInteger (rotateR (Int128 a1 a0) rot) `shouldBe` correctInt128 (toInteger $ rotateR (Word128 a1 a0) rot)+    countTrailingZeros (Int128 a1 a0) === expected -  prop "quotRem" $ \ (a1, a0, NonZero b1, b0) -> do-    let (aq128, ar128) = quotRem (Int128 a1 a0) (Int128 b1 b0)-    (toInteger aq128, toInteger ar128) `shouldBe` quotRem (mkInteger a1 a0) (mkInteger b1 b0)+-- Don't need to test `quot` or `rem` because they are implemented by applying+-- `fst` or `snd` to the output of `quotRem`.+prop_quotRem :: Property+prop_quotRem =+  propertyCount $ do+    num <- H.forAll genInt128+    den <- H.forAll $ Gen.filter (/= 0) genInt128+    let (q, r) = quotRem num den+    (toInteger128 q, toInteger128 r) === quotRem (toInteger128 num) (toInteger128 den) -  prop "divMod" $ \ (a1, a0, NonZero b1, b0) -> do-    let (aq128, ar128) = divMod (Int128 a1 a0) (Int128 b1 b0)-    (toInteger aq128, toInteger ar128) `shouldBe` divMod (mkInteger a1 a0) (mkInteger b1 b0)+prop_divMod :: Property+prop_divMod =+  propertyCount $ do+    num <- H.forAll genInt128+    den <- H.forAll $ Gen.filter (/= 0) genInt128+    let (d, m) = divMod num den+    (toInteger128 d, toInteger128 m) === divMod (toInteger128 num) (toInteger128 den) -  prop "peek / poke" $ \ (a1, a0) -> do-    ar <- allocaBytes (sizeOf zeroInt128) $ \ ptr -> do-                    poke ptr $ Int128 a1 a0-                    peek ptr-    toInteger128 ar `shouldBe` mkInteger a1 a0+prop_peek_and_poke :: Property+prop_peek_and_poke =+  propertyCount $ do+    i128 <- H.forAll genInt128+    ar <- liftIO $+            allocaBytes (sizeOf zeroInt128) $ \ ptr -> do+              poke ptr i128+              peek ptr+    toInteger128 ar === toInteger128 i128 -  prop "peekElemOff / pokeElemOff" $ \ (a1, a0, b1, b0) -> do-    (ar, br) <- allocaBytes (2 * sizeOf zeroInt128) $ \ ptr -> do-                    pokeElemOff ptr 0 $ Int128 a1 a0-                    pokeElemOff ptr 1 $ Int128 b1 b0+prop_peekElemOff_pokeElemOff :: Property+prop_peekElemOff_pokeElemOff =+  propertyCount $ do+    a128 <- H.forAll genInt128+    b128 <- H.forAll genInt128+    (ar, br) <- liftIO $+                  allocaBytes (2 * sizeOf zeroInt128) $ \ ptr -> do+                    pokeElemOff ptr 0 a128+                    pokeElemOff ptr 1 b128                     (,) <$> peekElemOff ptr 0 <*>  peekElemOff ptr 1-    (toInteger128 ar, toInteger128 br) `shouldBe` (mkInteger a1 a0, mkInteger b1 b0)-+    (toInteger128 ar, toInteger128 br) === (toInteger128 a128, toInteger128 b128)   -- ----------------------------------------------------------------------------- +mkInteger :: Word64 -> Word64 -> Integer+mkInteger a1 a0 = fromIntegral a1 `shiftL` 64 + fromIntegral a0+ -- Convert an `Integer` to the `Integer` with the same bit pattern as the -- corresponding `Int128`. correctInt128 :: Integer -> Integer@@ -183,11 +301,14 @@     minBoundInt128 = fromIntegral (minBound :: Int128)     maxBoundInt128 = fromIntegral (maxBound :: Int128) -mkInteger :: Word64 -> Word64 -> Integer-mkInteger a1 a0-  | testBit a1 63 = negate (fromIntegral (complement a1) `shiftL` 64 + fromIntegral (complement a0) + 1)-  | otherwise = fromIntegral a1 `shiftL` 64 + fromIntegral a0-- toInteger128 :: Int128 -> Integer toInteger128 = toInteger++showArithException :: ArithException -> String+showArithException = show++-- -----------------------------------------------------------------------------++tests :: IO Bool+tests =+  H.checkParallel $$discover

@@ -1,113 +1,200 @@-{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-} module Test.Data.WideWord.Word128-  ( testWord128+  ( tests   ) where -import Control.Exception (evaluate)+import           Control.Exception (ArithException, evaluate, try)+import           Control.Monad.IO.Class (liftIO) -import Data.Bits ((.&.), (.|.), bit, complement, countLeadingZeros, countTrailingZeros, popCount, rotateL, rotateR, shiftL, shiftR, testBit, xor)-import Data.Int (Int16)-import Data.Word (Word32, Word64)-import Data.WideWord+import           Data.Bifunctor (bimap)+import           Data.Bits ((.&.), (.|.), bit, complement, countLeadingZeros, countTrailingZeros+                            , popCount, rotateL, rotateR, shiftL, shiftR, testBit, xor)+import           Data.Word (Word64, byteSwap64)+import           Data.WideWord -import Foreign (allocaBytes)-import Foreign.Storable (Storable (..))+import           Foreign (allocaBytes)+import           Foreign.Storable (Storable (..)) -import Test.Hspec (Spec, describe, errorCall, it, shouldBe, shouldThrow)-import Test.Hspec.QuickCheck (prop)-import Test.QuickCheck.Modifiers (NonZero (..))+import           Hedgehog (Property, (===), discover)+import qualified Hedgehog as H+import qualified Hedgehog.Gen as Gen+import qualified Hedgehog.Range as Range +import Test.Data.WideWord.Gen -testWord128 :: Spec-testWord128 = describe "Word128:" $ do-  prop "constructor and accessors" $ \ (h, l) ->-    let w128 = Word128 h l in-    (word128Hi64 w128, word128Lo64 w128) `shouldBe` (h, l) -  prop "byte swap" $ \ (h, l) ->-    let w128 = byteSwapWord128 $ byteSwapWord128 (Word128 h l) in-    (word128Hi64 w128, word128Lo64 w128) `shouldBe` (h, l)+-- Set the number of times to run each property test here.+propertyCount :: H.PropertyT IO () -> Property+propertyCount =+  H.withTests 10000 . H.property -  prop "derivied Eq instance" $ \ (a1, a0, b1, b0) ->-    (Word128 a1 a0 == Word128 b1 b0) `shouldBe` (a1 == b1 && a0 == b0)+prop_constructor_and_accessors :: Property+prop_constructor_and_accessors =+  propertyCount $ do+    (h, l) <- H.forAll $ (,) <$> genWord64 <*> genWord64+    let w128 = Word128 h l+    (word128Hi64 w128, word128Lo64 w128) === (h, l) -  prop "Ord instance" $ \ (a1, a0, b1, b0) ->-    compare (Word128 a1 a0) (Word128 b1 b0) `shouldBe` compare (mkInteger a1 a0) (mkInteger b1 b0)+prop_byte_swap :: Property+prop_byte_swap =+  propertyCount $ do+    h <- H.forAll genWord64+    l <- H.forAll $ Gen.filter (/= h) genWord64+    let w128 = Word128 h l+        swapped = byteSwapWord128 w128+    (byteSwapWord128 swapped, byteSwap64 h, byteSwap64 l)+            === (w128, word128Lo64 swapped, word128Hi64 swapped) -  prop "show" $ \ (a1, a0) ->-    show (Word128 a1 a0) `shouldBe` show (mkInteger a1 a0)+prop_derivied_eq_instance :: Property+prop_derivied_eq_instance =+  propertyCount $ do+    (a1, a0) <- H.forAll $ (,) <$> genWord64 <*> genWord64+    (b1, b0) <- H.forAll $ (,) <$> genWord64 <*> genWord64+    (Word128 a1 a0 == Word128 b1 b0) === (a1 == b1 && a0 == b0) -  prop "read" $ \ (a1, a0) ->-    read (show $ Word128 a1 a0) `shouldBe` Word128 a1 a0+prop_ord_instance :: Property+prop_ord_instance =+  propertyCount $ do+    (a, b) <- H.forAll $ (,) <$> genWord128 <*> genWord128+    compare a b === compare (toInteger128 a) (toInteger128 b) -  prop "succ" $ \ (a1, a0) ->-    if a1 == maxBound && a0 == maxBound-      then evaluate (succ $ Word128 a1 a0) `shouldThrow` errorCall "Enum.succ{Word128}: tried to take `succ' of maxBound"-      else toInteger128 (succ $ Word128 a1 a0) `shouldBe` succ (mkInteger a1 a0)+prop_show_instance :: Property+prop_show_instance =+  propertyCount $ do+    w128 <- H.forAll genWord128+    show w128 === show (toInteger128 w128) -  prop "pred" $ \ (a1, a0) ->-    if a1 == 0 && a0 == 0-      then evaluate (pred $ Word128 a1 a0) `shouldThrow` errorCall "Enum.pred{Word128}: tried to take `pred' of minBound"-      else toInteger128 (pred $ Word128 a1 a0) `shouldBe` pred (mkInteger a1 a0)+prop_read_instance :: Property+prop_read_instance =+  propertyCount $ do+    (a1, a0) <- H.forAll $ (,) <$> genWord64 <*> genWord64+    read (show $ Word128 a1 a0) === Word128 a1 a0 -  it "succ maxBound throws error" $-    evaluate (succ $ Word128 maxBound maxBound) `shouldThrow` errorCall "Enum.succ{Word128}: tried to take `succ' of maxBound"+prop_read_show :: Property+prop_read_show =+  propertyCount $ do+    (a1, a0) <- H.forAll $ (,) <$> genWord64 <*> genWord64+    H.tripping (Word128 a1 a0) show (Just . read) -  it "pred minBount throws error" $-    evaluate (pred $ Word128 0 0) `shouldThrow` errorCall "Enum.pred{Word128}: tried to take `pred' of minBound"+prop_succ :: Property+prop_succ =+  propertyCount $ do+    w128 <- H.forAll genWord128+    res <- liftIO . try $ evaluate (succ w128)+    bimap showArithException toInteger128 res+        === if w128 == maxBound+              then Left "Enum.succ{Word128}: tried to take `succ' of maxBound"+              else Right $ succ (toInteger128 w128) -  prop "toEnum / fromEnum" $ \ (a0 :: Word32) -> do+prop_pred :: Property+prop_pred =+  propertyCount $ do+    w128 <- H.forAll genWord128+    res <- liftIO . try $ evaluate (pred w128)+    bimap showArithException toInteger128 res+        === if w128 == 0+              then Left "Enum.pred{Word128}: tried to take `pred' of minBound"+              else Right $ pred (toInteger128 w128)++prop_toEnum_fromEnum :: Property+prop_toEnum_fromEnum =+  propertyCount $ do+    a0 <- H.forAll genWord32     let w128 = Word128 0 (fromIntegral a0)         e128 = fromEnum w128-    toInteger e128 `shouldBe` toInteger a0-    toInteger128 (toEnum e128 :: Word128) `shouldBe` toInteger a0+    toInteger e128 === toInteger a0+    toInteger128 (toEnum e128 :: Word128) === toInteger a0 -  prop "addition" $ \ (a1, a0, b1, b0) ->-    toInteger128 (Word128 a1 a0 + Word128 b1 b0) `shouldBe` correctWord128 (mkInteger a1 a0 + mkInteger b1 b0)+prop_addition :: Property+prop_addition =+  propertyCount $ do+    (a, b) <- H.forAll $ (,) <$> genWord128 <*> genWord128+    toInteger128 (a + b) === correctWord128 (toInteger128 a + toInteger128 b) -  prop "subtraction" $ \ (a1, a0, b1, b0) -> do-    let ai = mkInteger a1 a0-        bi = mkInteger b1 b0+prop_subtraction :: Property+prop_subtraction =+  propertyCount $ do+    (a, b) <- H.forAll $ (,) <$> genWord128 <*> genWord128+    let ai = toInteger128 a+        bi = toInteger128 b         expected = ai + (1 `shiftL` 128) - bi-    toInteger128 (Word128 a1 a0 - Word128 b1 b0) `shouldBe` correctWord128 expected+    toInteger128 (a - b) === correctWord128 expected -  prop "multiplication" $ \ (a1, a0, b1, b0) ->-    toInteger128 (Word128 a1 a0 * Word128 b1 b0) `shouldBe` correctWord128 (mkInteger a1 a0 * mkInteger b1 b0)+prop_multiplication :: Property+prop_multiplication =+  propertyCount $ do+    (a, b) <- H.forAll $ (,) <$> genWord128 <*> genWord128+    toInteger128 (a * b) === correctWord128 (toInteger128 a * toInteger128 b) -  prop "negate" $ \ (a1, a0) ->-    toInteger128 (negate (Word128 a1 a0)) `shouldBe` correctWord128 (negate $ mkInteger a1 a0)+prop_negate :: Property+prop_negate =+  propertyCount $ do+    w128 <- H.forAll genWord128+    toInteger128 (negate w128) === correctWord128 (negate $ toInteger128 w128) -  prop "abs" $ \ (a1, a0) ->-    toInteger128 (abs (Word128 a1 a0)) `shouldBe` correctWord128 (abs $ mkInteger a1 a0)+prop_abs :: Property+prop_abs =+  propertyCount $ do+    w128 <- H.forAll genWord128+    toInteger128 (abs w128) === correctWord128 (abs $ toInteger128 w128) -  prop "signum" $ \ (a1, a0) ->-    toInteger128 (signum $ Word128 a1 a0) `shouldBe` signum (mkInteger a1 a0)+prop_signum :: Property+prop_signum =+  propertyCount $ do+    w128 <- H.forAll genWord128+    toInteger128 (signum w128) === signum (toInteger128 w128) -  prop "fromInteger" $ \ (a1, a0) -> do+prop_fromInteger :: Property+prop_fromInteger =+  propertyCount $ do+    (a1, a0) <- H.forAll $ (,) <$> genWord64 <*> genWord64     let w128 = fromInteger $ mkInteger a1 a0-    (word128Hi64 w128, word128Lo64 w128) `shouldBe` (a1, a0)+    (word128Hi64 w128, word128Lo64 w128) === (a1, a0) -  prop "logical and/or/xor" $ \ (a1, a0, b1, b0) -> do-    toInteger128 (Word128 a1 a0 .&. Word128 b1 b0) `shouldBe` (mkInteger a1 a0 .&. mkInteger b1 b0)-    toInteger128 (Word128 a1 a0 .|. Word128 b1 b0) `shouldBe` (mkInteger a1 a0 .|. mkInteger b1 b0)-    toInteger128 (xor (Word128 a1 a0) (Word128 b1 b0)) `shouldBe` xor (mkInteger a1 a0) (mkInteger b1 b0)+prop_bitwise_and :: Property+prop_bitwise_and =+  propertyCount $ do+    (a, b) <- H.forAll $ (,) <$> genWord128 <*> genWord128+    toInteger128 (a .&. b) === (toInteger128 a .&. toInteger128 b) -  prop "complement" $ \ (a1, a0) ->-    toInteger128 (complement $ Word128 a1 a0) `shouldBe` mkInteger (complement a1) (complement a0)+prop_bitwise_or :: Property+prop_bitwise_or =+  propertyCount $ do+    (a, b) <- H.forAll $ (,) <$> genWord128 <*> genWord128+    toInteger128 (a .|. b) === (toInteger128 a .|. toInteger128 b) -  prop "logical shiftL" $ \ (a1, a0) shift ->-    let safeShift = if shift < 0 then 128 - (abs shift `mod` 128) else shift in-    toInteger128 (shiftL (Word128 a1 a0) shift) `shouldBe` correctWord128 (shiftL (mkInteger a1 a0) safeShift)+prop_bitwise_xor :: Property+prop_bitwise_xor =+  propertyCount $ do+    (a, b) <- H.forAll $ (,) <$> genWord128 <*> genWord128+    toInteger128 (xor a b) === xor (toInteger128 a) (toInteger128 b) -  prop "logical shiftR" $ \ (a1, a0) shift ->-    let expected = if shift < 0 then 0 else correctWord128 (shiftR (mkInteger a1 a0) shift) in-    toInteger128 (shiftR (Word128 a1 a0) shift) `shouldBe` expected+prop_complement :: Property+prop_complement =+  propertyCount $ do+    (a1, a0) <- H.forAll $ (,) <$> genWord64 <*> genWord64+    toInteger128 (complement $ Word128 a1 a0) === mkInteger (complement a1) (complement a0) -  -- Use `Int16` here to force a uniform distribution across the `Int16` range-  -- (standard QuickCkeck generator for `Int` doesn't give an even distribution).-  prop "logical rotateL" $ \ (a1, a0) (r :: Int16) -> do-    let rot = fromIntegral r-        i128 = mkInteger a1 a0+prop_logical_shift_left :: Property+prop_logical_shift_left =+  propertyCount $ do+    w128 <- H.forAll genWord128+    shift <- H.forAll $ Gen.int (Range.linear 0 130)+    toInteger128 (shiftL w128 shift) === correctWord128 (shiftL (toInteger128 w128) shift)++prop_logical_shift_right :: Property+prop_logical_shift_right =+  propertyCount $ do+    w128 <- H.forAll genWord128+    shift <- H.forAll $ Gen.int (Range.linear 0 130)+    toInteger128 (shiftR w128 shift) === shiftR (toInteger128 w128) shift++prop_logical_rotate_left :: Property+prop_logical_rotate_left =+  propertyCount $ do+    w128 <- H.forAll genWord128+    rot <- H.forAll $ Gen.int (Range.linearFrom 0 (-20000) 20000)+    let i128 = toInteger128 w128         expected           | rot < 0 = 0           | otherwise =@@ -116,81 +203,107 @@                 erot                   | rot < 0 = 128 - (abs rot `mod` 128)                   | otherwise = rot `mod` 128-    toInteger128 (rotateL (Word128 a1 a0) rot) `shouldBe` expected+    toInteger128 (rotateL w128 rot) === expected -  prop "logical rotateR" $ \ (a1, a0) (r :: Int16) -> do-    let rot = fromIntegral r-        i128 = mkInteger a1 a0+prop_logical_rotate_right :: Property+prop_logical_rotate_right =+  propertyCount $ do+    w128 <- H.forAll genWord128+    rot <- H.forAll $ Gen.int (Range.linearFrom 0 (-20000) 20000)+    let i128 = toInteger128 w128         expected =           correctWord128 $ i128 `shiftR` erot + i128 `shiftL` (128 - erot)           where             erot               | rot < 0 = 128 - (abs rot `mod` 128)               | otherwise = rot `mod` 128-    toInteger128 (rotateR (Word128 a1 a0) rot) `shouldBe` expected+    toInteger128 (rotateR w128 rot) === expected -  prop "testBit" $ \ (a1, a0) (b :: Int16) -> do-    let idx = fromIntegral b-        expected+prop_testBit :: Property+prop_testBit =+  propertyCount $ do+    w128 <- H.forAll genWord128+    idx <- H.forAll $ Gen.int (Range.linearFrom 0 (-200) 200)+    let expected           | idx < 0 = False           | idx >= 128 = False-          | otherwise = testBit (mkInteger a1 a0) idx-    testBit (Word128 a1 a0) idx `shouldBe` expected+          | otherwise = testBit (toInteger128 w128) idx+    testBit w128 idx === expected -  prop "bit" $ \ (b :: Int16) -> do+prop_bit :: Property+prop_bit =+  propertyCount $ do+    b <- H.forAll $ Gen.int (Range.linearFrom 0 (-200) 200)     let idx = fromIntegral b         expected           | idx < 0 = 0           | idx >= 128 = 0           | otherwise = bit idx-    toInteger128 (bit idx :: Word128) `shouldBe` expected+    toInteger128 (bit idx :: Word128) === expected -  prop "popCount" $ \ (a1, a0) ->-    popCount (Word128 a1 a0) `shouldBe` popCount (mkInteger a1 a0)+prop_popCount :: Property+prop_popCount =+  propertyCount $ do+    w128 <- H.forAll genWord128+    popCount w128 === popCount (toInteger128 w128) -  prop "countLeadingZeros" $ \ (a1, a0) -> do+prop_countLeadingZeros :: Property+prop_countLeadingZeros =+  propertyCount $ do+    (a1, a0) <- H.forAll $ (,) <$> genWord64 <*> genWord64     let expected = if a1 == 0                     then 64 + countLeadingZeros a0                     else countLeadingZeros a1-    countLeadingZeros (Word128 a1 a0) `shouldBe` expected+    countLeadingZeros (Word128 a1 a0) === expected -  prop "countTrailingZeros" $ \ (a1, a0) -> do+prop_countTrailingZeros :: Property+prop_countTrailingZeros =+  propertyCount $ do+    (a1, a0) <- H.forAll $ (,) <$> genWord64 <*> genWord64     let expected = if a0 == 0                     then 64 + countTrailingZeros a1                     else countTrailingZeros a0-    countTrailingZeros (Word128 a1 a0) `shouldBe` expected--  prop "quotRem (both upper words zero)" $ \ (a0, NonZero b0) -> do-    let (aq128, ar128) = quotRem (Word128 0 a0) (Word128 0 b0)-    (toInteger128 aq128, toInteger128 ar128) `shouldBe` quotRem (mkInteger 0 a0) (mkInteger 0 b0)--  prop "quotRem (denominator upper word zero)" $ \ (NonZero a1, a0, NonZero b0) -> do-    let (aq128, ar128) = quotRem (Word128 a1 a0) (Word128 0 b0)-    (toInteger128 aq128, toInteger128 ar128) `shouldBe` quotRem (mkInteger a1 a0) (mkInteger 0 b0)+    countTrailingZeros (Word128 a1 a0) === expected -  -- Don't need to test `quot` or `rem` because they are implemented by applying-  -- `fst` or `snd` to the output of `quotRem`.-  prop "quotRem (full)" $ \ (a1, a0, NonZero b1, b0) -> do-    let (aq128, ar128) = quotRem (Word128 a1 a0) (Word128 b1 b0)-    (toInteger128 aq128, toInteger128 ar128) `shouldBe` quotRem (mkInteger a1 a0) (mkInteger b1 b0)+-- Don't need to test `quot` or `rem` because they are implemented by applying+-- `fst` or `snd` to the output of `quotRem`.+prop_quotRem :: Property+prop_quotRem =+  propertyCount $ do+    num <- H.forAll genWord128+    den <- H.forAll $ Gen.filter (/= 0) genWord128+    let (q, r) = quotRem num den+    (toInteger128 q, toInteger128 r) === quotRem (toInteger128 num) (toInteger128 den) -  -- For unsigned values `quotRem` and `divMod` should give the same results.-  prop "divMod (full)" $ \ (a1, a0, NonZero b1, b0) -> do-    let (aq128, ar128) = divMod (Word128 a1 a0) (Word128 b1 b0)-    (toInteger128 aq128, toInteger128 ar128) `shouldBe` divMod (mkInteger a1 a0) (mkInteger b1 b0)+prop_divMod :: Property+prop_divMod =+  propertyCount $ do+    num <- H.forAll genWord128+    den <- H.forAll $ Gen.filter (/= 0) genWord128+    let (d, m) = divMod num den+    (toInteger128 d, toInteger128 m) === divMod (toInteger128 num) (toInteger128 den) -  prop "peek / poke" $ \ (a1, a0) -> do-    ar <- allocaBytes (sizeOf zeroWord128) $ \ ptr -> do-                    poke ptr $ Word128 a1 a0-                    peek ptr-    toInteger128 ar `shouldBe` mkInteger a1 a0+prop_peek_and_poke :: Property+prop_peek_and_poke =+  propertyCount $ do+    w128 <- H.forAll genWord128+    ar <- liftIO $+            allocaBytes (sizeOf zeroWord128) $ \ ptr -> do+              poke ptr w128+              peek ptr+    toInteger128 ar === toInteger128 w128 -  prop "peekElemOff / pokeElemOff" $ \ (a1, a0, b1, b0) -> do-    (ar, br) <- allocaBytes (2 * sizeOf zeroWord128) $ \ ptr -> do-                    pokeElemOff ptr 0 $ Word128 a1 a0-                    pokeElemOff ptr 1 $ Word128 b1 b0+prop_peekElemOff_pokeElemOff :: Property+prop_peekElemOff_pokeElemOff =+  propertyCount $ do+    a128 <- H.forAll genWord128+    b128 <- H.forAll genWord128+    (ar, br) <- liftIO $+                  allocaBytes (2 * sizeOf zeroWord128) $ \ ptr -> do+                    pokeElemOff ptr 0 a128+                    pokeElemOff ptr 1 b128                     (,) <$> peekElemOff ptr 0 <*>  peekElemOff ptr 1-    (toInteger128 ar, toInteger128 br) `shouldBe` (mkInteger a1 a0, mkInteger b1 b0)+    (toInteger128 ar, toInteger128 br) === (toInteger128 a128, toInteger128 b128)  -- ----------------------------------------------------------------------------- @@ -206,3 +319,12 @@  toInteger128 :: Word128 -> Integer toInteger128 = toInteger++showArithException :: ArithException -> String+showArithException = show++-- -----------------------------------------------------------------------------++tests :: IO Bool+tests =+  H.checkParallel $$discover

@@ -1,26 +1,18 @@-import Control.Monad (when)--import Test.Data.WideWord.Int128-import Test.Data.WideWord.Word128--import Test.Hspec (Spec)-import Test.Hspec.Runner (configQuickCheckMaxSuccess, defaultConfig, hspecWithResult, summaryFailures)--import System.Exit (exitFailure, exitSuccess)+import           Control.Monad (unless) +import           System.Exit (exitFailure) +import qualified Test.Data.WideWord.Int128+import qualified Test.Data.WideWord.Word128  main :: IO ()-main = do-  summary <- hspecWithResult config testAll-  when (summaryFailures summary == 0)-    exitSuccess-  exitFailure-  where-    config = defaultConfig { configQuickCheckMaxSuccess = Just 100000 }--testAll :: Spec-testAll = do-  testWord128-  testInt128+main = runTests+  [ Test.Data.WideWord.Int128.tests+  , Test.Data.WideWord.Word128.tests+  ] +runTests :: [IO Bool] -> IO ()+runTests tests = do+  result <- and <$> sequence tests+  unless result+    exitFailure

@@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/  name:                wide-word-version:             0.1.0.6+version:             0.1.0.7 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@@ -28,12 +28,12 @@ library   default-language:   Haskell2010   ghc-options:        -Wall -fwarn-tabs-  hs-source-dirs:    .-  other-extensions:  StrictData+  hs-source-dirs:     src+  other-extensions:   StrictData    exposed-modules:     Data.WideWord-                     , Data.WideWord.Word128-                     , Data.WideWord.Int128+                       Data.WideWord.Word128+                       Data.WideWord.Int128    build-depends:       base                          >= 4.8         && < 5.0                      , deepseq                       >= 1.3         && < 1.5@@ -47,12 +47,12 @@   main-is:            test.hs   hs-source-dirs:     test -  other-modules:      Test.Data.WideWord.Int128-                    , Test.Data.WideWord.Word128+  other-modules:      Test.Data.WideWord.Gen+                      Test.Data.WideWord.Int128+                      Test.Data.WideWord.Word128    build-depends:       base                          >= 4.8         && < 5.0                      , bytestring                    >= 0.10                      , ghc-prim-                     , hspec                         >= 2.3         && < 2.6-                     , QuickCheck                    >= 2.9+                     , hedgehog                      == 0.6.*                      , wide-word