data-dword (empty) → 0.1
raw patch · 8 files changed
+2449/−0 lines, 8 filesdep +QuickCheckdep +basedep +data-dwordsetup-changed
Dependencies added: QuickCheck, base, data-dword, ghc-prim, hashable, template-haskell, test-framework, test-framework-quickcheck2
Files
- LICENSE +27/−0
- Setup.hs +2/−0
- data-dword.cabal +56/−0
- src/Data/DoubleWord.hs +35/−0
- src/Data/DoubleWord/Base.hs +557/−0
- src/Data/DoubleWord/TH.hs +1457/−0
- tests/Tests.hs +302/−0
- tests/Types.hs +13/−0
+ LICENSE view
@@ -0,0 +1,27 @@+Copyright (c) 2011, 2012 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.+
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ data-dword.cabal view
@@ -0,0 +1,56 @@+Name: data-dword+Version: 0.1+Category: Data+Stability: experimental+Synopsis: Stick two binary words together to get a bigger one+Description:+ 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.++Homepage: https://github.com/mvv/data-dword+Bug-Reports: https://github.com/mvv/data-dword/issues++Author: Mikhail Vorozhtsov <mikhail.vorozhtsov@gmail.com>+Maintainer: Mikhail Vorozhtsov <mikhail.vorozhtsov@gmail.com>+Copyright: 2011, 2012 Mikhail Vorozhtsov <mikhail.vorozhtsov@gmail.com>+License: BSD3+License-File: LICENSE++Cabal-Version: >= 1.10.0+Build-Type: Simple++Source-Repository head+ Type: git+ Location: https://github.com/mvv/data-dword.git++Library+ Default-Language: Haskell2010+ Build-Depends:+ base >= 4.5 && < 5,+ hashable >= 1.1,+ template-haskell >= 2.8,+ ghc-prim+ Hs-Source-Dirs: src+ GHC-Options: -Wall+ Exposed-Modules:+ Data.DoubleWord+ Data.DoubleWord.TH+ Other-Modules:+ Data.DoubleWord.Base++Test-Suite tests+ Default-Language: Haskell2010+ Type: exitcode-stdio-1.0+ Build-Depends:+ base >= 4.5 && < 5,+ test-framework >= 0.5,+ test-framework-quickcheck2 >= 0.2,+ QuickCheck >= 2.4,+ data-dword+ Hs-Source-Dirs: tests+ GHC-Options: -Wall+ Main-Is: Tests.hs+ Other-Modules:+ Types+
+ src/Data/DoubleWord.hs view
@@ -0,0 +1,35 @@+{-# LANGUAGE UnicodeSyntax #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}++-- | This module provides strict (low and high halves are unpacked)+-- signed and unsigned binary word data types of sizes 96, 128,+-- 160, 192, 224, and 256 bits.+module Data.DoubleWord+ ( module Data.DoubleWord.Base+ , Word96(..)+ , Word128(..)+ , Word160(..)+ , Word192(..)+ , Word224(..)+ , Word256(..)+ , Int96(..)+ , Int128(..)+ , Int160(..)+ , Int192(..)+ , Int224(..)+ , Int256(..)+ ) where++import Data.Word+import Data.Int+import Data.DoubleWord.Base+import Data.DoubleWord.TH++mkUnpackedDoubleWord "Word96" ''Word32 "Int96" ''Int32 ''Word64+mkUnpackedDoubleWord "Word128" ''Word64 "Int128" ''Int64 ''Word64+mkUnpackedDoubleWord "Word160" ''Word32 "Int160" ''Int32 ''Word128+mkUnpackedDoubleWord "Word192" ''Word64 "Int192" ''Int64 ''Word128+mkUnpackedDoubleWord "Word224" ''Word96 "Int224" ''Int96 ''Word128+mkUnpackedDoubleWord "Word256" ''Word128 "Int256" ''Int128 ''Word128+
+ src/Data/DoubleWord/Base.hs view
@@ -0,0 +1,557 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE UnicodeSyntax #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE UnboxedTuples #-}++#include "MachDeps.h"++module Data.DoubleWord.Base+ ( BinaryWord(..)+ , DoubleWord(..)+ ) where++import Data.Int+import Data.Word+import Data.Bits (Bits(..))+#if __GLASGOW_HASKELL__ >= 705+import GHC.Prim (plusWord2#, timesWord2#)+# if WORD_SIZE_IN_BITS == 32+import GHC.Word (Word32(..))+# endif+# if WORD_SIZE_IN_BITS == 64+import GHC.Word (Word64(..))+# endif+#endif++-- | Extra bit-manipulation functions for binary words of fixed length.+class Bits w ⇒ BinaryWord w where+ -- | The unsigned variant type+ type UnsignedWord w+ -- | The signed variant type+ type SignedWord w+ -- | Convert the word to the unsigned type (identical to 'fromIntegral')+ unsignedWord ∷ w → UnsignedWord w+ -- | Convert the word to the signed type (identical to 'fromIntegral')+ signedWord ∷ w → SignedWord w+ -- | Unwrapped addition+ unwrappedAdd ∷ w → w → (w, UnsignedWord w)+ -- | Unwrapped multiplication+ unwrappedMul ∷ w → w → (w, UnsignedWord w)+ -- | Number of leading (from MSB) zero bits+ leadingZeroes ∷ w → Int+ -- | Number or trailing (from LSB) zero bits+ trailingZeroes ∷ w → Int+ -- | The word with all bits set to 0+ allZeroes ∷ w+ -- | The word with all bits set to 1+ allOnes ∷ w+ -- | The word with MSB set to 1 and all the other bits set to 0+ msb ∷ w+ -- | The word with LSB set to 1 and all the other bits set to 0+ lsb ∷ w+ -- | Test if the MSB is 1+ testMsb ∷ w → Bool+ -- | Test if the LSB is 1+ testLsb ∷ w → Bool++instance BinaryWord Word8 where+ type UnsignedWord Word8 = Word8+ type SignedWord Word8 = Int8+ unsignedWord = id+ {-# INLINE unsignedWord #-}+ signedWord = fromIntegral+ {-# INLINE signedWord #-}+ unwrappedAdd x y = hi `seq` lo `seq` (hi, lo)+ where s = fromIntegral x + fromIntegral y ∷ Word16+ hi = hiWord s+ lo = loWord s+ {-# INLINE unwrappedAdd #-}+ unwrappedMul x y = hi `seq` lo `seq` (hi, lo)+ where p = fromIntegral x * fromIntegral y ∷ Word16+ hi = hiWord p+ lo = loWord p+ {-# INLINE unwrappedMul #-}+ leadingZeroes w | w .&. 0xF0 == 0 = go4 4 w+ | otherwise = go4 0 (shiftR w 4)+ where go4 off w' | w' .&. 8 /= 0 = off+ | w' .&. 4 /= 0 = off + 1+ | w' .&. 2 /= 0 = off + 2+ | w' .&. 1 /= 0 = off + 3+ | otherwise = off + 4+ trailingZeroes w | w .&. 0x0F == 0 = go4 4 (shiftR w 4)+ | otherwise = go4 0 w+ where go4 off w' | w' .&. 1 /= 0 = off+ | w' .&. 2 /= 0 = off + 1+ | w' .&. 4 /= 0 = off + 2+ | w' .&. 8 /= 0 = off + 3+ | otherwise = off + 4+ allZeroes = 0+ {-# INLINE allZeroes #-}+ allOnes = 0xFF+ {-# INLINE allOnes #-}+ msb = 0x80+ {-# INLINE msb #-}+ lsb = 1+ {-# INLINE lsb #-}+ testMsb x = testBit x 7+ {-# INLINE testMsb #-}+ testLsb x = testBit x 0+ {-# INLINE testLsb #-}++instance BinaryWord Word16 where+ type UnsignedWord Word16 = Word16+ type SignedWord Word16 = Int16+ unsignedWord = id+ {-# INLINE unsignedWord #-}+ signedWord = fromIntegral+ {-# INLINE signedWord #-}+ unwrappedAdd x y = hi `seq` lo `seq` (hi, lo)+ where s = fromIntegral x + fromIntegral y ∷ Word32+ lo = loWord s+ hi = hiWord s+ {-# INLINE unwrappedAdd #-}+ unwrappedMul x y = hi `seq` lo `seq` (hi, lo)+ where p = fromIntegral x * fromIntegral y ∷ Word32+ lo = loWord p+ hi = hiWord p+ {-# INLINE unwrappedMul #-}+ leadingZeroes w | w .&. 0xFF00 == 0 = go8 8 w+ | otherwise = go8 0 (shiftR w 8)+ where+ go8 off w' | w' .&. 0xF0 == 0 = go4 (off + 4) w'+ | otherwise = go4 off (shiftR w' 4)+ go4 off w' | w' .&. 8 /= 0 = off+ | w' .&. 4 /= 0 = off + 1+ | w' .&. 2 /= 0 = off + 2+ | w' .&. 1 /= 0 = off + 3+ | otherwise = off + 4+ trailingZeroes w | w .&. 0x00FF == 0 = go8 8 (shiftR w 8)+ | otherwise = go8 0 w+ where+ go8 off w' | w' .&. 0x0F == 0 = go4 (off + 4) (shiftR w' 4)+ | otherwise = go4 off w'+ go4 off w' | w' .&. 1 /= 0 = off+ | w' .&. 2 /= 0 = off + 1+ | w' .&. 4 /= 0 = off + 2+ | w' .&. 8 /= 0 = off + 3+ | otherwise = off + 4+ allZeroes = 0+ {-# INLINE allZeroes #-}+ allOnes = 0xFFFF+ {-# INLINE allOnes #-}+ msb = 0x8000+ {-# INLINE msb #-}+ lsb = 1+ {-# INLINE lsb #-}+ testMsb x = testBit x 15+ {-# INLINE testMsb #-}+ testLsb x = testBit x 0+ {-# INLINE testLsb #-}++instance BinaryWord Word32 where+ type UnsignedWord Word32 = Word32+ type SignedWord Word32 = Int32+ unsignedWord = id+ {-# INLINE unsignedWord #-}+ signedWord = fromIntegral+ {-# INLINE signedWord #-}+#if __GLASGOW_HASKELL__ >= 705 && WORD_SIZE_IN_BITS == 32+ unwrappedAdd (W32# x) (W32# y) = hi `seq` lo `seq` (hi, lo)+ where (# hi', lo' #) = plusWord2# x y+ hi = W32# hi'+ lo = W32# lo'+#else+ unwrappedAdd x y = hi `seq` lo `seq` (hi, lo)+ where s = fromIntegral x + fromIntegral y ∷ Word64+ lo = loWord s+ hi = hiWord s+#endif+ {-# INLINE unwrappedAdd #-}+#if __GLASGOW_HASKELL__ >= 705 && WORD_SIZE_IN_BITS == 32+ unwrappedMul (W32# x) (W32# y) = hi `seq` lo `seq` (hi, lo)+ where (# hi', lo' #) = timesWord2# x y+ lo = W32# lo'+ hi = W32# hi'+#else+ unwrappedMul x y = hi `seq` lo `seq` (hi, lo)+ where p = fromIntegral x * fromIntegral y ∷ Word64+ lo = loWord p+ hi = hiWord p+#endif+ {-# INLINE unwrappedMul #-}+ leadingZeroes w | w .&. 0xFFFF0000 == 0 = go16 16 w+ | otherwise = go16 0 (shiftR w 16)+ where+ go16 off w' | w' .&. 0xFF00 == 0 = go8 (off + 8) w'+ | otherwise = go8 off (shiftR w' 8)+ go8 off w' | w' .&. 0xF0 == 0 = go4 (off + 4) w'+ | otherwise = go4 off (shiftR w' 4)+ go4 off w' | w' .&. 8 /= 0 = off+ | w' .&. 4 /= 0 = off + 1+ | w' .&. 2 /= 0 = off + 2+ | w' .&. 1 /= 0 = off + 3+ | otherwise = off + 4+ trailingZeroes w | w .&. 0x0000FFFF == 0 = go16 16 (shiftR w 16)+ | otherwise = go16 0 w+ where+ go16 off w' | w' .&. 0x00FF == 0 = go8 (off + 8) (shiftR w' 8)+ | otherwise = go8 off w'+ go8 off w' | w' .&. 0x0F == 0 = go4 (off + 4) (shiftR w' 4)+ | otherwise = go4 off w'+ go4 off w' | w' .&. 1 /= 0 = off+ | w' .&. 2 /= 0 = off + 1+ | w' .&. 4 /= 0 = off + 2+ | w' .&. 8 /= 0 = off + 3+ | otherwise = off + 4+ allZeroes = 0+ {-# INLINE allZeroes #-}+ allOnes = 0xFFFFFFFF+ {-# INLINE allOnes #-}+ msb = 0x80000000+ {-# INLINE msb #-}+ lsb = 1+ {-# INLINE lsb #-}+ testMsb x = testBit x 31+ {-# INLINE testMsb #-}+ testLsb x = testBit x 0+ {-# INLINE testLsb #-}++instance BinaryWord Word64 where+ type UnsignedWord Word64 = Word64+ type SignedWord Word64 = Int64+ unsignedWord = id+ {-# INLINE unsignedWord #-}+ signedWord = fromIntegral+ {-# INLINE signedWord #-}+#if __GLASGOW_HASKELL__ >= 705 && WORD_SIZE_IN_BITS == 64+ unwrappedAdd (W64# x) (W64# y) = hi `seq` lo `seq` (hi, lo)+ where (# hi', lo' #) = plusWord2# x y+ lo = W64# lo'+ hi = W64# hi'+ {-# INLINE unwrappedAdd #-}+#else+ unwrappedAdd x y = hi `seq` lo `seq` (hi, lo)+ where lo = x + y+ hi = if lo > x then 1 else 0+ {-# INLINABLE unwrappedAdd #-}+#endif+#if __GLASGOW_HASKELL__ >= 705 && WORD_SIZE_IN_BITS == 64+ unwrappedMul (W64# x) (W64# y) = hi `seq` lo `seq` (hi, lo)+ where (# hi', lo' #) = timesWord2# x y+ lo = W64# lo'+ hi = W64# hi'+ {-# INLINE unwrappedMul #-}+#else+ unwrappedMul x y = hi `seq` lo `seq` (hi, lo)+ where xHi = hiWord x+ xLo = loWord x+ yHi = hiWord y+ yLo = loWord y+ hi0 = xHi * yHi+ lo0 = xLo * yLo+ p1 = xHi * yLo+ p2 = xLo * yHi+ lo = lo0 + shiftL p1 32 + shiftL p2 32+ hi = hi0 + shiftR p1 32 + shiftR p2 32+#endif+#if WORD_SIZE_IN_BITS == 64+ leadingZeroes w | w .&. 0xFFFFFFFF00000000 == 0 = go32 32 w+ | otherwise = go32 0 (shiftR w 32)+ where+ go32 off w' | w' .&. 0xFFFF0000 == 0 = go16 (off + 16) w'+ | otherwise = go16 off (shiftR w' 16)+ go16 off w' | w' .&. 0xFF00 == 0 = go8 (off + 8) w'+ | otherwise = go8 off (shiftR w' 8)+ go8 off w' | w' .&. 0xF0 == 0 = go4 (off + 4) w'+ | otherwise = go4 off (shiftR w' 4)+ go4 off w' | w' .&. 8 /= 0 = off+ | w' .&. 4 /= 0 = off + 1+ | w' .&. 2 /= 0 = off + 2+ | w' .&. 1 /= 0 = off + 3+ | otherwise = off + 4+ trailingZeroes w | w .&. 0x00000000FFFFFFFF == 0 = go32 32 (shiftR w 32)+ | otherwise = go32 0 w+ where+ go32 off w' | w' .&. 0x0000FFFF == 0 = go16 (off + 16) (shiftR w' 16)+ | otherwise = go16 off w'+ go16 off w' | w' .&. 0x00FF == 0 = go8 (off + 8) (shiftR w' 8)+ | otherwise = go8 off w'+ go8 off w' | w' .&. 0x0F == 0 = go4 (off + 4) (shiftR w' 4)+ | otherwise = go4 off w'+ go4 off w' | w' .&. 1 /= 0 = off+ | w' .&. 2 /= 0 = off + 1+ | w' .&. 4 /= 0 = off + 2+ | w' .&. 8 /= 0 = off + 3+ | otherwise = off + 4+#else+ leadingZeroes w | hiZeroes == 32 = 32 + leadingZeroes (loWord w)+ | otherwise = hiZeroes+ where hiZeroes = leadingZeroes (hiWord w)+ trailingZeroes w | loZeroes == 32 = 32 + trailingZeroes (hiWord w)+ | otherwise = loZeroes+ where loZeroes = trailingZeroes (loWord w)+#endif+ allZeroes = 0+ {-# INLINE allZeroes #-}+ allOnes = 0xFFFFFFFFFFFFFFFF+ {-# INLINE allOnes #-}+ msb = 0x8000000000000000+ {-# INLINE msb #-}+ lsb = 1+ {-# INLINE lsb #-}+ testMsb x = testBit x 63+ {-# INLINE testMsb #-}+ testLsb x = testBit x 0+ {-# INLINE testLsb #-}++instance BinaryWord Int8 where+ type UnsignedWord Int8 = Word8+ type SignedWord Int8 = Int8+ unsignedWord = fromIntegral+ {-# INLINE unsignedWord #-}+ signedWord = id+ {-# INLINE signedWord #-}+ unwrappedAdd x y = hi `seq` lo `seq` (hi, lo)+ where s = fromIntegral x + fromIntegral y ∷ Int16+ hi = hiWord s+ lo = loWord s+ {-# INLINE unwrappedAdd #-}+ unwrappedMul x y = hi `seq` lo `seq` (hi, lo)+ where p = fromIntegral x * fromIntegral y ∷ Int16+ hi = hiWord p+ lo = loWord p+ {-# INLINE unwrappedMul #-}+ leadingZeroes = leadingZeroes . unsignedWord+ {-# INLINE leadingZeroes #-}+ trailingZeroes = trailingZeroes . unsignedWord+ {-# INLINE trailingZeroes #-}+ allZeroes = 0+ {-# INLINE allZeroes #-}+ allOnes = 0xFF+ {-# INLINE allOnes #-}+ msb = 0x80+ {-# INLINE msb #-}+ lsb = 1+ {-# INLINE lsb #-}+ testMsb x = testBit x 7+ {-# INLINE testMsb #-}+ testLsb x = testBit x 0+ {-# INLINE testLsb #-}++instance BinaryWord Int16 where+ type UnsignedWord Int16 = Word16+ type SignedWord Int16 = Int16+ unsignedWord = fromIntegral+ {-# INLINE unsignedWord #-}+ signedWord = id+ {-# INLINE signedWord #-}+ unwrappedAdd x y = hi `seq` lo `seq` (hi, lo)+ where s = fromIntegral x + fromIntegral y ∷ Int32+ lo = loWord s+ hi = hiWord s+ {-# INLINE unwrappedAdd #-}+ unwrappedMul x y = hi `seq` lo `seq` (hi, lo)+ where p = fromIntegral x * fromIntegral y ∷ Int32+ lo = loWord p+ hi = hiWord p+ {-# INLINE unwrappedMul #-}+ leadingZeroes = leadingZeroes . unsignedWord+ {-# INLINE leadingZeroes #-}+ trailingZeroes = trailingZeroes . unsignedWord+ {-# INLINE trailingZeroes #-}+ allZeroes = 0+ {-# INLINE allZeroes #-}+ allOnes = 0xFFFF+ {-# INLINE allOnes #-}+ msb = 0x8000+ {-# INLINE msb #-}+ lsb = 1+ {-# INLINE lsb #-}+ testMsb x = testBit x 15+ {-# INLINE testMsb #-}+ testLsb x = testBit x 0+ {-# INLINE testLsb #-}++instance BinaryWord Int32 where+ type UnsignedWord Int32 = Word32+ type SignedWord Int32 = Int32+ unsignedWord = fromIntegral+ {-# INLINE unsignedWord #-}+ signedWord = id+ {-# INLINE signedWord #-}+#if WORD_SIZE_IN_BITS == 32+ unwrappedAdd x y = hi `seq` lo `seq` (hi, lo)+ where extX = if x < 0 then maxBound else 0+ extY = if y < 0 then maxBound else 0+ (hi', lo) = unsignedWord x `unwrappedAdd` unsignedWord y+ hi = signedWord $ hi' + extX + extY+ unwrappedMul x y = hi `seq` lo `seq` (hi, lo)+ where extX = if x < 0 then negate y else 0+ extY = if y < 0 then negate x else 0+ (hi', lo) = unsignedWord x `unwrappedMul` unsignedWord y+ hi = signedWord hi' + extX + extY+#else+ unwrappedAdd x y = hi `seq` lo `seq` (hi, lo)+ where s = fromIntegral x + fromIntegral y ∷ Int64+ lo = loWord s+ hi = hiWord s+ {-# INLINE unwrappedAdd #-}+ unwrappedMul x y = hi `seq` lo `seq` (hi, lo)+ where p = fromIntegral x * fromIntegral y ∷ Int64+ lo = loWord p+ hi = hiWord p+ {-# INLINE unwrappedMul #-}+#endif+ leadingZeroes = leadingZeroes . unsignedWord+ {-# INLINE leadingZeroes #-}+ trailingZeroes = trailingZeroes . unsignedWord+ {-# INLINE trailingZeroes #-}+ allZeroes = 0+ {-# INLINE allZeroes #-}+ allOnes = 0xFFFFFFFF+ {-# INLINE allOnes #-}+ msb = 0x80000000+ {-# INLINE msb #-}+ lsb = 1+ {-# INLINE lsb #-}+ testMsb x = testBit x 31+ {-# INLINE testMsb #-}+ testLsb x = testBit x 0+ {-# INLINE testLsb #-}++instance BinaryWord Int64 where+ type UnsignedWord Int64 = Word64+ type SignedWord Int64 = Int64+ unsignedWord = fromIntegral+ {-# INLINE unsignedWord #-}+ signedWord = id+ {-# INLINE signedWord #-}+ unwrappedAdd x y = hi `seq` lo `seq` (hi, lo)+ where extX = if x < 0 then maxBound else 0+ extY = if y < 0 then maxBound else 0+ (hi', lo) = unsignedWord x `unwrappedAdd` unsignedWord y+ hi = signedWord $ hi' + extX + extY+ unwrappedMul x y = hi `seq` lo `seq` (hi, lo)+ where extX = if x < 0 then negate y else 0+ extY = if y < 0 then negate x else 0+ (hi', lo) = unsignedWord x `unwrappedMul` unsignedWord y+ hi = signedWord hi' + extX + extY+ leadingZeroes = leadingZeroes . unsignedWord+ {-# INLINE leadingZeroes #-}+ trailingZeroes = trailingZeroes . unsignedWord+ {-# INLINE trailingZeroes #-}+ allZeroes = 0+ {-# INLINE allZeroes #-}+ allOnes = 0xFFFFFFFFFFFFFFFF+ {-# INLINE allOnes #-}+ msb = 0x8000000000000000+ {-# INLINE msb #-}+ lsb = 1+ {-# INLINE lsb #-}+ testMsb x = testBit x 63+ {-# INLINE testMsb #-}+ testLsb x = testBit x 0+ {-# INLINE testLsb #-}++-- | Defines a particular way to split a binary word in halves.+class BinaryWord w ⇒ DoubleWord w where+ -- | The low half type+ type LoWord w+ -- | The high half type+ type HiWord w+ -- | The low half of the word+ loWord ∷ w → LoWord w+ -- | The high half of the word+ hiWord ∷ w → HiWord w+ -- | Construct a word from the low and high halves+ fromHiAndLo ∷ HiWord w → LoWord w → w+ -- | Extend the low half+ extendLo ∷ LoWord w → w+ -- | Sign-extend the low half+ signExtendLo ∷ SignedWord (LoWord w) → w++instance DoubleWord Word16 where+ type LoWord Word16 = Word8+ type HiWord Word16 = Word8+ loWord w = fromIntegral w+ {-# INLINE loWord #-}+ hiWord w = fromIntegral $ shiftR w 8+ {-# INLINE hiWord #-}+ fromHiAndLo hi lo = shiftL (fromIntegral hi) 8 .|. fromIntegral lo+ {-# INLINE fromHiAndLo #-}+ extendLo = fromIntegral+ {-# INLINE extendLo #-}+ signExtendLo = fromIntegral+ {-# INLINE signExtendLo #-}++instance DoubleWord Word32 where+ type LoWord Word32 = Word16+ type HiWord Word32 = Word16+ loWord w = fromIntegral w+ {-# INLINE loWord #-}+ hiWord w = fromIntegral $ shiftR w 16+ {-# INLINE hiWord #-}+ fromHiAndLo hi lo = shiftL (fromIntegral hi) 16 .|. fromIntegral lo+ {-# INLINE fromHiAndLo #-}+ extendLo = fromIntegral+ {-# INLINE extendLo #-}+ signExtendLo = fromIntegral+ {-# INLINE signExtendLo #-}++instance DoubleWord Word64 where+ type LoWord Word64 = Word32+ type HiWord Word64 = Word32+ loWord w = fromIntegral w+ {-# INLINE loWord #-}+ hiWord w = fromIntegral $ shiftR w 32+ {-# INLINE hiWord #-}+ fromHiAndLo hi lo = shiftL (fromIntegral hi) 32 .|. fromIntegral lo+ {-# INLINE fromHiAndLo #-}+ extendLo = fromIntegral+ {-# INLINE extendLo #-}+ signExtendLo = fromIntegral+ {-# INLINE signExtendLo #-}++instance DoubleWord Int16 where+ type LoWord Int16 = Word8+ type HiWord Int16 = Int8+ loWord w = fromIntegral w+ {-# INLINE loWord #-}+ hiWord w = fromIntegral $ shiftR w 8+ {-# INLINE hiWord #-}+ fromHiAndLo hi lo = shiftL (fromIntegral hi) 8 .|. fromIntegral lo+ {-# INLINE fromHiAndLo #-}+ extendLo = fromIntegral+ {-# INLINE extendLo #-}+ signExtendLo = fromIntegral+ {-# INLINE signExtendLo #-}++instance DoubleWord Int32 where+ type LoWord Int32 = Word16+ type HiWord Int32 = Int16+ loWord w = fromIntegral w+ {-# INLINE loWord #-}+ hiWord w = fromIntegral $ shiftR w 16+ {-# INLINE hiWord #-}+ fromHiAndLo hi lo = shiftL (fromIntegral hi) 16 .|. fromIntegral lo+ {-# INLINE fromHiAndLo #-}+ extendLo = fromIntegral+ {-# INLINE extendLo #-}+ signExtendLo = fromIntegral+ {-# INLINE signExtendLo #-}++instance DoubleWord Int64 where+ type LoWord Int64 = Word32+ type HiWord Int64 = Int32+ loWord w = fromIntegral w+ {-# INLINE loWord #-}+ hiWord w = fromIntegral $ shiftR w 32+ {-# INLINE hiWord #-}+ fromHiAndLo hi lo = shiftL (fromIntegral hi) 32 .|. fromIntegral lo+ {-# INLINE fromHiAndLo #-}+ extendLo = fromIntegral+ {-# INLINE extendLo #-}+ signExtendLo = fromIntegral+ {-# INLINE signExtendLo #-}+
+ src/Data/DoubleWord/TH.hs view
@@ -0,0 +1,1457 @@+{-# LANGUAGE UnicodeSyntax #-}+{-# LANGUAGE TemplateHaskell #-}++-- | Template Haskell utilities for generating double words declarations+module Data.DoubleWord.TH+ ( mkDoubleWord+ , mkUnpackedDoubleWord+ ) where++import GHC.Arr (Ix(..))+import Data.Ratio ((%))+import Data.Bits (Bits(..))+import Data.Word (Word8, Word16, Word32, Word64)+import Data.Int (Int8, Int16, Int32, Int64)+import Data.Hashable (Hashable(..), combine)+import Control.Applicative ((<$>), (<*>))+import Language.Haskell.TH hiding (match)+import Data.DoubleWord.Base++-- | 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+-- the following instances are declared: 'DoubleWord', 'Eq', 'Ord',+-- 'Bounded', 'Enum', 'Num', 'Real', 'Integral', 'Show', 'Hashable',+-- 'Ix', 'Bits', 'BinaryWord'.+mkDoubleWord ∷ String -- ^ Unsigned variant type name+ → String -- ^ Unsigned variant constructor name+ → Strict -- ^ Unsigned variant higher half strictness+ → Name -- ^ Unsigned variant higher half type+ → String -- ^ Signed variant type name+ → String -- ^ Signed variant constructor name+ → Strict -- ^ Signed variant higher half strictness+ → Name -- ^ Signed variant higher half type+ → Strict -- ^ Lower half strictness+ → Name -- ^ Lower half type+ → Q [Dec]+mkDoubleWord un uc uhs uhn sn sc shs shn ls ln =+ (++) <$> mkDoubleWord' False un' uc' sn' sc' uhs (ConT uhn) ls (ConT ln)+ <*> mkDoubleWord' True sn' sc' un' uc' shs (ConT shn) ls (ConT ln)+ where un' = mkName un+ uc' = mkName uc+ sn' = mkName sn+ sc' = mkName sc++-- | @'mkUnpackedDoubleWord' u uh s sh l@ is an alias for+-- @'mkDoubleWord' u u 'Unpacked' uh s s 'Unpacked' sh 'Unpacked' l@+mkUnpackedDoubleWord ∷ String -- ^ Unsigned variant type name+ → Name -- ^ Unsigned variant higher half type+ → String -- ^ Signed variant type name+ → Name -- ^ Signed variant higher half type+ → Name -- ^ Lower half type+ → Q [Dec]+mkUnpackedDoubleWord un uhn sn shn ln =+ mkDoubleWord un un Unpacked uhn sn sn Unpacked shn Unpacked ln++mkDoubleWord' ∷ Bool+ → Name → Name+ → Name → Name+ → Strict → Type+ → Strict → Type+ → Q [Dec]+mkDoubleWord' signed tp cn otp ocn hiS hiT loS loT = (<$> mkRules) $ (++) $+ [ DataD [] tp [] [NormalC cn [(hiS, hiT), (loS, loT)]] []+ , inst ''DoubleWord [tp]+ [ TySynInstD ''LoWord [tpT] loT+ , TySynInstD ''HiWord [tpT] hiT+ , funLo 'loWord (VarE lo)+ , inline 'loWord+ , funHi 'hiWord (VarE hi)+ , inline 'hiWord+ , fun 'fromHiAndLo (ConE cn)+ , inline 'fromHiAndLo+ {- extendLo x = W allZeroes x -}+ , funX 'extendLo $ appWN ['allZeroes, x]+ , inline 'extendLo+ {-+ signExtendLo x = W (if x < 0 then allOnes else allZeroes)+ (unsignedWord x)+ -}+ , funX 'signExtendLo $+ appW [ CondE (appVN 'testMsb [x])+ (VarE 'allOnes) (VarE 'allZeroes)+ , appVN 'unsignedWord [x] ]+ , inlinable 'signExtendLo+ ]+ , inst ''Eq [tp] $+ {- (W hi lo) == (W hi' lo') = hi == hi' && lo == lo' -}+ [ funHiLo2 '(==) $+ appV '(&&) [appVN '(==) [hi, hi'], appVN '(==) [lo, lo']]+ , inline '(==) ]+ , inst ''Ord [tp]+ {-+ compare (W hi lo) (W hi' lo') = case hi `compare` hi' of+ EQ → lo `compare` lo'+ x → x+ -}+ [ funHiLo2 'compare $+ CaseE (appVN 'compare [hi, hi'])+ [ Match (ConP 'EQ []) (NormalB (appVN 'compare [lo, lo'])) []+ , Match (VarP x) (NormalB (VarE x)) [] ]+ , inline 'compare ]+ , inst ''Bounded [tp]+ {- minBound = W minBound minBound -}+ [ fun 'minBound $ appWN ['minBound, 'minBound]+ , inline 'minBound+ {- maxBound = W maxBound maxBound -}+ , fun 'maxBound $ appWN ['maxBound, 'maxBound]+ , inline 'maxBound ]+ , inst ''Enum [tp]+ {-+ succ (W hi lo) = if lo == maxBound then W (succ hi) minBound+ else W hi (succ lo)+ -}+ [ funHiLo 'succ $ CondE (appVN '(==) [lo, 'maxBound])+ (appW [appVN 'succ [hi], VarE 'minBound])+ (appW [VarE hi, appVN 'succ [lo]])+ , inline 'succ+ {-+ pred (W hi lo) = if lo == minBound then W (pred hi) maxBound+ else W hi (pred lo)+ -}+ , funHiLo 'pred $ CondE (appVN '(==) [lo, 'minBound])+ (appW [appVN 'pred [hi], VarE 'maxBound])+ (appW [VarE hi, appVN 'pred [lo]])+ , inline 'pred+ {-+ toEnum x+ | x < 0 = if signed+ then W (-1) (negate $ 1 + toEnum (negate (x + 1)))+ else ERROR+ | otherwise = W 0 (toEnum x)+ -}+ , funX 'toEnum $+ CondE (appV '(<) [VarE x, litI 0])+ (if signed+ then appW [ VarE 'allOnes+ , appV 'negate+ [ appV '(+)+ [ oneE+ , appV 'toEnum+ [ appV 'negate+ [appV '(+) [VarE x, litI 1]] ]+ ]+ ]+ ]+ else appV 'error [litS "toEnum: nagative value"])+ (appW [VarE 'allZeroes, appVN 'toEnum [x]])+ , inline 'toEnum+ {-+ fromEnum (W 0 lo) = fromEnum lo+ fromEnum (W (-1) lo) = if signed then negate $ fromEnum $ negate lo+ else ERROR+ fromEnum _ = ERROR+ -}+ , FunD 'fromEnum $+ Clause [ConP cn [LitP $ IntegerL 0, VarP lo]]+ (NormalB $ appVN 'fromEnum [lo]) [] :+ if signed+ then [ Clause [ConP cn [LitP $ IntegerL (-1), VarP lo]]+ (NormalB $+ appV 'negate+ [appV 'fromEnum [appV 'negate [VarE lo]]])+ []+ , Clause [WildP]+ (NormalB $+ appV 'error [litS "fromEnum: out of bounds"])+ []+ ]+ else [ Clause [WildP]+ (NormalB $+ appV 'error [litS "fromEnum: out of bounds"])+ [] ]+ , 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)+ ]+ , inline '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]) []]+ ]+ , inlinable 'enumFromTo+ {-+ 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]) []]]+ , inlinable 'enumFromThenTo+ ]+ , inst ''Num [tp]+ {-+ negate (W hi lo) = if lo == 0 then W (negate hi) 0+ else W (negate $ hi + 1) (negate lo)+ -}+ [ funHiLo 'negate $+ CondE (appVN '(==) [lo, 'allZeroes])+ (appW [appVN 'negate [hi], zeroE])+ (appW [ appV 'negate [appVN '(+) ['lsb, hi]]+ , appVN 'negate [lo] ])+ , inline 'negate+ {- + abs x = if SIGNED+ then if x < 0 then negate x else x + else x+ -}+ , funX 'abs $+ if signed+ then CondE (appVN '(<) [x, 'allZeroes])+ (appVN 'negate [x]) (VarE x)+ else VarE x+ , inline 'abs+ {-+ signum (W hi lo) = if SIGNED+ then case hi `compare` 0 of+ LT → W (-1) maxBound+ EQ → if lo == 0 then 0 else 1+ GT → W 0 1+ else if hi == 0 && lo == 0 then 0 else 1+ -}+ , funHiLo 'signum $+ if signed+ then CaseE (appVN 'compare [hi, 'allZeroes])+ [ Match (ConP 'LT [])+ (NormalB $ appWN ['allOnes, 'maxBound]) []+ , Match (ConP 'EQ [])+ (NormalB $ CondE (appVN '(==) [lo, 'allZeroes])+ zeroE oneE)+ []+ , Match (ConP 'GT []) (NormalB oneE) []+ ]+ else CondE (appV '(&&) [ appVN '(==) [hi, 'allZeroes]+ , appVN '(==) [lo, 'allZeroes] ])+ zeroE oneE+ , inline 'signum+ {-+ (W hi lo) + (W hi' lo') = W y x+ where x = lo + lo'+ y = hi + hi' + if x < lo then 1 else 0+ -}+ , funHiLo2' '(+) (appWN [y, x])+ [ val x $ appVN '(+) [lo, lo']+ , val y $ appV '(+)+ [ appVN '(+) [hi, hi']+ , CondE (appVN '(<) [x, lo]) oneE zeroE ]+ ]+ , inlinable '(+)+ {-+ UNSIGNED:+ (W hi lo) * (W hi' lo') =+ W (hi * fromIntegral lo' + hi' * fromIntegral lo ++ fromIntegral x) y+ where (x, y) = unwrappedMul lo lo'++ SIGNED:+ x * y = signedWord $ unsignedWord x * unsignedWord y+ -}+ , if signed+ then+ funXY '(*) $+ appV 'signedWord+ [appV '(*) [ appVN 'unsignedWord [x]+ , appVN 'unsignedWord [y] ]]+ else+ funHiLo2' '(*)+ (appW [ appV '(+)+ [ appV '(+)+ [ appV '(*) [VarE hi, appVN 'fromIntegral [lo']]+ , appV '(*) [VarE hi', appVN 'fromIntegral [lo]] ]+ , appVN 'fromIntegral [x] ]+ , VarE y ])+ [vals [x, y] (appVN 'unwrappedMul [lo, lo'])]+ , inlinable '(*)+ {-+ fromInteger x = W (fromInteger y) (fromInteger z)+ where (y, z) = x `divMod` (toInteger (maxBound ∷ L) + 1)+ -}+ , funX' 'fromInteger+ (appW [appVN 'fromInteger [y], appVN 'fromInteger [z]])+ [vals [y, z]+ (appV 'divMod+ [ VarE x+ , appV '(+)+ [appV 'toInteger [SigE (VarE 'maxBound) loT], litI 1]+ ])]+ , inlinable 'fromInteger+ ]+ , inst ''Real [tp]+ {- toRational x = toInteger x % 1 -}+ [ funX 'toRational $ appV '(%) [appVN 'toInteger [x], litI 1]+ , inline 'toRational ]+ , inst ''Integral [tp]+ {-+ toInteger (W hi lo) =+ toInteger hi * (toInteger (maxBound ∷ L) + 1) + toInteger lo+ -}+ [ funHiLo 'toInteger $+ appV '(+)+ [ appV '(*)+ [ appVN 'toInteger [hi]+ , appV '(+)+ [appV 'toInteger [SigE (VarE 'maxBound) loT], litI 1] ]+ , appVN 'toInteger [lo] ]+ {-+ UNSIGNED:+ quotRem x@(W hi lo) y@(W hi' lo') =+ if hi' == 0 && lo' == 0+ then error "divide by zero"+ else case compare hi hi' of+ LT → (0, x)+ EQ → compare lo lo' of+ LT → (0, x)+ EQ → (1, 0)+ GT | hi' == 0 → (W 0 t2, W 0 t1)+ where (t2, t1) = quotRem lo lo'+ GT → (1, lo - lo')+ GT | lo' == 0 → (W 0 (fromIntegral t2),+ W (fromIntegral t1) lo)+ where (t2, t1) = quotRem hi hi'+ GT | hi' == 0 && lo' == maxBound → + if t2 == 0+ then if t1 == maxBound+ then (W 0 z + 1, 0)+ else (W 0 z, t1)+ else if t1 == maxBound+ then (W 0 z + 2, 1)+ else if t1 == xor maxBound 1+ then (W 0 z + 2, 0)+ else (W 0 z + 1, W 0 (t1 + 1))+ where z = fromIntegral hi+ (t2, t1) = unwrappedAdd z lo+ GT | hi' == 0 → (t2, W 0 t1)+ where (t2, t1) = div1 hi lo lo'+ GT → if t1 == t2+ then (1, x - y)+ else (W 0 (fromIntegral q2), shiftR r2 t2)+ where t1 = leadingZeroes hi+ t2 = leadingZeroes hi'+ z = shiftR hi (bitSize (undefined ∷ H) - t2)+ W hhh hll = shiftL x t2+ v@(W lhh lll) = shiftL y t2+ -- z hhh hll / lhh lll+ ((0, q1), r1) = div2 z hhh lhh+ (t4, t3) = unwrappedMul (fromIntegral q1) lll+ t5 = W (fromIntegral t4) t3+ t6 = W r1 hll+ (t8, t7) = unwrappedAdd t6 v+ (t10, t9) = unwrappedAdd t7 v+ (q2, r2) =+ if t5 > t6+ then+ if loWord t8 == 0+ then+ if t7 >= t5+ then (q1 - 1, t7 - t5)+ else+ if loWord t10 == 0+ then (q1 - 2, t9 - t5)+ else (q1 - 2, (maxBound - t5) + t9 + 1)+ else+ (q1 - 1, (maxBound - t5) + t7 + 1) + else+ (q1, t6 - t5)+ where div1 hhh hll by = go hhh hll 0+ where (t2, t1) = quotRem maxBound by+ go h l c =+ if z == 0+ then (c + W (fromIntegral t8) t7 + W 0 t10, t9)+ else go (fromIntegral z) t5+ (c + (W (fromIntegral t8) t7))+ where h1 = fromIntegral h+ (t4, t3) = unwrappedMul h1 (t1 + 1)+ (t6, t5) = unwrappedAdd t3 l+ z = t4 + t6+ (t8, t7) = unwrappedMul h1 t2+ (t10, t9) = quotRem t5 by+ div2 hhh hll by = go hhh hll (0, 0)+ where (t2, t1) = quotRem maxBound by+ go h l c =+ if z == 0+ then (addT (addT c (t8, t7)) (0, t10), t9)+ else go z t5 (addT c (t8, t7))+ where (t4, t3) = unwrappedMul h (t1 + 1)+ (t6, t5) = unwrappedAdd t3 l+ z = t4 + t6+ (t8, t7) = unwrappedMul h t2+ (t10, t9) = quotRem t5 by+ addT (lhh, lhl) (llh, lll) = (lhh + llh + t4, t3)+ where (t4, t3) = unwrappedAdd lhl lll++ SIGNED:+ quotRem x y =+ if x < 0+ then+ if y < 0+ then let (q, r) = quotRem (negate $ unsignedWord x)+ (negate $ unsignedWord y) in+ (signedWord q, signedWord $ negate r)+ else let (q, r) = quotRem (negate $ unsignedWord x)+ (unsignedWord y) in+ (signedWord $ negate q, signedWord $ negate r)+ else+ if y < 0+ then let (q, r) = quotRem (unsignedWord x)+ (negate $ unsignedWord y) in+ (signedWord $ negate q, signedWord r)+ else let (q, r) = quotRem (unsignedWord x)+ (unsignedWord y) in+ (signedWord q, signedWord r)+ -}+ , if signed+ then+ funXY 'quotRem $+ CondE (appVN 'testMsb [x])+ (CondE (appVN 'testMsb [y])+ (LetE [vals [q, r] $+ appV 'quotRem+ [ appV 'unsignedWord [appVN 'negate [x]]+ , appV 'unsignedWord [appVN 'negate [y]] ]]+ (TupE [ 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]]+ , 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]]+ , appVN 'signedWord [r] ]))+ (LetE [vals [q, r] $+ appV 'quotRem+ [ appVN 'unsignedWord [x]+ , appVN 'unsignedWord [y] ]]+ (TupE [ appVN 'signedWord [q]+ , appVN 'signedWord [r] ])))+ else+ funHiLo2XY' 'quotRem+ (CondE (appV '(&&) [ appVN '(==) [hi', 'allZeroes]+ , appVN '(==) [lo', 'allZeroes] ])+ (appV 'error [litS "divide by zero"])+ (CaseE (appVN 'compare [hi, hi'])+ [ match (ConP 'LT []) (TupE [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 [])+ (GuardedB $ return+ ( NormalG (appVN '(==) [hi', 'allZeroes])+ , TupE [ appWN ['allZeroes, t2]+ , appWN ['allZeroes, t1] ]))+ [vals [t2, t1] $ appVN 'quotRem [lo, lo']]+ , match (ConP 'GT []) $+ TupE [ oneE+ , appW [zeroE, appVN '(-) [lo, lo']] ]+ ])+ , Match (ConP 'GT [])+ (GuardedB $ return+ ( NormalG (appVN '(==) [lo', 'allZeroes])+ , TupE+ [ appW [zeroE, appVN 'fromIntegral [t2]]+ , appW [appVN 'fromIntegral [t1], VarE lo]+ ] ))+ [vals [t2, t1] $ appVN 'quotRem [hi, hi']]+ , Match (ConP 'GT [])+ (GuardedB $ return+ ( NormalG (appV '(&&)+ [ appVN '(==) [hi', 'allZeroes]+ , appVN '(==) [lo', 'maxBound] ])+ , CondE (appVN '(==) [t2, 'allZeroes])+ (CondE (appVN '(==) [t1, 'maxBound])+ (TupE+ [ appV '(+)+ [ appWN ['allZeroes, z] + , oneE ]+ , zeroE ])+ (TupE+ [ appWN ['allZeroes, z]+ , appWN ['allZeroes, t1] ]))+ (CondE (appVN '(==) [t1, 'maxBound])+ (TupE+ [ appV '(+)+ [appWN ['allZeroes, z], litI 2]+ , oneE ])+ (CondE+ (appV '(==)+ [ VarE t1+ , appVN 'xor ['maxBound, 'lsb]+ ])+ (TupE+ [ appV '(+)+ [appWN ['allZeroes, z], litI 2]+ , zeroE ])+ (TupE+ [ appV '(+)+ [appWN ['allZeroes, z], oneE]+ , appW [ zeroE+ , appVN '(+) [t1, 'lsb] ]+ ])))+ ))+ [ val z $ appVN 'fromIntegral [hi]+ , vals [t2, t1] $ appVN 'unwrappedAdd [z, lo] ]+ , Match (ConP 'GT [])+ (GuardedB $ return+ ( NormalG (appVN '(==) [hi', 'allZeroes])+ , TupE [VarE t2, appWN ['allZeroes, t1]] ))+ [vals [t2, t1] $ appVN div1 [hi, lo, lo']]+ , match' (ConP 'GT [])+ (CondE (appVN '(==) [t1, t2])+ (TupE [oneE, appVN '(-) [x, y]])+ (TupE [ 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 ]+ ]+ , 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 ])+ (NormalB $ appVN div2 [z, hhh, lhh]) []+ , vals [t4, t3] $+ appV 'unwrappedMul+ [appVN 'fromIntegral [q1], VarE lll]+ , val t5 $ appW [appVN 'fromIntegral [t4], VarE t3]+ , val t6 $ appWN [r1, hll]+ , vals [t8, t7] $ appVN 'unwrappedAdd [t6, v]+ , vals [t10, t9] $ appVN 'unwrappedAdd [t7, v]+ , vals [q2, r2] $+ CondE (appVN '(>) [t5, t6])+ (CondE (appV '(==) [appVN 'loWord [t8], zeroE])+ (CondE (appVN '(>=) [t7, t5])+ (TupE [ appVN '(-) [q1, 'lsb]+ , appVN '(-) [t7, t5] ])+ (CondE (appV '(==) [ appVN 'loWord [t10]+ , zeroE ])+ (TupE [ appV '(-) [VarE q1, litI 2]+ , appVN '(-) [t9, t5] ])+ (TupE [ appV '(-) [VarE q1, litI 2]+ , appV '(+)+ [ appVN '(-) ['maxBound, t5]+ , appVN '(+) [t9, 'lsb]+ ]+ ])))+ (TupE [ appVN '(-) [q1, 'lsb]+ , appV '(+)+ [ appVN '(-) ['maxBound, t5]+ , appVN '(+) [t7, 'lsb] ]+ ]))+ (TupE [VarE q1, appVN '(-) [t6, t5]])+ ]+ ]))+ [ FunD div1 $ return $+ Clause [VarP hhh, VarP hll, VarP by]+ (NormalB (appVN go [hhh, hll, 'allZeroes]))+ [ vals [t2, t1] $ appVN 'quotRem ['maxBound, by]+ , FunD go $ return $+ Clause [VarP h, VarP l, VarP c]+ (NormalB+ (CondE (appVN '(==) [z, 'allZeroes])+ (TupE [ appV '(+)+ [ VarE c+ , appV '(+)+ [ appW [ appVN 'fromIntegral [t8]+ , VarE t7 ]+ , appWN ['allZeroes, t10] ]+ ]+ , VarE t9 ])+ (appV go+ [ appVN 'fromIntegral [z]+ , VarE t5+ , appV '(+)+ [ VarE c+ , appW [ appVN 'fromIntegral [t8]+ , VarE t7 ]+ ]+ ])))+ [ val h1 $ appVN 'fromIntegral [h]+ , vals [t4, t3] $+ appV 'unwrappedMul+ [VarE h1, appVN '(+) [t1, 'lsb]]+ , vals [t6, t5] $ appVN 'unwrappedAdd [t3, l]+ , val z $ appVN '(+) [t4, t6]+ , vals [t8, t7] $ appVN 'unwrappedMul [h1, t2]+ , vals [t10, t9] $ appVN 'quotRem [t5, by] ]+ ]+ , FunD div2 $ return $+ Clause [VarP hhh, VarP hll, VarP by]+ (NormalB (appV go [ VarE hhh+ , VarE hll+ , TupE [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+ [ VarE c+ , appV addT+ [ TupE [VarE t8 , VarE t7]+ , TupE [zeroE, VarE t10] ]+ ]+ , VarE t9 ])+ (appV go+ [ VarE z+ , VarE t5+ , appV addT+ [ VarE c+ , TupE [VarE t8, VarE t7]+ ]+ ])))+ [ vals [t4, t3] $+ appV 'unwrappedMul+ [VarE h, appVN '(+) [t1, 'lsb]]+ , vals [t6, t5] $ appVN 'unwrappedAdd [t3, l]+ , val z $ appVN '(+) [t4, t6]+ , vals [t8, t7] $ appVN 'unwrappedMul [h, t2]+ , vals [t10, t9] $ appVN 'quotRem [t5, by] ]+ , FunD addT $ return $+ Clause [ TupP [VarP lhh, VarP lhl]+ , TupP [VarP llh, VarP lll]+ ]+ (NormalB (TupE [ appV '(+)+ [ VarE t4+ , appVN '(+) [lhh, llh]+ ]+ , VarE t3+ ]))+ [vals [t4, t3] $ appVN 'unwrappedAdd [lhl, lll]]+ ]+ ]+ {-+ UNSIGNED:+ divMod = quotRem++ SIGNED:+ divMod x y =+ if x < 0+ then+ if y < 0+ then let (q, r) = quotRem (negate $ unsignedWord x)+ (negate $ unsignedWord y) in+ (signedWord q, signedWord $ negate r)+ else let (q, r) = quotRem (negate $ unsignedWord x)+ (unsignedWord y)+ q1 = signedWord (negate q)+ r1 = signedWord (negate r) in+ if r == 0+ then (q1, r1)+ else (q1 - 1, r1 + y)+ else + if y < 0+ then let (q, r) = quotRem (unsignedWord x)+ (negate $ unsignedWord y)+ q1 = signedWord (negate q)+ r1 = signedWord r in+ if r == 0+ then (q1, r1)+ else (q1 - 1, r1 + y)+ else let (q, r) = quotRem (unsignedWord x)+ (unsignedWord y) in+ (signedWord q, signedWord r)+ -}+ , if signed+ then+ funXY 'divMod $+ CondE (appVN 'testMsb [x])+ (CondE (appVN 'testMsb [y])+ (LetE [vals [q, r] $+ appV 'quotRem+ [ appV 'unsignedWord [appVN 'negate [x]]+ , appV 'unsignedWord [appVN 'negate [y]] ]]+ (TupE [ appVN 'signedWord [q]+ , appV 'signedWord [appVN 'negate [r]] ]))+ (LetE [ vals [q, r] $+ appV 'quotRem+ [ appV 'unsignedWord [appVN 'negate [x]]+ , appVN 'unsignedWord [y] ]+ , val q1 $ appV 'signedWord [appVN 'negate [q]]+ , val r1 $ appV 'signedWord [appVN 'negate [r]]+ ]+ (CondE (appVN '(==) [r, 'allZeroes])+ (TupE [VarE q1, VarE r1])+ (TupE [ appVN '(-) [q1, 'lsb]+ , appVN '(+) [r1, y] ]))))+ (CondE (appVN 'testMsb [y])+ (LetE [ vals [q, r] $+ appV 'quotRem+ [ appVN 'unsignedWord [x]+ , appV 'unsignedWord [appVN 'negate [y]] ]+ , val q1 $ appV 'signedWord [appVN 'negate [q]]+ , val r1 $ appVN 'signedWord [r]+ ]+ (CondE (appVN '(==) [r, 'allZeroes])+ (TupE [VarE q1, VarE r1])+ (TupE [ appVN '(-) [q1, 'lsb]+ , appVN '(+) [r1, y] ])))+ (LetE [vals [q, r] $+ appV 'quotRem+ [ appVN 'unsignedWord [x]+ , appVN 'unsignedWord [y] ]]+ (TupE [ appVN 'signedWord [q]+ , appVN 'signedWord [r] ])))+ else+ fun 'divMod $ VarE 'quotRem+ , inline 'divMod+ ]+ , inst ''Show [tp]+ [ fun 'show $ appVN '(.) ['show, 'toInteger]+ , inline 'show ]+ , inst ''Hashable [tp]+ {- hash (W hi lo) = hash hi `combine` hash lo -}+ [ funHiLo 'hash $ appV 'combine [appVN 'hash [hi], appVN 'hash [lo]]+ , inline 'hash+ , 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 _ = bitSize (undefined ∷ H) + bitSize (undefined ∷ L) -}+ [ fun_ 'bitSize $+ appV '(+)+ [ appV 'bitSize [SigE (VarE 'undefined) hiT]+ , appV 'bitSize [SigE (VarE 'undefined) loT] ]+ , inline 'bitSize+ {- isSigned _ = SIGNED -}+ , fun_ 'isSigned $ ConE $ if signed then 'True else 'False+ , inline 'isSigned+ {- complement (W hi lo) = W (complement hi) (complement lo) -}+ , funHiLo 'complement $+ appW [appVN 'complement [hi], appVN 'complement [lo]]+ , inline 'complement+ {- xor (W hi lo) (W hi' lo') = W (xor hi hi') (xor lo lo') -}+ , funHiLo2 'xor $ appW [appVN 'xor [hi, hi'], appVN 'xor [lo, lo']]+ , inline 'xor+ {- (W hi lo) .&. (W hi' lo') = W (hi .&. hi') (lo .&. lo') -}+ , funHiLo2 '(.&.) $+ appW [appVN '(.&.) [hi, hi'], appVN '(.&.) [lo, lo']]+ , inline '(.&.)+ {- (W hi lo) .|. (W hi' lo') = W (hi .|. hi') (lo .|. lo') -}+ , funHiLo2 '(.|.) $+ appW [appVN '(.|.) [hi, hi'], appVN '(.|.) [lo, lo']]+ , inline '(.|.)+ {-+ shiftL (W hi lo) x =+ if y > 0+ then W (shiftL hi x .|. fromIntegral (shiftR lo y))+ (shiftL lo x)+ else W (fromIntegral $ shiftL lo $ negate y) 0+ where y = bitSize (undefined ∷ L) - x+ -}+ , funHiLoX' 'shiftL+ (CondE (appV '(>) [VarE y, litI 0])+ (appW+ [ appV '(.|.)+ [ appVN 'shiftL [hi, x]+ , appV 'fromIntegral [appVN 'shiftR [lo, y]] ]+ , appVN 'shiftL [lo, x] ])+ (appW [ appV 'fromIntegral+ [appV 'shiftL [VarE lo, appVN 'negate [y]]]+ , zeroE ]))+ [val y $+ appV '(-) [ appV 'bitSize [SigE (VarE 'undefined) loT]+ , VarE x ]]+ {-+ shiftR (W hi lo) x =+ W (shiftR hi x)+ (if y >= 0 then shiftL (fromIntegral hi) y .|. shiftR lo x+ else z)+ where y = bitSize (undefined ∷ L) - x+ z = if SIGNED+ then fromIntegral $+ shiftR (fromIntegral hi ∷ SignedWord L) $+ negate y+ else shiftR (fromIntegral hi) $ negate y+ -}+ , funHiLoX' 'shiftR+ (appW [ appVN 'shiftR [hi, x]+ , CondE (appV '(>=) [VarE y, litI 0])+ (appV '(.|.)+ [ appV 'shiftL+ [appVN 'fromIntegral [hi], VarE y]+ , appVN 'shiftR [lo, x] ])+ (VarE z) ])+ [ val y $ appV '(-) [ appV 'bitSize [SigE (VarE 'undefined) loT]+ , VarE x ]+ , val z $+ if signed+ then appV 'fromIntegral+ [appV 'shiftR+ [ SigE (appVN 'fromIntegral [hi])+ (AppT (ConT ''SignedWord) loT)+ , appVN 'negate [y] ]]+ else appV 'shiftR [ appVN 'fromIntegral [hi]+ , appVN 'negate [y] ]+ ]+ {-+ UNSIGNED:+ rotateL (W hi lo) x =+ if y >= 0+ then W (fromIntegral (shiftL lo y) .|. shiftR hi z)+ W (shiftL (fromIntegral hi) (bitSize (undefined ∷ L) - z)+ .|. shiftR lo z)+ else W (fromIntegral (shiftR lo $ negate y) .|. shiftL hi x)+ (shift (fromIntegral hi) (bitSize (undefined ∷ L) - z)+ .|. shiftL lo x+ .|. shiftR lo z)+ where y = x - bitSize (undefined ∷ L)+ z = bitSize (undefined ∷ W) - x+ SIGNED:+ rotateL x y = signedWord $ rotateL (unsignedWord x) y+ -}+ , if signed+ then+ funXY 'rotateL $+ appV 'signedWord+ [appV 'rotateL [appVN 'unsignedWord [x], VarE y]]+ else + funHiLoX' 'rotateL+ (CondE (appV '(>=) [VarE y, litI 0])+ (appW+ [ appV '(.|.)+ [ appV 'fromIntegral [appVN 'shiftL [lo, y]]+ , appVN 'shiftR [hi, z] ]+ , appV '(.|.)+ [ appV 'shiftL+ [ appVN 'fromIntegral [hi]+ , appV '(-)+ [ appV 'bitSize [SigE (VarE 'undefined) loT]+ , VarE z ]+ ]+ , appVN 'shiftR [lo, z] ]+ ])+ (appW+ [ appV '(.|.)+ [ appV 'fromIntegral+ [appV 'shiftR [VarE lo, appVN 'negate [y]]]+ , appVN 'shiftL [hi, x] ]+ , appV '(.|.)+ [ appV 'shift+ [ appVN 'fromIntegral [hi]+ , appV '(-)+ [ appV 'bitSize [SigE (VarE 'undefined) loT]+ , 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 ]+ ]+ {- rotateR x y = rotateL x $ bitSize (undefined ∷ W) - y -}+ , funXY 'rotateR $+ appV 'rotateL+ [ VarE x+ , appV '(-)+ [appV 'bitSize [SigE (VarE 'undefined) tpT], VarE y]+ ]+ , inline 'rotateR+ {-+ bit x = if y >= 0 then W (bit y) 0 else W 0 (bit x)+ where y = x - bitSize (undefined ∷ LoWord W)+ -}+ , 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] ]]+ , inline 'bit+ {-+ setBit (W hi lo) x =+ if y >= 0 then W (setBit hi y) lo else W hi (setBit lo x)+ where y = x - bitSize (undefined ∷ L)+ -}+ , funHiLoX' 'setBit+ (CondE (appV '(>=) [VarE y, litI 0])+ (appW [appVN 'setBit [hi, y], VarE lo])+ (appW [VarE hi, appVN 'setBit [lo, x]]))+ [val y $+ appV '(-) [ VarE x+ , appV 'bitSize [SigE (VarE 'undefined) loT] ]]+ , inline 'setBit+ {-+ clearBit (W hi lo) x =+ if y >= 0 then W (clearBit hi y) lo+ else W hi (clearBit lo x)+ where y = x - bitSize (undefined ∷ L)+ -}+ , funHiLoX' 'clearBit+ (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] ]]+ , inline 'clearBit+ {-+ complementBit (W hi lo) x =+ if y >= 0 then W (complementBit hi y) lo+ else W hi (complementBit lo x)+ where y = x - bitSize (undefined ∷ L)+ -}+ , funHiLoX' 'complementBit+ (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] ]]+ , inline 'complementBit+ {-+ testBit (W hi lo) x =+ if y >= 0 then testBit hi y else testBit lo x+ where y = x - bitSize (undefined ∷ L)+ -}+ , funHiLoX' 'testBit+ (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] ]]+ , inline 'testBit+ {- popCount (W hi lo) = popCount hi + popCount lo -}+ , funHiLo 'popCount+ (appV '(+) [appVN 'popCount [hi], appVN 'popCount [lo]])+ , inline 'popCount+ ]+ , inst ''BinaryWord [tp]+ [ TySynInstD ''UnsignedWord [tpT] $+ ConT $ if signed then otp else tp+ , TySynInstD ''SignedWord [tpT] $+ ConT $ if signed then tp else otp+ {-+ UNSIGNED:+ unsignedWord = id+ + SIGNED:+ unsignedWord (W hi lo) = U (unsignedWord hi) lo+ -}+ , if signed+ then+ funHiLo 'unsignedWord $+ appC ocn [appVN 'unsignedWord [hi], VarE lo]+ else+ fun 'unsignedWord $ VarE 'id+ , inline 'unsignedWord+ {-+ UNSIGNED:+ signedWord (W hi lo) = S (signedWord hi) lo+ + SIGNED:+ signedWord = id+ -}+ , if signed+ then+ fun 'signedWord $ VarE 'id+ else+ funHiLo 'signedWord $+ appC ocn [appVN 'signedWord [hi], VarE lo]+ , inline 'signedWord+ {-+ UNSIGNED:+ unwrappedAdd (W hi lo) (W hi' lo') = (W 0 z, W y x)+ where (t1, x) = unwrappedAdd lo lo' + (t3, t2) = unwrappedAdd hi (fromIntegral t1)+ (t4, y) = unwrappedAdd t2 hi'+ z = fromIntegral $ t3 + t4+ SIGNED:+ unwrappedAdd x y = (z, t4)+ where t1 = if x < 0 then maxBound else minBound+ t2 = if y < 0 then maxBound else minBound+ (t3, t4) = unwrappedAdd (unsignedWord x) (unsignedWord y)+ z = signedWord $ t1 + t2 + t3+ -}+ , if signed+ then+ funXY' 'unwrappedAdd (TupE [VarE z, VarE t4])+ [ val t1 $ CondE (appVN 'testMsb [x])+ (VarE 'maxBound) (VarE 'minBound)+ , val t2 $ CondE (appVN 'testMsb [y])+ (VarE 'maxBound) (VarE 'minBound)+ , vals [t3, t4] $+ appV 'unwrappedAdd [ appVN 'unsignedWord [x]+ , appVN 'unsignedWord [y] ]+ , val z $+ appV 'signedWord [appV '(+) [VarE t1, appVN '(+) [t2, t3]]]+ ]+ else+ funHiLo2' 'unwrappedAdd+ (TupE [appWN ['allZeroes, z], appWN [y, x]])+ [ vals [t1, x] $ appVN 'unwrappedAdd [lo, lo']+ , vals [t3, t2] $+ appV 'unwrappedAdd [VarE hi, appVN 'fromIntegral [t1]]+ , vals [t4, y] $ appVN 'unwrappedAdd [t2, hi']+ , val z $ appV 'fromIntegral [appVN '(+) [t3, t4]]+ ]+ {-+ UNSIGNED:+ unwrappedMul (W hi lo) (W hi' lo') =+ (W (hhh + fromIntegral (shiftR t9 y) + shiftL x z)+ (shiftL t9 z .|. shiftR t3 y),+ W (fromIntegral t3) lll)+ where (llh, lll) = unwrappedMul lo lo'+ (hlh, hll) = unwrappedMul (fromIntegral hi) lo'+ (lhh, lhl) = unwrappedMul lo (fromIntegral hi')+ (hhh, hhl) = unwrappedMul hi hi'+ (t2, t1) = unwrappedAdd llh hll+ (t4, t3) = unwrappedAdd t1 lhl+ (t6, t5) = unwrappedAdd (fromIntegral hhl) (t2 + t4)+ (t8, t7) = unwrappedAdd t5 lhh+ (t10, t9) = unwrappedAdd t7 hlh+ x = fromIntegral $ t6 + t8 + t10+ y = bitSize (undefined ∷ H)+ z = bitSize (undefined ∷ L) - y+ SIGNED:+ unwrappedMul (W hi lo) (W hi' lo') = (x, y)+ where t1 = W (complement hi') (complement lo') + 1+ t2 = W (complement hi) (complement lo) + 1+ (t3, y) = unwrappedMul (U (unsignedWord hi) lo)+ (U (unsignedWord hi') lo')+ z = signedWord t3+ x = if hi < 0+ then if hi' < 0+ then z + t1 + t2+ else z + t1+ else if hi' < 0+ then z + t2+ else z+ -}+ , if signed+ then+ funHiLo2' 'unwrappedMul (TupE [VarE x, VarE y])+ [ val t1 $+ appV '(+) [ appW [ appVN 'complement [hi']+ , appVN 'complement [lo'] ]+ , oneE ]+ , val t2 $+ appV '(+) [ appW [ appVN 'complement [hi]+ , appVN 'complement [lo] ]+ , oneE ]+ , vals [t3, y] $+ appV 'unwrappedMul+ [ appC ocn [appVN 'unsignedWord [hi], VarE lo]+ , appC ocn [appVN 'unsignedWord [hi'], VarE lo'] ]+ , val z $ appVN 'signedWord [t3]+ , val x $+ CondE (appVN 'testMsb [hi])+ (CondE (appVN 'testMsb [hi'])+ (appV '(+) [VarE z, appVN '(+) [t1, t2]])+ (appVN '(+) [z, t1]))+ (CondE (appVN 'testMsb [hi'])+ (appVN '(+) [z, t2]) (VarE z))+ ]+ else+ funHiLo2' 'unwrappedMul+ (TupE [ appW+ [ appV '(+)+ [ VarE hhh+ , appV '(+)+ [ appV 'fromIntegral [appVN 'shiftR [t9, y]]+ , appVN 'shiftL [x, z] ]+ ]+ , appV '(.|.) [ appVN 'shiftL [t9, z]+ , appVN 'shiftR [t3, y] ]+ ]+ , appW [appVN 'fromIntegral [t3], VarE lll]+ ])+ [ vals [llh, lll] $ appVN 'unwrappedMul [lo, lo']+ , vals [hlh, hll] $+ appV 'unwrappedMul [appVN 'fromIntegral [hi], VarE lo']+ , vals [lhh, lhl] $+ appV 'unwrappedMul [VarE lo, appVN 'fromIntegral [hi']]+ , vals [hhh, hhl] $ appVN 'unwrappedMul [hi, hi']+ , vals [t2, t1] $ appVN 'unwrappedAdd [llh, hll]+ , vals [t4, t3] $ appVN 'unwrappedAdd [t1, lhl]+ , vals [t6, t5] $+ appV 'unwrappedAdd [ appVN 'fromIntegral [hhl]+ , appVN '(+) [t2, t4] ]+ , vals [t8, t7] $ appVN 'unwrappedAdd [t5, lhh]+ , vals [t10, t9] $ appVN 'unwrappedAdd [t7, hlh]+ , 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 ]+ ]+ {-+ UNSIGNED:+ leadingZeroes (W hi lo) =+ if x == y then y + leadingZeroes lo else x+ where x = leadingZeroes hi+ y = bitSize (undefined ∷ H)+ SIGNED:+ leadingZeroes = leadingZeroes . unsignedWord+ -}+ , if signed+ then+ fun 'leadingZeroes $ appVN '(.) ['leadingZeroes, 'unsignedWord]+ else+ funHiLo' 'leadingZeroes+ (CondE (appVN '(==) [x, y])+ (appV '(+) [VarE y, appVN 'leadingZeroes [lo]])+ (VarE x))+ [ val x $ appVN 'leadingZeroes [hi]+ , val y $ appV 'bitSize [SigE (VarE 'undefined) hiT]+ ]+ , inline 'leadingZeroes+ {-+ UNSIGNED:+ trailingZeroes (W hi lo) =+ if x == y then y + trailingZeroes hi else x+ where x = trailingZeroes lo+ y = bitSize (undefined ∷ L)+ SIGNED:+ trailingZeroes = trailingZeroes . unsignedWord+ -}+ , if signed+ then+ fun 'trailingZeroes $ appVN '(.) ['trailingZeroes, 'unsignedWord]+ else+ funHiLo' 'trailingZeroes+ (CondE (appVN '(==) [x, y])+ (appV '(+) [VarE y, appVN 'trailingZeroes [hi]])+ (VarE x))+ [ val x $ appVN 'trailingZeroes [lo]+ , val y $ appV 'bitSize [SigE (VarE 'undefined) loT]+ ]+ , inline 'trailingZeroes+ {- allZeroes = W allZeroes allZeroes -}+ , fun 'allZeroes $ appWN ['allZeroes, 'allZeroes]+ , inline 'allZeroes+ {- allOnes = W allOnes allOnes -}+ , fun 'allOnes $ appWN ['allOnes, 'allOnes]+ , inline 'allOnes+ {- msb = W msb allZeroes -}+ , fun 'msb $ appWN ['msb, 'allZeroes]+ , inline 'msb+ {- lsb = W allZeroes lsb -}+ , fun 'lsb $ appWN ['allZeroes, 'lsb]+ , inline 'lsb+ {- testMsb (W hi _) = testMsb hi -}+ , funHi 'testMsb $ appVN 'testMsb [hi]+ , inline 'testMsb+ {- testLsb (W _ lo) = testLsb lo -}+ , funLo 'testLsb $ appVN 'testLsb [lo]+ , inline 'testLsb+ ]+ ]+ where+ x = mkName "x"+ y = mkName "y"+ z = mkName "z"+ t1 = mkName "t1"+ t2 = mkName "t2"+ t3 = mkName "t3"+ t4 = mkName "t4"+ t5 = mkName "t5"+ t6 = mkName "t6"+ t7 = mkName "t7"+ t8 = mkName "t8"+ t9 = mkName "t9"+ t10 = mkName "t10"+ v = mkName "v"+ q = mkName "q"+ q1 = mkName "q1"+ q2 = mkName "q2"+ r = mkName "r"+ r1 = mkName "r1"+ r2 = mkName "r2"+ lll = mkName "lll"+ llh = mkName "llh"+ lhl = mkName "lhl"+ lhh = mkName "lhh"+ hll = mkName "hll"+ hlh = mkName "hlh"+ hhl = mkName "hhl"+ hhh = mkName "hhh"+ h = mkName "h"+ h1 = mkName "h1"+ l = mkName "l"+ div1 = mkName "div1"+ div2 = mkName "div2"+ addT = mkName "addT"+ by = mkName "by"+ go = mkName "go"+ c = mkName "c"+ next = mkName "next"+ step = mkName "step"+ to = mkName "to"+ down = mkName "down"+ up = mkName "up"+ hi = mkName "hi"+ lo = mkName "lo"+ hi' = mkName "hi'"+ lo' = mkName "lo'"+ tpT = ConT tp+ inst cls params = InstanceD [] (foldl AppT (ConT cls) (ConT <$> params))+ fun n e = FunD n [Clause [] (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 []+ 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) []]+ 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]+ funHiLoX' n 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'] ]+ (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']) ]+ (NormalB e) ds]+ match' p e ds = Match p (NormalB e) ds+ match p e = match' p e []+ inline n = PragmaD $ InlineP n Inline FunLike AllPhases+ inlinable n = PragmaD $ InlineP n Inlinable FunLike 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 = appC cn+ appVN f = appN (VarE f)+ appCN f = appN (ConE f)+ appWN = appCN cn+ litI = LitE . IntegerL+ litS = LitE . StringL+ zeroE = VarE 'allZeroes+ oneE = VarE 'lsb+ mkRules = do+ let idRule = RuleP ("fromIntegral/" ++ show tp ++ "->" ++ show tp) []+ (VarE 'fromIntegral)+ (SigE (VarE 'id) (AppT (AppT ArrowT tpT) tpT))+ AllPhases+ mkRules' [idRule] loT+ (VarE 'loWord)+ (VarE 'extendLo)+ (VarE 'signExtendLo)+ mkRules' rules t narrowE extE signExtE = do+ 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)+ []+ (VarE 'fromIntegral)+ (SigE extE (AppT (AppT ArrowT t) tpT))+ AllPhases+ signedRules ← do+ insts ← reifyInstances ''SignedWord [t]+ case insts of+ [TySynInstD _ _ signT] → return $+ [ 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)+ []+ (VarE 'fromIntegral)+ (SigE signExtE (AppT (AppT ArrowT signT) tpT))+ AllPhases ]+ _ → return []+ let rules' = narrowRule : extRule : signedRules ++ rules+ case smallerStdTypes t of+ Just ts → do+ let smallRules = ts >>= \(uSmallName, sSmallName) →+ let uSmallT = ConT uSmallName+ sSmallT = ConT sSmallName in+ [ RuleP ("fromIntegral/" +++ show tp ++ "->" ++ show uSmallName)+ []+ (VarE 'fromIntegral)+ (SigE (appV '(.) [VarE 'fromIntegral, narrowE])+ (AppT (AppT ArrowT tpT) uSmallT))+ AllPhases+ , RuleP ("fromIntegral/" +++ show uSmallName ++ "->" ++ show tp)+ []+ (VarE 'fromIntegral)+ (SigE (appV '(.) [extE, VarE 'fromIntegral])+ (AppT (AppT ArrowT uSmallT) tpT))+ AllPhases+ , RuleP ("fromIntegral/" +++ show tp ++ "->" ++ show sSmallName)+ []+ (VarE 'fromIntegral)+ (SigE (appV '(.) [VarE 'fromIntegral, narrowE])+ (AppT (AppT ArrowT tpT) sSmallT))+ AllPhases+ , RuleP ("fromIntegral/" +++ show sSmallName ++ "->" ++ show tp)+ []+ (VarE 'fromIntegral)+ (SigE (appV '(.) [signExtE, VarE 'fromIntegral])+ (AppT (AppT ArrowT sSmallT) tpT))+ AllPhases+ ]+ return $ PragmaD <$> rules' ++ smallRules+ _ → do+ insts ← reifyInstances ''LoWord [t]+ case insts of+ [TySynInstD _ _ t'] →+ mkRules' rules' t'+ (appV '(.) [VarE 'loWord, narrowE])+ (appV '(.) [VarE 'extendLo, extE])+ (appV '(.) [VarE 'signExtendLo, signExtE])+ _ → return $ PragmaD <$> rules'+ showT (ConT n) = show n+ showT t = show t+ stdTypes = [(''Word64, ''Int64), (''Word32, ''Int32),+ (''Word16, ''Int16), (''Word8, ''Int8)]+ smallerStdTypes t = smallerStdTypes' t stdTypes+ smallerStdTypes' _ [] = Nothing+ smallerStdTypes' t ((ut, _) : ts)+ | ConT ut == t = Just ts+ | otherwise = smallerStdTypes' t ts+
+ tests/Tests.hs view
@@ -0,0 +1,302 @@+{-# LANGUAGE UnicodeSyntax #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}++import Test.Framework (RunnerOptions'(..), TestOptions'(..),+ defaultMainWithOpts, testGroup)+import Test.Framework.Providers.QuickCheck2 (testProperty)+import Test.QuickCheck hiding ((.&.))++import Data.Bits+import Data.Word+import Data.Int+import Data.Monoid (mempty)+import Data.DoubleWord (BinaryWord(..))+import Types++class Iso α τ | τ → α where+ fromArbitrary ∷ α → τ + toArbitrary ∷ τ → α++instance Iso Word64 U64 where+ fromArbitrary w = U64 (fromIntegral $ w `shiftR` 32) (fromIntegral w)+ toArbitrary (U64 h l) = fromIntegral h `shiftL` 32 .|. fromIntegral l++instance Iso Int64 I64 where+ fromArbitrary w = I64 (fromIntegral $ w `shiftR` 32) (fromIntegral w)+ toArbitrary (I64 h l) = fromIntegral h `shiftL` 32 .|. fromIntegral l++instance Iso Word64 UU64 where+ fromArbitrary w = UU64 (fromIntegral $ w `shiftR` 48)+ (U48 (fromIntegral $ w `shiftR` 32) (fromIntegral w))+ toArbitrary (UU64 h (U48 lh ll)) = fromIntegral h `shiftL` 48+ .|. fromIntegral lh `shiftL` 32+ .|. fromIntegral ll++instance Iso Int64 II64 where+ fromArbitrary w = II64 (fromIntegral $ w `shiftR` 48)+ (U48 (fromIntegral $ w `shiftR` 32) (fromIntegral w))+ toArbitrary (II64 h (U48 lh ll)) = fromIntegral h `shiftL` 48+ .|. fromIntegral lh `shiftL` 32+ .|. fromIntegral ll++main = defaultMainWithOpts+ [ 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 "|Int32|Word32|" (0 ∷ I64)+ , isoTestGroup "|Word16|Word16|Word32|" (0 ∷ UU64)+ , isoTestGroup "|Int16|Word16|Word32|" (0 ∷ II64) ]+ mempty {+ ropt_test_options =+ Just (mempty { topt_maximum_generated_tests = Just 1000 })+ }++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+ , 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+ ]+ ]++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++toType ∷ Iso α τ ⇒ τ → α → τ +toType _ = fromArbitrary++fromType ∷ Iso α τ ⇒ τ → τ → α +fromType _ = toArbitrary++withUnary ∷ Iso α τ ⇒ τ → (τ → τ) → α → α+withUnary _ f = toArbitrary . f . fromArbitrary++withUnary' ∷ Iso α τ ⇒ τ → (τ → β) → α → β+withUnary' _ f = f . fromArbitrary++withBinary ∷ Iso α τ ⇒ τ → (τ → τ → τ) → α → α → α+withBinary _ f x y = toArbitrary $ f (fromArbitrary x) (fromArbitrary y)++withBinary' ∷ Iso α τ ⇒ τ → (τ → τ → β) → α → α → β+withBinary' _ f x y = f (fromArbitrary x) (fromArbitrary y)++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++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) ==> (succ w == withUnary t succ w)+prop_pred t w = (w /= minBound) ==> (pred w == withUnary t pred w)++prop_unwrappedAdd ∷ (Iso α τ, Iso (UnsignedWord α) (UnsignedWord τ),+ BinaryWord α, BinaryWord τ, Eq α, Eq (UnsignedWord α))+ ⇒ τ → α → α → 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 α))+ ⇒ τ → α → α → 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 → f w b == withUnary t (`g` b) w) [0 .. bitSize 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]+propBits f g t w =+ all (\b → f w b == withUnary t (`g` b) w) [0 .. bitSize 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]+prop_popCount = propUnary' popCount popCount+
+ tests/Types.hs view
@@ -0,0 +1,13 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}++module Types where++import Data.Word+import Data.Int+import Data.DoubleWord.TH++$(mkUnpackedDoubleWord "U64" ''Word32 "I64" ''Int32 ''Word32)+$(mkUnpackedDoubleWord "U48" ''Word16 "I48" ''Int16 ''Word32)+$(mkUnpackedDoubleWord "UU64" ''Word16 "II64" ''Int16 ''U48)+