diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,7 +1,7 @@ The following license covers this documentation, and the source code, except where otherwise indicated. -Copyright 2011, Robin KAY. All rights reserved. +Copyright 2011-2015, Robin KAY. All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: diff --git a/NEWS b/NEWS --- a/NEWS +++ b/NEWS @@ -1,5 +1,14 @@ OddWord - Release History +release-1.0.1.0 - 2015.10.25 + + * Added optional support for GHC type-level literals. + * Added FiniteBits instance. + * Added more test coverage. + * Fixed bug in toEnum function and extended test suite. (Thanks to Pasqualino "Titto" Assini) + * Fixed warnings when compiling test suite with base-4.7 (GHC 7.8). + * Relaxed QuickCheck version constraint. + release-1.0.0.2 - 2013.05.14 * Fixed misdefinition of type synonyms for Word10, Word12, and Word14, diff --git a/OddWord.cabal b/OddWord.cabal --- a/OddWord.cabal +++ b/OddWord.cabal @@ -1,8 +1,8 @@ name: OddWord -version: 1.0.0.2 +version: 1.0.1.0 license: BSD3 license-file: LICENSE -copyright: (c) 2011-2013 Robin KAY +copyright: (c) 2011-2015 Robin KAY author: Robin KAY maintainer: Robin KAY synopsis: Provides a wrapper for deriving word types with fewer bits. @@ -17,25 +17,45 @@ 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 + other-extensions: ScopedTypeVariables CPP build-depends: base >= 4.5 && < 5 + if flag(TypeLitsSupport) && impl(ghc >= 7.8) + cpp-options: -DTYPE_LITS + other-modules: Data.Word.Odd.TypeLits Test-Suite oddword-tests type: exitcode-stdio-1.0 hs-source-dirs: test main-is: Main.hs default-language: Haskell2010 - other-extensions: ScopedTypeVariables + other-extensions: ScopedTypeVariables CPP build-depends: base >= 4.5 && < 5, - QuickCheck >= 2.4 && < 2.7, + QuickCheck >= 2.4 && < 2.9, OddWord >= 1.0 && < 1.1 +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 >= 1.0 && < 1.1 + else + buildable: False + Source-repository head type: darcs - location: https://patch-tag.com/r/komadori/OddWord + location: http://hub.darcs.net/komadori/OddWord diff --git a/src/Data/Word/Odd.hs b/src/Data/Word/Odd.hs --- a/src/Data/Word/Odd.hs +++ b/src/Data/Word/Odd.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE Haskell2010, ScopedTypeVariables #-} +{-# LANGUAGE Haskell2010, ScopedTypeVariables, CPP #-} module Data.Word.Odd ( -- * Odd Word Wrapper @@ -8,6 +8,9 @@ TypeNum, One, Zero, +#ifdef TYPE_LITS + Lit, +#endif -- * Predefined Odd Words Word1, Word2, Word3, Word4, Word5, Word6, Word7, @@ -24,11 +27,37 @@ import Data.Word import Data.Function --- | OddWord wraps the integer type specified in the first type parameter and --- exposes a subset of the available bits as an unsigned word. The number of --- bits to expose is encoded into the second type parameter. +#ifdef TYPE_LITS +import Data.Word.Odd.TypeLits +import Data.Proxy +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 +-- integer type which can hold at least as many bits as required for the +-- 'OddWord'. The second type paramter @n@ then encodes the length in bits +-- which the 'OddWord' will be restricted to. -- --- The predefined word types provided by this module give some examples. +-- The length of the 'OddWord' can be encoded as a string of binary digits +-- using the 'One', 'Zero', and @()@ type constructors. The outermost +-- constructor specifies the most significant digit and each subsequent digit +-- is nested inside the previous type constructor via its type parameter. Hence, +-- the encoding is terminated by the @()@ type constructor. For example, the +-- number 4 would be expressed as: @One (Zero (Zero ()))@. +-- +-- Alternatively, if the compiler supports type-level naturals then these can +-- be used via the 'Lit' type constructor. For example, the number 4 can be +-- expressed as: @Lit 4@. +-- +-- To supply a complete example, a 4-bit integer type could be built from a +-- 'Word8' and specified as either @OddWord Word8 (One (Zero (Zero ())))@ or +-- @OddWord Word8 (Lit 4)@. +-- +-- The behaviour of an 'OddWord' is undefined if the specified length is +-- 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) data TypeNumBuilder a = TypeNumBuilder Int Int @@ -41,11 +70,11 @@ typeNum :: TypeNumBuilder a -- | Represents a type-level number with a leading one bit followed by the --- string of digits specified by a. +-- string of digits specified by @a@. data One a -- | Represents a type-level number with a placeholder zero bit followed by the --- string of digits specified by a. +-- string of digits specified by @a@. data Zero a instance TypeNum () where @@ -59,18 +88,35 @@ 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 +#endif + +-- | Wraps both parts of a homogenous pair with the OddWord constructor. pairOW :: (a, a) -> (OddWord a n, OddWord a n) pairOW = uncurry ((,) `on` OW) +-- | An OddWord with all the bits set, used for masking. owMask :: forall a n. (Num a, Bits a, TypeNum n) => OddWord a n -owMask = OW $ (flip (-) 1) $ bit $ fromTypeNum (typeNum :: TypeNumBuilder n) +owMask = OW . (flip (-) 1) . bit $ fromTypeNum (typeNum :: TypeNumBuilder n) +-- | Smart constructor for OddWords which masks off the unused upper bits. maskOW :: forall a n. (Num a, Bits a, TypeNum n) => a -> OddWord a n maskOW w = OW $ w .&. unOW (owMask :: OddWord a n) +-- | Applies a function to the first component of each pair in a list thereof. mapFst :: (a -> b) -> [(a, c)] -> [(b, c)] mapFst f xs = map (\(a,c) -> (f a,c)) xs +-- +-- Instances for the OddWord type +-- +-- The instances largely forward operations to the underlying integer type +-- while wrapping and unwrapping the newtype, and masking or otherwise +-- adjusting the results as appropriate for the desired bit length of the word. +-- + instance (Show a) => Show (OddWord a n) where showsPrec p (OW x) s = showsPrec p x s show (OW x) = show x @@ -100,9 +146,9 @@ instance (Enum a, Ord a, Num a, Bits a, TypeNum n) => Enum (OddWord a n) where succ x = x + 1 pred x = x - 1 - toEnum i | i >= 0 && fromIntegral i <= (owMask :: OddWord a n) + toEnum i | i >= 0 && fromIntegral i <= unOW (owMask :: OddWord a n) = OW $ toEnum i - | otherwise = error "OddWord: toEnum: Out of range." + | otherwise = error "OddWord: toEnum: Index out of bounds." fromEnum (OW x) = fromEnum x enumFrom x = enumFromTo x owMask enumFromThen x1 x2 = enumFromThenTo x1 x2 bound @@ -136,7 +182,10 @@ = OW $ complementBit x n | otherwise = OW x testBit (OW x) n = testBit x n - bitSize _ = fromTypeNum (typeNum :: TypeNumBuilder 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 @@ -149,6 +198,21 @@ where n' = n `mod` w 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 + 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 + +-- +-- Predefined Odd Words +-- type Word1 = OddWord Word8 (One ()) type Word2 = OddWord Word8 (One (Zero ())) diff --git a/src/Data/Word/Odd/TypeLits.hs b/src/Data/Word/Odd/TypeLits.hs new file mode 100644 --- /dev/null +++ b/src/Data/Word/Odd/TypeLits.hs @@ -0,0 +1,9 @@ +{-# 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 -> * diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -1,70 +1,103 @@ -{-# LANGUAGE Haskell2010, ScopedTypeVariables #-} +{-# LANGUAGE Haskell2010, ScopedTypeVariables, CPP #-} 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.Monad +import Control.Applicative +import Control.Exception +import System.IO.Unsafe -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 | - And Integer | Or Integer | Xor Integer | - ClrB Int | SetB Int | InvB Int | - Shift Int | Rot Int | PopCnt +-- | 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 [ - choose (0, 0xffff) >>= return . Add, - choose (0, 0xffff) >>= return . Mul, - choose (0, 0xffff) >>= return . Sub, - choose (0, 0xffff) >>= return . SubR, - choose (0, 0xffff) >>= return . Div, - choose (0, 0xffff) >>= return . Mod, - choose (0, 0xffff) >>= return . Quot, - choose (0, 0xffff) >>= return . Rem, - choose (0, 0xffff) >>= return . DivR, - choose (0, 0xffff) >>= return . ModR, - choose (0, 0xffff) >>= return . QuotR, - choose (0, 0xffff) >>= return . RemR, - return Neg, - return Abs, - return Inv, - return AddDigit, - choose (0, 0xffff) >>= return . And, - choose (0, 0xffff) >>= return . Or, - choose (0, 0xffff) >>= return . Xor, - choose (0, 32) >>= return . ClrB, - choose (0, 32) >>= return . SetB, - choose (0, 32) >>= return . InvB, - choose (-32, 32) >>= return . Shift, - choose (-32, 32) >>= return . Rot, - return PopCnt] + 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 -fromUFunc :: (Integral a, Bounded a, Bits a, Read a, Show a) => UFunc -> a -> a +-- | 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) @@ -80,48 +113,65 @@ 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 ()))))) +-- | 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) +-- | List of bit lengths for all words up to 63-bits. preDefWordLengths :: [Int] preDefWordLengths = [ - bitSize (0 :: Word1), bitSize (0 :: Word2), bitSize (0 :: Word3), - bitSize (0 :: Word4), bitSize (0 :: Word5), bitSize (0 :: Word6), - bitSize (0 :: Word7), bitSize (0 :: Word8), bitSize (0 :: Word9), - bitSize (0 :: Word10), bitSize (0 :: Word11), bitSize (0 :: Word12), - bitSize (0 :: Word13), bitSize (0 :: Word14), bitSize (0 :: Word15), - bitSize (0 :: Word16), bitSize (0 :: Word17), bitSize (0 :: Word18), - bitSize (0 :: Word19), bitSize (0 :: Word20), bitSize (0 :: Word21), - bitSize (0 :: Word22), bitSize (0 :: Word23), bitSize (0 :: Word24), - bitSize (0 :: Word25), bitSize (0 :: Word26), bitSize (0 :: Word27), - bitSize (0 :: Word28), bitSize (0 :: Word29), bitSize (0 :: Word30), - bitSize (0 :: Word31), bitSize (0 :: Word32), bitSize (0 :: Word33), - bitSize (0 :: Word34), bitSize (0 :: Word35), bitSize (0 :: Word36), - bitSize (0 :: Word37), bitSize (0 :: Word38), bitSize (0 :: Word39), - bitSize (0 :: Word40), bitSize (0 :: Word41), bitSize (0 :: Word42), - bitSize (0 :: Word43), bitSize (0 :: Word44), bitSize (0 :: Word45), - bitSize (0 :: Word46), bitSize (0 :: Word47), bitSize (0 :: Word48), - bitSize (0 :: Word49), bitSize (0 :: Word50), bitSize (0 :: Word51), - bitSize (0 :: Word52), bitSize (0 :: Word53), bitSize (0 :: Word54), - bitSize (0 :: Word55), bitSize (0 :: Word56), bitSize (0 :: Word57), - bitSize (0 :: Word58), bitSize (0 :: Word59), bitSize (0 :: Word60), - bitSize (0 :: Word61), bitSize (0 :: Word62), bitSize (0 :: Word63)] + bits (0 :: Word1), bits (0 :: Word2), bits (0 :: Word3), + bits (0 :: Word4), bits (0 :: Word5), bits (0 :: Word6), + bits (0 :: Word7), bits (0 :: Word8), bits (0 :: Word9), + bits (0 :: Word10), bits (0 :: Word11), bits (0 :: Word12), + bits (0 :: Word13), bits (0 :: Word14), bits (0 :: Word15), + bits (0 :: Word16), bits (0 :: Word17), bits (0 :: Word18), + bits (0 :: Word19), bits (0 :: Word20), bits (0 :: Word21), + bits (0 :: Word22), bits (0 :: Word23), bits (0 :: Word24), + bits (0 :: Word25), bits (0 :: Word26), bits (0 :: Word27), + bits (0 :: Word28), bits (0 :: Word29), bits (0 :: Word30), + bits (0 :: Word31), bits (0 :: Word32), bits (0 :: Word33), + bits (0 :: Word34), bits (0 :: Word35), bits (0 :: Word36), + bits (0 :: Word37), bits (0 :: Word38), bits (0 :: Word39), + bits (0 :: Word40), bits (0 :: Word41), bits (0 :: Word42), + bits (0 :: Word43), bits (0 :: Word44), bits (0 :: Word45), + bits (0 :: Word46), bits (0 :: Word47), bits (0 :: Word48), + bits (0 :: Word49), bits (0 :: Word50), bits (0 :: Word51), + bits (0 :: Word52), bits (0 :: Word53), bits (0 :: Word54), + 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 main :: IO () main = do diff --git a/test/TypeLitsTest.hs b/test/TypeLitsTest.hs new file mode 100644 --- /dev/null +++ b/test/TypeLitsTest.hs @@ -0,0 +1,25 @@ +{-# 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