data-dword 0.3 → 0.3.1

raw patch · 3 files changed

+100/−146 lines, 3 filesdep ~template-haskellPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: template-haskell

API changes (from Hackage documentation)

Files

• data-dword.cabal +1/−1
• src/Data/DoubleWord/TH.hs +88/−61
• tests/Tests.hs +11/−84

@@ -1,5 +1,5 @@ Name: data-dword-Version: 0.3+Version: 0.3.1 Category: Data Stability: experimental Synopsis: Stick two binary words together to get a bigger one

@@ -13,7 +13,6 @@ 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)@@ -23,7 +22,7 @@ import Data.Hashable (Hashable(..), combine) #endif import Control.Applicative ((<$>), (<*>))-import Language.Haskell.TH hiding (match)+import Language.Haskell.TH hiding (unpacked, match) import Data.BinaryWord (BinaryWord(..)) import Data.DoubleWord.Base @@ -35,13 +34,25 @@ --   'Hashable', 'Ix', 'Bits', 'BinaryWord'. mkDoubleWord ∷ String -- ^ Unsigned variant type name              → String -- ^ Unsigned variant constructor name+#if MIN_VERSION_template_haskell(2,11,0)+             → Bang   -- ^ Unsigned variant higher half strictness+#else              → Strict -- ^ Unsigned variant higher half strictness+#endif              → Name   -- ^ Unsigned variant higher half type              → String -- ^ Signed variant type name              → String -- ^ Signed variant constructor name+#if MIN_VERSION_template_haskell(2,11,0)+             → Bang   -- ^ Signed variant higher half strictness+#else              → Strict -- ^ Signed variant higher half strictness+#endif              → Name   -- ^ Signed variant higher half type+#if MIN_VERSION_template_haskell(2,11,0)+             → Bang   -- ^ Lower half strictness+#else              → Strict -- ^ Lower half strictness+#endif              → Name   -- ^ Lower half type              → [Name] -- ^ List of instances for automatic derivation              → Q [Dec]@@ -64,17 +75,42 @@                      → [Name] -- ^ List of instances for automatic derivation                      → Q [Dec] mkUnpackedDoubleWord un uhn sn shn ln ad =-  mkDoubleWord un un Unpacked uhn sn sn Unpacked shn Unpacked ln ad+    mkDoubleWord un un unpacked uhn sn sn unpacked shn unpacked ln ad+  where unpacked =+#if MIN_VERSION_template_haskell(2,11,0)+                   Bang SourceUnpack SourceStrict+#else+                   Unpacked+#endif  mkDoubleWord' ∷ Bool               → Name → Name               → Name → Name-              → Strict → Type-              → Strict → Type+#if MIN_VERSION_template_haskell(2,11,0)+              → Bang+#else+              → Strict+#endif+              → Type+#if MIN_VERSION_template_haskell(2,11,0)+              → Bang+#else+              → Strict+#endif+              → Type               → [Name]               → Q [Dec] mkDoubleWord' signed tp cn otp ocn hiS hiT loS loT ad = (<$> mkRules) $ (++) $-    [ DataD [] tp [] [NormalC cn [(hiS, hiT), (loS, loT)]] ad+    [ DataD [] tp []+#if MIN_VERSION_template_haskell(2,11,0)+            Nothing+#endif+            [NormalC cn [(hiS, hiT), (loS, loT)]]+#if MIN_VERSION_template_haskell(2,11,0)+            (ConT <$> ad)+#else+            ad+#endif     , inst ''DoubleWord [tp]         [ tySynInst ''LoWord [tpT] loT         , tySynInst ''HiWord [tpT] hiT@@ -624,10 +660,7 @@                         , val t2 $ appVN 'leadingZeroes [hi']                         , val z $ appV 'shiftR                                     [ VarE hi-                                    , appV '(-)-                                        [ appV 'bitSize-                                            [SigE (VarE 'undefined) hiT]-                                        , VarE t2 ]+                                    , appV '(-) [hiSizeE, VarE t2]                                     ]                         , ValD (ConP cn [VarP hhh, VarP hll])                             (NormalB $ appVN 'shiftL [x, t2]) [] @@ -863,14 +896,11 @@         , inline 'inRange ]     , inst ''Bits [tp] $         {- bitSize _ = bitSize (undefined ∷ H) + bitSize (undefined ∷ L) -}-        [ fun_ 'bitSize $-            appV '(+)-              [ appV 'bitSize [SigE (VarE 'undefined) hiT]-              , appV 'bitSize [SigE (VarE 'undefined) loT] ]+        [ fun_ 'bitSize $ appV '(+) [hiSizeE, loSizeE]         , inline 'bitSize #if MIN_VERSION_base(4,7,0)-        {- bitSizeMaybe = Just . bitSize -}-        , fun 'bitSizeMaybe $ appV '(.) [ConE 'Just, VarE 'bitSize]+        {- bitSizeMaybe = Just . finiteBitSize -}+        , fun 'bitSizeMaybe $ appV '(.) [ConE 'Just, VarE 'finiteBitSize]         , inline 'bitSizeMaybe #endif         {- isSigned _ = SIGNED -}@@ -909,9 +939,7 @@                    (appW [ appV 'fromIntegral                              [appV 'shiftL [VarE lo, appVN 'negate [y]]]                          , zeroE ]))-            [val y $-               appV '(-) [ appV 'bitSize [SigE (VarE 'undefined) loT]-                         , VarE x ]]+            [val y $ appV '(-) [loSizeE, VarE x]]         {-           shiftR (W hi lo) x =               W (shiftR hi x)@@ -932,8 +960,7 @@                                  [appVN 'fromIntegral [hi], VarE y]                              , appVN 'shiftR [lo, x] ])                           (VarE z) ])-            [ val y $ appV '(-) [ appV 'bitSize [SigE (VarE 'undefined) loT]-                                , VarE x ]+            [ val y $ appV '(-) [loSizeE, VarE x]             , val z $                 if signed                 then appV 'fromIntegral@@ -975,9 +1002,7 @@                     , appV '(.|.)                         [ appV 'shiftL                             [ appVN 'fromIntegral [hi]-                            , appV '(-)-                                [ appV 'bitSize [SigE (VarE 'undefined) loT]-                                , VarE z ]+                            , appV '(-) [loSizeE, VarE z]                             ]                         , appVN 'shiftR [lo, z] ]                     ])@@ -989,27 +1014,15 @@                     , appV '(.|.)                         [ appV 'shift                             [ appVN 'fromIntegral [hi]-                            , appV '(-)-                                [ appV 'bitSize [SigE (VarE 'undefined) loT]-                                , VarE z] ]+                            , appV '(-) [loSizeE, VarE z] ]                         , appV '(.|.)                             [appVN 'shiftL [lo, x], appVN 'shiftR [lo, z]] ]                     ]))-              [ val y $-                  appV '(-) [ VarE x-                            , appV 'bitSize [SigE (VarE 'undefined) loT] ]-              , val z $-                  appV '(-)-                    [ appV 'bitSize [SigE (VarE 'undefined) tpT]-                    , VarE x ]+              [ val y $ appV '(-) [VarE x, loSizeE]+              , val z $ appV '(-) [sizeE, VarE x]               ]         {- rotateR x y = rotateL x $ bitSize (undefined ∷ W) - y -}-        , funXY 'rotateR $-            appV 'rotateL-              [ VarE x-              , appV '(-)-                  [appV 'bitSize [SigE (VarE 'undefined) tpT], VarE y]-              ]+        , funXY 'rotateR $ appV 'rotateL [VarE x, appV '(-) [sizeE, VarE y]]         , inline 'rotateR         {-           bit x = if y >= 0 then W (bit y) 0 else W 0 (bit x)@@ -1018,9 +1031,7 @@         , funX' 'bit (CondE (appV '(>=) [VarE y, litI 0])                             (appW [appVN 'bit [y], zeroE])                             (appW [zeroE, appVN 'bit [x]]))-            [val y $-               appV '(-) [ VarE x-                         , appV 'bitSize [SigE (VarE 'undefined) loT] ]]+            [val y $ appV '(-) [VarE x, loSizeE]]         , inlinable 'bit         {-           setBit (W hi lo) x =@@ -1045,9 +1056,7 @@             (CondE (appV '(>=) [VarE y, litI 0])                    (appW [appVN 'clearBit [hi, y], VarE lo])                    (appW [VarE hi, appVN 'clearBit [lo, x]]))-            [val y $-               appV '(-) [ VarE x-                         , appV 'bitSize [SigE (VarE 'undefined) loT] ]]+            [val y $ appV '(-) [VarE x, loSizeE]]         , inlinable 'clearBit         {-           complementBit (W hi lo) x =@@ -1059,9 +1068,7 @@             (CondE (appV '(>=) [VarE y, litI 0])                    (appW [appVN 'complementBit [hi, y], VarE lo])                    (appW [VarE hi, appVN 'complementBit [lo, x]]))-            [val y $-               appV '(-) [ VarE x-                         , appV 'bitSize [SigE (VarE 'undefined) loT] ]]+            [val y $ appV '(-) [VarE x, loSizeE]]         , inlinable 'complementBit         {-           testBit (W hi lo) x =@@ -1072,9 +1079,7 @@             (CondE (appV '(>=) [VarE y, litI 0])                    (appVN 'testBit [hi, y])                    (appVN 'testBit [lo, x]))-            [val y $-               appV '(-) [ VarE x-                         , appV 'bitSize [SigE (VarE 'undefined) loT] ]]+            [val y $ appV '(-) [VarE x, loSizeE]]         , inlinable 'testBit         {- popCount (W hi lo) = popCount hi + popCount lo -}         , funHiLo 'popCount@@ -1084,9 +1089,20 @@         if signed then [inline 'rotateL] else [] #if MIN_VERSION_base(4,7,0)     , inst ''FiniteBits [tp]-        {- finiteBitSize = bitSize -}-        [ fun 'finiteBitSize $ VarE 'bitSize+        {- +           finiteBitSize = finiteBitSize (undefined ∷ H) ++                           finiteBitSize (undefined ∷ L)+        -}+        [ fun_ 'finiteBitSize $ appV '(+) [hiSizeE, loSizeE]         , inline 'finiteBitSize+# if MIN_VERSION_base(4,8,0)+        {- countLeadingZeros = leadingZeroes -}+        , fun 'countLeadingZeros $ VarE 'leadingZeroes+        , inline 'countLeadingZeros+        {- countTrailingZeros = trailingZeroes -}+        , fun 'countTrailingZeros $ VarE 'trailingZeroes+        , inline 'countTrailingZeros+# endif         ] #endif     , inst ''BinaryWord [tp]@@ -1245,9 +1261,8 @@               , val x $                   appV 'fromIntegral                     [appV '(+) [VarE t6, appVN '(+) [t8, t10]]]-              , val y $ appV 'bitSize [SigE (VarE 'undefined) hiT]-              , val z $ appV '(-) [ appV 'bitSize [SigE (VarE 'undefined) loT]-                                  , VarE y ]+              , val y $ hiSizeE+              , val z $ appV '(-) [loSizeE, VarE y]               ]         {-           UNSIGNED:@@ -1267,7 +1282,7 @@                      (appV '(+) [VarE y, appVN 'leadingZeroes [lo]])                      (VarE x))               [ val x $ appVN 'leadingZeroes [hi]-              , val y $ appV 'bitSize [SigE (VarE 'undefined) hiT]+              , val y $ hiSizeE               ]         , if signed then inlinable 'leadingZeroes                     else inline 'leadingZeroes@@ -1289,8 +1304,7 @@                      (appV '(+) [VarE y, appVN 'trailingZeroes [hi]])                      (VarE x))               [ val x $ appVN 'trailingZeroes [lo]-              , val y $ appV 'bitSize [SigE (VarE 'undefined) loT]-              ]+              , val y $ loSizeE ]         , if signed then inlinable 'trailingZeroes                     else inline 'trailingZeroes         {- allZeroes = W allZeroes allZeroes -}@@ -1379,7 +1393,11 @@ #else       TySynInstD n ps t #endif-    inst cls params = InstanceD [] (foldl AppT (ConT cls) (ConT <$> params))+    inst cls params = InstanceD+#if MIN_VERSION_template_haskell(2,11,0)+                                Nothing+#endif+                                [] (foldl AppT (ConT cls) (ConT <$> params))     fun n e       = FunD n [Clause [] (NormalB e) []]     fun_ n e      = FunD n [Clause [WildP] (NormalB e) []]     funX' n e ds  = FunD n [Clause [VarP x] (NormalB e) ds]@@ -1427,6 +1445,15 @@     litS = LitE . StringL     zeroE = VarE 'allZeroes     oneE  = VarE 'lsb+#if MIN_VERSION_base(4,7,0)+    loSizeE = appV 'finiteBitSize [SigE (VarE 'undefined) loT]+    hiSizeE = appV 'finiteBitSize [SigE (VarE 'undefined) hiT]+    sizeE   = appV 'finiteBitSize [SigE (VarE 'undefined) tpT]+#else+    loSizeE = appV 'bitSize [SigE (VarE 'undefined) loT]+    hiSizeE = appV 'bitSize [SigE (VarE 'undefined) hiT]+    sizeE   = appV 'bitSize [SigE (VarE 'undefined) tpT]+#endif     mkRules = do       let idRule = RuleP ("fromIntegral/" ++ show tp ++ "->" ++ show tp) []                          (VarE 'fromIntegral)

@@ -1,4 +1,5 @@ {-# LANGUAGE UnicodeSyntax #-}+{-# LANGUAGE CPP #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-}@@ -44,34 +45,11 @@ main = defaultMain      $ localOption (QuickCheckTests 10000)      $ testGroup "Tests"-         [ arbTestGroup "Word8" (0 ∷ Word8)-         , arbTestGroup "Int8" (0 ∷ Int8)-         , arbTestGroup "Word16" (0 ∷ Word16)-         , arbTestGroup "Int16" (0 ∷ Int16)-         , arbTestGroup "Word32" (0 ∷ Word32)-         , arbTestGroup "Int32" (0 ∷ Int32)-         , arbTestGroup "Word64" (0 ∷ Word64)-         , arbTestGroup "Int64" (0 ∷ Int64)-         , isoTestGroup "|Word32|Word32|" (0 ∷ U64)+         [ isoTestGroup "|Word32|Word32|" (0 ∷ U64)          , isoTestGroup "|Int32|Word32|" (0 ∷ I64)          , isoTestGroup "|Word16|Word16|Word32|" (0 ∷ UU64)          , isoTestGroup "|Int16|Word16|Word32|" (0 ∷ II64) ] -arbTestGroup name t =-  testGroup name-    [ testGroup "BinaryWord"-        [ testProperty "unwrappedAdd" $ prop_unwrappedAddArb t-        , testProperty "unwrappedMul" $ prop_unwrappedMulArb t-        , testProperty "leadingZeroes" $ prop_leadingZeroesArb t-        , testProperty "trailingZeroes" $ prop_trailingZeroesArb t-        , testProperty "allZeroes" $ prop_allZeroesArb t-        , testProperty "allOnes" $ prop_allOnesArb t-        , testProperty "msb" $ prop_msbArb t-        , testProperty "lsb" $ prop_lsbArb t-        , testProperty "testMsb" $ prop_testMsbArb t-        , testProperty "testLsb" $ prop_testLsbArb t ]-    ]- isoTestGroup name t =   testGroup name     [ testProperty "Iso" $ prop_conv t@@ -131,60 +109,9 @@         ]     ] -prop_unwrappedAddArb ∷ ∀ α-                     . (Integral α, BinaryWord α, Bounded (UnsignedWord α),-                        Integral (UnsignedWord α))-                     ⇒ α → α → α → Bool-prop_unwrappedAddArb _ x y = s == toInteger x + toInteger y-  where (hi, lo) = unwrappedAdd x y-        s = toInteger hi * (toInteger (maxBound ∷ UnsignedWord α) + 1)-          + toInteger lo--prop_unwrappedMulArb ∷ ∀ α-                     . (Integral α, BinaryWord α, Bounded (UnsignedWord α),-                        Integral (UnsignedWord α))-                     ⇒ α → α → α → Bool-prop_unwrappedMulArb _ x y = p == toInteger x * toInteger y-  where (hi, lo) = unwrappedMul x y -        p = toInteger hi * (toInteger (maxBound ∷ UnsignedWord α) + 1)-          + toInteger lo--prop_leadingZeroesArb ∷ ∀ α . (Num α, BinaryWord α) ⇒ α → α → Bool-prop_leadingZeroesArb _ x-  | lz == 0   = testBit x (bs - 1)-  | lz == bs  = x == 0-  | otherwise = shiftR x (bs - lz) == 0 && testBit x (bs - lz - 1)-  where lz = leadingZeroes x-        bs = bitSize x--prop_trailingZeroesArb ∷ ∀ α . (Num α, BinaryWord α) ⇒ α → α → Bool-prop_trailingZeroesArb _ x-  | tz == 0   = testBit x 0-  | tz == bs  = x == 0-  | otherwise = shiftL x (bs - tz) == 0 && testBit x tz-  where tz = trailingZeroes x-        bs = bitSize x--prop_allZeroesArb ∷ ∀ α . BinaryWord α ⇒ α → Bool-prop_allZeroesArb a =-  all (not . testBit (allZeroes ∷ α)) [0 .. bitSize a - 1]--prop_allOnesArb ∷ ∀ α . BinaryWord α ⇒ α → Bool-prop_allOnesArb a = all (testBit (allOnes ∷ α)) [0 .. bitSize a - 1]--prop_msbArb ∷ ∀ α . BinaryWord α ⇒ α → Bool-prop_msbArb a = testBit (msb ∷ α) (bitSize a - 1) &&-                all (not . testBit (msb ∷ α)) [0 .. bitSize a - 2]--prop_lsbArb ∷ ∀ α . BinaryWord α ⇒ α → Bool-prop_lsbArb a = testBit (lsb ∷ α) 0 &&-                all (not . testBit (lsb ∷ α)) [1 .. bitSize a - 1]--prop_testMsbArb ∷ ∀ α . BinaryWord α ⇒ α → α → Bool-prop_testMsbArb _ x = testMsb x == testBit x (bitSize x - 1)--prop_testLsbArb ∷ ∀ α . BinaryWord α ⇒ α → α → Bool-prop_testLsbArb _ x = testLsb x == testBit x 0+#if !MIN_VERSION_base(4,7,0)+finiteBitSize = bitSize+#endif  toType ∷ Iso α τ ⇒ τ → α → τ  toType _ = fromArbitrary@@ -223,14 +150,14 @@ prop_pred t w = (w /= minBound) ==> (pred w == withUnary t pred w)  prop_unwrappedAdd ∷ (Iso α τ, Iso (UnsignedWord α) (UnsignedWord τ),-                     BinaryWord α, BinaryWord τ, Eq α, Eq (UnsignedWord α))+                     BinaryWord α, BinaryWord τ)                   ⇒ τ → α → α → Bool prop_unwrappedAdd t x y = h1 == toArbitrary h2 && l1 == toArbitrary l2   where (h1, l1) = unwrappedAdd x y         (h2, l2) = unwrappedAdd (toType t x) (toType t y)  prop_unwrappedMul ∷ (Iso α τ, Iso (UnsignedWord α) (UnsignedWord τ),-                     BinaryWord α, BinaryWord τ, Eq α, Eq (UnsignedWord α))+                     BinaryWord α, BinaryWord τ)                   ⇒ τ → α → α → Bool prop_unwrappedMul t x y = h1 == toArbitrary h2 && l1 == toArbitrary l2   where (h1, l1) = unwrappedMul x y@@ -280,18 +207,18 @@ prop_and = propBinary (.&.) (.&.) prop_or = propBinary (.|.) (.|.) propOffsets f g t w =-  all (\b → f w b == withUnary t (`g` b) w) [0 .. bitSize t]+  all (\b → f w b == withUnary t (`g` b) w) [0 .. finiteBitSize t] prop_shiftL = propOffsets shiftL shiftL prop_shiftR = propOffsets shiftR shiftR prop_rotateL = propOffsets rotateL rotateL prop_rotateR = propOffsets rotateR rotateR-prop_bit t = all (\b → bit b == fromType t (bit b)) [0 .. bitSize t - 1]+prop_bit t = all (\b → bit b == fromType t (bit b)) [0 .. finiteBitSize t - 1] propBits f g t w =-  all (\b → f w b == withUnary t (`g` b) w) [0 .. bitSize t - 1]+  all (\b → f w b == withUnary t (`g` b) w) [0 .. finiteBitSize t - 1] prop_setBit = propBits setBit setBit prop_clearBit = propBits clearBit clearBit prop_complementBit = propBits complementBit complementBit prop_testBit t w =-  all (\b → testBit w b == withUnary' t (`testBit` b) w) [0 .. bitSize t - 1]+  all (\b → testBit w b == withUnary' t (`testBit` b) w) [0 .. finiteBitSize t - 1] prop_popCount = propUnary' popCount popCount