diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -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 diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,5 +1,8 @@ Data-DWord ========== + +[![Travis](https://img.shields.io/travis/mvv/data-dword/master.svg)](https://travis-ci.org/mvv/data-dword) [![Hackage](https://img.shields.io/hackage/v/data-dword.svg)](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. 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.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 Maintainer: Mikhail Vorozhtsov -Copyright: 2011-2014 Mikhail Vorozhtsov +Copyright: 2011-2019 Mikhail Vorozhtsov 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 - 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 @@ -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'] → diff --git a/tests/Tests.hs b/tests/Tests.hs --- a/tests/Tests.hs +++ b/tests/Tests.hs @@ -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