OddWord 1.0.1.1 → 1.0.2.0

raw patch · 9 files changed

+397/−246 lines, 9 filesdep +hspecdep ~QuickCheckdep ~basePVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: hspec

Dependency ranges changed: QuickCheck, base

API changes (from Hackage documentation)

Files

• CHANGELOG +10/−0
• OddWord.cabal +15/−27
• bench/Main.hs +17/−6
• src/Data/Word/Odd.hs +125/−26
• src/Data/Word/Odd/TypeLits.hs +0/−9
• test/Equiv.hs +141/−0
• test/Main.hs +51/−153
• test/Props.hs +38/−0
• test/TypeLitsTest.hs +0/−25

@@ -1,5 +1,15 @@ OddWord - Release History +release-1.0.2.0 - 2018.04.11++  * Added FiniteBitsBase to support FiniteBits atop non-finite base types.+  * Added explicit Typeable instances.+  * Removed Cabal flag for type-level literals in favour of always enabling.+  * Fixed performance impact of using type-level literals.+  * Fixed undefined behaviour in test suite.+  * Changed minimum supported GHC version to 7.10 (base 4.8).+  * Changed test suite to use hspec.+ release-1.0.1.1 - 2018.04.05    * Added criterion benchmark

@@ -1,5 +1,5 @@ name:               OddWord-version:            1.0.1.1+version:            1.0.2.0 license:            BSD3 license-file:       LICENSE copyright:          (c) 2011-2018 Robin KAY@@ -17,52 +17,40 @@     exposes a subset of its bits as a new narrower word type. Includes     predefined type synonyms for all the odd sized words up to 63 bits. -Flag TypeLitsSupport-    description: Enable support for GHC type-level naturals.-    default: True- Library     hs-source-dirs:   src     exposed-modules:  Data.Word.Odd     default-language: Haskell2010-    other-extensions: ScopedTypeVariables CPP+    other-extensions:+        ScopedTypeVariables CPP+        DeriveDataTypeable DataKinds KindSignatures+        TypeFamilies TypeOperators UndecidableInstances     build-depends:-        base >= 4.5 && < 5-    if flag(TypeLitsSupport) && impl(ghc >= 7.8)-        cpp-options: -DTYPE_LITS-        other-modules: Data.Word.Odd.TypeLits+        base >= 4.8 && < 5  Test-Suite oddword-tests     type:             exitcode-stdio-1.0     hs-source-dirs:   test     main-is:          Main.hs     default-language: Haskell2010-    other-extensions: ScopedTypeVariables CPP+    other-modules: Equiv Props+    other-extensions:+        ScopedTypeVariables DataKinds KindSignatures     build-depends:-        base       >= 4.5 && < 5,-        QuickCheck >= 2.4 && < 2.12,+        base       >= 4.8 && < 5,+        hspec      >= 2.5 && < 2.6,+        QuickCheck >= 2.11 && < 2.12,         OddWord -Test-Suite oddword-tests-typelits-    type:             exitcode-stdio-1.0-    hs-source-dirs:   test-    main-is:          TypeLitsTest.hs-    default-language: Haskell2010-    if flag(TypeLitsSupport) && impl(ghc >= 7.8)-        buildable: True-        build-depends:-            base       >= 4.5 && < 5,-            OddWord-    else-        buildable: False- Benchmark oddword-bench     type:             exitcode-stdio-1.0     hs-source-dirs:   bench     main-is:          Main.hs     default-language: Haskell2010+    other-extensions:+        ScopedTypeVariables DataKinds     build-depends:-        base       >= 4.5 && < 5,+        base       >= 4.8 && < 5,         criterion  >= 1.4 && < 1.5,         OddWord 

@@ -1,5 +1,9 @@+{-# LANGUAGE ScopedTypeVariables, DataKinds #-}+ module Main where +import Data.Proxy+import Data.Typeable import Data.Word import Data.Word.Odd import Criterion.Main@@ -7,13 +11,20 @@ testAddMul :: (Num a) => a -> a testAddMul n = 2*n*n + 3*n + 4 +testEquals :: (Eq a, Num a) => a -> Bool+testEquals n = n == 7 || n == 11 || n == 13++benchNum :: forall a. (Eq a, Num a, Typeable a) => a -> Benchmark+benchNum x =+    bgroup (show $ typeRep (Proxy :: Proxy a)) [+        bench "addMul" $ whnf testAddMul x,+        bench "equals" $ whnf testEquals x+    ]+ main :: IO () main =     defaultMain [-        bgroup "Word" [-            bench "addMul" $ whnf testAddMul (1::Word)-        ],-        bgroup "Word20" [-            bench "addMul" $ whnf testAddMul (1::Word20)-        ]+        benchNum (1::Word),+        benchNum (1::Word20),+        benchNum (1::(OddWord Word32 (Lit 20)))     ]

@@ -1,4 +1,6 @@-{-# LANGUAGE Haskell2010, ScopedTypeVariables, CPP #-}+{-# LANGUAGE Haskell2010, ScopedTypeVariables, CPP,+             DeriveDataTypeable, DataKinds, KindSignatures,+             TypeFamilies, TypeOperators, UndecidableInstances #-}  module Data.Word.Odd (     -- * Odd Word Wrapper@@ -8,10 +10,13 @@     TypeNum,     One,     Zero,-#ifdef TYPE_LITS     Lit,-#endif +    -- * Finite Bits+    FiniteBitsBase(+        subWordClz,+        subWordCtz),+     -- * Predefined Odd Words     Word1, Word2, Word3, Word4, Word5, Word6, Word7,     Word9,  Word10, Word11, Word12, Word13, Word14, Word15,@@ -24,14 +29,11 @@ ) where  import Data.Bits+import Data.Proxy import Data.Word import Data.Function--#ifdef TYPE_LITS-import Data.Word.Odd.TypeLits-import Data.Proxy+import Data.Typeable import GHC.TypeLits-#endif  -- | 'OddWord' provides a range of unsigned integer word types with a length in -- bits encoded at the type level. The first type parameter @a@ must supply an@@ -58,7 +60,7 @@ -- greater than that of the underlying integer type. The behaviour is also -- undefined if the specified length is equal to that of the underlying integer -- type and that type is also signed.-newtype OddWord a n = OW {unOW :: a} deriving (Eq, Ord)+newtype OddWord a n = OW {unOW :: a} deriving (Eq, Ord, Typeable)  data TypeNumBuilder a = TypeNumBuilder Int Int @@ -71,12 +73,16 @@  -- | Represents a type-level number with a leading one bit followed by the -- string of digits specified by @a@.-data One a+data One a deriving Typeable  -- | Represents a type-level number with a placeholder zero bit followed by the -- string of digits specified by @a@.-data Zero a+data Zero a deriving Typeable +-- | Converts a native GHC type-level natural into one usable by this library.+-- This requires the @DataKinds@ extension.+data Lit :: Nat -> * deriving Typeable+ instance TypeNum () where     typeNum = TypeNumBuilder 0 0 @@ -88,11 +94,110 @@     typeNum = let (TypeNumBuilder n m) = (typeNum :: TypeNumBuilder a)               in TypeNumBuilder (n) (m+1) -#ifdef TYPE_LITS-instance (KnownNat a) => TypeNum (Lit a) where-    typeNum = TypeNumBuilder (fromIntegral $ natVal (Proxy :: Proxy a)) 0+-- | Provides a more efficient mechanism for converting 'Nat'-kinded types into+-- small integers than 'KnownNat'.+#if MIN_VERSION_base(4,11,0)+-- Decomposes Nats in log2(n) recursions, one bit at a time.+data ZNat = IsZ | NonZE Nat | NonZO Nat++type family ToZNatImpl (n::Nat) (lsb::Nat) where+    ToZNatImpl 0 0 = IsZ+    ToZNatImpl n 0 = NonZE n+    ToZNatImpl n 1 = NonZO n++type ToZNat n = ToZNatImpl n (Mod n 2)++class ZNatValue (n::ZNat) where+    znatIntVal :: proxy n -> Int++instance ZNatValue IsZ where+    znatIntVal _ = 0+    {-# INLINE znatIntVal #-}++instance ZNatValue (ToZNat (Div n 2)) => ZNatValue (NonZE n) where+    znatIntVal _ = 2 * (znatIntVal (Proxy :: Proxy (ToZNat (Div n 2))))+    {-# INLINE znatIntVal #-}++instance ZNatValue (ToZNat (Div n 2)) => ZNatValue (NonZO n) where+    znatIntVal _ = 1 + 2 * (znatIntVal (Proxy :: Proxy (ToZNat (Div n 2))))+    {-# INLINE znatIntVal #-}+#else+-- For older GHCs that don't support Div and Mod, decomposes Nats in+-- 16*log16(n) recursions for values of n below 2^16.+data ZNat = IsZ | NonZ Nat | NonZ4 Nat | NonZ8 Nat | NonZ12 Nat++-- Regarding u, v, and w, GHC 7.10 doesn't like wildcards in type families.+type family ToZNatImpl+        (n::Nat) (nz4::Ordering) (nz8::Ordering) (nz12::Ordering) where+    ToZNatImpl 0 LT LT LT = IsZ+    ToZNatImpl n LT LT LT = NonZ n+    ToZNatImpl n u  LT LT = NonZ4 n+    ToZNatImpl n u  v  LT = NonZ8 n+    ToZNatImpl n u  v  w  = NonZ12 n++type ToZNat n = ToZNatImpl n (CmpNat n 16) (CmpNat n 256) (CmpNat n 4096)++class ZNatValue (n::ZNat) where+    znatIntVal :: proxy n -> Int++instance ZNatValue IsZ where+    znatIntVal _ = 0+    {-# INLINE znatIntVal #-}++instance ZNatValue (ToZNat (n - 1)) => ZNatValue (NonZ n) where+    znatIntVal _ = 1 + (znatIntVal (Proxy :: Proxy (ToZNat (n - 1))))+    {-# INLINE znatIntVal #-}++instance ZNatValue (ToZNat (n - 16)) => ZNatValue (NonZ4 n) where+    znatIntVal _ = 16 + (znatIntVal (Proxy :: Proxy (ToZNat (n - 16))))+    {-# INLINE znatIntVal #-}++instance ZNatValue (ToZNat (n - 256)) => ZNatValue (NonZ8 n) where+    znatIntVal _ = 256 + (znatIntVal (Proxy :: Proxy (ToZNat (n - 256))))+    {-# INLINE znatIntVal #-}++instance ZNatValue (ToZNat (n - 4096)) => ZNatValue (NonZ12 n) where+    znatIntVal _ = 4096 + (znatIntVal (Proxy :: Proxy (ToZNat (n - 4096))))+    {-# INLINE znatIntVal #-} #endif +instance (ZNatValue (ToZNat n)) => TypeNum (Lit n) where+    typeNum = TypeNumBuilder+        (fromIntegral $ znatIntVal (Proxy :: Proxy (ToZNat n))) 0++-- | Required to implement 'FiniteBits' for an 'OddWord' based on type @a@.+class Bits a => FiniteBitsBase a where+    -- | Count the leading zeros on a @w@-bit wide word.+    subWordClz :: Int -> a -> Int+    subWordClz w x = (w-1) - worker (w-1)+        where worker i | i < 0       = i+                       | testBit x i = i+                       | otherwise   = worker (i-1)+    -- | Count the trailing zeros on a @w@-bit wide word.+    subWordCtz :: Int -> a -> Int+    subWordCtz w x = worker 0+        where worker i | i >= w      = i+                       | testBit x i = i+                       | otherwise   = worker (i+1)++instance FiniteBitsBase Word8 where+    subWordClz w x = countLeadingZeros x + w - finiteBitSize x+    subWordCtz w x = min (countTrailingZeros x) w++instance FiniteBitsBase Word16 where+    subWordClz w x = countLeadingZeros x + w - finiteBitSize x+    subWordCtz w x = min (countTrailingZeros x) w++instance FiniteBitsBase Word32 where+    subWordClz w x = countLeadingZeros x + w - finiteBitSize x+    subWordCtz w x = min (countTrailingZeros x) w++instance FiniteBitsBase Word64 where+    subWordClz w x = countLeadingZeros x + w - finiteBitSize x+    subWordCtz w x = min (countTrailingZeros x) w++instance FiniteBitsBase Integer where+ -- | Wraps both parts of a homogenous pair with the OddWord constructor. pairOW :: (a, a) -> (OddWord a n, OddWord a n) pairOW = uncurry ((,) `on` OW)@@ -170,7 +275,7 @@     (OW l) .&. (OW r) = OW $ l .&. r     (OW l) .|. (OW r) = OW $ l .|. r     xor (OW l) (OW r) = OW $ xor l r-    complement (OW x) = maskOW $ complement x+    complement x = x `xor` owMask     bit n | n < fromTypeNum (typeNum :: TypeNumBuilder n)           = OW $ bit n           | otherwise = OW 0@@ -183,9 +288,7 @@                            | otherwise = OW x     testBit (OW x) n = testBit x n     bitSize _ = fromTypeNum (typeNum :: TypeNumBuilder n)-#if MIN_VERSION_base(4,7,0)     bitSizeMaybe _ = Just $ fromTypeNum (typeNum :: TypeNumBuilder n)-#endif     isSigned _ = False      shiftL (OW x) n = maskOW $ shiftL x n     shiftR (OW x) n = OW $ shiftR x n@@ -199,16 +302,12 @@               w  = fromTypeNum (typeNum :: TypeNumBuilder n)     popCount (OW x) = popCount x -#if MIN_VERSION_base(4,7,0)-instance (Num a, FiniteBits a, TypeNum n) => FiniteBits (OddWord a n) where+instance (Num a, FiniteBitsBase a, TypeNum n) => FiniteBits (OddWord a n) where     finiteBitSize _ = fromTypeNum (typeNum :: TypeNumBuilder n) -#if MIN_VERSION_base(4,8,0)-    countLeadingZeros (OW x) = countLeadingZeros x +-        fromTypeNum (typeNum :: TypeNumBuilder n) - finiteBitSize x-    countTrailingZeros (OW x) = min (countTrailingZeros x) $-        fromTypeNum (typeNum :: TypeNumBuilder n)-#endif-#endif+    countLeadingZeros (OW x) =+        subWordClz (fromTypeNum (typeNum :: TypeNumBuilder n)) x+    countTrailingZeros (OW x) =+        subWordCtz (fromTypeNum (typeNum :: TypeNumBuilder n)) x  -- -- Predefined Odd Words

@@ -1,9 +0,0 @@-{-# LANGUAGE Haskell2010, DataKinds, KindSignatures #-}--module Data.Word.Odd.TypeLits where--import GHC.TypeLits---- | Converts a native GHC type-level natural into one usable by this library.--- This requires GHC 7.8 or later and the @DataKinds@ extension.-data Lit :: Nat -> *

@@ -0,0 +1,141 @@+{-# LANGUAGE Haskell2010, ScopedTypeVariables, DataKinds, KindSignatures #-}++module Equiv where++import Prelude hiding (catch)+import Test.QuickCheck hiding ((.&.))+import Test.QuickCheck.Gen+import Data.Bits+import Data.Maybe+import Data.Proxy+import Data.Word+import Data.Word.Odd+import Control.Applicative+import Control.Exception+import System.IO.Unsafe+import GHC.TypeLits++-- | Represents a range of unary functions which can be applied to a word.+data UFunc (n::Nat)+    = Add   Integer | Mul   Integer | Sub   Integer | SubR  Integer+    | Div   Integer | Mod   Integer | Quot  Integer | Rem   Integer+    | DivR  Integer | ModR  Integer | QuotR Integer | RemR  Integer+    | Neg           | Abs           | Inv           | AddDigit+    | From  Integer | And   Integer | Or    Integer | Xor   Integer+    | TstB  Int     | ClrB  Int     | SetB  Int     | InvB  Int+    | FromB Int     | Shift Int     | Rot   Int     | PopCnt+    | CntLZ         | CntTZ+    | AdjEnum Int Integer+    deriving Show++instance KnownNat n => Arbitrary (UFunc n) where+    arbitrary = oneof+        [Add   <$> choose (0, upper)+        ,Mul   <$> choose (0, upper)+        ,Sub   <$> choose (0, upper)+        ,SubR  <$> choose (0, upper)+        ,Div   <$> choose (0, upper)+        ,Mod   <$> choose (0, upper)+        ,Quot  <$> choose (0, upper)+        ,Rem   <$> choose (0, upper)+        ,DivR  <$> choose (0, upper)+        ,ModR  <$> choose (0, upper)+        ,QuotR <$> choose (0, upper)+        ,RemR  <$> choose (0, upper)+        ,return Neg+        ,return Abs+        ,return Inv+        ,return AddDigit+        ,From  <$> arbitrary+        ,And   <$> choose (0, upper)+        ,Or    <$> choose (0, upper)+        ,Xor   <$> choose (0, upper)+        ,TstB  <$> choose (0, 2*width)+        ,ClrB  <$> choose (0, 2*width)+        ,SetB  <$> choose (0, 2*width)+        ,InvB  <$> choose (0, 2*width)+        ,FromB <$> choose (0, 2*width)+        ,Shift <$> choose (0, 2*width)+        ,Rot   <$> choose (0, 2*width)+        ,return PopCnt+        ,return CntLZ+        ,return CntTZ+        ,AdjEnum <$> arbitrary <*> choose (0, upper)+        ]+        where width = fromIntegral $ natVal (Proxy :: Proxy n) +              upper = shiftL 1 width - 1++-- | Total wrapper for 'div'.+safeDiv :: (Integral a, Bounded a) => a -> a -> a+safeDiv d 0 = maxBound+safeDiv d n = div d n++-- | Total wrapper for 'mod'.+safeMod :: (Integral a) => a -> a -> a+safeMod d 0 = 0+safeMod d n = mod d n++-- | Total wrapper for 'quot'.+safeQuot :: (Integral a, Bounded a) => a -> a -> a+safeQuot d 0 = maxBound+safeQuot d n = quot d n++-- | Total wrapper for 'rem'.+safeRem :: (Integral a) => a -> a -> a+safeRem d 0 = 0+safeRem d n = rem d n++-- | Total wrapper for 'toEnum'.+safeToEnum :: (Enum a) => a -> Int -> a+safeToEnum def x =+    unsafePerformIO (evaluate (toEnum x) `catch` \(ErrorCall _) -> return def)++-- | Interpreter for executing 'UFunc' values.+fromUFunc :: (Integral a, Bounded a, Enum a, FiniteBits a, Read a, Show a) =>+    UFunc n -> a -> a+fromUFunc (Add   i) x = x + (fromInteger i)+fromUFunc (Mul   i) x = x * (fromInteger i)+fromUFunc (Sub   i) x = x - (fromInteger i)+fromUFunc (SubR  i) x = (fromInteger i) - x+fromUFunc (Div   i) x = safeDiv  x (fromInteger i)+fromUFunc (Mod   i) x = safeMod  x (fromInteger i)+fromUFunc (Quot  i) x = safeQuot x (fromInteger i)+fromUFunc (Rem   i) x = safeRem  x (fromInteger i)+fromUFunc (DivR  i) x = safeDiv  (fromInteger i) x+fromUFunc (ModR  i) x = safeMod  (fromInteger i) x+fromUFunc (QuotR i) x = safeQuot (fromInteger i) x+fromUFunc (RemR  i) x = safeRem  (fromInteger i) x+fromUFunc  Neg      x = negate x+fromUFunc  Abs      x = abs x+fromUFunc  Inv      x = complement x+fromUFunc (From i)  _ = fromInteger i+fromUFunc  AddDigit x = read . ('1':) $ show x+fromUFunc (And   i) x = x .&. (fromInteger i)+fromUFunc (Or    i) x = x .|. (fromInteger i)+fromUFunc (Xor   i) x = xor x (fromInteger i)+fromUFunc (TstB  n) x = fromIntegral $ fromEnum $ testBit x n+fromUFunc (ClrB  n) x = clearBit x n+fromUFunc (SetB  n) x = setBit x n+fromUFunc (InvB  n) x = complementBit x n+fromUFunc (FromB n) _ = bit n+fromUFunc (Shift n) x = shift x n+fromUFunc (Rot   n) x = rotate x n+fromUFunc  PopCnt   x = fromIntegral $ popCount x+fromUFunc  CntLZ    x = fromIntegral $ countLeadingZeros x+fromUFunc  CntTZ    x = fromIntegral $ countTrailingZeros x+fromUFunc (AdjEnum i def) x = safeToEnum (fromIntegral def) . (+i) $ fromEnum x++-- | Checks that computations using real and simulated words produce the same+-- result for a series of 'UFunc's.+verifyEquivalence :: forall n a b.+    (KnownNat n,+     Integral a, Bounded a, Enum a, FiniteBits a, Read a, Show a,+     Integral b, Bounded b, Enum b, FiniteBits b, Read b, Show b) =>+    Proxy n -> Proxy a -> Proxy b -> Property+verifyEquivalence width _ _ = property $ \(us :: [UFunc n]) ->+    let refFn = foldr (.) id $ map fromUFunc us :: a -> a+        tstFn = foldr (.) id $ map fromUFunc us :: b -> b+    in toInteger (refFn 0) == toInteger (tstFn 0)++-- | A 16-bit word backed by something else.+type TestWord16 a = OddWord a (One (Zero (Zero (Zero (Zero ())))))

@@ -1,147 +1,18 @@-{-# LANGUAGE Haskell2010, ScopedTypeVariables, CPP #-}+{-# LANGUAGE Haskell2010, ScopedTypeVariables, DataKinds #-}  module Main where -import Prelude hiding (catch)-import System.Exit-import Test.QuickCheck hiding ((.&.))-import Test.QuickCheck.Gen import Data.Bits import Data.Maybe import Data.Word import Data.Word.Odd-import Control.Applicative-import Control.Exception-import System.IO.Unsafe---- | Represents a range of unary functions which can be applied to a word.-data UFunc-    = Add   Integer | Mul   Integer | Sub   Integer | SubR  Integer-    | Div   Integer | Mod   Integer | Quot  Integer | Rem   Integer-    | DivR  Integer | ModR  Integer | QuotR Integer | RemR  Integer-    | Neg           | Abs           | Inv           | AddDigit-    | From  Integer | And   Integer | Or    Integer | Xor   Integer-    | TstB  Int     | ClrB  Int     | SetB  Int     | InvB  Int-    | FromB Int     | Shift Int     | Rot   Int     | PopCnt-#if MIN_VERSION_base(4,8,0)-    | CntLZ         | CntTZ-#endif-    | AdjEnum Int Integer-    deriving Show--instance Arbitrary (UFunc) where-    arbitrary = oneof-        [Add   <$> choose (0, 0xffff)-        ,Mul   <$> choose (0, 0xffff)-        ,Sub   <$> choose (0, 0xffff)-        ,SubR  <$> choose (0, 0xffff)-        ,Div   <$> choose (0, 0xffff)-        ,Mod   <$> choose (0, 0xffff)-        ,Quot  <$> choose (0, 0xffff)-        ,Rem   <$> choose (0, 0xffff)-        ,DivR  <$> choose (0, 0xffff)-        ,ModR  <$> choose (0, 0xffff)-        ,QuotR <$> choose (0, 0xffff)-        ,RemR  <$> choose (0, 0xffff)-        ,return Neg-        ,return Abs-        ,return Inv-        ,return AddDigit-        ,From  <$> arbitrary-        ,And   <$> choose (0, 0xffff)-        ,Or    <$> choose (0, 0xffff)-        ,Xor   <$> choose (0, 0xffff)-        ,TstB  <$> choose (-32, 32)-        ,ClrB  <$> choose (-32, 32)-        ,SetB  <$> choose (-32, 32)-        ,InvB  <$> choose (-32, 32)-        ,FromB <$> choose (-32, 32)-        ,Shift <$> choose (-32, 32)-        ,Rot   <$> choose (-32, 32)-        ,return PopCnt-#if MIN_VERSION_base(4,8,0)-        ,return CntLZ-        ,return CntTZ-#endif-        ,AdjEnum <$> choose (-0x1ffff, 0x1ffff) <*> choose (0, 0xffff)-        ]---- | Total wrapper for 'div'.-safeDiv :: (Integral a, Bounded a) => a -> a -> a-safeDiv d 0 = maxBound-safeDiv d n = div d n---- | Total wrapper for 'mod'.-safeMod :: (Integral a) => a -> a -> a-safeMod d 0 = 0-safeMod d n = mod d n---- | Total wrapper for 'quot'.-safeQuot :: (Integral a, Bounded a) => a -> a -> a-safeQuot d 0 = maxBound-safeQuot d n = quot d n---- | Total wrapper for 'rem'.-safeRem :: (Integral a) => a -> a -> a-safeRem d 0 = 0-safeRem d n = rem d n---- | Total wrapper for 'toEnum'.-safeToEnum :: (Enum a) => a -> Int -> a-safeToEnum def x =-    unsafePerformIO (evaluate (toEnum x) `catch` \(ErrorCall _) -> return def)---- | Interpreter for executing 'UFunc' values.-#if MIN_VERSION_base(4,7,0)-fromUFunc :: (Integral a, Bounded a, Enum a, FiniteBits a, Read a, Show a) =>-#else-fromUFunc :: (Integral a, Bounded a, Enum a, Bits a, Read a, Show a) =>-#endif-    UFunc -> a -> a-fromUFunc (Add   i) x = x + (fromInteger i)-fromUFunc (Mul   i) x = x * (fromInteger i)-fromUFunc (Sub   i) x = x - (fromInteger i)-fromUFunc (SubR  i) x = (fromInteger i) - x-fromUFunc (Div   i) x = safeDiv  x (fromInteger i)-fromUFunc (Mod   i) x = safeMod  x (fromInteger i)-fromUFunc (Quot  i) x = safeQuot x (fromInteger i)-fromUFunc (Rem   i) x = safeRem  x (fromInteger i)-fromUFunc (DivR  i) x = safeDiv  (fromInteger i) x-fromUFunc (ModR  i) x = safeMod  (fromInteger i) x-fromUFunc (QuotR i) x = safeQuot (fromInteger i) x-fromUFunc (RemR  i) x = safeRem  (fromInteger i) x-fromUFunc  Neg      x = negate x-fromUFunc  Abs      x = abs x-fromUFunc  Inv      x = complement x-fromUFunc (From i)  _ = fromInteger i-fromUFunc  AddDigit x = read . ('1':) $ show x-fromUFunc (And   i) x = x .&. (fromInteger i)-fromUFunc (Or    i) x = x .|. (fromInteger i)-fromUFunc (Xor   i) x = xor x (fromInteger i)-fromUFunc (TstB  n) x = fromIntegral $ fromEnum $ testBit x n-fromUFunc (ClrB  n) x = clearBit x n-fromUFunc (SetB  n) x = setBit x n-fromUFunc (InvB  n) x = complementBit x n-fromUFunc (FromB n) _ = bit n-fromUFunc (Shift n) x = shift x n-fromUFunc (Rot   n) x = rotate x n-fromUFunc  PopCnt   x = fromIntegral $ popCount x-#if MIN_VERSION_base(4,8,0)-fromUFunc  CntLZ    x = fromIntegral $ countLeadingZeros x-fromUFunc  CntTZ    x = fromIntegral $ countTrailingZeros x-#endif-fromUFunc (AdjEnum i def) x = safeToEnum (fromIntegral def) . (+i) $ fromEnum x---- | A 16-bit word underlied by a 32-bit word.-type TestWord16 = OddWord Word32 (One (Zero (Zero (Zero (Zero ())))))+import Data.Proxy+import Test.Hspec+import Test.Hspec.QuickCheck+import Test.QuickCheck --- | Checks that computations using real and simulated 16-bit words produce--- the same result for a series of 'UFunc's.-verifyTestWord16 :: [UFunc] -> Bool-verifyTestWord16 us =-    let refFn = foldr (.) id $ map fromUFunc us :: Word16 -> Word16-        tstFn = foldr (.) id $ map fromUFunc us :: TestWord16 -> TestWord16-    in toInteger (refFn 0) == toInteger (tstFn 0)+import Equiv+import Props  -- | List of bit lengths for all words up to 63-bits. preDefWordLengths :: [Int]@@ -167,22 +38,49 @@     bits (0 :: Word55), bits (0 :: Word56), bits (0 :: Word57),     bits (0 :: Word58), bits (0 :: Word59), bits (0 :: Word60),     bits (0 :: Word61), bits (0 :: Word62), bits (0 :: Word63)]-#if MIN_VERSION_base(4,8,0)-    where bits n = fromMaybe 0 $ bitSizeMaybe n-#else-    where bits n = bitSize n-#endif+    where bits n = finiteBitSize n +typeLitWordLengths :: [Int]+typeLitWordLengths = [+    finiteBitSize (0 :: OddWord Word8 (Lit 1)),+    finiteBitSize (0 :: OddWord Word8 (Lit 2)),+    finiteBitSize (0 :: OddWord Word8 (Lit 3)),+    finiteBitSize (0 :: OddWord Word8 (Lit 4))]++checkWordLengths :: [Int] -> Expectation+checkWordLengths =+    flip shouldBe [] .+    map fst . filter snd . map (\t -> (t,uncurry (/=) t)) .  zip [1..]+ main :: IO ()-main = do-    -- Verify lengths of predefined odd word synonyms-    mapM_ (\(u,v) -> putStrLn (-        showString "Error: Word" . shows u . showString " has length " $-            shows v ".") >> exitFailure) $-        map fst $ filter snd $ map (\t -> (t,uncurry (/=) t)) $-        zip [1..] preDefWordLengths-    -- Verify correctness of operations on a test word type-    r <- quickCheckWithResult stdArgs {maxSuccess = 1000} verifyTestWord16-    case r of-        Success _ _ _ -> exitSuccess-        _             -> exitFailure+main = hspec $ do+    describe "Predefined odd word synonyms" $+        it "have the correct length" $+            checkWordLengths preDefWordLengths+    describe "Odd words with type literals" $+        it "have the correct length" $+            checkWordLengths typeLitWordLengths+    modifyMaxSuccess (const 5000) $ describe "Word16" $ do+        it "is equivalent to TestWord16 Word16" $+            verifyEquivalence (Proxy :: Proxy 16)+                (Proxy :: Proxy Word16) (Proxy :: Proxy (TestWord16 Word16))+        it "is equivalent to TestWord16 Word32" $+            verifyEquivalence (Proxy :: Proxy 16)+                (Proxy :: Proxy Word16) (Proxy :: Proxy (TestWord16 Word32))+        it "is equivalent to TestWord16 Word64" $+            verifyEquivalence (Proxy :: Proxy 16)+                (Proxy :: Proxy Word16) (Proxy :: Proxy (TestWord16 Word64))+        it "is equivalent to TestWord16 Integer" $+            verifyEquivalence (Proxy :: Proxy 16)+                (Proxy :: Proxy Word16) (Proxy :: Proxy (TestWord16 Integer))+    describe "Word20" $ do+        it "is in bounds" $ +            propInBounds (Proxy :: Proxy 20) (Proxy :: Proxy Word20)+        it "can rotate left and right" $ +            propRotateRL (Proxy :: Proxy Word20)+    describe "Word2000" $ do+        it "is in bounds" $ +            propInBounds (Proxy :: Proxy 2000)+                         (Proxy :: Proxy (OddWord Integer (Lit 2000)))+        it "can rotate left and right" $ +            propRotateRL (Proxy :: Proxy (OddWord Integer (Lit 2000)))

@@ -0,0 +1,38 @@+{-# LANGUAGE Haskell2010, ScopedTypeVariables, DataKinds #-}++module Props where++import Test.QuickCheck hiding ((.&.))+import Test.QuickCheck.Gen+import Data.Bits+import Data.Proxy+import Data.Word+import Data.Word.Odd+import GHC.TypeLits++import Equiv++genOddWord :: forall a n.+    (Integral a, Bits a, TypeNum n) =>+    Proxy (OddWord a n) -> Gen (OddWord a n)+genOddWord _ =+    fmap (fromIntegral :: Integer -> OddWord a n) $ choose (+        fromIntegral (minBound::OddWord a n),+        fromIntegral (maxBound::OddWord a n))++propRotateRL :: (Integral a, FiniteBitsBase a, TypeNum n) =>+    Proxy (OddWord a n) -> Property+propRotateRL proxy =+    property $ do+        x <- genOddWord proxy+        i <- choose (0, 2*finiteBitSize x)+        return $ (==) x $ flip rotateL i $ rotateR x i++propInBounds :: forall n a.+    (KnownNat n, Integral a, Bounded a, Enum a, FiniteBits a, Read a, Show a) =>+    Proxy n -> Proxy a -> Property+propInBounds _ _ = property $ \(us :: [UFunc n]) ->+    let tstFn = foldr (.) id $ map fromUFunc us :: a -> a+        value = toInteger $ tstFn 0+    in value >= toInteger (minBound :: a) &&+       value <= toInteger (maxBound :: a)

@@ -1,25 +0,0 @@-{-# LANGUAGE Haskell2010, ScopedTypeVariables, DataKinds #-}--module Main where--import System.Exit-import Data.Bits-import Data.Word-import Data.Word.Odd-import GHC.TypeLits--typeLitWordLengths :: [Int]-typeLitWordLengths = [-    finiteBitSize (0 :: OddWord Word8 (Lit 1)),-    finiteBitSize (0 :: OddWord Word8 (Lit 2)),-    finiteBitSize (0 :: OddWord Word8 (Lit 3)),-    finiteBitSize (0 :: OddWord Word8 (Lit 4))]--main :: IO ()-main = do-    -- Verify lengths of odd words defined using GHC type-level literals-    mapM_ (\(u,v) -> putStrLn (-        showString "Error: Word" . shows u . showString " has length " $-            shows v ".") >> exitFailure) $-        map fst $ filter snd $ map (\t -> (t,uncurry (/=) t)) $-        zip [1..] typeLitWordLengths