data-sword (empty) → 0.1
raw patch · 8 files changed
+964/−0 lines, 8 filesdep +basedep +data-bworddep +data-swordsetup-changed
Dependencies added: base, data-bword, data-sword, hashable, tasty, tasty-quickcheck, template-haskell
Files
- LICENSE +27/−0
- README.md +12/−0
- Setup.hs +2/−0
- data-sword.cabal +53/−0
- src/Data/ShortWord.hs +30/−0
- src/Data/ShortWord/TH.hs +617/−0
- tests/Tests.hs +214/−0
- tests/Types.hs +9/−0
+ LICENSE view
@@ -0,0 +1,27 @@+Copyright (c) 2016 Mikhail Vorozhtsov+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++- Redistributions of source code must retain the above copyright notice,+ this list of conditions and the following disclaimer.+- Redistributions in binary form must reproduce the above copyright+ notice, this list of conditions and the following disclaimer in the+ documentation and/or other materials provided with the distribution.+- Neither the names of the copyright owners nor the names of the+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.+
+ README.md view
@@ -0,0 +1,12 @@+Data-SWord+==========+This package provides Template Haskell utilities for declaring short binary word+data types built on top of longer binary word data types. Signed and unsigned+2, 4, 7, 24, and 48-bit types are predefined.++Installation+------------+The usual:++ $ cabal install+
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ data-sword.cabal view
@@ -0,0 +1,53 @@+Name: data-sword+Version: 0.1+Category: Data+Stability: experimental+Synopsis: Shorter binary words+Description:+ This package provides Template Haskell utilities for declaring short binary+ word data types built on top of longer binary word data types. Signed and+ unsigned 2, 4, 7, 24, and 48-bit types are predefined.++Homepage: https://github.com/mvv/data-sword+Bug-Reports: https://github.com/mvv/data-sword/issues++Author: Mikhail Vorozhtsov <mikhail.vorozhtsov@gmail.com>+Maintainer: Mikhail Vorozhtsov <mikhail.vorozhtsov@gmail.com>+Copyright: 2016 Mikhail Vorozhtsov <mikhail.vorozhtsov@gmail.com>+License: BSD3+License-File: LICENSE++Extra-Source-Files:+ README.md++Cabal-Version: >= 1.10.0+Build-Type: Simple++Source-Repository head+ Type: git+ Location: https://github.com/mvv/data-sword.git++Library+ Default-Language: Haskell2010+ Build-Depends: base >= 4.6 && < 5+ , template-haskell+ , hashable >= 1.1+ , data-bword >= 0.1+ Hs-Source-Dirs: src+ GHC-Options: -Wall+ Exposed-Modules:+ Data.ShortWord+ Data.ShortWord.TH++Test-Suite tests+ Default-Language: Haskell2010+ Type: exitcode-stdio-1.0+ Build-Depends: base >= 4.6 && < 5+ , tasty >= 0.8+ , tasty-quickcheck >= 0.8+ , data-sword+ Hs-Source-Dirs: tests+ GHC-Options: -Wall+ Main-Is: Tests.hs+ Other-Modules:+ Types
+ src/Data/ShortWord.hs view
@@ -0,0 +1,30 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE UnicodeSyntax #-}+{-# LANGUAGE TypeFamilies #-}++-- | This module provides signed and unsigned binary word data types of sizes+-- 2, 4, 7, 24, and 48 bits.+module Data.ShortWord+ ( module Data.BinaryWord+ , Word2+ , Word4+ , Word7+ , Word24+ , Word48+ , Int2+ , Int4+ , Int7+ , Int24+ , Int48+ ) where++import Data.Typeable+import Data.Word+import Data.BinaryWord+import Data.ShortWord.TH++mkShortWord "Word2" "Word2" "Int2" "Int2" ''Word8 2 [''Typeable]+mkShortWord "Word4" "Word4" "Int4" "Int4" ''Word8 4 [''Typeable]+mkShortWord "Word7" "Word7" "Int7" "Int7" ''Word8 7 [''Typeable]+mkShortWord "Word24" "Word24" "Int24" "Int24" ''Word32 24 [''Typeable]+mkShortWord "Word48" "Word48" "Int48" "Int48" ''Word64 48 [''Typeable]
+ src/Data/ShortWord/TH.hs view
@@ -0,0 +1,617 @@+{-# LANGUAGE UnicodeSyntax #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE TemplateHaskell #-}++-- | Template Haskell utilities for generating short words declarations+module Data.ShortWord.TH+ ( mkShortWord+ ) where++import GHC.Arr (Ix(..))+import GHC.Enum (succError, predError, toEnumError)+import Data.Ratio ((%))+import Data.Bits (Bits(..))+#if MIN_VERSION_base(4,7,0)+import Data.Bits (FiniteBits(..))+#endif+#if MIN_VERSION_hashable(1,2,0)+import Data.Hashable (Hashable(..), hashWithSalt)+#else+import Data.Hashable (Hashable(..), combine)+#endif+import Control.Applicative ((<$>), (<*>))+import Language.Haskell.TH hiding (match)+import Data.BinaryWord (BinaryWord(..))++-- | Declare signed and unsigned binary word types that use a subset+-- of the bits of the specified underlying type. For each data type+-- the following instances are declared: 'Eq', 'Ord',+-- 'Bounded', 'Enum', 'Num', 'Real', 'Integral', 'Show', 'Read',+-- 'Hashable', 'Ix', 'Bits', 'BinaryWord'.+mkShortWord ∷ String -- ^ Unsigned variant type name+ → String -- ^ Unsigned variant constructor name+ → String -- ^ Signed variant type name+ → String -- ^ Signed variant constructor name+ → Name -- ^ The underlying (unsigned) type+ → Int -- ^ The bit length+ → [Name] -- ^ List of instances for automatic derivation+ → Q [Dec]+mkShortWord un uc sn sc utp bl ad =+ (++) <$> mkShortWord' False un' uc' sn' sc' utp bl ad+ <*> mkShortWord' True sn' sc' un' uc' utp bl ad+ where un' = mkName un+ uc' = mkName uc+ sn' = mkName sn+ sc' = mkName sc++mkShortWord' ∷ Bool+ → Name → Name+ → Name → Name+ → Name+ → Int+ → [Name]+ → Q [Dec]+mkShortWord' signed tp cn otp ocn utp bl ad = return $+ [ NewtypeD [] tp []+#if MIN_VERSION_template_haskell(2,11,0)+ Nothing+ (NormalC cn [(Bang NoSourceUnpackedness+ NoSourceStrictness,+ uT)])+ (ConT <$> ad)+#else+ (NormalC cn [(NotStrict, uT)])+# if MIN_VERSION_template_haskell(2,10,0)+ (ConT <$> ad)+# else+ ad+# endif+#endif+ , inst ''Eq [tp] $+ {- (W x) == (W y) = x == y -}+ [ funUn2 '(==) $ appVN '(==) [x, y]+ , inline '(==) ]+ , inst ''Ord [tp]+ {- compare (W x) (W y) = x `compare` y -}+ [ funUn2 'compare $ appVN 'compare [x, y]+ , inline 'compare ]+ , inst ''Bounded [tp]+ {- minBound = W (minBound .&. MASK) -}+ [ fun 'minBound $ appW $ appV '(.&.) [VarE 'minBound, maskE]+ , inline 'minBound+ {- maxBound = W (maxBound .&. MASK) -}+ , fun 'maxBound $ appW $ appV '(.&.) [VarE 'maxBound, maskE]+ , inline 'maxBound ]+ , inst ''Enum [tp]+ {-+ succ x@(W y) = if x == maxBound then succError "TYPE"+ else W (y + shiftL 1 SHIFT)+ -}+ [ funUnAsX 'succ $+ CondE (appVN '(==) [x, 'maxBound])+ (appV 'succError [litS (show tp)])+ (appW (appV '(+) [VarE y, appV 'shiftL [litI 1, shiftE]]))+ , inlinable 'succ+ {-+ pred x@(W y) = if x == minBound then predError "TYPE"+ else W (y - shiftL 1 SHIFT)+ -}+ , funUnAsX 'pred $+ CondE (appVN '(==) [x, 'minBound])+ (appV 'predError [litS (show tp)])+ (appW (appV '(-) [VarE y, appV 'shiftL [litI 1, shiftE]]))+ , inlinable 'pred+ {-+ toEnum x = if y < shiftR minBound SHIFT || y > shiftR maxBound SHIFT+ then toEnumError "TYPE" x [minBound ∷ TYPE, maxBound ∷ TYPE]+ else W (shiftL y SHIFT)+ where y = toEnum x+ -}+ , funX' 'toEnum+ (CondE (appV '(||) [ appV '(<) [ VarE y+ , appV 'shiftR+ [VarE 'minBound, shiftE]+ ]+ , appV '(>) [ VarE y+ , appV 'shiftR+ [VarE 'maxBound, shiftE]+ ]+ ])+ (appV 'toEnumError [ litS (show tp)+ , VarE x+ , TupE [ SigE (VarE 'minBound) tpT+ , SigE (VarE 'maxBound) tpT+ ]+ ])+ (appW $ appV 'shiftL [VarE y, shiftE]))+ [val y $ appVN 'toEnum [x]]+ {- fromEnum (W x) = fromEnum (shiftR x SHIFT) -}+ , funUn 'fromEnum $ appV 'fromEnum [appV 'shiftR [VarE x, shiftE]]+ , inline 'fromEnum+ {- 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 + -}+ , funXY 'enumFromThen $+ appV 'enumFromThenTo+ [ VarE x+ , VarE y+ , CondE (appVN '(>=) [x, y]) (VarE 'maxBound) (VarE 'minBound)+ ]+ , inlinable 'enumFromThen+ {-+ enumFromTo x y = case y `compare` x of+ LT → x : down y x+ 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 + -}+ , 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]])+ []+ ])+ [ 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 $+ Clause [VarP to, VarP c]+ (NormalB $+ appC '(:)+ [ VarE next+ , CondE (appVN '(==) [next, to])+ (ConE '[]) (appVN up [to, next])+ ])+ [ValD (VarP next)+ (NormalB $ 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 + -}+ , 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]))+ []+ ])+ [ 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]+ {- negate (W x) = W (negate x) -}+ [ funUn 'negate $ appW $ appVN 'negate [x]+ , inline 'negate+ {- + abs x@(W y) = if SIGNED+ then if y < 0 then W (negate y) else x + else x+ -}+ , if signed+ then funUnAsX 'abs $+ CondE (appVN '(<) [y, 'allZeroes])+ (appW $ appVN 'negate [y]) (VarE x)+ else funX 'abs $ VarE x+ , if signed then inlinable 'abs else inline 'abs+ {- signum (W x) = W (shiftL (signum x) SHIFT) -}+ , funUn 'signum $ appW $ appV 'shiftL [appVN 'signum [x], shiftE]+ , inline 'signum+ {- (W x) + (W y) = W (x + y) -}+ , funUn2 '(+) $ appW $ appVN '(+) [x, y]+ , inline '(+)+ {- (W x) * (W y) = W (shiftR x SHIFT * y) -}+ , funUn2 '(*) $+ appW $ appV '(*) [appV 'shiftR [VarE x, shiftE], VarE y]+ , inline '(*)+ {- fromInteger x = W (shiftL (fromInteger x) SHIFT) -}+ , funX 'fromInteger $+ appW $ appV 'shiftL [appVN 'fromInteger [x], shiftE]+ , inline 'fromInteger+ ]+ , inst ''Real [tp]+ {- toRational x = toInteger x % 1 -}+ [ funX 'toRational $ appV '(%) [appVN 'toInteger [x], litI 1]+ , inline 'toRational ]+ , inst ''Integral [tp] $+ {- toInteger (W x) = toInteger (shiftR x SHIFT) -}+ [ funUn 'toInteger $ appV 'toInteger [appV 'shiftR [VarE x, shiftE]]+ , inline 'toInteger+ {-+ quotRem (W x) (W y) = (W (shiftL q SHIFT), W r)+ where (q, r) = quotRem x y+ -}+ , funUn2' 'quotRem+ (TupE [appW (appV 'shiftL [VarE q, shiftE]), appWN r])+ [vals [q, r] $ appVN 'quotRem [x, y]]+ , inline 'quotRem+ {-+ divMod (W x) (W y) = (W (shiftL q SHIFT), W r)+ where (q, r) = divMod x y+ -}+ , funUn2' 'divMod+ (TupE [appW (appV 'shiftL [VarE q, shiftE]), appWN r])+ [vals [q, r] $ appVN 'divMod [x, y]]+ , inline 'divMod+ ]+ , inst ''Show [tp]+ [ {- show (W x) = show (shiftR x SHIFT) -}+ funUn 'show $ appV 'show [appV 'shiftR [VarE x, shiftE]]+ , inline 'show ]+ , inst ''Read [tp]+ {-+ readsPrec x y = fmap (\(q, r) → (fromInteger q, r))+ $ readsPrec x y+ -}+ [ funXY 'readsPrec $+ appV 'fmap [ LamE [TupP [VarP q, VarP r]]+ (TupE [appVN 'fromInteger [q], VarE r])+ , appVN 'readsPrec [x, y] ]+ ]+ , inst ''Hashable [tp]+#if MIN_VERSION_hashable(1,2,0)+ {- hashWithSalt x (W y) = x `hashWithSalt` y -}+ [ funXUn 'hashWithSalt $ appVN 'hashWithSalt [x, y]+#else+ {- hash (W x) = hash x -}+ [ funUn 'hash $ appVN 'hash [x]+ , inline 'hash+#endif+ , inline 'hashWithSalt ]+ , inst ''Ix [tp]+ {- range (x, y) = enumFromTo x y -}+ [ funTup 'range $ appVN 'enumFromTo [x, y]+ , inline 'range+ {- unsafeIndex (x, _) z = fromIntegral z - fromIntegral x -}+ , funTupLZ 'unsafeIndex $+ appV '(-) [appVN 'fromIntegral [z], appVN 'fromIntegral [x]]+ , inline 'unsafeIndex+ {- inRange (x, y) z = z >= x && z <= y -}+ , funTupZ 'inRange $+ appV '(&&) [appVN '(>=) [z, x], appVN '(<=) [z, y]]+ , inline 'inRange ]+ , inst ''Bits [tp] $+ {- bitSize _ = SIZE -}+ [ fun_ 'bitSize $ sizeE+ , inline 'bitSize+#if MIN_VERSION_base(4,7,0)+ {- bitSizeMaybe _ = Just SIZE -}+ , fun_ 'bitSizeMaybe $ app (ConE 'Just) [sizeE]+ , inline 'bitSizeMaybe+#endif+ {- isSigned _ = SIGNED -}+ , fun_ 'isSigned $ ConE $ if signed then 'True else 'False+ , inline 'isSigned+ {- complement (W x) = W (complement x .&. MASK) -}+ , funUn 'complement $+ appW $ appV '(.&.) [appVN 'complement [x], maskE]+ , inline 'complement+ {- xor (W x) (W y) = W (xor x y) -}+ , funUn2 'xor $ appW $ appVN 'xor [x, y]+ , inline 'xor+ {- (W x) .&. (W y) = W (x .&. y) -}+ , funUn2 '(.&.) $ appW $ appVN '(.&.) [x, y]+ , inline '(.&.)+ {- (W x) .|. (W y) = W (x .|. y) -}+ , funUn2 '(.|.) $ appW $ appVN '(.|.) [x, y]+ , inline '(.|.)+ {- shiftL (W x) y = W (shiftL x y) -}+ , funUnY 'shiftL $ appW $ appVN 'shiftL [x, y]+ , inline 'shiftL+ {- shiftR (W x) y = W (shiftR x y .&. MASK) -}+ , funUnY 'shiftR $ appW $ appV '(.&.) [appVN 'shiftR [x, y], maskE]+ , inline 'shiftR+ {-+ UNSIGNED:+ rotateL (W x) y = W (shiftL x y .|.+ (shiftR x (SIZE - y) .&. MASK))++ SIGNED:+ rotateL (W x) y =+ W (shiftL x y .|.+ (signedWord (shiftR (unsignedWord x) (SIZE - y)) .&.+ MASK))+ -}+ , funUnY 'rotateL $ appW $ appV '(.|.) $ (appVN 'shiftL [x, y] :) $+ return $ appV '(.&.) $+ [ if signed+ then appV 'signedWord [ appV 'shiftR+ [ appVN 'unsignedWord [x]+ , appV '(-) [sizeE, VarE y]+ ]+ ]+ else appV 'shiftR [VarE x, appV '(-) [sizeE, VarE y]]+ , maskE+ ]+ , inline 'rotateL+ {- rotateR x y = rotateL x (SIZE - y) -}+ , funXY 'rotateR $ appV 'rotateL [VarE x, appV '(-) [sizeE, VarE y]]+ , inline 'rotateR+ {- bit x = W (bit (x + SHIFT)) -}+ , funX 'bit $ appW $ appV 'bit [appV '(+) [VarE x, shiftE]]+ , inline 'bit+ {- setBit (W x) y = W (setBit x (y + SHIFT)) -}+ , funUnY 'setBit $+ appW $ appV 'setBit [VarE x, appV '(+) [VarE y, shiftE]]+ , inline 'setBit+ {- clearBit (W x) y = W (clearBit x (y + SHIFT)) -}+ , funUnY 'clearBit $+ appW $ appV 'clearBit [VarE x, appV '(+) [VarE y, shiftE]]+ , inline 'clearBit+ {- complementBit (W x) y = W (complementBit x (y + SHIFT)) -}+ , funUnY 'complementBit $+ appW $ appV 'complementBit [VarE x, appV '(+) [VarE y, shiftE]]+ , inline 'complementBit+ {- testBit (W x) y = testBit x (y + SHIFT) -}+ , funUnY 'testBit $ appV 'testBit [VarE x, appV '(+) [VarE y, shiftE]]+ , inline 'testBit+ {- popCount (W x) = popCount x -}+ , funUn 'popCount $ appVN 'popCount [x]+ , inline 'popCount+ ]+#if MIN_VERSION_base(4,7,0)+ , inst ''FiniteBits [tp]+ {- finiteBitSize _ = SIZE -}+ [ fun_ 'finiteBitSize $ sizeE+ , 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]+ [ tySynInst ''UnsignedWord [tpT] $+ ConT $ if signed then otp else tp+ , tySynInst ''SignedWord [tpT] $+ ConT $ if signed then tp else otp+ {-+ UNSIGNED:+ unsignedWord = id+ + SIGNED:+ unsignedWord (W x) = U (unsignedWord x)+ -}+ , if signed+ then funUn 'unsignedWord $ appC ocn [appVN 'unsignedWord [x]]+ else fun 'unsignedWord $ VarE 'id+ , inline 'unsignedWord+ {-+ UNSIGNED:+ signedWord (W x) = S (signedWord hi)+ + SIGNED:+ signedWord = id+ -}+ , if signed+ then fun 'signedWord $ VarE 'id+ else funUn 'signedWord $ appC ocn [appVN 'signedWord [x]]+ , inline 'signedWord+ {-+ unwrappedAdd (W x) (W y) = (W (shiftL t1 SHIFT),+ U (unsignedWord t2))+ where (t1, t2) = unwrappedAdd x y+ -}+ , funUn2' 'unwrappedAdd+ (TupE [ appW (appV 'shiftL [VarE t1, shiftE])+ , appC (if signed then ocn else cn)+ [appVN 'unsignedWord [t2]]+ ])+ [vals [t1, t2] $ appVN 'unwrappedAdd [x, y]]+ , inline 'unwrappedAdd+ {-+ unwrappedMul (W x) (W y) = (W (shiftL t1 SHIFT),+ U (unsignedWord t2))+ where (t1, t2) = unwrappedMul (shiftR x SHIFT) y+ -}+ , funUn2' 'unwrappedMul+ (TupE [ appW (appV 'shiftL [VarE t1, shiftE])+ , appC (if signed then ocn else cn)+ [appVN 'unsignedWord [t2]]+ ])+ [vals [t1, t2] $+ appV 'unwrappedMul [appV 'shiftR [VarE x, shiftE], VarE y]]+ , inline 'unwrappedMul+ {- leadingZeroes (W x) = leadingZeroes (x .|. complement MASK) -}+ , funUn 'leadingZeroes $+ appV 'leadingZeroes [appV '(.|.)+ [VarE x, appV 'complement [maskE]]]+ , inline 'leadingZeroes+ {- trailingZeroes (W x) = trailingZeroes x - SHIFT -}+ , funUn 'trailingZeroes $+ appV '(-) [appVN 'trailingZeroes [x], shiftE]+ , inline 'trailingZeroes+ {- allZeroes = W allZeroes -}+ , fun 'allZeroes $ appWN 'allZeroes+ , inline 'allZeroes+ {- allOnes = W (allOnes .&. MASK) -}+ , fun 'allOnes $ appW $ appV '(.&.) [VarE 'allOnes, maskE]+ , inline 'allOnes+ {- msb = W msb -}+ , fun 'msb $ appWN 'msb+ , inline 'msb+ {- lsb = W (shiftL lsb SHIFT) -}+ , fun 'lsb $ appW $ appV 'shiftL [VarE 'lsb, shiftE]+ , inline 'lsb+ {- testMsb (W x) = testMsb x -}+ , funUn 'testMsb $ appVN 'testMsb [x]+ , inline 'testMsb+ {- testLsb (W x) = testBit x SHIFT -}+ , funUn 'testLsb $ appV 'testBit [VarE x, shiftE]+ , inline 'testLsb+ {- setMsb (W x) = W (setMsb x) -}+ , funUn 'setMsb $ appW $ appVN 'setMsb [x]+ , inline 'setMsb+ {- setLsb (W x) = W (setBit x SHIFT) -}+ , funUn 'setLsb $ appW $ appV 'setBit [VarE x, shiftE]+ , inline 'setLsb+ {- clearMsb (W x) = W (clearMsb x) -}+ , funUn 'clearMsb $ appW $ appVN 'clearMsb [x]+ , inline 'clearMsb+ {- clearLsb (W x) = W (clearBit x SHIFT) -}+ , funUn 'clearLsb $ appW $ appV 'clearBit [VarE x, shiftE]+ , inline 'clearLsb+ ]+ , rule ("fromIntegral/" ++ show tp ++ "->" ++ show tp)+ (VarE 'fromIntegral)+ (SigE (VarE 'id) (AppT (AppT ArrowT tpT) tpT))+ , rule ("fromIntegral/" ++ show tp ++ "->" ++ show otp)+ (VarE 'fromIntegral)+ (SigE (VarE $ if signed then 'unsignedWord else 'signedWord)+ (AppT (AppT ArrowT tpT) (ConT otp)))+ , rule ("fromIntegral/" ++ show tp ++ "->a")+ (VarE 'fromIntegral)+ (LetE [funUn fn $ appV 'fromIntegral+ [appV 'shiftR [VarE x, shiftE]]]+ (VarE fn))+ , rule ("fromIntegral/a->" ++ show tp)+ (VarE 'fromIntegral)+ (appV '(.) [ appV '(.) [ ConE tp+ , appV 'flip [VarE 'shiftL, shiftE] ]+ , VarE 'fromIntegral ])+ ]+ where+ x = mkName "x"+ y = mkName "y"+ z = mkName "z"+ q = mkName "q"+ r = mkName "r"+ t1 = mkName "t1"+ t2 = mkName "t2"+ c = mkName "c"+ next = mkName "next_"+ step = mkName "step_"+ to = mkName "to_"+ down = mkName "down_"+ up = mkName "up_"+ fn = mkName "fn_"+ uT | signed = AppT (ConT ''SignedWord) (ConT utp)+ | otherwise = AppT (ConT ''UnsignedWord) (ConT utp)+ tpT = ConT tp+ tySynInst n ps t =+#if MIN_VERSION_template_haskell(2,9,0)+ TySynInstD n (TySynEqn ps t)+#else+ TySynInstD n ps t+#endif+ 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) []]+ fun_ n e = FunD n [Clause [WildP] (NormalB e) []]+ funUn' n e ds =+ FunD n [Clause [ConP cn [VarP x]] (NormalB e) ds]+ funUn n e = funUn' n e []+ funUnAsX' n e ds = FunD n [Clause [AsP x (ConP cn [VarP y])]+ (NormalB e) ds]+ funUnAsX n e = funUnAsX' n e []+ funUn2' n e ds =+ FunD n [Clause [ConP cn [VarP x], ConP cn [VarP y]] (NormalB e) ds]+ funUn2 n e = funUn2' n e []+ funXUn' n e ds =+ FunD n [Clause [VarP x, ConP cn [VarP y]] (NormalB e) ds]+ funXUn n e = funXUn' n e []+ funUnY' n e ds =+ FunD n [Clause [ConP cn [VarP x], VarP y] (NormalB e) ds]+ funUnY n e = funUnY' n e []+ funX' n e ds = FunD n [Clause [VarP x] (NormalB e) ds]+ funX n e = funX' n e []+ funXY' n e ds = FunD n [Clause [VarP x, VarP y] (NormalB e) ds]+ funXY n e = funXY' n e []+ funTup n e = FunD n [Clause [TupP [VarP x, VarP y]] (NormalB e) []]+ funTupZ n e =+ 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) []]+ inline n = PragmaD $ InlineP n Inline FunLike AllPhases+ inlinable n = PragmaD $ InlineP n Inlinable FunLike AllPhases+ rule n m e = PragmaD $ RuleP n [] m e AllPhases+ val n e = ValD (VarP n) (NormalB e) []+ vals ns e = ValD (TupP (VarP <$> ns)) (NormalB e) []+ app f = foldl AppE f+ appN f = app f . fmap VarE+ appV f = app (VarE f)+ appC f = app (ConE f)+ appW e = appC cn [e]+ appVN f = appN (VarE f)+ appCN f = appN (ConE f)+ appWN e = appCN cn [e]+ litI = LitE . IntegerL+ litS = LitE . StringL+ sizeE = litI $ toInteger bl+ shiftE = appV '(-)+ [ appV+#if MIN_VERSION_base(4,7,0)+ 'finiteBitSize +#else+ 'bitSize +#endif+ [SigE (VarE 'undefined) uT]+ , sizeE ]+ maskE = appV 'shiftL [VarE 'allOnes, shiftE]
+ tests/Tests.hs view
@@ -0,0 +1,214 @@+{-# LANGUAGE UnicodeSyntax #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}++import Test.Tasty (defaultMain, localOption, testGroup)+import Test.Tasty.QuickCheck hiding ((.&.))++import Data.Bits+import Data.Word+import Data.Int+import Data.ShortWord (BinaryWord(..))+import Types++class Iso α τ | τ → α where+ fromArbitrary ∷ α → τ + toArbitrary ∷ τ → α+ isValid ∷ τ → Bool++instance Iso Word16 U16 where+ fromArbitrary w = U16 $ fromIntegral w `shiftL` 48+ toArbitrary (U16 w) = fromIntegral $ w `shiftR` 48+ isValid (U16 w) = (w .&. 0xFFFFFFFFFF) == 0++instance Iso Int16 I16 where+ fromArbitrary w = I16 $ fromIntegral w `shiftL` 48+ toArbitrary (I16 w) = fromIntegral $ w `shiftR` 48+ isValid (I16 w) = (w .&. 0xFFFFFFFFFF) == 0++main = defaultMain+ $ localOption (QuickCheckTests 1000)+ $ testGroup "Tests"+ [ isoTestGroup "Word64/16" (0 ∷ U16)+ , isoTestGroup "Int64/16" (0 ∷ I16) ]++#if !MIN_VERSION_base(4,7,0)+finiteBitSize = bitSize+#endif++isoTestGroup name t =+ testGroup name+ [ testProperty "Iso" $ prop_conv t+ , testGroup "Eq" [ testProperty "(==)" $ prop_eq t ]+ , testGroup "Ord" [ testProperty "compare" $ prop_compare t ]+ , testGroup "Bounded"+ [ testProperty "minBound" $ prop_minBound t+ , testProperty "maxBound" $ prop_maxBound t ]+ , testGroup "Enum"+ [ testProperty "succ" $ prop_succ t+ , testProperty "pred" $ prop_pred t ]+ , testGroup "Num"+ [ testProperty "negate" $ prop_negate t+ , testProperty "abs" $ prop_abs t+ , testProperty "signum" $ prop_signum t+ , testProperty "(+)" $ prop_add t+ , testProperty "(-)" $ prop_sub t+ , testProperty "(*)" $ prop_mul t+ , testProperty "fromInteger" $ prop_fromInteger t ]+ , testGroup "Real"+ [ testProperty "toRational" $ prop_toRational t ]+ , testGroup "Integral"+ [ testProperty "toInteger" $ prop_toInteger t+ , testProperty "quotRem" $ prop_quotRem t+ , testProperty "quot" $ prop_quot t+ , testProperty "rem" $ prop_rem t+ , testProperty "divMod" $ prop_divMod t+ , testProperty "div" $ prop_div t+ , testProperty "mod" $ prop_mod t ]+ , testGroup "Bits"+ [ testProperty "complement" $ prop_complement t+ , testProperty "xor" $ prop_xor t+ , testProperty "(.&.)" $ prop_and t+ , testProperty "(.|.)" $ prop_or t+ , testProperty "shiftL" $ prop_shiftL t+ , testProperty "shiftR" $ prop_shiftR t+ , testProperty "rotateL" $ prop_rotateL t+ , testProperty "rotateR" $ prop_rotateR t+ , testProperty "bit" $ prop_bit t+ , testProperty "setBit" $ prop_setBit t+ , testProperty "clearBit" $ prop_clearBit t+ , testProperty "complementBit" $ prop_complementBit t+ , testProperty "testBit" $ prop_testBit t+ , testProperty "popCount" $ prop_popCount t+ ]+ , testGroup "BinaryWord"+ [ testProperty "unwrappedAdd" $ prop_unwrappedAdd t+ , testProperty "unwrappedMul" $ prop_unwrappedMul t+ , testProperty "leadingZeroes" $ prop_leadingZeroes t+ , testProperty "trailingZeroes" $ prop_trailingZeroes t+ , testProperty "allZeroes" $ prop_allZeroes t+ , testProperty "allOnes" $ prop_allOnes t+ , testProperty "msb" $ prop_msb t+ , testProperty "lsb" $ prop_lsb t+ , testProperty "testMsb" $ prop_testMsb t+ , testProperty "testLsb" $ prop_testLsb t+ ]+ ]++toType ∷ Iso α τ ⇒ τ → α → τ +toType _ = fromArbitrary++fromType ∷ Iso α τ ⇒ τ → τ → α +fromType _ = toArbitrary++withUnary ∷ Iso α τ ⇒ τ → (τ → β) → α → β+withUnary _ f = f . fromArbitrary++withBinary ∷ Iso α τ ⇒ τ → (τ → τ → β) → α → α → β+withBinary _ f x y = f (fromArbitrary x) (fromArbitrary y)++propUnary f g t w = isValid r && toArbitrary r == f w+ where r = withUnary t g w+propUnary' f g t w = f w == withUnary t g w++propBinary f g t w1 w2 = isValid r && f w1 w2 == toArbitrary r+ where r = withBinary t g w1 w2+propBinary' f g t w1 w2 = f w1 w2 == withBinary t g w1 w2++prop_conv t w = toArbitrary (toType t w) == w++prop_eq = propBinary' (==) (==)++prop_compare = propBinary' compare compare++prop_minBound t = minBound == fromType t minBound+prop_maxBound t = maxBound == fromType t maxBound++prop_succ t w = (w /= maxBound) ==> (isValid r && succ w == toArbitrary r)+ where r = withUnary t succ w+prop_pred t w = (w /= minBound) ==> (isValid r && pred w == toArbitrary r)+ where r = withUnary t pred w++prop_unwrappedAdd ∷ (Iso α τ, Iso (UnsignedWord α) (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 τ)+ ⇒ τ → α → α → Bool+prop_unwrappedMul t x y = h1 == toArbitrary h2 && l1 == toArbitrary l2+ where (h1, l1) = unwrappedMul x y+ (h2, l2) = unwrappedMul (toType t x) (toType t y)++prop_leadingZeroes = propUnary' leadingZeroes leadingZeroes+prop_trailingZeroes = propUnary' trailingZeroes trailingZeroes+prop_allZeroes t = allZeroes == fromType t allZeroes+prop_allOnes t = allOnes == fromType t allOnes+prop_msb t = msb == fromType t msb+prop_lsb t = lsb == fromType t lsb+prop_testMsb = propUnary' testMsb testMsb+prop_testLsb = propUnary' testLsb testLsb++prop_negate = propUnary negate negate+prop_abs = propUnary abs abs+prop_signum = propUnary signum signum+prop_add = propBinary (+) (+)+prop_sub = propBinary (-) (-)+prop_mul = propBinary (*) (*)+prop_fromInteger t i = fromInteger i == fromType t (fromInteger i) ++prop_toRational = propUnary' toRational toRational++prop_toInteger = propUnary' toInteger toInteger+prop_quotRem t n d = (d /= 0) ==> (qr == (fromType t q1, fromType t r1))+ where qr = quotRem n d+ (q1, r1) = quotRem (fromArbitrary n) (fromArbitrary d)+prop_quot t n d = (d /= 0) ==> (q == fromType t q1)+ where q = quot n d+ q1 = quot (fromArbitrary n) (fromArbitrary d)+prop_rem t n d = (d /= 0) ==> (r == fromType t r1)+ where r = rem n d+ r1 = rem (fromArbitrary n) (fromArbitrary d)+prop_divMod t n d = (d /= 0) ==> (qr == (fromType t q1, fromType t r1))+ where qr = divMod n d+ (q1, r1) = divMod (fromArbitrary n) (fromArbitrary d)+prop_div t n d = (d /= 0) ==> (q == fromType t q1)+ where q = div n d+ q1 = div (fromArbitrary n) (fromArbitrary d)+prop_mod t n d = (d /= 0) ==> (r == fromType t r1)+ where r = mod n d+ r1 = mod (fromArbitrary n) (fromArbitrary d)++prop_complement = propUnary complement complement+prop_xor = propBinary xor xor+prop_and = propBinary (.&.) (.&.)+prop_or = propBinary (.|.) (.|.)+propOffsets f g t w =+ all (\b → let r = withUnary t (`g` b) w in+ isValid r && toArbitrary r == f w b)+ [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 .. finiteBitSize t - 1]+propBits f g t w =+ all (\b → let r = withUnary t (`g` b) w in+ isValid r && toArbitrary r == f w b)+ [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 .. finiteBitSize t - 1]+prop_popCount = propUnary' popCount popCount
+ tests/Types.hs view
@@ -0,0 +1,9 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}++module Types where++import Data.Word+import Data.ShortWord.TH++mkShortWord "U16" "U16" "I16" "I16" ''Word64 16 []