data-dword 0.1 → 0.2
raw patch · 6 files changed
+81/−56 lines, 6 files
Files
- data-dword.cabal +2/−2
- src/Data/DoubleWord.hs +11/−1
- src/Data/DoubleWord/Base.hs +10/−7
- src/Data/DoubleWord/TH.hs +54/−42
- tests/Tests.hs +1/−1
- tests/Types.hs +3/−3
data-dword.cabal view
@@ -1,5 +1,5 @@ Name: data-dword-Version: 0.1+Version: 0.2 Category: Data Stability: experimental Synopsis: Stick two binary words together to get a bigger one@@ -27,7 +27,7 @@ Library Default-Language: Haskell2010 Build-Depends:- base >= 4.5 && < 5,+ base >= 4.6 && < 5, hashable >= 1.1, template-haskell >= 2.8, ghc-prim
src/Data/DoubleWord.hs view
@@ -1,6 +1,8 @@-{-# LANGUAGE UnicodeSyntax #-} {-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE UnicodeSyntax #-} {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-} -- | This module provides strict (low and high halves are unpacked) -- signed and unsigned binary word data types of sizes 96, 128,@@ -21,15 +23,23 @@ , Int256(..) ) where +import Data.Data+import GHC.Generics import Data.Word import Data.Int import Data.DoubleWord.Base import Data.DoubleWord.TH mkUnpackedDoubleWord "Word96" ''Word32 "Int96" ''Int32 ''Word64+ [''Typeable, ''Data, ''Generic] mkUnpackedDoubleWord "Word128" ''Word64 "Int128" ''Int64 ''Word64+ [''Typeable, ''Data, ''Generic] mkUnpackedDoubleWord "Word160" ''Word32 "Int160" ''Int32 ''Word128+ [''Typeable, ''Data, ''Generic] mkUnpackedDoubleWord "Word192" ''Word64 "Int192" ''Int64 ''Word128+ [''Typeable, ''Data, ''Generic] mkUnpackedDoubleWord "Word224" ''Word96 "Int224" ''Int96 ''Word128+ [''Typeable, ''Data, ''Generic] mkUnpackedDoubleWord "Word256" ''Word128 "Int256" ''Int128 ''Word128+ [''Typeable, ''Data, ''Generic]
src/Data/DoubleWord/Base.hs view
@@ -233,7 +233,7 @@ #else unwrappedAdd x y = hi `seq` lo `seq` (hi, lo) where lo = x + y- hi = if lo > x then 1 else 0+ hi = if lo < x then 1 else 0 {-# INLINABLE unwrappedAdd #-} #endif #if __GLASGOW_HASKELL__ >= 705 && WORD_SIZE_IN_BITS == 64@@ -244,16 +244,19 @@ {-# INLINE unwrappedMul #-} #else unwrappedMul x y = hi `seq` lo `seq` (hi, lo)- where xHi = hiWord x- xLo = loWord x- yHi = hiWord y- yLo = loWord y+ 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- lo = lo0 + shiftL p1 32 + shiftL p2 32- hi = hi0 + shiftR p1 32 + shiftR p2 32+ 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
src/Data/DoubleWord/TH.hs view
@@ -21,8 +21,8 @@ -- the specified low and high halves. The high halves /must/ have -- less or equal bit-length than the lover half. For each data type -- the following instances are declared: 'DoubleWord', 'Eq', 'Ord',--- 'Bounded', 'Enum', 'Num', 'Real', 'Integral', 'Show', 'Hashable',--- 'Ix', 'Bits', 'BinaryWord'.+-- 'Bounded', 'Enum', 'Num', 'Real', 'Integral', 'Show', 'Read',+-- 'Hashable', 'Ix', 'Bits', 'BinaryWord'. mkDoubleWord ∷ String -- ^ Unsigned variant type name → String -- ^ Unsigned variant constructor name → Strict -- ^ Unsigned variant higher half strictness@@ -33,14 +33,16 @@ → Name -- ^ Signed variant higher half type → Strict -- ^ Lower half strictness → Name -- ^ Lower half type+ → [Name] -- ^ List of instances for automatic derivation → Q [Dec]-mkDoubleWord un uc uhs uhn sn sc shs shn ls ln =- (++) <$> mkDoubleWord' False un' uc' sn' sc' uhs (ConT uhn) ls (ConT ln)- <*> mkDoubleWord' True sn' sc' un' uc' shs (ConT shn) ls (ConT ln)+mkDoubleWord un uc uhs uhn sn sc shs shn ls ln ad =+ (++) <$> mkDoubleWord' False un' uc' sn' sc' uhs (ConT uhn) ls lt ad+ <*> mkDoubleWord' True sn' sc' un' uc' shs (ConT shn) ls lt ad where un' = mkName un uc' = mkName uc sn' = mkName sn sc' = mkName sc+ lt = ConT ln -- | @'mkUnpackedDoubleWord' u uh s sh l@ is an alias for -- @'mkDoubleWord' u u 'Unpacked' uh s s 'Unpacked' sh 'Unpacked' l@@@ -49,18 +51,20 @@ → String -- ^ Signed variant type name → Name -- ^ Signed variant higher half type → Name -- ^ Lower half type+ → [Name] -- ^ List of instances for automatic derivation → Q [Dec]-mkUnpackedDoubleWord un uhn sn shn ln =- mkDoubleWord un un Unpacked uhn sn sn Unpacked shn Unpacked ln+mkUnpackedDoubleWord un uhn sn shn ln ad =+ mkDoubleWord un un Unpacked uhn sn sn Unpacked shn Unpacked ln ad mkDoubleWord' ∷ Bool → Name → Name → Name → Name → Strict → Type → Strict → Type+ → [Name] → Q [Dec]-mkDoubleWord' signed tp cn otp ocn hiS hiT loS loT = (<$> mkRules) $ (++) $- [ DataD [] tp [] [NormalC cn [(hiS, hiT), (loS, loT)]] []+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@@ -98,7 +102,7 @@ CaseE (appVN 'compare [hi, hi']) [ Match (ConP 'EQ []) (NormalB (appVN 'compare [lo, lo'])) [] , Match (VarP x) (NormalB (VarE x)) [] ]- , inline 'compare ]+ , inlinable 'compare ] , inst ''Bounded [tp] {- minBound = W minBound minBound -} [ fun 'minBound $ appWN ['minBound, 'minBound]@@ -114,7 +118,7 @@ [ funHiLo 'succ $ CondE (appVN '(==) [lo, 'maxBound]) (appW [appVN 'succ [hi], VarE 'minBound]) (appW [VarE hi, appVN 'succ [lo]])- , inline 'succ+ , inlinable 'succ {- pred (W hi lo) = if lo == minBound then W (pred hi) maxBound else W hi (pred lo)@@ -122,7 +126,7 @@ , funHiLo 'pred $ CondE (appVN '(==) [lo, 'minBound]) (appW [appVN 'pred [hi], VarE 'maxBound]) (appW [VarE hi, appVN 'pred [lo]])- , inline 'pred+ , inlinable 'pred {- toEnum x | x < 0 = if signed@@ -145,7 +149,6 @@ ] else appV 'error [litS "toEnum: nagative value"]) (appW [VarE 'allZeroes, appVN 'toEnum [x]])- , inline 'toEnum {- fromEnum (W 0 lo) = fromEnum lo fromEnum (W (-1) lo) = if signed then negate $ fromEnum $ negate lo@@ -170,7 +173,6 @@ (NormalB $ appV 'error [litS "fromEnum: out of bounds"]) [] ]- , inline 'fromEnum {- enumFrom x = enumFromTo x maxBound -} , funX 'enumFrom $ appVN 'enumFromTo [x, 'maxBound] , inline 'enumFrom@@ -184,7 +186,7 @@ , VarE y , CondE (appVN '(>=) [x, y]) (VarE 'maxBound) (VarE 'minBound) ]- , inline 'enumFromThen+ , inlinable 'enumFromThen {- enumFromTo x y = case y `compare` x of LT → x : down y x@@ -234,7 +236,6 @@ [ValD (VarP next) (NormalB $ appVN '(+) [c, 'lsb]) []] ]- , inlinable 'enumFromTo {- enumFromThenTo x y z = case y `compare` x of LT → if z > x then [] else down (x - y) z x@@ -282,7 +283,6 @@ (ConE '[]) (appVN up [step, to, next]) ]) [ValD (VarP next) (NormalB $ appVN '(+) [c, step]) []]]- , inlinable 'enumFromThenTo ] , inst ''Num [tp] {-@@ -294,7 +294,7 @@ (appW [appVN 'negate [hi], zeroE]) (appW [ appV 'negate [appVN '(+) ['lsb, hi]] , appVN 'negate [lo] ])- , inline 'negate+ , inlinable 'negate {- abs x = if SIGNED then if x < 0 then negate x else x @@ -305,7 +305,7 @@ then CondE (appVN '(<) [x, 'allZeroes]) (appVN 'negate [x]) (VarE x) else VarE x- , inline 'abs+ , if signed then inlinable 'abs else inline 'abs {- signum (W hi lo) = if SIGNED then case hi `compare` 0 of@@ -328,7 +328,7 @@ else CondE (appV '(&&) [ appVN '(==) [hi, 'allZeroes] , appVN '(==) [lo, 'allZeroes] ]) zeroE oneE- , inline 'signum+ , inlinable 'signum {- (W hi lo) + (W hi' lo') = W y x where x = lo + lo'@@ -379,13 +379,12 @@ , appV '(+) [appV 'toInteger [SigE (VarE 'maxBound) loT], litI 1] ])]- , inlinable 'fromInteger ] , inst ''Real [tp] {- toRational x = toInteger x % 1 -} [ funX 'toRational $ appV '(%) [appVN 'toInteger [x], litI 1] , inline 'toRational ]- , inst ''Integral [tp]+ , inst ''Integral [tp] $ {- toInteger (W hi lo) = toInteger hi * (toInteger (maxBound ∷ L) + 1) + toInteger lo@@ -811,11 +810,21 @@ , appVN 'signedWord [r] ]))) else fun 'divMod $ VarE 'quotRem- , inline 'divMod- ]+ ] +++ if signed then [] else [inline 'divMod] , inst ''Show [tp] [ fun 'show $ appVN '(.) ['show, 'toInteger] , inline 'show ]+ , inst ''Read [tp]+ {-+ readsPrec x y = fmap (\(q, r) → (fromInteger q, r))+ $ readsPrec x y+ -}+ [ funXY 'readsPrec $+ appV 'fmap [ LamE [TupP [VarP q, VarP r]]+ (TupE [appVN 'fromInteger [q], VarE r])+ , appVN 'readsPrec [x, y] ]+ ] , inst ''Hashable [tp] {- hash (W hi lo) = hash hi `combine` hash lo -} [ funHiLo 'hash $ appV 'combine [appVN 'hash [hi], appVN 'hash [lo]]@@ -833,7 +842,7 @@ , funTupZ 'inRange $ appV '(&&) [appVN '(>=) [z, x], appVN '(<=) [z, y]] , inline 'inRange ]- , inst ''Bits [tp]+ , inst ''Bits [tp] $ {- bitSize _ = bitSize (undefined ∷ H) + bitSize (undefined ∷ L) -} [ fun_ 'bitSize $ appV '(+)@@ -988,7 +997,7 @@ [val y $ appV '(-) [ VarE x , appV 'bitSize [SigE (VarE 'undefined) loT] ]]- , inline 'bit+ , inlinable 'bit {- setBit (W hi lo) x = if y >= 0 then W (setBit hi y) lo else W hi (setBit lo x)@@ -1001,7 +1010,7 @@ [val y $ appV '(-) [ VarE x , appV 'bitSize [SigE (VarE 'undefined) loT] ]]- , inline 'setBit+ , inlinable 'setBit {- clearBit (W hi lo) x = if y >= 0 then W (clearBit hi y) lo@@ -1015,7 +1024,7 @@ [val y $ appV '(-) [ VarE x , appV 'bitSize [SigE (VarE 'undefined) loT] ]]- , inline 'clearBit+ , inlinable 'clearBit {- complementBit (W hi lo) x = if y >= 0 then W (complementBit hi y) lo@@ -1029,7 +1038,7 @@ [val y $ appV '(-) [ VarE x , appV 'bitSize [SigE (VarE 'undefined) loT] ]]- , inline 'complementBit+ , inlinable 'complementBit {- testBit (W hi lo) x = if y >= 0 then testBit hi y else testBit lo x@@ -1042,12 +1051,13 @@ [val y $ appV '(-) [ VarE x , appV 'bitSize [SigE (VarE 'undefined) loT] ]]- , inline 'testBit+ , inlinable 'testBit {- popCount (W hi lo) = popCount hi + popCount lo -} , funHiLo 'popCount (appV '(+) [appVN 'popCount [hi], appVN 'popCount [lo]]) , inline 'popCount- ]+ ] +++ if signed then [inline 'rotateL] else [] , inst ''BinaryWord [tp] [ TySynInstD ''UnsignedWord [tpT] $ ConT $ if signed then otp else tp@@ -1228,7 +1238,8 @@ [ val x $ appVN 'leadingZeroes [hi] , val y $ appV 'bitSize [SigE (VarE 'undefined) hiT] ]- , inline 'leadingZeroes+ , if signed then inlinable 'leadingZeroes+ else inline 'leadingZeroes {- UNSIGNED: trailingZeroes (W hi lo) =@@ -1249,7 +1260,8 @@ [ val x $ appVN 'trailingZeroes [lo] , val y $ appV 'bitSize [SigE (VarE 'undefined) loT] ]- , inline 'trailingZeroes+ , if signed then inlinable 'trailingZeroes+ else inline 'trailingZeroes {- allZeroes = W allZeroes allZeroes -} , fun 'allZeroes $ appWN ['allZeroes, 'allZeroes] , inline 'allZeroes@@ -1305,16 +1317,16 @@ div1 = mkName "div1" div2 = mkName "div2" addT = mkName "addT"- by = mkName "by"- go = mkName "go"+ by = mkName "by_"+ go = mkName "go_" c = mkName "c"- next = mkName "next"- step = mkName "step"- to = mkName "to"- down = mkName "down"- up = mkName "up"- hi = mkName "hi"- lo = mkName "lo"+ next = mkName "next_"+ step = mkName "step_"+ to = mkName "to_"+ down = mkName "down_"+ up = mkName "up_"+ hi = mkName "hi_"+ lo = mkName "lo_" hi' = mkName "hi'" lo' = mkName "lo'" tpT = ConT tp
tests/Tests.hs view
@@ -59,7 +59,7 @@ , isoTestGroup "|Int16|Word16|Word32|" (0 ∷ II64) ] mempty { ropt_test_options =- Just (mempty { topt_maximum_generated_tests = Just 1000 })+ Just (mempty { topt_maximum_generated_tests = Just 10000 }) } arbTestGroup name t =
tests/Types.hs view
@@ -7,7 +7,7 @@ import Data.Int import Data.DoubleWord.TH -$(mkUnpackedDoubleWord "U64" ''Word32 "I64" ''Int32 ''Word32)-$(mkUnpackedDoubleWord "U48" ''Word16 "I48" ''Int16 ''Word32)-$(mkUnpackedDoubleWord "UU64" ''Word16 "II64" ''Int16 ''U48)+mkUnpackedDoubleWord "U64" ''Word32 "I64" ''Int32 ''Word32 []+mkUnpackedDoubleWord "U48" ''Word16 "I48" ''Int16 ''Word32 []+mkUnpackedDoubleWord "UU64" ''Word16 "II64" ''Int16 ''U48 []