data-dword 0.3 → 0.3.2.1
raw patch · 5 files changed
Files
- LICENSE +1/−1
- README.md +3/−0
- data-dword.cabal +6/−3
- src/Data/DoubleWord/TH.hs +271/−231
- tests/Tests.hs +30/−85
LICENSE view
@@ -1,4 +1,4 @@-Copyright (c) 2011-2014 Mikhail Vorozhtsov+Copyright (c) 2011-2019 Mikhail Vorozhtsov All rights reserved. Redistribution and use in source and binary forms, with or without
README.md view
@@ -1,5 +1,8 @@ Data-DWord ==========++[](https://travis-ci.org/mvv/data-dword) [](http://hackage.haskell.org/package/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.
data-dword.cabal view
@@ -1,5 +1,5 @@ Name: data-dword-Version: 0.3+Version: 0.3.2.1 Category: Data Stability: experimental Synopsis: Stick two binary words together to get a bigger one@@ -13,13 +13,17 @@ Author: Mikhail Vorozhtsov <mikhail.vorozhtsov@gmail.com> Maintainer: Mikhail Vorozhtsov <mikhail.vorozhtsov@gmail.com>-Copyright: 2011-2014 Mikhail Vorozhtsov <mikhail.vorozhtsov@gmail.com>+Copyright: 2011-2019 Mikhail Vorozhtsov <mikhail.vorozhtsov@gmail.com> License: BSD3 License-File: LICENSE Extra-Source-Files: README.md +Tested-With: GHC==7.6.3, GHC==7.8.4, GHC==7.10.3, GHC==8.0.2, GHC==8.2.2,+ GHC==8.4.4, GHC==8.6.5, GHC==8.8.4, GHC==8.10.7, GHC==9.0.1,+ GHC==9.2.1+ Cabal-Version: >= 1.10.0 Build-Type: Simple @@ -56,4 +60,3 @@ Main-Is: Tests.hs Other-Modules: Types-
src/Data/DoubleWord/TH.hs view
@@ -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)@@ -22,11 +21,20 @@ #else import Data.Hashable (Hashable(..), combine) #endif+#if !MIN_VERSION_base(4,12,0) import Control.Applicative ((<$>), (<*>))-import Language.Haskell.TH hiding (match)+#endif+import Language.Haskell.TH hiding (unpacked, match, conP) import Data.BinaryWord (BinaryWord(..)) import Data.DoubleWord.Base +tup ∷ [Exp] → Exp+#if MIN_VERSION_template_haskell(2,16,0)+tup = TupE . fmap Just+#else+tup = TupE+#endif+ -- | Declare signed and unsigned binary word types built from -- the specified low and high halves. The high halves /must/ have -- less or equal bit-length than the lover half. For each data type@@ -35,13 +43,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 +84,44 @@ → [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,12,0)+ [DerivClause Nothing (map ConT ad)]+#elif MIN_VERSION_template_haskell(2,11,0)+ (ConT <$> ad)+#else+ ad+#endif , inst ''DoubleWord [tp] [ tySynInst ''LoWord [tpT] loT , tySynInst ''HiWord [tpT] hiT@@ -110,7 +157,7 @@ -} [ funHiLo2 'compare $ CaseE (appVN 'compare [hi, hi'])- [ Match (ConP 'EQ []) (NormalB (appVN 'compare [lo, lo'])) []+ [ Match (conP 'EQ []) (NormalB (appVN 'compare [lo, lo'])) [] , Match (VarP x) (NormalB (VarE x)) [] ] , inlinable 'compare ] , inst ''Bounded [tp]@@ -166,10 +213,10 @@ fromEnum _ = ERROR -} , FunD 'fromEnum $- Clause [ConP cn [LitP $ IntegerL 0, VarP lo]]+ Clause [conP cn [LitP $ IntegerL 0, VarP lo]] (NormalB $ appVN 'fromEnum [lo]) [] : if signed- then [ Clause [ConP cn [LitP $ IntegerL (-1), VarP lo]]+ then [ Clause [conP cn [LitP $ IntegerL (-1), VarP lo]] (NormalB $ appV 'negate [appV 'fromEnum [appV 'negate [VarE lo]]])@@ -186,56 +233,35 @@ {- enumFrom x = enumFromTo x maxBound -} , funX 'enumFrom $ appVN 'enumFromTo [x, 'maxBound] , inline 'enumFrom- {- + {- enumFromThen x y =- enumFromThenTo x y $ if y >= x then maxBound else minBound + enumFromThenTo x y $ if y >= x then maxBound else minBound -} , funXY 'enumFromThen $ appV 'enumFromThenTo [ VarE x , VarE y- , CondE (appVN '(>=) [x, y]) (VarE 'maxBound) (VarE 'minBound)+ , CondE (appVN '(>=) [y, x]) (VarE 'maxBound) (VarE 'minBound) ] , inlinable 'enumFromThen {- enumFromTo x y = case y `compare` x of- LT → x : down y x+ LT → [] EQ → [x] GT → x : up y x- where down to c = next : if next == to then [] else down to next- where next = c - 1- up to c = next : if next == to then [] else up to next- where next = c + 1 + where up to c = next : if next == to then [] else up to next+ where next = c + 1 -} , FunD 'enumFromTo $ return $ Clause [VarP x, VarP y] (NormalB $ CaseE (appVN 'compare [y, x])- [ Match- (ConP 'LT [])- (NormalB $ appC '(:) [VarE x, appVN down [y, x]])- []- , Match- (ConP 'EQ [])- (NormalB $ appC '(:) [VarE x, ConE '[]])- []- , Match- (ConP 'GT [])- (NormalB $ appC '(:) [VarE x, appVN up [y, x]])- []+ [ match (conP 'LT []) (ConE '[])+ , match (conP 'EQ []) (singE $ VarE x)+ , match (conP 'GT []) $ appC '(:) [VarE x, appVN up [y, x]] ])- [ FunD down $ return $- Clause [VarP to, VarP c]- (NormalB $- appC '(:)- [ VarE next- , CondE (appVN '(==) [next, to])- (ConE '[]) (appVN down [to, next])- ])- [ValD (VarP next)- (NormalB $ appVN '(-) [c, 'lsb]) []]- , FunD up $ return $+ [ FunD up $ return $ Clause [VarP to, VarP c] (NormalB $ appC '(:)@@ -243,56 +269,66 @@ , CondE (appVN '(==) [next, to]) (ConE '[]) (appVN up [to, next]) ])- [ValD (VarP next)- (NormalB $ appVN '(+) [c, 'lsb]) []]+ [val next $ appVN '(+) [c, 'lsb]] ] {-- enumFromThenTo x y z = case y `compare` x of - LT → if z > x then [] else down (x - y) z x- EQ → repeat x- GT → if z < x then [] else up (y - x) z x- where down s to c = c : if next < to then [] else down s to next- where next = c - s- up s to c = c : if next > to then [] else up s to next- where next = c + s + enumFromThenTo x y z = case y `compare` x of+ LT → if z > y then (if z > x then [] else [x])+ else x : down step (z + step) y+ where step = x - y+ to = z + step+ down c | c < to = [c]+ | otherwise = c : down (c - step)+ EQ → if z < x then [] else repeat x+ GT → if z < y then (if z < x then [] else [x])+ else x : up step (z - step) y+ where step = y - x+ to = z - step+ up c | c > to = [c]+ | otherwise = c : up (c + step) -} , FunD 'enumFromThenTo $ return $ Clause [VarP x, VarP y, VarP z] (NormalB $ CaseE (appVN 'compare [y, x])- [ Match- (ConP 'LT [])- (NormalB $- CondE (appVN '(>) [z, x])- (ConE '[])- (appV down [appVN '(-) [x, y], VarE z, VarE x]))- []- , Match (ConP 'EQ []) (NormalB $ appVN 'repeat [x]) []- , Match- (ConP 'GT [])- (NormalB $- CondE (appVN '(<) [z, x]) (ConE '[])- (appV up [appVN '(-) [y, x], VarE z, VarE x]))- []+ [ match'+ (conP 'LT [])+ (CondE (appVN '(>) [z, y])+ (CondE (appVN '(>) [z, x])+ (ConE '[]) (singE $ VarE x))+ (appC '(:) [VarE x, appVN down [y]]))+ [ val step $ appVN '(-) [x, y]+ , val to $ appVN '(+) [z, step]+ , fun1 down c $+ CondE (appVN '(<) [c, to])+ (singE $ VarE c)+ (appC '(:)+ [ VarE c+ , appV down [appVN '(-) [c, step]]+ ])+ ]+ , match+ (conP 'EQ [])+ (CondE (appVN '(<) [z, x])+ (ConE '[]) (appVN 'repeat [x]))+ , match'+ (conP 'GT [])+ (CondE (appVN '(<) [z, y])+ (CondE (appVN '(<) [z, x])+ (ConE '[]) (singE $ VarE x))+ (appC '(:) [VarE x, appVN up [y]]))+ [ val step $ appVN '(-) [y, x]+ , val to $ appVN '(-) [z, step]+ , fun1 up c $+ CondE (appVN '(>) [c, to])+ (singE $ VarE c)+ (appC '(:)+ [ VarE c+ , appV up [appVN '(+) [c, step]]+ ])+ ] ])- [ FunD down $ return $- Clause [VarP step, VarP to, VarP c]- (NormalB $- appC '(:)- [ VarE c- , CondE (appVN '(<) [next, to])- (ConE '[]) (appVN down [step, to, next])- ])- [ValD (VarP next) (NormalB $ appVN '(-) [c, step]) []]- , FunD up $ return $- Clause [VarP step, VarP to, VarP c]- (NormalB $- appC '(:)- [ VarE c- , CondE (appVN '(==) [next, to])- (ConE '[]) (appVN up [step, to, next])- ])- [ValD (VarP next) (NormalB $ appVN '(+) [c, step]) []]]+ [] ] , inst ''Num [tp] {-@@ -305,9 +341,9 @@ (appW [ appV 'negate [appVN '(+) ['lsb, hi]] , appVN 'negate [lo] ]) , inlinable 'negate- {- + {- abs x = if SIGNED- then if x < 0 then negate x else x + then if x < 0 then negate x else x else x -} , funX 'abs $@@ -327,13 +363,13 @@ , funHiLo 'signum $ if signed then CaseE (appVN 'compare [hi, 'allZeroes])- [ Match (ConP 'LT [])+ [ Match (conP 'LT []) (NormalB $ appWN ['allOnes, 'maxBound]) []- , Match (ConP 'EQ [])+ , Match (conP 'EQ []) (NormalB $ CondE (appVN '(==) [lo, 'allZeroes]) zeroE oneE) []- , Match (ConP 'GT []) (NormalB oneE) []+ , Match (conP 'GT []) (NormalB oneE) [] ] else CondE (appV '(&&) [ appVN '(==) [hi, 'allZeroes] , appVN '(==) [lo, 'allZeroes] ])@@ -422,7 +458,7 @@ GT | lo' == 0 → (W 0 (fromIntegral t2), W (fromIntegral t1) lo) where (t2, t1) = quotRem hi hi'- GT | hi' == 0 && lo' == maxBound → + GT | hi' == 0 && lo' == maxBound → if t2 == 0 then if t1 == maxBound then (W 0 z + 1, 0)@@ -463,7 +499,7 @@ then (q1 - 2, t9 - t5) else (q1 - 2, (maxBound - t5) + t9 + 1) else- (q1 - 1, (maxBound - t5) + t7 + 1) + (q1 - 1, (maxBound - t5) + t7 + 1) else (q1, t6 - t5) where div1 hhh hll by = go hhh hll 0@@ -522,26 +558,26 @@ appV 'quotRem [ appV 'unsignedWord [appVN 'negate [x]] , appV 'unsignedWord [appVN 'negate [y]] ]]- (TupE [ appVN 'signedWord [q]+ (tup [ appVN 'signedWord [q] , appV 'signedWord [appVN 'negate [r]] ])) (LetE [vals [q, r] $ appV 'quotRem [ appV 'unsignedWord [appVN 'negate [x]] , appVN 'unsignedWord [y] ]]- (TupE [ appV 'signedWord [appVN 'negate [q]]+ (tup [ appV 'signedWord [appVN 'negate [q]] , appV 'signedWord [appVN 'negate [r]] ]))) (CondE (appVN 'testMsb [y]) (LetE [vals [q, r] $ appV 'quotRem [ appVN 'unsignedWord [x] , appV 'unsignedWord [appVN 'negate [y]] ]]- (TupE [ appV 'signedWord [appVN 'negate [q]]+ (tup [ appV 'signedWord [appVN 'negate [q]] , appVN 'signedWord [r] ])) (LetE [vals [q, r] $ appV 'quotRem [ appVN 'unsignedWord [x] , appVN 'unsignedWord [y] ]]- (TupE [ appVN 'signedWord [q]+ (tup [ appVN 'signedWord [q] , appVN 'signedWord [r] ]))) else funHiLo2XY' 'quotRem@@ -549,46 +585,46 @@ , appVN '(==) [lo', 'allZeroes] ]) (appV 'error [litS "divide by zero"]) (CaseE (appVN 'compare [hi, hi'])- [ match (ConP 'LT []) (TupE [zeroE, VarE x])- , match (ConP 'EQ [])+ [ match (conP 'LT []) (tup [zeroE, VarE x])+ , match (conP 'EQ []) (CaseE (appVN 'compare [lo, lo'])- [ match (ConP 'LT []) (TupE [zeroE, VarE x])- , match (ConP 'EQ []) (TupE [oneE, zeroE])- , Match (ConP 'GT [])+ [ match (conP 'LT []) (tup [zeroE, VarE x])+ , match (conP 'EQ []) (tup [oneE, zeroE])+ , Match (conP 'GT []) (GuardedB $ return ( NormalG (appVN '(==) [hi', 'allZeroes])- , TupE [ appWN ['allZeroes, t2]+ , tup [ appWN ['allZeroes, t2] , appWN ['allZeroes, t1] ])) [vals [t2, t1] $ appVN 'quotRem [lo, lo']]- , match (ConP 'GT []) $- TupE [ oneE+ , match (conP 'GT []) $+ tup [ oneE , appW [zeroE, appVN '(-) [lo, lo']] ] ])- , Match (ConP 'GT [])+ , Match (conP 'GT []) (GuardedB $ return ( NormalG (appVN '(==) [lo', 'allZeroes])- , TupE+ , tup [ appW [zeroE, appVN 'fromIntegral [t2]] , appW [appVN 'fromIntegral [t1], VarE lo] ] )) [vals [t2, t1] $ appVN 'quotRem [hi, hi']]- , Match (ConP 'GT [])+ , Match (conP 'GT []) (GuardedB $ return ( NormalG (appV '(&&) [ appVN '(==) [hi', 'allZeroes] , appVN '(==) [lo', 'maxBound] ]) , CondE (appVN '(==) [t2, 'allZeroes]) (CondE (appVN '(==) [t1, 'maxBound])- (TupE+ (tup [ appV '(+)- [ appWN ['allZeroes, z] + [ appWN ['allZeroes, z] , oneE ] , zeroE ])- (TupE+ (tup [ appWN ['allZeroes, z] , appWN ['allZeroes, t1] ])) (CondE (appVN '(==) [t1, 'maxBound])- (TupE+ (tup [ appV '(+) [appWN ['allZeroes, z], litI 2] , oneE ])@@ -597,11 +633,11 @@ [ VarE t1 , appVN 'xor ['maxBound, 'lsb] ])- (TupE+ (tup [ appV '(+) [appWN ['allZeroes, z], litI 2] , zeroE ])- (TupE+ (tup [ appV '(+) [appWN ['allZeroes, z], oneE] , appW [ zeroE@@ -610,28 +646,25 @@ )) [ val z $ appVN 'fromIntegral [hi] , vals [t2, t1] $ appVN 'unwrappedAdd [z, lo] ]- , Match (ConP 'GT [])+ , Match (conP 'GT []) (GuardedB $ return ( NormalG (appVN '(==) [hi', 'allZeroes])- , TupE [VarE t2, appWN ['allZeroes, t1]] ))+ , tup [VarE t2, appWN ['allZeroes, t1]] )) [vals [t2, t1] $ appVN div1 [hi, lo, lo']]- , match' (ConP 'GT [])+ , match' (conP 'GT []) (CondE (appVN '(==) [t1, t2])- (TupE [oneE, appVN '(-) [x, y]])- (TupE [ appW [zeroE, appVN 'fromIntegral [q2]]+ (tup [oneE, appVN '(-) [x, y]])+ (tup [ appW [zeroE, appVN 'fromIntegral [q2]] , appVN 'shiftR [r2, t2] ])) [ val t1 $ appVN 'leadingZeroes [hi] , 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]) [] - , ValD (AsP v $ ConP cn [VarP lhh, VarP lll])+ , ValD (conP cn [VarP hhh, VarP hll])+ (NormalB $ appVN 'shiftL [x, t2]) []+ , ValD (AsP v $ conP cn [VarP lhh, VarP lll]) (NormalB $ appVN 'shiftL [y, t2]) [] , ValD (TupP [ TupP [LitP (IntegerL 0), VarP q1] , VarP r1 ])@@ -647,24 +680,24 @@ CondE (appVN '(>) [t5, t6]) (CondE (appV '(==) [appVN 'loWord [t8], zeroE]) (CondE (appVN '(>=) [t7, t5])- (TupE [ appVN '(-) [q1, 'lsb]+ (tup [ appVN '(-) [q1, 'lsb] , appVN '(-) [t7, t5] ]) (CondE (appV '(==) [ appVN 'loWord [t10] , zeroE ])- (TupE [ appV '(-) [VarE q1, litI 2]+ (tup [ appV '(-) [VarE q1, litI 2] , appVN '(-) [t9, t5] ])- (TupE [ appV '(-) [VarE q1, litI 2]+ (tup [ appV '(-) [VarE q1, litI 2] , appV '(+) [ appVN '(-) ['maxBound, t5] , appVN '(+) [t9, 'lsb] ] ])))- (TupE [ appVN '(-) [q1, 'lsb]+ (tup [ appVN '(-) [q1, 'lsb] , appV '(+) [ appVN '(-) ['maxBound, t5] , appVN '(+) [t7, 'lsb] ] ]))- (TupE [VarE q1, appVN '(-) [t6, t5]])+ (tup [VarE q1, appVN '(-) [t6, t5]]) ] ])) [ FunD div1 $ return $@@ -675,7 +708,7 @@ Clause [VarP h, VarP l, VarP c] (NormalB (CondE (appVN '(==) [z, 'allZeroes])- (TupE [ appV '(+)+ (tup [ appV '(+) [ VarE c , appV '(+) [ appW [ appVN 'fromIntegral [t8]@@ -705,17 +738,17 @@ Clause [VarP hhh, VarP hll, VarP by] (NormalB (appV go [ VarE hhh , VarE hll- , TupE [zeroE, zeroE]]))+ , tup [zeroE, zeroE]])) [ vals [t2, t1] $ appVN 'quotRem ['maxBound, by] , FunD go $ return $ Clause [VarP h, VarP l, VarP c] (NormalB (CondE (appVN '(==) [z, 'allZeroes])- (TupE [ appV addT+ (tup [ appV addT [ VarE c , appV addT- [ TupE [VarE t8 , VarE t7]- , TupE [zeroE, VarE t10] ]+ [ tup [VarE t8 , VarE t7]+ , tup [zeroE, VarE t10] ] ] , VarE t9 ]) (appV go@@ -723,7 +756,7 @@ , VarE t5 , appV addT [ VarE c- , TupE [VarE t8, VarE t7]+ , tup [VarE t8, VarE t7] ] ]))) [ vals [t4, t3] $@@ -737,7 +770,7 @@ Clause [ TupP [VarP lhh, VarP lhl] , TupP [VarP llh, VarP lll] ]- (NormalB (TupE [ appV '(+)+ (NormalB (tup [ appV '(+) [ VarE t4 , appVN '(+) [lhh, llh] ]@@ -765,7 +798,7 @@ if r == 0 then (q1, r1) else (q1 - 1, r1 + y)- else + else if y < 0 then let (q, r) = quotRem (unsignedWord x) (negate $ unsignedWord y)@@ -787,7 +820,7 @@ appV 'quotRem [ appV 'unsignedWord [appVN 'negate [x]] , appV 'unsignedWord [appVN 'negate [y]] ]]- (TupE [ appVN 'signedWord [q]+ (tup [ appVN 'signedWord [q] , appV 'signedWord [appVN 'negate [r]] ])) (LetE [ vals [q, r] $ appV 'quotRem@@ -797,8 +830,8 @@ , val r1 $ appV 'signedWord [appVN 'negate [r]] ] (CondE (appVN '(==) [r, 'allZeroes])- (TupE [VarE q1, VarE r1])- (TupE [ appVN '(-) [q1, 'lsb]+ (tup [VarE q1, VarE r1])+ (tup [ appVN '(-) [q1, 'lsb] , appVN '(+) [r1, y] ])))) (CondE (appVN 'testMsb [y]) (LetE [ vals [q, r] $@@ -809,14 +842,14 @@ , val r1 $ appVN 'signedWord [r] ] (CondE (appVN '(==) [r, 'allZeroes])- (TupE [VarE q1, VarE r1])- (TupE [ appVN '(-) [q1, 'lsb]+ (tup [VarE q1, VarE r1])+ (tup [ appVN '(-) [q1, 'lsb] , appVN '(+) [r1, y] ]))) (LetE [vals [q, r] $ appV 'quotRem [ appVN 'unsignedWord [x] , appVN 'unsignedWord [y] ]]- (TupE [ appVN 'signedWord [q]+ (tup [ appVN 'signedWord [q] , appVN 'signedWord [r] ]))) else fun 'divMod $ VarE 'quotRem@@ -832,7 +865,7 @@ -} [ funXY 'readsPrec $ appV 'fmap [ LamE [TupP [VarP q, VarP r]]- (TupE [appVN 'fromInteger [q], VarE r])+ (tup [appVN 'fromInteger [q], VarE r]) , appVN 'readsPrec [x, y] ] ] , inst ''Hashable [tp]@@ -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@@ -965,7 +992,7 @@ funXY 'rotateL $ appV 'signedWord [appV 'rotateL [appVN 'unsignedWord [x], VarE y]]- else + else funHiLoX' 'rotateL (CondE (appV '(>=) [VarE y, litI 0]) (appW@@ -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]@@ -1097,7 +1113,7 @@ {- UNSIGNED: unsignedWord = id- + SIGNED: unsignedWord (W hi lo) = U (unsignedWord hi) lo -}@@ -1111,7 +1127,7 @@ {- UNSIGNED: signedWord (W hi lo) = S (signedWord hi) lo- + SIGNED: signedWord = id -}@@ -1125,7 +1141,7 @@ {- UNSIGNED: unwrappedAdd (W hi lo) (W hi' lo') = (W 0 z, W y x)- where (t1, x) = unwrappedAdd lo lo' + where (t1, x) = unwrappedAdd lo lo' (t3, t2) = unwrappedAdd hi (fromIntegral t1) (t4, y) = unwrappedAdd t2 hi' z = fromIntegral $ t3 + t4@@ -1138,7 +1154,7 @@ -} , if signed then- funXY' 'unwrappedAdd (TupE [VarE z, VarE t4])+ funXY' 'unwrappedAdd (tup [VarE z, VarE t4]) [ val t1 $ CondE (appVN 'testMsb [x]) (VarE 'maxBound) (VarE 'minBound) , val t2 $ CondE (appVN 'testMsb [y])@@ -1151,7 +1167,7 @@ ] else funHiLo2' 'unwrappedAdd- (TupE [appWN ['allZeroes, z], appWN [y, x]])+ (tup [appWN ['allZeroes, z], appWN [y, x]]) [ vals [t1, x] $ appVN 'unwrappedAdd [lo, lo'] , vals [t3, t2] $ appV 'unwrappedAdd [VarE hi, appVN 'fromIntegral [t1]]@@ -1193,7 +1209,7 @@ -} , if signed then- funHiLo2' 'unwrappedMul (TupE [VarE x, VarE y])+ funHiLo2' 'unwrappedMul (tup [VarE x, VarE y]) [ val t1 $ appV '(+) [ appW [ appVN 'complement [hi'] , appVN 'complement [lo'] ]@@ -1217,7 +1233,7 @@ ] else funHiLo2' 'unwrappedMul- (TupE [ appW+ (tup [ appW [ appV '(+) [ VarE hhh , appV '(+)@@ -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 -}@@ -1374,13 +1388,20 @@ lo' = mkName "lo'" tpT = ConT tp tySynInst n ps t =-#if MIN_VERSION_template_haskell(2,9,0)+#if MIN_VERSION_template_haskell(2,15,0)+ TySynInstD (TySynEqn Nothing (foldl AppT (ConT n) ps) t)+#elif 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))+ 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) []]+ fun1 n a e = FunD n [Clause [VarP a] (NormalB e) []] fun_ n e = FunD n [Clause [WildP] (NormalB e) []] funX' n e ds = FunD n [Clause [VarP x] (NormalB e) ds] funX n e = funX' n e []@@ -1391,23 +1412,23 @@ FunD n [Clause [TupP [VarP x, VarP y], VarP z] (NormalB e) []] funTupLZ n e = FunD n [Clause [TupP [VarP x, WildP], VarP z] (NormalB e) []]- funLo n e = FunD n [Clause [ConP cn [WildP, VarP lo]] (NormalB e) []]- funHi n e = FunD n [Clause [ConP cn [VarP hi, WildP]] (NormalB e) []]+ funLo n e = FunD n [Clause [conP cn [WildP, VarP lo]] (NormalB e) []]+ funHi n e = FunD n [Clause [conP cn [VarP hi, WildP]] (NormalB e) []] funHiLo n e = funHiLo' n e [] funHiLo' n e ds =- FunD n [Clause [ConP cn [VarP hi, VarP lo]] (NormalB e) ds]+ FunD n [Clause [conP cn [VarP hi, VarP lo]] (NormalB e) ds] funHiLoX' n e ds =- FunD n [Clause [ConP cn [VarP hi, VarP lo], VarP x] (NormalB e) ds]+ FunD n [Clause [conP cn [VarP hi, VarP lo], VarP x] (NormalB e) ds] funHiLo2 n e = funHiLo2' n e [] funHiLo2' n e ds =- FunD n [Clause [ ConP cn [VarP hi, VarP lo]- , ConP cn [VarP hi', VarP lo'] ]+ FunD n [Clause [ conP cn [VarP hi, VarP lo]+ , conP cn [VarP hi', VarP lo'] ] (NormalB e) ds] funHiLo2XY' n e ds =- FunD n [Clause [ AsP x (ConP cn [VarP hi, VarP lo])- , AsP y (ConP cn [VarP hi', VarP lo']) ]+ FunD n [Clause [ AsP x (conP cn [VarP hi, VarP lo])+ , AsP y (conP cn [VarP hi', VarP lo']) ] (NormalB e) ds]- funXHiLo n e = FunD n [Clause [VarP x, ConP cn [VarP hi, VarP lo]]+ funXHiLo n e = FunD n [Clause [VarP x, conP cn [VarP hi, VarP lo]] (NormalB e) []] match' p e ds = Match p (NormalB e) ds match p e = match' p e []@@ -1427,12 +1448,35 @@ 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+ singE e = appC '(:) [e, ConE '[]]+ conP name ps =+ ConP name+#if MIN_VERSION_template_haskell(2,18,0)+ [] ps+#else+ ps+#endif+ ruleP name lhs rhs phases =+ RuleP name+#if MIN_VERSION_template_haskell(2,15,0)+ Nothing+#endif+ [] lhs rhs phases mkRules = do- let idRule = RuleP ("fromIntegral/" ++ show tp ++ "->" ++ show tp) []+ let idRule = ruleP ("fromIntegral/" ++ show tp ++ "->" ++ show tp) (VarE 'fromIntegral) (SigE (VarE 'id) (AppT (AppT ArrowT tpT) tpT)) AllPhases- signRule = RuleP ("fromIntegral/" ++ show tp ++ "->" ++ show otp) []+ signRule = ruleP ("fromIntegral/" ++ show tp ++ "->" ++ show otp) (VarE 'fromIntegral) (SigE (VarE (if signed then 'unsignedWord else 'signedWord))@@ -1443,32 +1487,30 @@ (VarE 'extendLo) (VarE 'signExtendLo) mkRules' rules t narrowE extE signExtE = do- let narrowRule = RuleP ("fromIntegral/" ++ show tp ++ "->" ++ showT t)- []+ let narrowRule = ruleP ("fromIntegral/" ++ show tp ++ "->" ++ showT t) (VarE 'fromIntegral) (SigE narrowE (AppT (AppT ArrowT tpT) t)) AllPhases- extRule = RuleP ("fromIntegral/" ++ showT t ++ "->" ++ show tp)- []+ extRule = ruleP ("fromIntegral/" ++ showT t ++ "->" ++ show tp) (VarE 'fromIntegral) (SigE extE (AppT (AppT ArrowT t) tpT)) AllPhases signedRules ← do insts ← reifyInstances ''SignedWord [t] case insts of-#if MIN_VERSION_template_haskell(2,9,0)+#if MIN_VERSION_template_haskell(2,15,0)+ [TySynInstD (TySynEqn _ _ signT)] → return $+#elif MIN_VERSION_template_haskell(2,9,0) [TySynInstD _ (TySynEqn _ signT)] → return $ #else [TySynInstD _ _ signT] → return $ #endif- [ RuleP ("fromIntegral/" ++ show tp ++ "->" ++ showT signT)- []+ [ ruleP ("fromIntegral/" ++ show tp ++ "->" ++ showT signT) (VarE 'fromIntegral) (SigE (AppE (appVN '(.) ['signedWord]) narrowE) (AppT (AppT ArrowT tpT) signT)) AllPhases- , RuleP ("fromIntegral/" ++ showT signT ++ "->" ++ show tp)- []+ , ruleP ("fromIntegral/" ++ showT signT ++ "->" ++ show tp) (VarE 'fromIntegral) (SigE signExtE (AppT (AppT ArrowT signT) tpT)) AllPhases ]@@ -1479,30 +1521,26 @@ let smallRules = ts >>= \(uSmallName, sSmallName) → let uSmallT = ConT uSmallName sSmallT = ConT sSmallName in- [ RuleP ("fromIntegral/" +++ [ ruleP ("fromIntegral/" ++ show tp ++ "->" ++ show uSmallName)- [] (VarE 'fromIntegral) (SigE (appV '(.) [VarE 'fromIntegral, narrowE]) (AppT (AppT ArrowT tpT) uSmallT)) AllPhases- , RuleP ("fromIntegral/" +++ , ruleP ("fromIntegral/" ++ show uSmallName ++ "->" ++ show tp)- [] (VarE 'fromIntegral) (SigE (appV '(.) [extE, VarE 'fromIntegral]) (AppT (AppT ArrowT uSmallT) tpT)) AllPhases- , RuleP ("fromIntegral/" +++ , ruleP ("fromIntegral/" ++ show tp ++ "->" ++ show sSmallName)- [] (VarE 'fromIntegral) (SigE (appV '(.) [VarE 'fromIntegral, narrowE]) (AppT (AppT ArrowT tpT) sSmallT)) AllPhases- , RuleP ("fromIntegral/" +++ , ruleP ("fromIntegral/" ++ show sSmallName ++ "->" ++ show tp)- [] (VarE 'fromIntegral) (SigE (appV '(.) [signExtE, VarE 'fromIntegral]) (AppT (AppT ArrowT sSmallT) tpT))@@ -1512,7 +1550,9 @@ _ → do insts ← reifyInstances ''LoWord [t] case insts of-#if MIN_VERSION_template_haskell(2,9,0)+#if MIN_VERSION_template_haskell(2,15,0)+ [TySynInstD (TySynEqn _ _ t')] →+#elif MIN_VERSION_template_haskell(2,9,0) [TySynInstD _ (TySynEqn _ t')] → #else [TySynInstD _ _ t'] →
tests/Tests.hs view
@@ -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@@ -82,7 +60,10 @@ , testProperty "maxBound" $ prop_maxBound t ] , testGroup "Enum" [ testProperty "succ" $ prop_succ t- , testProperty "pred" $ prop_pred t ]+ , testProperty "pred" $ prop_pred t+ , testProperty "enumFromTo" $ prop_enumFromTo t+ , testProperty "enumFromThen" $ prop_enumFromThen t+ , testProperty "enumFromThenTo" $ prop_enumFromThenTo t ] , testGroup "Num" [ testProperty "negate" $ prop_negate t , testProperty "abs" $ prop_abs t@@ -131,60 +112,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@@ -204,12 +134,18 @@ withBinary' ∷ Iso α τ ⇒ τ → (τ → τ → β) → α → α → β withBinary' _ f x y = f (fromArbitrary x) (fromArbitrary y) +withTernary' ∷ Iso α τ ⇒ τ → (τ → τ → τ → β) → α → α → α → β+withTernary' _ f x y z =+ f (fromArbitrary x) (fromArbitrary y) (fromArbitrary z)+ propUnary f g t w = f w == withUnary t g w propUnary' f g t w = f w == withUnary' t g w propBinary f g t w1 w2 = f w1 w2 == withBinary t g w1 w2 propBinary' f g t w1 w2 = f w1 w2 == withBinary' t g w1 w2 +propTernary' f g t w1 w2 w3 = f w1 w2 w3 == withTernary' t g w1 w2 w3+ prop_conv t w = toArbitrary (toType t w) == w prop_eq = propBinary' (==) (==)@@ -221,16 +157,25 @@ prop_succ t w = (w /= maxBound) ==> (succ w == withUnary t succ w) prop_pred t w = (w /= minBound) ==> (pred w == withUnary t pred w)+prop_enumFromTo =+ propBinary' ((take 8 .) . enumFromTo)+ (((fmap toArbitrary . take 8) .) . enumFromTo)+prop_enumFromThen =+ propBinary' ((take 8 .) . enumFromThen)+ (((fmap toArbitrary . take 8) .) . enumFromThen)+prop_enumFromThenTo =+ propTernary' (((take 8 .) .) . enumFromThenTo)+ ((((fmap toArbitrary . take 8) .) .) . enumFromThenTo) 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 +225,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