diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2011-2013 Mikhail Vorozhtsov +Copyright (c) 2011-2014 Mikhail Vorozhtsov All rights reserved. Redistribution and use in source and binary forms, with or without diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,12 @@ +Data-DWord +========== +This package provides Template Haskell utilities for declaring fixed-length +binary word data types. Signed and unsigned 96, 128, 160, 192, 224, and +256-bit types are predefined. + +Installation +------------ +The usual: + + $ cabal install + diff --git a/data-dword.cabal b/data-dword.cabal --- a/data-dword.cabal +++ b/data-dword.cabal @@ -1,5 +1,5 @@ Name: data-dword -Version: 0.2.2 +Version: 0.3 Category: Data Stability: experimental Synopsis: Stick two binary words together to get a bigger one @@ -13,10 +13,13 @@ Author: Mikhail Vorozhtsov Maintainer: Mikhail Vorozhtsov -Copyright: 2011, 2012 Mikhail Vorozhtsov +Copyright: 2011-2014 Mikhail Vorozhtsov License: BSD3 License-File: LICENSE +Extra-Source-Files: + README.md + Cabal-Version: >= 1.10.0 Build-Type: Simple @@ -29,6 +32,7 @@ Build-Depends: base >= 4.6 && < 5, hashable >= 1.1, + data-bword >= 0.1, template-haskell >= 2.8, ghc-prim Hs-Source-Dirs: src @@ -43,10 +47,9 @@ Default-Language: Haskell2010 Type: exitcode-stdio-1.0 Build-Depends: - base >= 4.5 && < 5, - test-framework >= 0.5, - test-framework-quickcheck2 >= 0.2, - QuickCheck >= 2.4, + base >= 4.5 && < 5, + tasty >= 0.8, + tasty-quickcheck >= 0.8, data-dword Hs-Source-Dirs: tests GHC-Options: -Wall diff --git a/src/Data/DoubleWord.hs b/src/Data/DoubleWord.hs --- a/src/Data/DoubleWord.hs +++ b/src/Data/DoubleWord.hs @@ -8,7 +8,8 @@ -- signed and unsigned binary word data types of sizes 96, 128, -- 160, 192, 224, and 256 bits. module Data.DoubleWord - ( module Data.DoubleWord.Base + ( module Data.BinaryWord + , module Data.DoubleWord.Base , Word96(..) , Word128(..) , Word160(..) @@ -27,6 +28,7 @@ import GHC.Generics import Data.Word import Data.Int +import Data.BinaryWord import Data.DoubleWord.Base import Data.DoubleWord.TH diff --git a/src/Data/DoubleWord/Base.hs b/src/Data/DoubleWord/Base.hs --- a/src/Data/DoubleWord/Base.hs +++ b/src/Data/DoubleWord/Base.hs @@ -1,461 +1,14 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE UnicodeSyntax #-} {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE UnboxedTuples #-} -#include "MachDeps.h" - module Data.DoubleWord.Base - ( BinaryWord(..) - , DoubleWord(..) + ( DoubleWord(..) ) where +import Data.Bits (Bits(..)) import Data.Int import Data.Word -import Data.Bits (Bits(..)) -#if __GLASGOW_HASKELL__ >= 705 -import GHC.Prim (plusWord2#, timesWord2#) -# if WORD_SIZE_IN_BITS == 32 -import GHC.Word (Word32(..)) -# endif -# if WORD_SIZE_IN_BITS == 64 -import GHC.Word (Word64(..)) -# endif -#endif - --- | Extra bit-manipulation functions for binary words of fixed length. -class Bits w ⇒ BinaryWord w where - -- | The unsigned variant type - type UnsignedWord w - -- | The signed variant type - type SignedWord w - -- | Convert the word to the unsigned type (identical to 'fromIntegral') - unsignedWord ∷ w → UnsignedWord w - -- | Convert the word to the signed type (identical to 'fromIntegral') - signedWord ∷ w → SignedWord w - -- | Unwrapped addition - unwrappedAdd ∷ w → w → (w, UnsignedWord w) - -- | Unwrapped multiplication - unwrappedMul ∷ w → w → (w, UnsignedWord w) - -- | Number of leading (from MSB) zero bits - leadingZeroes ∷ w → Int - -- | Number or trailing (from LSB) zero bits - trailingZeroes ∷ w → Int - -- | The word with all bits set to 0 - allZeroes ∷ w - -- | The word with all bits set to 1 - allOnes ∷ w - -- | The word with MSB set to 1 and all the other bits set to 0 - msb ∷ w - -- | The word with LSB set to 1 and all the other bits set to 0 - lsb ∷ w - -- | Test if the MSB is 1 - testMsb ∷ w → Bool - -- | Test if the LSB is 1 - testLsb ∷ w → Bool - -instance BinaryWord Word8 where - type UnsignedWord Word8 = Word8 - type SignedWord Word8 = Int8 - unsignedWord = id - {-# INLINE unsignedWord #-} - signedWord = fromIntegral - {-# INLINE signedWord #-} - unwrappedAdd x y = hi `seq` lo `seq` (hi, lo) - where s = fromIntegral x + fromIntegral y ∷ Word16 - hi = hiWord s - lo = loWord s - {-# INLINE unwrappedAdd #-} - unwrappedMul x y = hi `seq` lo `seq` (hi, lo) - where p = fromIntegral x * fromIntegral y ∷ Word16 - hi = hiWord p - lo = loWord p - {-# INLINE unwrappedMul #-} - leadingZeroes w | w .&. 0xF0 == 0 = go4 4 w - | otherwise = go4 0 (shiftR w 4) - where go4 off w' | w' .&. 8 /= 0 = off - | w' .&. 4 /= 0 = off + 1 - | w' .&. 2 /= 0 = off + 2 - | w' .&. 1 /= 0 = off + 3 - | otherwise = off + 4 - trailingZeroes w | w .&. 0x0F == 0 = go4 4 (shiftR w 4) - | otherwise = go4 0 w - where go4 off w' | w' .&. 1 /= 0 = off - | w' .&. 2 /= 0 = off + 1 - | w' .&. 4 /= 0 = off + 2 - | w' .&. 8 /= 0 = off + 3 - | otherwise = off + 4 - allZeroes = 0 - {-# INLINE allZeroes #-} - allOnes = 0xFF - {-# INLINE allOnes #-} - msb = 0x80 - {-# INLINE msb #-} - lsb = 1 - {-# INLINE lsb #-} - testMsb x = testBit x 7 - {-# INLINE testMsb #-} - testLsb x = testBit x 0 - {-# INLINE testLsb #-} - -instance BinaryWord Word16 where - type UnsignedWord Word16 = Word16 - type SignedWord Word16 = Int16 - unsignedWord = id - {-# INLINE unsignedWord #-} - signedWord = fromIntegral - {-# INLINE signedWord #-} - unwrappedAdd x y = hi `seq` lo `seq` (hi, lo) - where s = fromIntegral x + fromIntegral y ∷ Word32 - lo = loWord s - hi = hiWord s - {-# INLINE unwrappedAdd #-} - unwrappedMul x y = hi `seq` lo `seq` (hi, lo) - where p = fromIntegral x * fromIntegral y ∷ Word32 - lo = loWord p - hi = hiWord p - {-# INLINE unwrappedMul #-} - leadingZeroes w | w .&. 0xFF00 == 0 = go8 8 w - | otherwise = go8 0 (shiftR w 8) - where - go8 off w' | w' .&. 0xF0 == 0 = go4 (off + 4) w' - | otherwise = go4 off (shiftR w' 4) - go4 off w' | w' .&. 8 /= 0 = off - | w' .&. 4 /= 0 = off + 1 - | w' .&. 2 /= 0 = off + 2 - | w' .&. 1 /= 0 = off + 3 - | otherwise = off + 4 - trailingZeroes w | w .&. 0x00FF == 0 = go8 8 (shiftR w 8) - | otherwise = go8 0 w - where - go8 off w' | w' .&. 0x0F == 0 = go4 (off + 4) (shiftR w' 4) - | otherwise = go4 off w' - go4 off w' | w' .&. 1 /= 0 = off - | w' .&. 2 /= 0 = off + 1 - | w' .&. 4 /= 0 = off + 2 - | w' .&. 8 /= 0 = off + 3 - | otherwise = off + 4 - allZeroes = 0 - {-# INLINE allZeroes #-} - allOnes = 0xFFFF - {-# INLINE allOnes #-} - msb = 0x8000 - {-# INLINE msb #-} - lsb = 1 - {-# INLINE lsb #-} - testMsb x = testBit x 15 - {-# INLINE testMsb #-} - testLsb x = testBit x 0 - {-# INLINE testLsb #-} - -instance BinaryWord Word32 where - type UnsignedWord Word32 = Word32 - type SignedWord Word32 = Int32 - unsignedWord = id - {-# INLINE unsignedWord #-} - signedWord = fromIntegral - {-# INLINE signedWord #-} -#if __GLASGOW_HASKELL__ >= 705 && WORD_SIZE_IN_BITS == 32 - unwrappedAdd (W32# x) (W32# y) = hi `seq` lo `seq` (hi, lo) - where (# hi', lo' #) = plusWord2# x y - hi = W32# hi' - lo = W32# lo' -#else - unwrappedAdd x y = hi `seq` lo `seq` (hi, lo) - where s = fromIntegral x + fromIntegral y ∷ Word64 - lo = loWord s - hi = hiWord s -#endif - {-# INLINE unwrappedAdd #-} -#if __GLASGOW_HASKELL__ >= 705 && WORD_SIZE_IN_BITS == 32 - unwrappedMul (W32# x) (W32# y) = hi `seq` lo `seq` (hi, lo) - where (# hi', lo' #) = timesWord2# x y - lo = W32# lo' - hi = W32# hi' -#else - unwrappedMul x y = hi `seq` lo `seq` (hi, lo) - where p = fromIntegral x * fromIntegral y ∷ Word64 - lo = loWord p - hi = hiWord p -#endif - {-# INLINE unwrappedMul #-} - leadingZeroes w | w .&. 0xFFFF0000 == 0 = go16 16 w - | otherwise = go16 0 (shiftR w 16) - where - go16 off w' | w' .&. 0xFF00 == 0 = go8 (off + 8) w' - | otherwise = go8 off (shiftR w' 8) - go8 off w' | w' .&. 0xF0 == 0 = go4 (off + 4) w' - | otherwise = go4 off (shiftR w' 4) - go4 off w' | w' .&. 8 /= 0 = off - | w' .&. 4 /= 0 = off + 1 - | w' .&. 2 /= 0 = off + 2 - | w' .&. 1 /= 0 = off + 3 - | otherwise = off + 4 - trailingZeroes w | w .&. 0x0000FFFF == 0 = go16 16 (shiftR w 16) - | otherwise = go16 0 w - where - go16 off w' | w' .&. 0x00FF == 0 = go8 (off + 8) (shiftR w' 8) - | otherwise = go8 off w' - go8 off w' | w' .&. 0x0F == 0 = go4 (off + 4) (shiftR w' 4) - | otherwise = go4 off w' - go4 off w' | w' .&. 1 /= 0 = off - | w' .&. 2 /= 0 = off + 1 - | w' .&. 4 /= 0 = off + 2 - | w' .&. 8 /= 0 = off + 3 - | otherwise = off + 4 - allZeroes = 0 - {-# INLINE allZeroes #-} - allOnes = 0xFFFFFFFF - {-# INLINE allOnes #-} - msb = 0x80000000 - {-# INLINE msb #-} - lsb = 1 - {-# INLINE lsb #-} - testMsb x = testBit x 31 - {-# INLINE testMsb #-} - testLsb x = testBit x 0 - {-# INLINE testLsb #-} - -instance BinaryWord Word64 where - type UnsignedWord Word64 = Word64 - type SignedWord Word64 = Int64 - unsignedWord = id - {-# INLINE unsignedWord #-} - signedWord = fromIntegral - {-# INLINE signedWord #-} -#if __GLASGOW_HASKELL__ >= 705 && WORD_SIZE_IN_BITS == 64 - unwrappedAdd (W64# x) (W64# y) = hi `seq` lo `seq` (hi, lo) - where (# hi', lo' #) = plusWord2# x y - lo = W64# lo' - hi = W64# hi' - {-# INLINE unwrappedAdd #-} -#else - unwrappedAdd x y = hi `seq` lo `seq` (hi, lo) - where lo = x + y - hi = if lo < x then 1 else 0 - {-# INLINABLE unwrappedAdd #-} -#endif -#if __GLASGOW_HASKELL__ >= 705 && WORD_SIZE_IN_BITS == 64 - unwrappedMul (W64# x) (W64# y) = hi `seq` lo `seq` (hi, lo) - where (# hi', lo' #) = timesWord2# x y - lo = W64# lo' - hi = W64# hi' - {-# INLINE unwrappedMul #-} -#else - unwrappedMul x y = hi `seq` lo `seq` (hi, lo) - where xHi = shiftR x 32 - xLo = x .&. 0xFFFFFFFF - yHi = shiftR y 32 - yLo = y .&. 0xFFFFFFFF - hi0 = xHi * yHi - lo0 = xLo * yLo - p1 = xHi * yLo - p2 = xLo * yHi - hi = hi0 + fromIntegral uHi1 + fromIntegral uHi2 + - shiftR p1 32 + shiftR p2 32 - lo = fromHiAndLo lo' (loWord lo0) - (uHi1, uLo) = unwrappedAdd (loWord p1) (loWord p2) - (uHi2, lo') = unwrappedAdd (hiWord lo0) uLo -#endif -#if WORD_SIZE_IN_BITS == 64 - leadingZeroes w | w .&. 0xFFFFFFFF00000000 == 0 = go32 32 w - | otherwise = go32 0 (shiftR w 32) - where - go32 off w' | w' .&. 0xFFFF0000 == 0 = go16 (off + 16) w' - | otherwise = go16 off (shiftR w' 16) - go16 off w' | w' .&. 0xFF00 == 0 = go8 (off + 8) w' - | otherwise = go8 off (shiftR w' 8) - go8 off w' | w' .&. 0xF0 == 0 = go4 (off + 4) w' - | otherwise = go4 off (shiftR w' 4) - go4 off w' | w' .&. 8 /= 0 = off - | w' .&. 4 /= 0 = off + 1 - | w' .&. 2 /= 0 = off + 2 - | w' .&. 1 /= 0 = off + 3 - | otherwise = off + 4 - trailingZeroes w | w .&. 0x00000000FFFFFFFF == 0 = go32 32 (shiftR w 32) - | otherwise = go32 0 w - where - go32 off w' | w' .&. 0x0000FFFF == 0 = go16 (off + 16) (shiftR w' 16) - | otherwise = go16 off w' - go16 off w' | w' .&. 0x00FF == 0 = go8 (off + 8) (shiftR w' 8) - | otherwise = go8 off w' - go8 off w' | w' .&. 0x0F == 0 = go4 (off + 4) (shiftR w' 4) - | otherwise = go4 off w' - go4 off w' | w' .&. 1 /= 0 = off - | w' .&. 2 /= 0 = off + 1 - | w' .&. 4 /= 0 = off + 2 - | w' .&. 8 /= 0 = off + 3 - | otherwise = off + 4 -#else - leadingZeroes w | hiZeroes == 32 = 32 + leadingZeroes (loWord w) - | otherwise = hiZeroes - where hiZeroes = leadingZeroes (hiWord w) - trailingZeroes w | loZeroes == 32 = 32 + trailingZeroes (hiWord w) - | otherwise = loZeroes - where loZeroes = trailingZeroes (loWord w) -#endif - allZeroes = 0 - {-# INLINE allZeroes #-} - allOnes = 0xFFFFFFFFFFFFFFFF - {-# INLINE allOnes #-} - msb = 0x8000000000000000 - {-# INLINE msb #-} - lsb = 1 - {-# INLINE lsb #-} - testMsb x = testBit x 63 - {-# INLINE testMsb #-} - testLsb x = testBit x 0 - {-# INLINE testLsb #-} - -instance BinaryWord Int8 where - type UnsignedWord Int8 = Word8 - type SignedWord Int8 = Int8 - unsignedWord = fromIntegral - {-# INLINE unsignedWord #-} - signedWord = id - {-# INLINE signedWord #-} - unwrappedAdd x y = hi `seq` lo `seq` (hi, lo) - where s = fromIntegral x + fromIntegral y ∷ Int16 - hi = hiWord s - lo = loWord s - {-# INLINE unwrappedAdd #-} - unwrappedMul x y = hi `seq` lo `seq` (hi, lo) - where p = fromIntegral x * fromIntegral y ∷ Int16 - hi = hiWord p - lo = loWord p - {-# INLINE unwrappedMul #-} - leadingZeroes = leadingZeroes . unsignedWord - {-# INLINE leadingZeroes #-} - trailingZeroes = trailingZeroes . unsignedWord - {-# INLINE trailingZeroes #-} - allZeroes = 0 - {-# INLINE allZeroes #-} - allOnes = 0xFF - {-# INLINE allOnes #-} - msb = 0x80 - {-# INLINE msb #-} - lsb = 1 - {-# INLINE lsb #-} - testMsb x = testBit x 7 - {-# INLINE testMsb #-} - testLsb x = testBit x 0 - {-# INLINE testLsb #-} - -instance BinaryWord Int16 where - type UnsignedWord Int16 = Word16 - type SignedWord Int16 = Int16 - unsignedWord = fromIntegral - {-# INLINE unsignedWord #-} - signedWord = id - {-# INLINE signedWord #-} - unwrappedAdd x y = hi `seq` lo `seq` (hi, lo) - where s = fromIntegral x + fromIntegral y ∷ Int32 - lo = loWord s - hi = hiWord s - {-# INLINE unwrappedAdd #-} - unwrappedMul x y = hi `seq` lo `seq` (hi, lo) - where p = fromIntegral x * fromIntegral y ∷ Int32 - lo = loWord p - hi = hiWord p - {-# INLINE unwrappedMul #-} - leadingZeroes = leadingZeroes . unsignedWord - {-# INLINE leadingZeroes #-} - trailingZeroes = trailingZeroes . unsignedWord - {-# INLINE trailingZeroes #-} - allZeroes = 0 - {-# INLINE allZeroes #-} - allOnes = 0xFFFF - {-# INLINE allOnes #-} - msb = 0x8000 - {-# INLINE msb #-} - lsb = 1 - {-# INLINE lsb #-} - testMsb x = testBit x 15 - {-# INLINE testMsb #-} - testLsb x = testBit x 0 - {-# INLINE testLsb #-} - -instance BinaryWord Int32 where - type UnsignedWord Int32 = Word32 - type SignedWord Int32 = Int32 - unsignedWord = fromIntegral - {-# INLINE unsignedWord #-} - signedWord = id - {-# INLINE signedWord #-} -#if WORD_SIZE_IN_BITS == 32 - unwrappedAdd x y = hi `seq` lo `seq` (hi, lo) - where extX = if x < 0 then maxBound else 0 - extY = if y < 0 then maxBound else 0 - (hi', lo) = unsignedWord x `unwrappedAdd` unsignedWord y - hi = signedWord $ hi' + extX + extY - unwrappedMul x y = hi `seq` lo `seq` (hi, lo) - where extX = if x < 0 then negate y else 0 - extY = if y < 0 then negate x else 0 - (hi', lo) = unsignedWord x `unwrappedMul` unsignedWord y - hi = signedWord hi' + extX + extY -#else - unwrappedAdd x y = hi `seq` lo `seq` (hi, lo) - where s = fromIntegral x + fromIntegral y ∷ Int64 - lo = loWord s - hi = hiWord s - {-# INLINE unwrappedAdd #-} - unwrappedMul x y = hi `seq` lo `seq` (hi, lo) - where p = fromIntegral x * fromIntegral y ∷ Int64 - lo = loWord p - hi = hiWord p - {-# INLINE unwrappedMul #-} -#endif - leadingZeroes = leadingZeroes . unsignedWord - {-# INLINE leadingZeroes #-} - trailingZeroes = trailingZeroes . unsignedWord - {-# INLINE trailingZeroes #-} - allZeroes = 0 - {-# INLINE allZeroes #-} - allOnes = 0xFFFFFFFF - {-# INLINE allOnes #-} - msb = 0x80000000 - {-# INLINE msb #-} - lsb = 1 - {-# INLINE lsb #-} - testMsb x = testBit x 31 - {-# INLINE testMsb #-} - testLsb x = testBit x 0 - {-# INLINE testLsb #-} - -instance BinaryWord Int64 where - type UnsignedWord Int64 = Word64 - type SignedWord Int64 = Int64 - unsignedWord = fromIntegral - {-# INLINE unsignedWord #-} - signedWord = id - {-# INLINE signedWord #-} - unwrappedAdd x y = hi `seq` lo `seq` (hi, lo) - where extX = if x < 0 then maxBound else 0 - extY = if y < 0 then maxBound else 0 - (hi', lo) = unsignedWord x `unwrappedAdd` unsignedWord y - hi = signedWord $ hi' + extX + extY - unwrappedMul x y = hi `seq` lo `seq` (hi, lo) - where extX = if x < 0 then negate y else 0 - extY = if y < 0 then negate x else 0 - (hi', lo) = unsignedWord x `unwrappedMul` unsignedWord y - hi = signedWord hi' + extX + extY - leadingZeroes = leadingZeroes . unsignedWord - {-# INLINE leadingZeroes #-} - trailingZeroes = trailingZeroes . unsignedWord - {-# INLINE trailingZeroes #-} - allZeroes = 0 - {-# INLINE allZeroes #-} - allOnes = 0xFFFFFFFFFFFFFFFF - {-# INLINE allOnes #-} - msb = 0x8000000000000000 - {-# INLINE msb #-} - lsb = 1 - {-# INLINE lsb #-} - testMsb x = testBit x 63 - {-# INLINE testMsb #-} - testLsb x = testBit x 0 - {-# INLINE testLsb #-} +import Data.BinaryWord -- | Defines a particular way to split a binary word in halves. class BinaryWord w ⇒ DoubleWord w where diff --git a/src/Data/DoubleWord/TH.hs b/src/Data/DoubleWord/TH.hs --- a/src/Data/DoubleWord/TH.hs +++ b/src/Data/DoubleWord/TH.hs @@ -11,6 +11,10 @@ import GHC.Arr (Ix(..)) import Data.Ratio ((%)) import Data.Bits (Bits(..)) +#if MIN_VERSION_base(4,7,0) +import Data.Bits (FiniteBits(..)) +#else +#endif import Data.Word (Word8, Word16, Word32, Word64) import Data.Int (Int8, Int16, Int32, Int64) #if MIN_VERSION_hashable(1,2,0) @@ -20,6 +24,7 @@ #endif import Control.Applicative ((<$>), (<*>)) import Language.Haskell.TH hiding (match) +import Data.BinaryWord (BinaryWord(..)) import Data.DoubleWord.Base -- | Declare signed and unsigned binary word types built from @@ -71,8 +76,8 @@ mkDoubleWord' signed tp cn otp ocn hiS hiT loS loT ad = (<$> mkRules) $ (++) $ [ DataD [] tp [] [NormalC cn [(hiS, hiT), (loS, loT)]] ad , inst ''DoubleWord [tp] - [ TySynInstD ''LoWord [tpT] loT - , TySynInstD ''HiWord [tpT] hiT + [ tySynInst ''LoWord [tpT] loT + , tySynInst ''HiWord [tpT] hiT , funLo 'loWord (VarE lo) , inline 'loWord , funHi 'hiWord (VarE hi) @@ -863,6 +868,11 @@ [ appV 'bitSize [SigE (VarE 'undefined) hiT] , appV 'bitSize [SigE (VarE 'undefined) loT] ] , inline 'bitSize +#if MIN_VERSION_base(4,7,0) + {- bitSizeMaybe = Just . bitSize -} + , fun 'bitSizeMaybe $ appV '(.) [ConE 'Just, VarE 'bitSize] + , inline 'bitSizeMaybe +#endif {- isSigned _ = SIGNED -} , fun_ 'isSigned $ ConE $ if signed then 'True else 'False , inline 'isSigned @@ -1072,10 +1082,17 @@ , inline 'popCount ] ++ if signed then [inline 'rotateL] else [] +#if MIN_VERSION_base(4,7,0) + , inst ''FiniteBits [tp] + {- finiteBitSize = bitSize -} + [ fun 'finiteBitSize $ VarE 'bitSize + , inline 'finiteBitSize + ] +#endif , inst ''BinaryWord [tp] - [ TySynInstD ''UnsignedWord [tpT] $ + [ tySynInst ''UnsignedWord [tpT] $ ConT $ if signed then otp else tp - , TySynInstD ''SignedWord [tpT] $ + , tySynInst ''SignedWord [tpT] $ ConT $ if signed then tp else otp {- UNSIGNED: @@ -1294,6 +1311,18 @@ {- testLsb (W _ lo) = testLsb lo -} , funLo 'testLsb $ appVN 'testLsb [lo] , inline 'testLsb + {- setMsb (W hi lo) = W (setMsb hi) lo -} + , funHiLo 'setMsb $ appW [appVN 'setMsb [hi], VarE lo] + , inline 'setMsb + {- setLsb (W hi lo) = W hi (setLsb lo) -} + , funHiLo 'setLsb $ appW [VarE hi, appVN 'setLsb [lo]] + , inline 'setLsb + {- clearMsb (W hi lo) = W (clearMsb hi) lo -} + , funHiLo 'clearMsb $ appW [appVN 'clearMsb [hi], VarE lo] + , inline 'clearMsb + {- clearLsb (W hi lo) = W hi (clearLsb lo) -} + , funHiLo 'clearLsb $ appW [VarE hi, appVN 'clearLsb [lo]] + , inline 'clearLsb ] ] where @@ -1344,6 +1373,12 @@ hi' = mkName "hi'" lo' = mkName "lo'" tpT = ConT tp + tySynInst n ps t = +#if MIN_VERSION_template_haskell(2,9,0) + TySynInstD n (TySynEqn ps t) +#else + TySynInstD n ps t +#endif inst cls params = InstanceD [] (foldl AppT (ConT cls) (ConT <$> params)) fun n e = FunD n [Clause [] (NormalB e) []] fun_ n e = FunD n [Clause [WildP] (NormalB e) []] @@ -1421,7 +1456,11 @@ signedRules ← do insts ← reifyInstances ''SignedWord [t] case insts of +#if MIN_VERSION_template_haskell(2,9,0) + [TySynInstD _ (TySynEqn _ signT)] → return $ +#else [TySynInstD _ _ signT] → return $ +#endif [ RuleP ("fromIntegral/" ++ show tp ++ "->" ++ showT signT) [] (VarE 'fromIntegral) @@ -1473,7 +1512,11 @@ _ → do insts ← reifyInstances ''LoWord [t] case insts of +#if MIN_VERSION_template_haskell(2,9,0) + [TySynInstD _ (TySynEqn _ t')] → +#else [TySynInstD _ _ t'] → +#endif mkRules' rules' t' (appV '(.) [VarE 'loWord, narrowE]) (appV '(.) [VarE 'extendLo, extE]) diff --git a/tests/Tests.hs b/tests/Tests.hs --- a/tests/Tests.hs +++ b/tests/Tests.hs @@ -6,15 +6,12 @@ {-# LANGUAGE NoMonomorphismRestriction #-} {-# OPTIONS_GHC -fno-warn-missing-signatures #-} -import Test.Framework (RunnerOptions'(..), TestOptions'(..), - defaultMainWithOpts, testGroup) -import Test.Framework.Providers.QuickCheck2 (testProperty) -import Test.QuickCheck hiding ((.&.)) +import Test.Tasty (defaultMain, localOption, testGroup) +import Test.Tasty.QuickCheck hiding ((.&.)) import Data.Bits import Data.Word import Data.Int -import Data.Monoid (mempty) import Data.DoubleWord (BinaryWord(..)) import Types @@ -44,7 +41,9 @@ .|. fromIntegral lh `shiftL` 32 .|. fromIntegral ll -main = defaultMainWithOpts +main = defaultMain + $ localOption (QuickCheckTests 10000) + $ testGroup "Tests" [ arbTestGroup "Word8" (0 ∷ Word8) , arbTestGroup "Int8" (0 ∷ Int8) , arbTestGroup "Word16" (0 ∷ Word16) @@ -57,10 +56,6 @@ , isoTestGroup "|Int32|Word32|" (0 ∷ I64) , isoTestGroup "|Word16|Word16|Word32|" (0 ∷ UU64) , isoTestGroup "|Int16|Word16|Word32|" (0 ∷ II64) ] - mempty { - ropt_test_options = - Just (mempty { topt_maximum_generated_tests = Just 10000 }) - } arbTestGroup name t = testGroup name