haskus-binary 0.6.0.0 → 1.0

raw patch · 30 files changed

+2000/−322 lines, 30 filesdep ~QuickCheckdep ~basedep ~bytestringsetup-changedPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: QuickCheck, base, bytestring, cereal, criterion, haskus-utils, mtl, tasty, tasty-quickcheck

API changes (from Hackage documentation)

Files

• Setup.hs +0/−2
• haskus-binary.cabal +89/−94
• src/lib/Haskus/Format/Binary/BitField.hs +6/−3
• src/lib/Haskus/Format/Binary/BitSet.hs +119/−30
• src/lib/Haskus/Format/Binary/Bits.hs +83/−27
• src/lib/Haskus/Format/Binary/Bits/Basic.hs +0/−7
• src/lib/Haskus/Format/Binary/Bits/Bitwise.hs +98/−0
• src/lib/Haskus/Format/Binary/Bits/Finite.hs +119/−0
• src/lib/Haskus/Format/Binary/Bits/Get.hs +9/−8
• src/lib/Haskus/Format/Binary/Bits/Index.hs +81/−0
• src/lib/Haskus/Format/Binary/Bits/Order.hs +10/−8
• src/lib/Haskus/Format/Binary/Bits/Put.hs +14/−8
• src/lib/Haskus/Format/Binary/Bits/Reverse.hs +64/−19
• src/lib/Haskus/Format/Binary/Bits/Rotate.hs +89/−0
• src/lib/Haskus/Format/Binary/Bits/Shift.hs +311/−0
• src/lib/Haskus/Format/Binary/Buffer.hs +19/−23
• src/lib/Haskus/Format/Binary/BufferBuilder.hs +3/−3
• src/lib/Haskus/Format/Binary/Char.hs +15/−0
• src/lib/Haskus/Format/Binary/Endianness.hs +17/−9
• src/lib/Haskus/Format/Binary/Enum.hs +24/−22
• src/lib/Haskus/Format/Binary/FixedPoint.hs +3/−4
• src/lib/Haskus/Format/Binary/Posit.hs +423/−0
• src/lib/Haskus/Format/Binary/Record.hs +1/−1
• src/lib/Haskus/Format/Binary/Union.hs +3/−2
• src/lib/Haskus/Format/Binary/Unum.hs +20/−20
• src/lib/Haskus/Format/Binary/VariableLength.hs +2/−0
• src/lib/Haskus/Format/Binary/Vector.hs +159/−5
• src/lib/Haskus/Format/Binary/Word.hs +33/−14
• src/tests/Haskus/Tests/Format/Binary/Bits.hs +179/−13
• src/tests/Haskus/Tests/Format/Binary/Vector.hs +7/−0

@@ -1,2 +0,0 @@-import Distribution.Simple-main = defaultMain

@@ -1,101 +1,96 @@-name:                haskus-binary-version:             0.6.0.0-synopsis:            Haskus binary format manipulation-license:             BSD3-license-file:        LICENSE-author:              Sylvain Henry-maintainer:          sylvain@haskus.fr-homepage:            http://www.haskus.org/system-copyright:           Sylvain Henry 2017-category:            System-build-type:          Simple-cabal-version:       >=1.20-+name: haskus-binary+version: 1.0+cabal-version: >=1.20+build-type: Simple+license: BSD3+license-file: LICENSE+copyright: Sylvain Henry 2017+maintainer: sylvain@haskus.fr+homepage: http://www.haskus.org/system+synopsis: Haskus binary format manipulation description:-   A set of types and tools to manipulate binary data, memory, etc. In-   particular to interface Haskell data types with foreign data types (C-   structs, unions, enums, etc.).+    A set of types and tools to manipulate binary data, memory, etc. In+    particular to interface Haskell data types with foreign data types (C+    structs, unions, enums, etc.).+category: System+author: Sylvain Henry  source-repository head-  type: git-  location: git://github.com/haskus/haskus-binary.git+    type: git+    location: git://github.com/haskus/haskus-binary.git  library-  exposed-modules:--    Haskus.Format.Binary.Bits-    Haskus.Format.Binary.Bits.Basic-    Haskus.Format.Binary.Bits.Reverse-    Haskus.Format.Binary.Bits.Order-    Haskus.Format.Binary.Bits.Get-    Haskus.Format.Binary.Bits.Put--    Haskus.Format.Binary.BitSet-    Haskus.Format.Binary.BitField-    Haskus.Format.Binary.Buffer-    Haskus.Format.Binary.BufferList-    Haskus.Format.Binary.BufferBuilder-    Haskus.Format.Binary.Enum-    Haskus.Format.Binary.Endianness-    Haskus.Format.Binary.FixedPoint-    Haskus.Format.Binary.Get-    Haskus.Format.Binary.Put-    Haskus.Format.Binary.VariableLength-    Haskus.Format.Binary.Vector-    Haskus.Format.Binary.Union-    Haskus.Format.Binary.Unum-    Haskus.Format.Binary.Record-    Haskus.Format.Binary.Storable-    Haskus.Format.Binary.Word-    Haskus.Format.Binary.Ptr--    Haskus.Format.Binary.Layout--    Haskus.Utils.Memory--  other-modules:--  build-depends:       -         base                      >= 4.9 && < 4.10-      ,  haskus-utils              >= 0.6-      ,  cereal                    >= 0.5-      ,  bytestring                >= 0.10-      ,  mtl                       >= 2.2--  build-tools: -  ghc-options:          -Wall-  default-language:     Haskell2010-  hs-source-dirs:       src/lib--test-suite tests-   type:                exitcode-stdio-1.0-   main-is:             Main.hs-   hs-source-dirs:      src/tests/-   ghc-options:         -O2 -Wall -threaded-   default-language:    Haskell2010-   other-modules:-         Haskus.Tests.Format.Binary-      ,  Haskus.Tests.Common-      ,  Haskus.Tests.Format.Binary.Bits-      ,  Haskus.Tests.Format.Binary.GetPut-      ,  Haskus.Tests.Format.Binary.Vector+    exposed-modules:+        Haskus.Format.Binary.Bits+        Haskus.Format.Binary.Bits.Finite+        Haskus.Format.Binary.Bits.Index+        Haskus.Format.Binary.Bits.Bitwise+        Haskus.Format.Binary.Bits.Reverse+        Haskus.Format.Binary.Bits.Rotate+        Haskus.Format.Binary.Bits.Shift+        Haskus.Format.Binary.Bits.Order+        Haskus.Format.Binary.Bits.Get+        Haskus.Format.Binary.Bits.Put+        Haskus.Format.Binary.BitSet+        Haskus.Format.Binary.BitField+        Haskus.Format.Binary.Buffer+        Haskus.Format.Binary.BufferList+        Haskus.Format.Binary.BufferBuilder+        Haskus.Format.Binary.Char+        Haskus.Format.Binary.Enum+        Haskus.Format.Binary.Endianness+        Haskus.Format.Binary.FixedPoint+        Haskus.Format.Binary.Get+        Haskus.Format.Binary.Put+        Haskus.Format.Binary.VariableLength+        Haskus.Format.Binary.Vector+        Haskus.Format.Binary.Union+        Haskus.Format.Binary.Unum+        Haskus.Format.Binary.Posit+        Haskus.Format.Binary.Record+        Haskus.Format.Binary.Storable+        Haskus.Format.Binary.Word+        Haskus.Format.Binary.Ptr+        Haskus.Format.Binary.Layout+        Haskus.Utils.Memory+    build-depends:+        base >=4.9 && <4.12,+        haskus-utils >=0.6 && <1.1,+        cereal ==0.5.*,+        bytestring ==0.10.*,+        mtl ==2.2.*+    default-language: Haskell2010+    hs-source-dirs: src/lib+    ghc-options: -Wall -   build-depends:    -         base-      ,  haskus-binary-      ,  haskus-utils-      ,  tasty                   >= 0.11-      ,  tasty-quickcheck        >= 0.8-      ,  QuickCheck              >= 2.8-      ,  bytestring+test-suite  tests+    type: exitcode-stdio-1.0+    main-is: Main.hs+    build-depends:+        base >=4.11.1.0 && <4.12,+        haskus-binary -any,+        haskus-utils ==1.0.*,+        tasty >=0.11 && <1.2,+        tasty-quickcheck >=0.8 && <0.11,+        QuickCheck >=2.8 && <2.12,+        bytestring >=0.10.8.2 && <0.11+    default-language: Haskell2010+    hs-source-dirs: src/tests/+    other-modules:+        Haskus.Tests.Format.Binary+        Haskus.Tests.Common+        Haskus.Tests.Format.Binary.Bits+        Haskus.Tests.Format.Binary.GetPut+        Haskus.Tests.Format.Binary.Vector+    ghc-options: -O2 -Wall -threaded -Benchmark bench-BitReverse-   type:               exitcode-stdio-1.0-   main-is:            BitReverse.hs-   hs-source-dirs:     src/bench-   ghc-options:         -Wall -threaded -O3-   default-language:     Haskell2010-   build-depends:-         base-      ,  haskus-binary-      ,  criterion+benchmark  bench-BitReverse+    type: exitcode-stdio-1.0+    main-is: BitReverse.hs+    build-depends:+        base >=4.11.1.0 && <4.12,+        haskus-binary -any,+        criterion >=1.4.1.0 && <1.5+    default-language: Haskell2010+    hs-source-dirs: src/bench+    ghc-options: -Wall -threaded -O3

@@ -17,10 +17,11 @@ -- have a Word16 split into 3 fields X, Y and Z composed of 5, 9 and 2 bits -- respectively. -----                   X             Y          Z---  w :: Word16 |0 0 0 0 0|0 0 0 0 0 0 0 0 0|0 0|+-- @                  X             Y          Z   @+-- @ w :: Word16 |0 0 0 0 0|0 0 0 0 0 0 0 0 0|0 0| @ --  -- You define it as follows:+-- -- @ -- {-# LANGUAGE DataKinds #-} --@@ -48,6 +49,7 @@ -- @ -- -- Fields can also be 'BitSet' or 'EnumField':+-- -- @ -- {-# LANGUAGE DataKinds #-} --@@ -61,6 +63,7 @@ --                        ] -- w = BitFields 0x0102 -- @+-- module Haskus.Format.Binary.BitField    ( BitFields (..)    , bitFieldsBits@@ -180,7 +183,7 @@    fromField = fromIntegral . BitSet.toBits    toField   = BitSet.fromBits . fromIntegral -instance CEnum a => Field (EnumField b a) where+instance (Integral b, CEnum a) => Field (EnumField b a) where    fromField = fromCEnum . fromEnumField    toField   = toEnumField . toCEnum 

@@ -2,6 +2,7 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE FlexibleContexts #-}  -- | A bit set based on Enum to name the bits. Use bitwise operations and -- minimal storage in a safer way.@@ -54,6 +55,7 @@    , unions    , fromListToBits    , toListFromBits+   , enumerateSetBits    , fromList    , toList    )@@ -71,18 +73,28 @@ -- | A bit set: use bitwise operations (fast!) and minimal storage (sizeOf -- basetype) ----- b is the base type (Bits b)--- a is the element type (Enum a)+-- * b is the base type (Bits b)+-- * a is the element type (Enum a) -- -- The elements in the Enum a are flags corresponding to each bit of b starting -- from the least-significant bit. newtype BitSet b a = BitSet b deriving (Eq,Ord,Storable) -instance (Show a, CBitSet a, FiniteBits b) => Show (BitSet b a) where-   show b = "fromList " ++ show (toList b)+instance+   ( Show a+   , CBitSet a+   , FiniteBits b+   , IndexableBits b+   , Eq b+   ) => Show (BitSet b a)+   where+      show b = "fromList " ++ show (toList b)  -- | Indicate if the set is empty-null :: (FiniteBits b) => BitSet b a -> Bool+null ::+   ( FiniteBits b+   , Eq b+   ) => BitSet b a -> Bool {-# INLINE null #-} null (BitSet b) = b == zeroBits @@ -94,19 +106,19 @@   -- | Create a BitSet from a single element-singleton :: (Bits b, CBitSet a) => a -> BitSet b a+singleton :: (IndexableBits b, CBitSet a) => a -> BitSet b a {-# INLINE singleton #-}-singleton e = BitSet $ setBit zeroBits (toBitOffset e)+singleton e = BitSet $ bit (toBitOffset e)   -- | Insert an element in the set-insert :: (Bits b, CBitSet a) => BitSet b a -> a -> BitSet b a+insert :: (IndexableBits b, CBitSet a) => BitSet b a -> a -> BitSet b a {-# INLINE insert #-} insert (BitSet b) e = BitSet $ setBit b (toBitOffset e)   -- | Remove an element from the set-delete :: (Bits b, CBitSet a) => BitSet b a -> a -> BitSet b a+delete :: (IndexableBits b, CBitSet a) => BitSet b a -> a -> BitSet b a {-# INLINE delete #-} delete (BitSet b) e = BitSet $ clearBit b (toBitOffset e) @@ -120,25 +132,42 @@ fromBits = BitSet  -- | Test if an element is in the set-member :: (CBitSet a, FiniteBits b) => BitSet b a -> a -> Bool+member ::+   ( CBitSet a+   , FiniteBits b+   , IndexableBits b+   ) => BitSet b a -> a -> Bool {-# INLINE member #-} member (BitSet b) e = testBit b (toBitOffset e)   -- | Test if an element is in the set-elem :: (CBitSet a, FiniteBits b) => a -> BitSet b a -> Bool+elem ::+   ( CBitSet a+   , FiniteBits b+   , IndexableBits b+   ) => a -> BitSet b a -> Bool {-# INLINE elem #-} elem e (BitSet b) = testBit b (toBitOffset e)   -- | Test if an element is not in the set-notMember :: (CBitSet a, FiniteBits b) => BitSet b a -> a -> Bool+notMember ::+   ( CBitSet a+   , FiniteBits b+   , IndexableBits b+   ) => BitSet b a -> a -> Bool {-# INLINE notMember #-} notMember b e = not (member b e)   -- | Retrieve elements in the set-elems :: (CBitSet a, FiniteBits b) => BitSet b a -> [a]+elems ::+   ( CBitSet a+   , FiniteBits b+   , IndexableBits b+   , Eq b+   ) => BitSet b a -> [a] elems (BitSet b) = go b    where       go !c@@ -146,19 +175,28 @@          | otherwise     = let e = countTrailingZeros c in fromBitOffset e : go (clearBit c e)  -- | Intersection of two sets-intersection :: FiniteBits b => BitSet b a -> BitSet b a -> BitSet b a+intersection ::+   ( FiniteBits b+   , Bitwise b+   ) => BitSet b a -> BitSet b a -> BitSet b a {-# INLINE intersection #-} intersection (BitSet b1) (BitSet b2) = BitSet (b1 .&. b2)   -- | Intersection of two sets-union :: FiniteBits b => BitSet b a -> BitSet b a -> BitSet b a+union ::+   ( FiniteBits b+   , Bitwise b+   ) => BitSet b a -> BitSet b a -> BitSet b a {-# INLINE union #-} union (BitSet b1) (BitSet b2) = BitSet (b1 .|. b2)   -- | Intersection of several sets-unions :: FiniteBits b => [BitSet b a] -> BitSet b a+unions ::+   ( FiniteBits b+   , Bitwise b+   ) => [BitSet b a] -> BitSet b a {-# INLINE unions #-} unions = foldl' union empty @@ -166,17 +204,22 @@ -- | Bit set indexed with a class CBitSet a where    -- | Return the bit offset of an element-   toBitOffset         :: a -> Int-   default toBitOffset :: Enum a => a -> Int-   toBitOffset         = fromEnum+   toBitOffset         :: a -> Word+   default toBitOffset :: Enum a => a -> Word+   toBitOffset         = fromIntegral . fromEnum     -- | Return the value associated with a bit offset-   fromBitOffset         :: Int -> a-   default fromBitOffset :: Enum a => Int -> a-   fromBitOffset         = toEnum+   fromBitOffset         :: Word -> a+   default fromBitOffset :: Enum a => Word -> a+   fromBitOffset         = toEnum . fromIntegral  -- | It can be useful to get the indexes of the set bits instance CBitSet Int where+   toBitOffset   = fromIntegral+   fromBitOffset = fromIntegral++-- | It can be useful to get the indexes of the set bits+instance CBitSet Word where    toBitOffset   = id    fromBitOffset = id    @@ -185,23 +228,69 @@ -- | Convert a list of enum elements into a bitset Warning: b -- must have enough bits to store the given elements! (we don't -- perform any check, for performance reason)-fromListToBits :: (CBitSet a, FiniteBits b, Foldable m) => m a -> b+fromListToBits ::+   ( CBitSet a+   , FiniteBits b+   , IndexableBits b+   , Foldable m+   ) => m a -> b fromListToBits = toBits . fromList  -- | Convert a bitset into a list of Enum elements-toListFromBits :: (CBitSet a, FiniteBits b) => b -> [a]+toListFromBits ::+   ( CBitSet a+   , FiniteBits b+   , IndexableBits b+   , Eq b+   ) => b -> [a] toListFromBits = toList . BitSet +-- | Convert a bitset into a list of Enum elements by testing the Enum values+-- successively.+--+-- The difference with `toListFromBits` is that extra values in the BitSet will+-- be ignored.+enumerateSetBits ::+   ( CBitSet a+   , FiniteBits b+   , IndexableBits b+   , Eq b+   , Bounded a+   , Enum a+   ) => b -> [a]+enumerateSetBits b = go [] [minBound..]+   where+      go rs []     = rs+      go rs (x:xs)+         | member (BitSet b) x = go (x:rs) xs+         | otherwise           = go rs xs+ -- | Convert a set into a list-toList :: (CBitSet a, FiniteBits b) => BitSet b a -> [a]+toList ::+   ( CBitSet a+   , FiniteBits b+   , IndexableBits b+   , Eq b+   ) => BitSet b a -> [a] toList = elems  -- | Convert a Foldable into a set-fromList :: (CBitSet a, FiniteBits b, Foldable m) => m a -> BitSet b a+fromList ::+   ( CBitSet a+   , IndexableBits b+   , FiniteBits b+   , Foldable m+   ) => m a -> BitSet b a fromList = foldl' insert (BitSet zeroBits)  -instance (FiniteBits b, CBitSet a) => Ext.IsList (BitSet b a) where-   type Item (BitSet b a) = a-   fromList = fromList-   toList   = toList+instance+   ( FiniteBits b+   , IndexableBits b+   , CBitSet a+   , Eq b+   ) => Ext.IsList (BitSet b a)+   where+      type Item (BitSet b a) = a+      fromList = fromList+      toList   = toList

@@ -1,10 +1,19 @@+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleContexts #-}+ -- | Operations on bits module Haskus.Format.Binary.Bits-   (-   -- * Basic-     module Haskus.Format.Binary.Bits.Basic+   ( Bits+   , FiniteBits (..)+   , IndexableBits (..)+   , ShiftableBits (..)+   , SignedShiftableBits (..)+   , RotatableBits (..)+   , Bitwise (..)    -- * Bit reversal-   , BitReversable (..)+   , ReversableBits (..)    , reverseBitsGeneric    , reverseLeastBits    -- * Mask@@ -12,6 +21,7 @@    , maskLeastBits    -- * String conversion    , bitsToString+   , bitsToStringN    , bitsFromString    -- * Shift    , getBitRange@@ -22,20 +32,42 @@ where  import Haskus.Utils.List (foldl')-import Haskus.Format.Binary.Bits.Basic+import Haskus.Utils.Types+import Haskus.Format.Binary.Bits.Finite+import Haskus.Format.Binary.Bits.Index import Haskus.Format.Binary.Bits.Reverse+import Haskus.Format.Binary.Bits.Rotate+import Haskus.Format.Binary.Bits.Shift+import Haskus.Format.Binary.Bits.Bitwise import Haskus.Format.Binary.Bits.Order import Haskus.Format.Binary.Word +type Bits a =+   ( Eq a+   , FiniteBits a+   , IndexableBits a+   , ShiftableBits a+   , Bitwise a+   , RotatableBits a+   , KnownNat (BitSize a)+   )+ -- | makeMask 3 = 00000111-makeMask :: (FiniteBits a) => Word -> a-makeMask n = x' `shiftR` (finiteBitSize x - fromIntegral n)+makeMask :: forall a.+   ( ShiftableBits a+   , FiniteBits a+   , KnownNat (BitSize a)+   , Bitwise a+   ) => Word -> a+makeMask n = complement zeroBits `shiftR` off    where-      x = complement zeroBits-      x' = if isSigned x -               then error "Cannot use makeMask with a signed type"-               else x+      off = natValue' @(BitSize a) - n+ {-# SPECIALIZE makeMask :: Word -> Int #-}+{-# SPECIALIZE makeMask :: Word -> Int8 #-}+{-# SPECIALIZE makeMask :: Word -> Int16 #-}+{-# SPECIALIZE makeMask :: Word -> Int32 #-}+{-# SPECIALIZE makeMask :: Word -> Int64 #-} {-# SPECIALIZE makeMask :: Word -> Word #-} {-# SPECIALIZE makeMask :: Word -> Word8 #-} {-# SPECIALIZE makeMask :: Word -> Word16 #-}@@ -43,7 +75,12 @@ {-# SPECIALIZE makeMask :: Word -> Word64 #-}  -- | Keep only the n least-significant bits of the given value-maskLeastBits :: (FiniteBits a) => Word -> a -> a+maskLeastBits :: forall a.+   ( ShiftableBits a+   , FiniteBits a+   , Bitwise a+   , KnownNat (BitSize a)+   ) => Word -> a -> a {-# INLINE maskLeastBits #-} maskLeastBits n v = v .&. makeMask n @@ -55,18 +92,32 @@ -- | Compute byte offset (equivalent to x `div` 8 but faster) byteOffset :: Word -> Word {-# INLINE byteOffset #-}-byteOffset n = n `shiftR` 3+byteOffset n = n `uncheckedShiftR` 3  -- | Reverse the @n@ least important bits of the given value. The higher bits -- are set to 0.-reverseLeastBits :: (FiniteBits a, BitReversable a) => Word -> a -> a-reverseLeastBits n value = reverseBits value `shiftR` (finiteBitSize value - fromIntegral n)+reverseLeastBits ::+   ( ShiftableBits a+   , FiniteBits a+   , ReversableBits a+   , KnownNat (BitSize a)+   ) => Word -> a -> a+reverseLeastBits n value = reverseBits value `uncheckedShiftR` ((bitSize value) - n)  -- | Convert bits into a string composed of '0' and '1' chars-bitsToString :: FiniteBits a => a -> String-bitsToString x = fmap b [s, s-1 .. 0]+bitsToString :: forall a.+   ( FiniteBits a+   , IndexableBits a+   , KnownNat (BitSize a)+   ) => a -> String+bitsToString = bitsToStringN (natValue @(BitSize a))++-- | Convert a specified amount of bits into a string composed of '0' and '1' chars+bitsToStringN :: forall a.+   ( IndexableBits a+   ) => Word -> a -> String+bitsToStringN n x = fmap b [n-1, n-2 .. 0]    where-      s   = finiteBitSize x - 1       b v = if testBit x v then '1' else '0'  -- | Convert a string of '0' and '1' chars into a word@@ -78,16 +129,21 @@       b _ (c,_)   = error $ "Invalid character in the string: " ++ [c]  --- | Take n bits at offset o and put them in the least-significant--- bits of the result-getBitRange :: (BitReversable b, FiniteBits b) => BitOrder -> Word -> Word -> b -> b+-- | `getBitRange bo offset n c` takes n bits at offset in c and put them in the+-- least-significant bits of the result+getBitRange :: forall b.+   ( ShiftableBits b+   , ReversableBits b+   , FiniteBits b+   , KnownNat (BitSize b)+   , Bitwise b+   ) => BitOrder -> Word -> Word -> b -> b {-# INLINE getBitRange #-} getBitRange bo o n c = case bo of-      BB -> maskLeastBits n $ c             `shiftR` d-      BL -> maskLeastBits n $ reverseBits c `shiftR` o'-      LB -> maskLeastBits n $ reverseBits c `shiftR` d-      LL -> maskLeastBits n $ c             `shiftR` o'+      BB -> maskLeastBits n $ c             `uncheckedShiftR` d+      BL -> maskLeastBits n $ reverseBits c `uncheckedShiftR` o+      LB -> maskLeastBits n $ reverseBits c `uncheckedShiftR` d+      LL -> maskLeastBits n $ c             `uncheckedShiftR` o    where -      o' = fromIntegral o-      d  = finiteBitSize c - fromIntegral n - fromIntegral o+      d  = bitSize c - n - o 

@@ -1,7 +0,0 @@--- | Basic operations on bits-module Haskus.Format.Binary.Bits.Basic-   ( module Data.Bits-   )-where--import Data.Bits

@@ -0,0 +1,98 @@+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE BangPatterns #-}++-- | Bitwise bit operations+module Haskus.Format.Binary.Bits.Bitwise+   ( Bitwise (..)+   )+where++import Haskus.Format.Binary.Word+import GHC.Exts+import GHC.Num++-- | Bitwise bit operations+class Bitwise a where+   -- | Bitwise "and"+   (.&.) :: a -> a -> a++   -- | Bitwise "or"+   (.|.) :: a -> a -> a++   -- | Bitwise "xor"+   xor :: a -> a -> a++   -- | Complement+   complement :: a -> a+++instance Bitwise Word where+   (W# x#) .&.   (W# y#) = W# (x# `and#` y#)+   (W# x#) .|.   (W# y#) = W# (x# `or#` y#)+   (W# x#) `xor` (W# y#) = W# (x# `xor#` y#)+   complement (W# x#)    = W# (x# `xor#` mb#)+      where !(W# mb#) = maxBound++instance Bitwise Word8 where+   (W8# x#) .&.   (W8# y#) = W8# (x# `and#` y#)+   (W8# x#) .|.   (W8# y#) = W8# (x# `or#` y#)+   (W8# x#) `xor` (W8# y#) = W8# (x# `xor#` y#)+   complement (W8# x#)     = W8# (x# `xor#` mb#)+      where !(W8# mb#) = maxBound++instance Bitwise Word16 where+   (W16# x#) .&.   (W16# y#) = W16# (x# `and#` y#)+   (W16# x#) .|.   (W16# y#) = W16# (x# `or#` y#)+   (W16# x#) `xor` (W16# y#) = W16# (x# `xor#` y#)+   complement (W16# x#)      = W16# (x# `xor#` mb#)+      where !(W16# mb#) = maxBound++instance Bitwise Word32 where+   (W32# x#) .&.   (W32# y#) = W32# (x# `and#` y#)+   (W32# x#) .|.   (W32# y#) = W32# (x# `or#` y#)+   (W32# x#) `xor` (W32# y#) = W32# (x# `xor#` y#)+   complement (W32# x#)      = W32# (x# `xor#` mb#)+      where !(W32# mb#) = maxBound++instance Bitwise Word64 where+   (W64# x#) .&.   (W64# y#) = W64# (x# `and#` y#)+   (W64# x#) .|.   (W64# y#) = W64# (x# `or#` y#)+   (W64# x#) `xor` (W64# y#) = W64# (x# `xor#` y#)+   complement (W64# x#)      = W64# (x# `xor#` mb#)+      where !(W64# mb#) = maxBound++instance Bitwise Int where+   (I# x#) .&.   (I# y#) = I# (x# `andI#` y#)+   (I# x#) .|.   (I# y#) = I# (x# `orI#` y#)+   (I# x#) `xor` (I# y#) = I# (x# `xorI#` y#)+   complement (I# x#)    = I# (notI# x#)++instance Bitwise Int8 where+   (I8# x#) .&.   (I8# y#) = I8# (word2Int# (int2Word# x# `and#` int2Word# y#))+   (I8# x#) .|.   (I8# y#) = I8# (word2Int# (int2Word# x# `or#`  int2Word# y#))+   (I8# x#) `xor` (I8# y#) = I8# (word2Int# (int2Word# x# `xor#` int2Word# y#))+   complement (I8# x#)     = I8# (word2Int# (not# (int2Word# x#)))++instance Bitwise Int16 where+   (I16# x#) .&.   (I16# y#) = I16# (word2Int# (int2Word# x# `and#` int2Word# y#))+   (I16# x#) .|.   (I16# y#) = I16# (word2Int# (int2Word# x# `or#`  int2Word# y#))+   (I16# x#) `xor` (I16# y#) = I16# (word2Int# (int2Word# x# `xor#` int2Word# y#))+   complement (I16# x#)      = I16# (word2Int# (not# (int2Word# x#)))++instance Bitwise Int32 where+   (I32# x#) .&.   (I32# y#) = I32# (word2Int# (int2Word# x# `and#` int2Word# y#))+   (I32# x#) .|.   (I32# y#) = I32# (word2Int# (int2Word# x# `or#`  int2Word# y#))+   (I32# x#) `xor` (I32# y#) = I32# (word2Int# (int2Word# x# `xor#` int2Word# y#))+   complement (I32# x#)      = I32# (word2Int# (not# (int2Word# x#)))++instance Bitwise Int64 where+   (I64# x#) .&.   (I64# y#) = I64# (word2Int# (int2Word# x# `and#` int2Word# y#))+   (I64# x#) .|.   (I64# y#) = I64# (word2Int# (int2Word# x# `or#`  int2Word# y#))+   (I64# x#) `xor` (I64# y#) = I64# (word2Int# (int2Word# x# `xor#` int2Word# y#))+   complement (I64# x#)      = I64# (word2Int# (int2Word# x# `xor#` int2Word# (-1#)))++instance Bitwise Integer where+   (.&.)      = andInteger+   (.|.)      = orInteger+   xor        = xorInteger+   complement = complementInteger

@@ -0,0 +1,119 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ConstrainedClassMethods #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- | Types with finite bit count+module Haskus.Format.Binary.Bits.Finite+   ( FiniteBits (..)+   )+where++import Haskus.Utils.Types+import Haskus.Format.Binary.Word+import Haskus.Format.Binary.Bits.Bitwise+import GHC.Exts++#include "MachDeps.h"++-- | Type representable by a fixed amount of bits+class FiniteBits a where++   -- | Number of bits+   type BitSize a :: Nat++   -- | Number of bits (the value is ignored)+   bitSize :: (Integral i, KnownNat (BitSize a)) => a -> i+   bitSize _ = natValue @(BitSize a)+   +   -- | All bits set to 0+   zeroBits :: a++   -- | All bits set to 1+   oneBits :: a+   default oneBits :: Bitwise a => a+   oneBits = complement zeroBits++   -- | Count number of zero bits preceding the most significant set bit+   countLeadingZeros :: a -> Word++   -- | Count number of zero bits following the least significant set bit+   countTrailingZeros :: a -> Word+++instance FiniteBits Word where+   type BitSize Word          = WORD_SIZE_IN_BITS+   zeroBits                   = 0+   oneBits                    = maxBound+   countLeadingZeros  (W# x#) = W# (clz# x#)+   countTrailingZeros (W# x#) = W# (ctz# x#)++instance FiniteBits Word8 where+   type BitSize Word8          = 8+   zeroBits                    = 0+   oneBits                     = maxBound+   countLeadingZeros  (W8# x#) = W# (clz8# x#)+   countTrailingZeros (W8# x#) = W# (ctz8# x#)++instance FiniteBits Word16 where+   type BitSize Word16          = 16+   zeroBits                     = 0+   oneBits                      = maxBound+   countLeadingZeros  (W16# x#) = W# (clz16# x#)+   countTrailingZeros (W16# x#) = W# (ctz16# x#)++instance FiniteBits Word32 where+   type BitSize Word32          = 32+   zeroBits                     = 0+   oneBits                      = maxBound+   countLeadingZeros  (W32# x#) = W# (clz32# x#)+   countTrailingZeros (W32# x#) = W# (ctz32# x#)++instance FiniteBits Word64 where+   type BitSize Word64          = 64+   zeroBits                     = 0+   oneBits                      = maxBound+   countLeadingZeros  (W64# x#) = W# (clz64# x#)+   countTrailingZeros (W64# x#) = W# (ctz64# x#)+++instance FiniteBits Int where+   type BitSize Int           = WORD_SIZE_IN_BITS+   zeroBits                   = 0+   oneBits                    = (-1)+   countLeadingZeros  (I# x#) = W# (clz# (int2Word# x#))+   countTrailingZeros (I# x#) = W# (ctz# (int2Word# x#))++instance FiniteBits Int8 where+   type BitSize Int8           = 8+   zeroBits                    = 0+   oneBits                     = (-1)+   countLeadingZeros  (I8# x#) = W# (clz8# (int2Word# x#))+   countTrailingZeros (I8# x#) = W# (ctz8# (int2Word# x#))++instance FiniteBits Int16 where+   type BitSize Int16           = 16+   zeroBits                     = 0+   oneBits                      = (-1)+   countLeadingZeros  (I16# x#) = W# (clz16# (int2Word# x#))+   countTrailingZeros (I16# x#) = W# (ctz16# (int2Word# x#))++instance FiniteBits Int32 where+   type BitSize Int32           = 32+   zeroBits                     = 0+   oneBits                      = (-1)+   countLeadingZeros  (I32# x#) = W# (clz32# (int2Word# x#))+   countTrailingZeros (I32# x#) = W# (ctz32# (int2Word# x#))++instance FiniteBits Int64 where+   type BitSize Int64           = 64+   zeroBits                     = 0+   oneBits                      = (-1)+   countLeadingZeros  (I64# x#) = W# (clz64# (int2Word# x#))+   countTrailingZeros (I64# x#) = W# (ctz64# (int2Word# x#))

@@ -1,4 +1,5 @@ {-# LANGUAGE BangPatterns #-}+{-# LANGUAGE FlexibleContexts #-}  -- | Bit getter module Haskus.Format.Binary.Bits.Get@@ -71,7 +72,7 @@    n -> skipBits (8-n) s  -- | Read the given number of bits and put the result in a word-getBits :: (Integral a, FiniteBits a) => Word -> BitGetState -> a+getBits :: (Integral a, Bits a) => Word -> BitGetState -> a getBits nbits (BitGetState bs off bo) = rec zeroBits 0 bs off nbits    where       -- w   = current result@@ -100,7 +101,7 @@ -- | Perform some checks before calling getBits -- -- Check that the number of bits to read is not greater than the first parameter-getBitsChecked :: (Integral a, FiniteBits a, BitReversable a) => Word -> Word -> BitGetState -> a+getBitsChecked :: (Integral a, Bits a, ReversableBits a) => Word -> Word -> BitGetState -> a {-# INLINE getBitsChecked #-} getBitsChecked m n s    | n > m     = error $ "Tried to read more than " ++ show m ++ " bits (" ++ show n ++")"@@ -109,10 +110,10 @@ -- | Read the given number of Word8 and return them in a Buffer -- -- Examples:---    BB: xxxABCDE FGHIJKLM NOPxxxxx -> ABCDEFGH IJKLMNOP---    LL: LMNOPxxx DEFGHIJK xxxxxABC -> ABCDEFGH IJKLMNOP---    BL: xxxPONML KJIHGFED CBAxxxxx -> ABCDEFGH IJKLMNOP---    LB: EDCBAxxx MLKJIHGF xxxxxPON -> ABCDEFGH IJKLMNOP+-- @  BB: xxxABCDE FGHIJKLM NOPxxxxx -> ABCDEFGH IJKLMNOP @+-- @  LL: LMNOPxxx DEFGHIJK xxxxxABC -> ABCDEFGH IJKLMNOP @+-- @  BL: xxxPONML KJIHGFED CBAxxxxx -> ABCDEFGH IJKLMNOP @+-- @  LB: EDCBAxxx MLKJIHGF xxxxxPON -> ABCDEFGH IJKLMNOP @ getBitsBuffer :: Word -> BitGetState -> Buffer getBitsBuffer n (BitGetState bs o bo) =    if n == 0@@ -189,14 +190,14 @@ skipBitsToAlignOnWord8M = modify skipBitsToAlignOnWord8  -- | Read the given number of bits and put the result in a word-getBitsM :: (Integral a, FiniteBits a, Monad m) => Word -> BitGetT m a+getBitsM :: (Integral a, Bits a, Monad m) => Word -> BitGetT m a getBitsM n = do    v <- gets (getBits n)    skipBitsM n    return v  -- | Perform some checks before calling getBitsM-getBitsCheckedM :: (Integral a, FiniteBits a, BitReversable a, Monad m) => Word -> Word -> BitGetT m a+getBitsCheckedM :: (Integral a, Bits a, ReversableBits a, Monad m) => Word -> Word -> BitGetT m a getBitsCheckedM m n = do    v <- gets (getBitsChecked m n)    skipBitsM n

@@ -0,0 +1,81 @@+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE MagicHash #-}++-- | Bit indexable types+module Haskus.Format.Binary.Bits.Index+   ( IndexableBits (..)+   )+where++import Haskus.Format.Binary.Bits.Shift+import Haskus.Format.Binary.Bits.Bitwise+import Haskus.Format.Binary.Word+import GHC.Exts++-- | Type whose bits are indexable+class IndexableBits a where+   -- | @bit /i/@ is a value with the @/i/@th bit set and all other bits clear.+   bit :: Word -> a+   default bit :: (Num a, ShiftableBits a) => Word -> a+   bit i = 1 `shiftL` i++   -- | @x \`setBit\` i@ is the same as @x .|. bit i@+   setBit :: a -> Word -> a+   default setBit :: (Bitwise a) => a -> Word -> a+   setBit a i = a .|. bit i++   -- | @x \`clearBit\` i@ is the same as @x .&. complement (bit i)@+   clearBit :: a -> Word -> a+   default clearBit :: (Bitwise a) => a -> Word -> a+   clearBit a i = a .&. complement (bit i)++   -- | @x \`complementBit\` i@ is the same as @x \`xor\` bit i@+   complementBit :: a -> Word -> a+   default complementBit :: (Bitwise a) => a -> Word -> a+   complementBit a i = a `xor` bit i++   -- | Return 'True' if the @n@th bit of the argument is 1+   testBit :: a -> Word -> Bool+   default testBit :: (Bitwise a, Num a, Eq a) => a -> Word -> Bool+   testBit a i = (a .&. bit i) /= 0++   -- | Return the number of set bits+   popCount :: a -> Word+   default popCount :: (Bitwise a, Num a, Eq a) => a -> Word+   popCount = go 0+      where+         go !c 0 = c+         go c  w = go (c+1) (w .&. (w-1))+++instance IndexableBits Word where+   popCount (W# x#) = W# (popCnt# x#)++instance IndexableBits Word8 where+   popCount (W8# x#) = W# (popCnt8# x#)++instance IndexableBits Word16 where+   popCount (W16# x#) = W# (popCnt16# x#)++instance IndexableBits Word32 where+   popCount (W32# x#) = W# (popCnt32# x#)++instance IndexableBits Word64 where+   popCount (W64# x#) = W# (popCnt64# x#)++instance IndexableBits Int where+   popCount (I# x#) = W# (popCnt# (int2Word# x#))++instance IndexableBits Int8 where+   popCount (I8# x#) = W# (popCnt8# (int2Word# x#))++instance IndexableBits Int16 where+   popCount (I16# x#) = W# (popCnt16# (int2Word# x#))++instance IndexableBits Int32 where+   popCount (I32# x#) = W# (popCnt32# (int2Word# x#))++instance IndexableBits Int64 where+   popCount (I64# x#) = W# (popCnt64# (int2Word# x#))+

@@ -7,18 +7,20 @@ -- | Bit order -- -- The first letter indicates the outer bit ordering, i.e. how bytes are filled:---    B*: from left to right (B is for BigEndian)---    L*: from right to left (L is for LittleEndian)+--  +--  * B?: from left to right (B is for BigEndian)+--  * L?: from right to left (L is for LittleEndian) -- -- The second letter indicates the inner bit ordering, i.e. how words are stored:---    *B: the most significant bit is stored first (in the outer bit order!)---    *L: the least-significant bit is stored first (in the outer bit order!)+--   +--  * ?B: the most significant bit is stored first (in the outer bit order!)+--  * ?L: the least-significant bit is stored first (in the outer bit order!) -- -- E.g. two successive words of 5 bits: ABCDE, VWXYZ---    - BB: ABCDEVWX YZxxxxxx---    - BL: EDCBAZYX WVxxxxxx---    - LB: XWVEDCBA xxxxxxZY---    - LL: XYZABCDE xxxxxxVW+-- @ BB: ABCDEVWX YZxxxxxx @  +-- @ BL: EDCBAZYX WVxxxxxx @+-- @ LB: XWVEDCBA xxxxxxZY @+-- @ LL: XYZABCDE xxxxxxVW @ data BitOrder    = BB    | LB

@@ -1,3 +1,5 @@+{-# LANGUAGE FlexibleContexts #-}+ -- | Bit putter module Haskus.Format.Binary.Bits.Put    ( BitPutState(..)@@ -43,7 +45,11 @@ newBitPutState = BitPutState mempty 0 0  -- | Put bits-putBits :: (Integral a, FiniteBits a, BitReversable a) => Word -> a -> BitPutState -> BitPutState+putBits ::+   ( Integral a+   , Bits a+   , ReversableBits a+   ) => Word -> a -> BitPutState -> BitPutState putBits n w s@(BitPutState builder b o bo) = s'    where       -- number of bits that will be stored in the current byte@@ -67,7 +73,7 @@       -- Select bits to store in the current byte.       -- Put them in the correct order and return them in the least-significant       -- bits of the returned value-      selectBits :: (FiniteBits a, BitReversable a, Integral a) => a -> Word8+      selectBits :: (Bits a, ReversableBits a, Integral a) => a -> Word8       selectBits x = fromIntegral $ case bo of          BB ->                       maskLeastBits cn $ x `shiftR` fromIntegral (n-cn)          LB -> reverseLeastBits cn $ maskLeastBits cn $ x `shiftR` fromIntegral (n-cn)@@ -91,10 +97,10 @@ -- | Put a Buffer -- -- Examples: 3 bits are already written in the current byte---    BB: ABCDEFGH IJKLMNOP -> xxxABCDE FGHIJKLM NOPxxxxx---    LL: ABCDEFGH IJKLMNOP -> LMNOPxxx DEFGHIJK xxxxxABC---    BL: ABCDEFGH IJKLMNOP -> xxxPONML KJIHGFED CBAxxxxx---    LB: ABCDEFGH IJKLMNOP -> EDCBAxxx MLKJIHGF xxxxxPON+-- @  BB: ABCDEFGH IJKLMNOP -> xxxABCDE FGHIJKLM NOPxxxxx @+-- @  LL: ABCDEFGH IJKLMNOP -> LMNOPxxx DEFGHIJK xxxxxABC @+-- @  BL: ABCDEFGH IJKLMNOP -> xxxPONML KJIHGFED CBAxxxxx @+-- @  LB: ABCDEFGH IJKLMNOP -> EDCBAxxx MLKJIHGF xxxxxPON @ putBitsBuffer :: Buffer -> BitPutState -> BitPutState putBitsBuffer bs s    | isBufferEmpty bs = s@@ -116,7 +122,7 @@   | o == 0    = s   | otherwise = BitPutState (b `mappend` B.fromWord8 w) 0 0 bo --- | Get a lazy byte string+-- | Get a buffer list getBitPutBufferList :: BitPutState -> BufferList getBitPutBufferList = toBufferList . bitPutStateBuilder . flushIncomplete  @@ -139,7 +145,7 @@ runBitPut bo m = runIdentity (runBitPutT bo m)  -- | Put bits (monadic)-putBitsM :: (Monad m, Integral a, FiniteBits a, BitReversable a) => Word -> a -> BitPutT m ()+putBitsM :: (Monad m, Integral a, Bits a, ReversableBits a) => Word -> a -> BitPutT m () putBitsM n w = modify (putBits n w)  -- | Put a single bit (monadic)

@@ -1,17 +1,19 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}  -- | Reverse bits -- -- There are several algorithms performing the same thing here (reversing bits--- into words of different sizes). There are benchmarks for them in Haskus's+-- into words of different sizes). There are benchmarks for them in the  -- "bench" directory. The fastest one for the current architecture should be -- selected below. If you find that another algorithm is faster on your -- architecture, please report it. module Haskus.Format.Binary.Bits.Reverse    (     -- * Generic-     BitReversable (..)+     ReversableBits (..)    , reverseBitsGeneric    -- * Algorithms    , reverseBitsObvious@@ -26,7 +28,11 @@  import Haskus.Format.Binary.Buffer import Haskus.Format.Binary.Word-import Haskus.Format.Binary.Bits.Basic+import Haskus.Format.Binary.Bits.Finite+import Haskus.Format.Binary.Bits.Shift+import Haskus.Format.Binary.Bits.Bitwise+import Haskus.Format.Binary.Bits.Index+import Haskus.Utils.Types (KnownNat)  --------------------------------------------------- -- Generic and specialized reverseBits@@ -34,29 +40,50 @@   -- | Reverse bits in a Word-reverseBitsGeneric :: (FiniteBits a, Integral a) => a -> a+reverseBitsGeneric ::+   ( FiniteBits a+   , Integral a+   , ShiftableBits a+   , Bitwise a+   , KnownNat (BitSize a)+   ) => a -> a reverseBitsGeneric = liftReverseBits reverseBits4Ops  -- | Data whose bits can be reversed-class BitReversable w where+class ReversableBits w where    reverseBits :: w -> w -instance BitReversable Word8 where+instance ReversableBits Word8 where    reverseBits = reverseBits4Ops -instance BitReversable Word16 where+instance ReversableBits Word16 where    reverseBits = reverseBits5LgN -instance BitReversable Word32 where+instance ReversableBits Word32 where    reverseBits = reverseBits5LgN -instance BitReversable Word64 where+instance ReversableBits Word64 where    reverseBits = reverseBits5LgN -instance BitReversable Word where+instance ReversableBits Word where    reverseBits = reverseBits5LgN +instance ReversableBits Int8 where+   reverseBits = fromIntegral . reverseBits4Ops . fromIntegral +instance ReversableBits Int16 where+   reverseBits = reverseBits5LgN++instance ReversableBits Int32 where+   reverseBits = reverseBits5LgN++instance ReversableBits Int64 where+   reverseBits = reverseBits5LgN++instance ReversableBits Int where+   reverseBits = reverseBits5LgN++ --------------------------------------------------- -- Bit reversal algorithms ---------------------------------------------------@@ -87,11 +114,18 @@ -- suggested a better version that loops while v is not 0, so rather than -- iterating over all bits it stops early.  --- | Obvious recursive verion-reverseBitsObvious :: FiniteBits a => a -> a-reverseBitsObvious x = rec x (x `shiftR` 1) (finiteBitSize x - 1)+-- | Obvious recursive version+reverseBitsObvious :: forall a.+   ( FiniteBits a+   , ShiftableBits a+   , IndexableBits a+   , Bitwise a+   , KnownNat (BitSize a)+   , Eq a+   ) => a -> a+reverseBitsObvious x = rec x (x `shiftR` 1) (bitSize x - 1)    where-      rec :: FiniteBits a => a -> a -> Int -> a+      rec :: FiniteBits a => a -> a -> Word -> a       rec !r !v !s           | v == zeroBits = r `shiftL` s          | otherwise     = rec ((r `shiftL` 1) .|. (v .&. bit 0)) (v `shiftR` 1) (s - 1)@@ -253,10 +287,15 @@ -- without ANDS in the last line on March 19, 2006.   -- | "Parallel" recursive version-reverseBits5LgN :: FiniteBits a => a -> a-reverseBits5LgN x = rec (finiteBitSize x `shiftR` 1) (complement zeroBits) x+reverseBits5LgN :: forall a.+   ( FiniteBits a+   , ShiftableBits a+   , Bitwise a+   , KnownNat (BitSize a)+   ) => a -> a+reverseBits5LgN x = rec (bitSize x `shiftR` 1) (complement zeroBits) x    where-      rec :: FiniteBits a => Int -> a -> a -> a+      rec :: FiniteBits a => Word -> a -> a -> a       rec !s !mask !v          | s <= 0        = v          | otherwise     = rec (s `shiftR` 1) mask' v'@@ -275,10 +314,16 @@ -- | Convert a function working on Word8 to one working on any Word -- -- The number of bits in the Word must be a multiple of 8-liftReverseBits :: (FiniteBits a, Integral a) => (Word8 -> Word8) -> a -> a+liftReverseBits ::+   ( ShiftableBits a+   , Bitwise a+   , FiniteBits a+   , Integral a+   , KnownNat (BitSize a)+   ) => (Word8 -> Word8) -> a -> a liftReverseBits f w = rec zeroBits 0    where-      nb = finiteBitSize w `shiftR` 3 -- div 8+      nb = bitSize w `shiftR` 3 -- div 8       f' = fromIntegral . f . fromIntegral       rec !v !o          | o == nb    = v

@@ -0,0 +1,89 @@+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE FlexibleContexts #-}++-- | Bit rotations+module Haskus.Format.Binary.Bits.Rotate+   ( RotatableBits (..)+   )+where++import Haskus.Format.Binary.Bits.Finite+import Haskus.Format.Binary.Bits.Shift+import Haskus.Format.Binary.Bits.Bitwise+import Haskus.Format.Binary.Word+import Haskus.Utils.Types++-- | Types whose bits can be rotated+class RotatableBits a where++   -- | Rotate left if positive, right if negative+   rotate :: a -> Int -> a+   default rotate ::+      ( FiniteBits a+      , KnownNat (BitSize a)+      ) => a -> Int -> a+   rotate a i+      | i' > 0     = rotateL a (fromIntegral i')+      | i' < 0     = rotateR a (fromIntegral (negate i'))+      | otherwise = a+      where+         i' = i `mod` bitSize a++   -- | Checked left bit rotation+   rotateL :: a -> Word -> a+   default rotateL ::+      ( FiniteBits a+      , KnownNat (BitSize a)+      ) => a -> Word -> a+   rotateL a n = uncheckedRotateL a (n `mod` bitSize a)++   -- | Checked right bit rotation+   rotateR :: a -> Word -> a+   default rotateR ::+      ( FiniteBits a+      , KnownNat (BitSize a)+      ) => a -> Word -> a+   rotateR a n = uncheckedRotateR a (n `mod` bitSize a)++   -- | Unchecked rotate left if positive, right if negative+   uncheckedRotate :: a -> Int -> a+   uncheckedRotate a i+      | i > 0     = uncheckedRotateL a (fromIntegral i)+      | i < 0     = uncheckedRotateR a (fromIntegral (negate i))+      | otherwise = a++   -- | Unchecked left bit rotation+   uncheckedRotateL :: a -> Word -> a+   default uncheckedRotateL ::+      ( ShiftableBits a+      , FiniteBits a+      , KnownNat (BitSize a)+      , Bitwise a+      ) => a -> Word -> a+   uncheckedRotateL a i = (a `uncheckedShiftL` i) .|. (a `uncheckedShiftR` (n-i))+      where n = bitSize a+      ++   -- | Unchecked right bit rotation+   uncheckedRotateR :: a -> Word -> a+   default uncheckedRotateR ::+      ( ShiftableBits a+      , FiniteBits a+      , KnownNat (BitSize a)+      , Bitwise a+      ) => a -> Word -> a+   uncheckedRotateR a i = (a `uncheckedShiftL` (n-i)) .|. (a `uncheckedShiftR` i)+      where n = bitSize a+++instance RotatableBits Word+instance RotatableBits Word8+instance RotatableBits Word16+instance RotatableBits Word32+instance RotatableBits Word64++instance RotatableBits Int+instance RotatableBits Int8+instance RotatableBits Int16+instance RotatableBits Int32+instance RotatableBits Int64

@@ -0,0 +1,311 @@+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE CPP #-}++-- | Bit shifts+module Haskus.Format.Binary.Bits.Shift+   ( ShiftableBits (..)+   , SignedShiftableBits (..)+   )+where++import Haskus.Format.Binary.Word+import GHC.Exts+import GHC.Num++#include "MachDeps.h"++-- | Bit shifts+--+-- "Checked" means that there is an additional test to ensure that the shift+-- offset is valid (less than the bit count). If you are sure that the offset is+-- valid, use the "unchecked" version which should be faster.+--+-- To shift signed numbers, see `SignedShiftableBits` class methods.+class ShiftableBits a where+   -- | Checked right shift+   shiftR :: a -> Word -> a++   -- | Checked left shift+   shiftL :: a -> Word -> a++   -- | Unchecked right shift+   uncheckedShiftR :: a -> Word -> a++   -- | Unchecked left shift+   uncheckedShiftL :: a -> Word -> a++   -- | Checked shift to the left if positive, to the right if negative+   shift :: a -> Int -> a+   shift a i+      | i > 0     = shiftL a (fromIntegral i)+      | i < 0     = shiftR a (fromIntegral (negate i))+      | otherwise = a++   -- | Unchecked shift to the left if positive, to the right if negative+   uncheckedShift :: a -> Int -> a+   uncheckedShift a i+      | i > 0     = uncheckedShiftL a (fromIntegral i)+      | i < 0     = uncheckedShiftR a (fromIntegral (negate i))+      | otherwise = a++-- | Signed bit shifts+--+-- "Signed" means that the sign bit (the higher order bit):+--    - propagates to the right during right shifts and +--    - keeps its value during left shifts (except when all other bits are 0)+--+-- "Checked" means that there is an additional test to ensure that the shift+-- offset is valid (less than the bit count). If you are sure that the offset is+-- valid, use the "unchecked" version which should be faster.+class SignedShiftableBits a where+   -- | Checked signed right shift+   signedShiftR :: a -> Word -> a++   -- | Checked signed left shift+   signedShiftL :: a -> Word -> a++   -- | Unchecked signed right shift+   uncheckedSignedShiftR :: a -> Word -> a++   -- | Unchecked signed left shift+   uncheckedSignedShiftL :: a -> Word -> a++   -- | Checked signed shift to the left if positive, to the right if negative+   signedShift :: a -> Int -> a+   signedShift a i+      | i > 0     = signedShiftL a (fromIntegral i)+      | i < 0     = signedShiftR a (fromIntegral (negate i))+      | otherwise = a++   -- | Unchecked signed shift to the left if positive, to the right if negative+   uncheckedSignedShift :: a -> Int -> a+   uncheckedSignedShift a i+      | i > 0     = uncheckedSignedShiftL a (fromIntegral i)+      | i < 0     = uncheckedSignedShiftR a (fromIntegral (negate i))+      | otherwise = a+++instance ShiftableBits Word where+   {-# INLINE shiftR #-}+   {-# INLINE shiftL #-}+   {-# INLINE uncheckedShiftL #-}+   {-# INLINE uncheckedShiftR #-}++   (W# x#) `shiftL`          (W# i#)+      | isTrue# (i# `geWord#` WORD_SIZE_IN_BITS##) = W# 0##+      | otherwise                                  = W# (x# `uncheckedShiftL#` word2Int# i#)+   (W# x#) `shiftR`          (W# i#)+      | isTrue# (i# `geWord#` WORD_SIZE_IN_BITS##) = W# 0##+      | otherwise                                  = W# (x# `uncheckedShiftRL#` word2Int# i#)+   (W# x#) `uncheckedShiftL` (W# i#) = W# (x# `uncheckedShiftL#` word2Int# i#)+   (W# x#) `uncheckedShiftR` (W# i#) = W# (x# `uncheckedShiftRL#` word2Int# i#)++instance ShiftableBits Word8 where+   {-# INLINE shiftR #-}+   {-# INLINE shiftL #-}+   {-# INLINE uncheckedShiftL #-}+   {-# INLINE uncheckedShiftR #-}++   (W8# x#) `shiftL` (W# i#)+      | isTrue# (i# `geWord#` 8##)    = W8# 0##+      | otherwise                     = W8# (narrow8Word# (x# `uncheckedShiftL#` word2Int# i#))++   (W8# x#) `uncheckedShiftL` (W# i#) = W8# (narrow8Word# (x# `uncheckedShiftL#` word2Int# i#))+   +   (W8# x#) `shiftR` (W# i#)+      | isTrue# (i# `geWord#` 8##)    = W8# 0##+      | otherwise                     = W8# (x# `uncheckedShiftRL#` word2Int# i#)+   +   (W8# x#) `uncheckedShiftR` (W# i#) = W8# (x# `uncheckedShiftRL#` word2Int# i#)++instance ShiftableBits Word16 where+   {-# INLINE shiftR #-}+   {-# INLINE shiftL #-}+   {-# INLINE uncheckedShiftL #-}+   {-# INLINE uncheckedShiftR #-}++   (W16# x#) `shiftL` (W# i#)+      | isTrue# (i# `geWord#` 16##)    = W16# 0##+      | otherwise                      = W16# (narrow16Word# (x# `uncheckedShiftL#` word2Int# i#))++   (W16# x#) `uncheckedShiftL` (W# i#) = W16# (narrow16Word# (x# `uncheckedShiftL#` word2Int# i#))+   +   (W16# x#) `shiftR` (W# i#)+      | isTrue# (i# `geWord#` 16##)    = W16# 0##+      | otherwise                      = W16# (x# `uncheckedShiftRL#` word2Int# i#)+   +   (W16# x#) `uncheckedShiftR` (W# i#) = W16# (x# `uncheckedShiftRL#` word2Int# i#)++instance ShiftableBits Word32 where+   {-# INLINE shiftR #-}+   {-# INLINE shiftL #-}+   {-# INLINE uncheckedShiftL #-}+   {-# INLINE uncheckedShiftR #-}++   (W32# x#) `shiftL` (W# i#)+      | isTrue# (i# `geWord#` 32##)    = W32# 0##+      | otherwise                      = W32# (narrow32Word# (x# `uncheckedShiftL#` word2Int# i#))++   (W32# x#) `uncheckedShiftL` (W# i#) = W32# (narrow32Word# (x# `uncheckedShiftL#` word2Int# i#))+   +   (W32# x#) `shiftR` (W# i#)+      | isTrue# (i# `geWord#` 32##)    = W32# 0##+      | otherwise                      = W32# (x# `uncheckedShiftRL#` word2Int# i#)+   +   (W32# x#) `uncheckedShiftR` (W# i#) = W32# (x# `uncheckedShiftRL#` word2Int# i#)++instance ShiftableBits Word64 where+   {-# INLINE shiftR #-}+   {-# INLINE shiftL #-}+   {-# INLINE uncheckedShiftL #-}+   {-# INLINE uncheckedShiftR #-}++   (W64# x#) `shiftL` (W# i#)+      | isTrue# (i# `geWord#` 64##)    = W64# 0##+      | otherwise                      = W64# (x# `uncheckedShiftL#` word2Int# i#)++   (W64# x#) `uncheckedShiftL` (W# i#) = W64# (x# `uncheckedShiftL#` word2Int# i#)+   +   (W64# x#) `shiftR` (W# i#)+      | isTrue# (i# `geWord#` 64##)    = W64# 0##+      | otherwise                      = W64# (x# `uncheckedShiftRL#` word2Int# i#)+   +   (W64# x#) `uncheckedShiftR` (W# i#) = W64# (x# `uncheckedShiftRL#` word2Int# i#)+++instance ShiftableBits Int where+   {-# INLINE shiftR #-}+   {-# INLINE shiftL #-}+   {-# INLINE uncheckedShiftL #-}+   {-# INLINE uncheckedShiftR #-}++   (I# x#) `shiftL`          (W# i#)+      | isTrue# (i# `geWord#` WORD_SIZE_IN_BITS##) = I# 0#+      | otherwise                                  = I# (x# `uncheckedIShiftL#` word2Int# i#)++   (I# x#) `uncheckedShiftL` (W# i#)               = I# (x# `uncheckedIShiftL#` word2Int# i#)+   +   (I# x#) `shiftR`          (W# i#)+      | isTrue# (i# `geWord#` WORD_SIZE_IN_BITS##) = I# 0#+      | otherwise                                  = I# (x# `uncheckedIShiftRL#` word2Int# i#)+   +   (I# x#) `uncheckedShiftR` (W# i#)               = I# (x# `uncheckedIShiftRL#` word2Int# i#)++instance ShiftableBits Int8 where+   {-# INLINE shiftR #-}+   {-# INLINE shiftL #-}+   {-# INLINE uncheckedShiftL #-}+   {-# INLINE uncheckedShiftR #-}++   (I8# x#) `shiftL`          (W# i#)+      | isTrue# (i# `geWord#` 8##)    = I8# 0#+      | otherwise                     = I8# (narrow8Int# (x# `uncheckedIShiftL#` word2Int# i#))++   (I8# x#) `uncheckedShiftL` (W# i#) = I8# (narrow8Int# (x# `uncheckedIShiftL#` word2Int# i#))+   +   (I8# x#) `shiftR`          (W# i#)+      | isTrue# (i# `geWord#` 8##)    = I8# 0#+      | otherwise                     = I8# (word2Int# (narrow8Word# (int2Word# x#) `uncheckedShiftRL#` word2Int# i#))++   (I8# x#) `uncheckedShiftR` (W# i#) = I8# (word2Int# (narrow8Word# (int2Word# x#) `uncheckedShiftRL#` word2Int# i#))+   ++instance ShiftableBits Int16 where+   {-# INLINE shiftR #-}+   {-# INLINE shiftL #-}+   {-# INLINE uncheckedShiftL #-}+   {-# INLINE uncheckedShiftR #-}++   (I16# x#) `shiftL`          (W# i#)+      | isTrue# (i# `geWord#` 16##)    = I16# 0#+      | otherwise                      = I16# (narrow16Int# (x# `uncheckedIShiftL#` word2Int# i#))++   (I16# x#) `uncheckedShiftL` (W# i#) = I16# (narrow16Int# (x# `uncheckedIShiftL#` word2Int# i#))+   +   (I16# x#) `shiftR`          (W# i#)+      | isTrue# (i# `geWord#` 16##)    = I16# 0#+      | otherwise                      = I16# (word2Int# (narrow16Word# (int2Word# x#) `uncheckedShiftRL#` word2Int# i#))++   (I16# x#) `uncheckedShiftR` (W# i#) = I16# (word2Int# (narrow16Word# (int2Word# x#) `uncheckedShiftRL#` word2Int# i#))+++instance ShiftableBits Int32 where+   {-# INLINE shiftR #-}+   {-# INLINE shiftL #-}+   {-# INLINE uncheckedShiftL #-}+   {-# INLINE uncheckedShiftR #-}++   (I32# x#) `shiftL`          (W# i#)+      | isTrue# (i# `geWord#` 32##)    = I32# 0#+      | otherwise                      = I32# (narrow32Int# (x# `uncheckedIShiftL#` word2Int# i#))++   (I32# x#) `uncheckedShiftL` (W# i#) = I32# (narrow32Int# (x# `uncheckedIShiftL#` word2Int# i#))+   +   (I32# x#) `shiftR`          (W# i#)+      | isTrue# (i# `geWord#` 32##)    = I32# 0#+      | otherwise                      = I32# (word2Int# (narrow32Word# (int2Word# x#) `uncheckedShiftRL#` word2Int# i#))++   (I32# x#) `uncheckedShiftR` (W# i#) = I32# (word2Int# (narrow32Word# (int2Word# x#) `uncheckedShiftRL#` word2Int# i#))++instance ShiftableBits Int64 where+   {-# INLINE shiftR #-}+   {-# INLINE shiftL #-}+   {-# INLINE uncheckedShiftL #-}+   {-# INLINE uncheckedShiftR #-}++   (I64# x#) `shiftL`          (W# i#)+      | isTrue# (i# `geWord#` 64##)    = I64# 0#+      | otherwise                      = I64# (x# `uncheckedIShiftL#` word2Int# i#)++   (I64# x#) `uncheckedShiftL` (W# i#) = I64# (x# `uncheckedIShiftL#` word2Int# i#)+   +   (I64# x#) `shiftR`          (W# i#)+      | isTrue# (i# `geWord#` 64##)    = I64# 0#+      | otherwise                      = I64# (word2Int# (int2Word# x# `uncheckedShiftRL#` word2Int# i#))++   (I64# x#) `uncheckedShiftR` (W# i#) = I64# (word2Int# (int2Word# x# `uncheckedShiftRL#` word2Int# i#))+++instance SignedShiftableBits Int where+   (I# x#) `signedShiftL`          (W# i#) = I# (x# `iShiftL#` word2Int# i#)+   (I# x#) `signedShiftR`          (W# i#) = I# (x# `iShiftRA#` word2Int# i#)+   (I# x#) `uncheckedSignedShiftL` (W# i#) = I# (x# `uncheckedIShiftL#` word2Int# i#)+   (I# x#) `uncheckedSignedShiftR` (W# i#) = I# (x# `uncheckedIShiftRA#` word2Int# i#)++instance SignedShiftableBits Int8 where+   (I8# x#) `signedShiftL`          (W# i#) = I8# (narrow8Int# (x# `iShiftL#` word2Int# i#))+   (I8# x#) `signedShiftR`          (W# i#) = I8# (x# `iShiftRA#` word2Int# i#)+   (I8# x#) `uncheckedSignedShiftL` (W# i#) = I8# (narrow8Int# (x# `uncheckedIShiftL#` word2Int# i#))+   (I8# x#) `uncheckedSignedShiftR` (W# i#) = I8# (x# `uncheckedIShiftRA#` word2Int# i#)++instance SignedShiftableBits Int16 where+   (I16# x#) `signedShiftL`          (W# i#) = I16# (narrow16Int# (x# `iShiftL#` word2Int# i#))+   (I16# x#) `signedShiftR`          (W# i#) = I16# (x# `iShiftRA#` word2Int# i#)+   (I16# x#) `uncheckedSignedShiftL` (W# i#) = I16# (narrow16Int# (x# `uncheckedIShiftL#` word2Int# i#))+   (I16# x#) `uncheckedSignedShiftR` (W# i#) = I16# (x# `uncheckedIShiftRA#` word2Int# i#)++instance SignedShiftableBits Int32 where+   (I32# x#) `signedShiftL`          (W# i#) = I32# (narrow32Int# (x# `iShiftL#` word2Int# i#))+   (I32# x#) `signedShiftR`          (W# i#) = I32# (x# `iShiftRA#` word2Int# i#)+   (I32# x#) `uncheckedSignedShiftL` (W# i#) = I32# (narrow32Int# (x# `uncheckedIShiftL#` word2Int# i#))+   (I32# x#) `uncheckedSignedShiftR` (W# i#) = I32# (x# `uncheckedIShiftRA#` word2Int# i#)++instance SignedShiftableBits Int64 where+   (I64# x#) `signedShiftL`          (W# i#) = I64# (x# `iShiftL#` word2Int# i#)+   (I64# x#) `signedShiftR`          (W# i#) = I64# (x# `iShiftRA#` word2Int# i#)+   (I64# x#) `uncheckedSignedShiftL` (W# i#) = I64# (x# `uncheckedIShiftL#` word2Int# i#)+   (I64# x#) `uncheckedSignedShiftR` (W# i#) = I64# (x# `uncheckedIShiftRA#` word2Int# i#)++++instance ShiftableBits Integer where+   {-# INLINE shiftR #-}+   {-# INLINE shiftL #-}+   {-# INLINE uncheckedShiftL #-}+   {-# INLINE uncheckedShiftR #-}++   x `shiftL` (W# i#) = shiftLInteger x (word2Int# i#)+   x `shiftR` (W# i#) = shiftRInteger x (word2Int# i#)++   uncheckedShiftL = shiftL+   uncheckedShiftR = shiftR

@@ -70,9 +70,11 @@ import Haskus.Format.Binary.Ptr import Haskus.Format.Binary.Word import Haskus.Format.Binary.Storable-import Haskus.Format.Binary.Bits.Basic+import Haskus.Format.Binary.Bits.Bitwise+import Haskus.Format.Binary.Bits.Index+import Haskus.Format.Binary.Bits.Shift import Haskus.Utils.Memory (memCopy,memSet)-import Haskus.Utils.List (foldl')+import Haskus.Utils.List as List import Haskus.Utils.Flow  -- | A buffer@@ -90,34 +92,28 @@          toHex 0xF = "F"          toHex x   = show x -instance Bits Buffer where+instance Bitwise Buffer where    (.&.)      = bufferZipWith (.&.)    (.|.)      = bufferZipWith (.|.)    xor        = bufferZipWith xor    complement = bufferMap complement-   shift b n-      | n == 0     = b-      | abs n <= 8 = bufferMap (`shift` n) b-      | otherwise  = if q > 0-            then bufferAppend zs b'-            else bufferAppend b' zs-         where-            (q,r) = n `quotRem` 8-            zs = bufferZero (fromIntegral (abs q))-            b' = bufferMap (`shift` r) b -   rotate     = shift-   zeroBits   = emptyBuffer-   isSigned _ = False-   bitSize _  = undefined-   bitSizeMaybe _ = Nothing-   testBit b n = testBit p r+instance IndexableBits Buffer where+   bit i = bufferPackByteList +         (bit r : List.replicate (fromIntegral n) 0)       where-         p     = bufferIndex b (bufferSize b - fromIntegral q)-         (q,r) = n `quotRem` 8+         n = i `uncheckedShiftR` 3+         r = i .&. 0x07+   +   testBit b i = testBit p r+      where+         p = bufferIndex b (bufferSize b - n)+         n = i `uncheckedShiftR` 3+         r = i .&. 0x07 -   bit _       = undefined-   popCount b  = foldl' (+) 0 (fmap popCount (bufferUnpackByteList b))+   popCount b  = sum (fmap popCount (bufferUnpackByteList b))++  -- | Duplicate a buffer bufferDup :: Buffer -> IO Buffer

@@ -19,9 +19,9 @@ import qualified Haskus.Format.Binary.BufferList as BL  -- | Buffer builder-newtype BufferBuilder = BufferBuilder B.Builder--deriving instance Monoid BufferBuilder+newtype BufferBuilder+   = BufferBuilder B.Builder+   deriving (Semigroup,Monoid)  -- | Empty buffer builder emptyBufferBuilder :: BufferBuilder

@@ -0,0 +1,15 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++-- | Character+module Haskus.Format.Binary.Char+   ( Char8 (..)+   )+where++import Haskus.Format.Binary.Word+import Haskus.Format.Binary.Storable++-- | 8-bit character (ASCII, etc.)+newtype Char8+   = Char8 Word8+   deriving (Show,Eq,Ord,Storable)

@@ -2,6 +2,7 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE FlexibleContexts #-}  -- | Byte order ("endianness") --@@ -31,9 +32,9 @@ import Haskus.Format.Binary.Put import Haskus.Format.Binary.Enum import Haskus.Format.Binary.Ptr-import Haskus.Format.Binary.Bits ((.|.), shiftL) import Haskus.Format.Binary.Storable import Haskus.Format.Binary.Word+import Haskus.Format.Binary.Bits  import System.IO.Unsafe @@ -49,7 +50,7 @@ data WordGetters = WordGetters    { wordGetter8  :: Get Word8   -- ^ Read a Word8    , wordGetter16 :: Get Word16  -- ^ Read a Word16-   , wordGetter32 :: Get Word32  -- ^ Read a Word132+   , wordGetter32 :: Get Word32  -- ^ Read a Word32    , wordGetter64 :: Get Word64  -- ^ Read a Word64    } @@ -57,7 +58,7 @@ data WordPutters = WordPutters    { wordPutter8  :: Word8  -> Put -- ^ Write a Word8    , wordPutter16 :: Word16 -> Put -- ^ Write a Word16-   , wordPutter32 :: Word32 -> Put -- ^ Write a Word132+   , wordPutter32 :: Word32 -> Put -- ^ Write a Word32    , wordPutter64 :: Word64 -> Put -- ^ Write a Word64    } @@ -85,7 +86,7 @@ data ExtendedWordGetters = ExtendedWordGetters    { extwordGetter8  :: Get Word8   -- ^ Read a Word8    , extwordGetter16 :: Get Word16  -- ^ Read a Word16-   , extwordGetter32 :: Get Word32  -- ^ Read a Word132+   , extwordGetter32 :: Get Word32  -- ^ Read a Word32    , extwordGetter64 :: Get Word64  -- ^ Read a Word64    , extwordGetterN  :: Get Word64  -- ^ Read a native size word into a Word64    }@@ -94,7 +95,7 @@ data ExtendedWordPutters = ExtendedWordPutters    { extwordPutter8  :: Word8  -> Put -- ^ Write a Word8    , extwordPutter16 :: Word16 -> Put -- ^ Write a Word16-   , extwordPutter32 :: Word32 -> Put -- ^ Write a Word132+   , extwordPutter32 :: Word32 -> Put -- ^ Write a Word32    , extwordPutter64 :: Word64 -> Put -- ^ Write a Word64    , extwordPutterN  :: Word64 -> Put -- ^ Write a Word64 into a native size word    }@@ -122,14 +123,17 @@ -- | Detect the endianness of the host memory getHostEndianness :: IO Endianness getHostEndianness = do-   -- Write a 32 bit Int and check byte ordering-   let magic = 1 .|. shiftL 8 2 .|. shiftL 16 3 .|. shiftL 24 4 :: Word32+   -- Write a 32 bit word and check byte ordering+   let magic = 0x01020304 :: Word32    alloca $ \p -> do       poke p magic       rs <- peekArray 4 (castPtr p :: Ptr Word8)+      print (show rs)       return $ if rs == [1,2,3,4] then BigEndian else LittleEndian  -- | Detected host endianness+--+-- TODO: use targetByteOrder in GHC.ByteOrder (should be introduced in GHC 8.4) hostEndianness :: Endianness {-# NOINLINE hostEndianness #-} hostEndianness = unsafePerformIO getHostEndianness@@ -174,13 +178,17 @@   -- | Force a data to be read/stored as big-endian-newtype AsBigEndian a    = AsBigEndian a    deriving (Eq,Ord,Enum,Num,Integral,Real)+newtype AsBigEndian a+   = AsBigEndian a+   deriving (Eq,Ord,Enum,Num,Integral,Real,Bitwise,FiniteBits,ReversableBits,RotatableBits,ShiftableBits,IndexableBits)  instance Show a => Show (AsBigEndian a) where    show (AsBigEndian a) = show a  -- | Force a data to be read/stored as little-endian-newtype AsLittleEndian a = AsLittleEndian a deriving (Eq,Ord,Enum,Num,Integral,Real)+newtype AsLittleEndian a+   = AsLittleEndian a+   deriving (Eq,Ord,Enum,Num,Integral,Real,Bitwise,FiniteBits,ReversableBits,RotatableBits,ShiftableBits,IndexableBits)  instance Show a => Show (AsLittleEndian a) where    show (AsLittleEndian a) = show a

@@ -2,6 +2,7 @@ {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeApplications #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}  -- | Store an Enum in the given backing word type module Haskus.Format.Binary.Enum@@ -24,19 +25,10 @@ -- EnumField b a: directly store the value of enum "a" as a "b" ----------------------------------------------------------------------------- --- | Store enum 'a' as a 'b'-newtype EnumField b a = EnumField a deriving (Show,Eq)--instance-      ( Storable b-      , Integral b-      , CEnum a-      ) => Storable (EnumField b a)-   where-      sizeOf _               = sizeOfT    @b-      alignment _            = alignmentT @b-      peekIO p               = (EnumField . toCEnum) <$> peek (castPtr p :: Ptr b)-      pokeIO p (EnumField v) = poke (castPtr p :: Ptr b) (fromCEnum v)+-- | Store enum `a` as a `b`+newtype EnumField b a+   = EnumField b+   deriving (Show,Eq,Storable)  instance       ( Integral b@@ -46,26 +38,28 @@    where       type SizeOf (EnumField b a)    = SizeOf b       type Alignment (EnumField b a) = Alignment b-      staticPeekIO p                 = (EnumField . toCEnum) <$> staticPeek (castPtr p :: Ptr b)-      staticPokeIO p (EnumField v)   = staticPoke (castPtr p :: Ptr b) (fromCEnum v)+      staticPeekIO p                 = EnumField  <$> staticPeek (castPtr p :: Ptr b)+      staticPokeIO p (EnumField v)   = staticPoke (castPtr p :: Ptr b) v  -- | Read an enum field-fromEnumField :: EnumField b a -> a+fromEnumField :: (CEnum a, Integral b) => EnumField b a -> a {-# INLINE fromEnumField #-}-fromEnumField (EnumField a) = a+fromEnumField (EnumField b) = toCEnum b  -- | Create an enum field-toEnumField :: a -> EnumField b a+toEnumField :: (CEnum a, Integral b) => a -> EnumField b a {-# INLINE toEnumField #-}-toEnumField = EnumField+toEnumField = EnumField . fromCEnum   ----------------------------------------------------------------------------- -- Extended Enum ----------------------------------------------------------------------------- --- | By default, use fromEnum/toEnum to convert from/to an Integral.+-- | Extended Enum --+-- By default, use fromEnum and toEnum to convert from and to an Integral.+-- -- But it can be overloaded to perform transformation before using -- fromEnum/toEnum. E.g. if values are shifted by 1 compared to Enum values, -- define fromCEnum = (+1) . fromIntegral . fromEnum@@ -82,13 +76,17 @@ -- | Make an enum with the last constructor taking a parameter for the rest of -- the range ----- E.g., data T = A | B | C | D Word8+-- @+-- data T = A | B | C | D Word8+-- -- makeEnumWithCustom :: Int -> T -- makeEnumWithCustom x = case x of --    0 -> A --    1 -> B --    2 -> C --    n -> D (n - 3)+-- @+-- makeEnumWithCustom :: forall a i. (Data a,Integral i) => i -> a {-# INLINE makeEnumWithCustom #-} makeEnumWithCustom x =@@ -104,13 +102,17 @@ -- | Make an enum with the last constructor taking a parameter for the rest of -- the range, but don't build the last constructor ----- E.g., data T = A | B | C | D Word8+-- @+-- data T = A | B | C | D Word8+-- -- makeEnumMaybe :: Int -> T -- makeEnumMaybe x = case x of --    0 -> Just A --    1 -> Just B --    2 -> Just C --    n -> Nothing+-- @+-- makeEnumMaybe :: forall a i. (Data a,Integral i) => i -> Maybe a {-# INLINE makeEnumMaybe #-} makeEnumMaybe x =

@@ -19,14 +19,13 @@  import Haskus.Format.Binary.BitField import Haskus.Format.Binary.Bits-import Haskus.Format.Binary.Word import Haskus.Format.Binary.Storable import Haskus.Utils.Types  -- | Fixed-point number--- `w` is the backing type--- `i` is the number of bits for the integer part (before the readix point)--- `f` is the number of bits for the fractional part (after the radix point)+-- * `w` is the backing type+-- * `i` is the number of bits for the integer part (before the radix point)+-- * `f` is the number of bits for the fractional part (after the radix point) newtype FixedPoint w (i :: Nat) (f :: Nat) = FixedPoint (BitFields w    '[ BitField i "integer"    w     , BitField f "fractional" w

@@ -0,0 +1,423 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE AllowAmbiguousTypes #-}++-- | Posit (type III unum)+module Haskus.Format.Binary.Posit+   ( Posit (..)+   , PositKind (..)+   , PositK (..)+   , positKind+   , isZero+   , isInfinity+   , isPositive+   , isNegative+   , positAbs+   , PositEncoding (..)+   , PositFields (..)+   , positEncoding+   , positFields+   , positToRational+   , positFromRational+   , positApproxFactor+   , positDecimalError+   , positDecimalAccuracy+   , positBinaryError+   , positBinaryAccuracy+   , floatBinaryAccuracy+   )+where++import Haskus.Format.Binary.Word+import Haskus.Format.Binary.Bits+import Haskus.Utils.Types+import Haskus.Utils.Tuple+import Haskus.Utils.Flow++import Data.Ratio+import qualified GHC.Real as Ratio++newtype Posit (nbits :: Nat) (es :: Nat) = Posit (IntN nbits)++-- | Show posit+instance+   ( Bits (IntN n)+   , FiniteBits (IntN n)+   , Ord (IntN n)+   , Num (IntN n)+   , KnownNat n+   , KnownNat es+   , Integral (IntN n)+   ) => Show (Posit n es)+   where+   show p = case positKind p of+      SomePosit Zero      -> "0"+      SomePosit Infinity  -> "Infinity"+      SomePosit (Value v) -> show (positToRational v)++data PositKind+   = ZeroK+   | InfinityK+   | NormalK+   deriving (Show,Eq)++-- | Kinded Posit+--+-- GADT that can be used to ensure at the type level that we deal with+-- non-infinite/non-zero Posit values+data PositK k nbits es where+   Zero     :: PositK 'ZeroK nbits es+   Infinity :: PositK 'InfinityK nbits es+   Value    :: Posit nbits es -> PositK 'NormalK nbits es++data SomePosit n es where+   SomePosit :: PositK k n es -> SomePosit n es++type PositValue n es = PositK 'NormalK n es++-- | Get the kind of the posit at the type level+positKind :: forall n es.+   ( Bits (IntN n)+   , KnownNat n+   , Eq (IntN n)+   ) => Posit n es -> SomePosit n es+positKind p+   | isZero p     = SomePosit Zero+   | isInfinity p = SomePosit Infinity+   | otherwise    = SomePosit (Value p)++-- | Check if a posit is zero+isZero :: forall n es.+   ( Bits (IntN n)+   , Eq (IntN n)+   , KnownNat n+   ) => Posit n es -> Bool+{-# INLINE isZero #-}+isZero (Posit i) = i == zeroBits++-- | Check if a posit is infinity+isInfinity :: forall n es.+   ( Bits (IntN n)+   , Eq (IntN n)+   , KnownNat n+   ) => Posit n es -> Bool+{-# INLINE isInfinity #-}+isInfinity (Posit i) = i == bit (natValue @n - 1)++-- | Check if a posit is positive+isPositive :: forall n es.+   ( Bits (IntN n)+   , Ord (IntN n)+   , KnownNat n+   ) => PositValue n es -> Bool+{-# INLINE isPositive #-}+isPositive (Value (Posit i)) = i > zeroBits++-- | Check if a posit is negative+isNegative :: forall n es.+   ( Bits (IntN n)+   , Ord (IntN n)+   , KnownNat n+   ) => PositValue n es -> Bool+{-# INLINE isNegative #-}+isNegative (Value (Posit i)) = i < zeroBits++-- | Posit absolute value+positAbs :: forall n es.+   ( Num (IntN n)+   , KnownNat n+   ) => PositValue n es -> PositValue n es+positAbs (Value (Posit i)) = Value (Posit (abs i))+++data PositFields = PositFields+   { positNegative         :: Bool+   , positRegimeBitCount   :: Word+   , positExponentBitCount :: Word+   , positFractionBitCount :: Word+   , positRegime           :: Int+   , positExponent         :: Word+   , positFraction         :: Word+   }+   deriving (Show)++data PositEncoding+   = PositInfinity+   | PositZero+   | PositEncoding PositFields+   deriving (Show)++positEncoding :: forall n es.+   ( Bits (IntN n)+   , Ord (IntN n)+   , Num (IntN n)+   , KnownNat n+   , KnownNat es+   , Integral (IntN n)+   ) => Posit n es -> PositEncoding+positEncoding p = case positKind p of+   SomePosit Zero        -> PositZero+   SomePosit Infinity    -> PositInfinity+   SomePosit v@(Value _) -> PositEncoding (positFields v)++-- | Decode posit fields+positFields :: forall n es.+   ( Bits (IntN n)+   , Ord (IntN n)+   , Num (IntN n)+   , KnownNat n+   , KnownNat es+   , Integral (IntN n)+   ) => PositValue n es -> PositFields+positFields p = PositFields+      { positNegative         = isNegative p+      , positRegimeBitCount   = rs+      , positExponentBitCount = es+      , positFractionBitCount = fs+      , positRegime           = regime+      , positExponent         = expo+      , positFraction         = frac+      }+   where+      -- get absolute value+      Value (Posit v) = positAbs p++      (negativeRegime,regimeLen) = +         if v `testBit` (natValue @n - 2)+            -- regime has shape 111...[0|end of word], subtract 1 for sign bit+            then (False, countLeadingZeros (complement v `clearBit` (natValue @n - 1)) - 1)+            -- regime has shape 00000...[1|end of word], subtract 1 for sign bit+            else (True, countLeadingZeros v - 1)++      regime = if negativeRegime+         then negate (fromIntegral regimeLen)+         else fromIntegral regimeLen - 1 -- we encode the 0 regime++      -- length of regime bits (with stop bit)+      rs = min (natValue @n - 1) (regimeLen + 1)++      -- real exponent size (regime bits can reduce the size of the exponent)+      es = min (natValue @n - rs - 1) (natValue @es)++      -- fraction size+      fs = natValue @n - es - rs - 1++      expo = fromIntegral (maskLeastBits es (v `shiftR` fs))+      frac = fromIntegral (maskLeastBits fs v)+++-- | Convert a Posit into a Rational+positToRational :: forall n es.+   ( KnownNat n+   , KnownNat es+   , Eq (IntN n)+   , Bits (IntN n)+   , Integral (IntN n)+   ) => Posit n es -> Rational+positToRational p+   | isZero p     = 0 Ratio.:% 1+   | isInfinity p = Ratio.infinity+   | otherwise    = (fromIntegral useed ^^ r) * (2 ^^ e) * (1 + (f % fd))+      where+         fields = positFields (Value p)+         r      = positRegime fields+         e      = positExponent fields+         f      = fromIntegral (positFraction fields)+         fd     = 1 `shiftL` positFractionBitCount fields+         useed  = 1 `shiftL` (1 `shiftL` natValue @es) :: Integer -- 2^(2^es)++-- | Convert a rational into the approximate Posit+positFromRational :: forall p n es.+   ( Posit n es ~ p+   , Num (IntN n)+   , Bits (IntN n)+   , KnownNat es+   , KnownNat n+   ) => Rational -> Posit n es+positFromRational x = if+      | x == 0              -> Posit 0+      | x == Ratio.infinity -> Posit (bit (natValue @n - 1))+      | otherwise           -> computeRegime+                              |> uncurry3 computeExponent+                              |> uncurry3 computeFraction+                              |> uncurry  computeRounding+                              |> computeSign+                              |> Posit+   where+      useed = fromIntegral (1 `shiftL` (1 `shiftL` es) :: Integer) -- 2^(2^es)++      nbits = natValue @n+      es    = natValue @es++      -- compute regime bits of the posit, return (y,p,i)+      --    y: remaining value to convert, in [1,useed) if there are enough available bits+      --    p: current posit bits+      --    i: number of set bits in p+      computeRegime+         | absx >= 1 = regime111 absx 1 2+         | otherwise = regime000 absx 1+         where+            absx = abs x++            -- push regime bits 111..1110+            regime111 y p i+               | y >= useed && i < nbits = regime111 (y / useed) ((p `uncheckedShiftL` 1) .|. 1) (i+1)+               | otherwise               = (y, p `uncheckedShiftL` 1, i+1)++            -- push regime bits 000..0001 (or 000...00010 if the full word+            -- (including the sign bit) is set)+            regime000 y i+               | y < 1 && i <= nbits = regime000 (y*useed) (i+1)+               | i >= nbits          = (y,2,nbits+1)+               | otherwise           = (y,1,i+1)++      -- compute exponent bits; return (y,p,i)+      --    y: remaining value to convert, in [1,2) if there are enough available bits+      --    p: current posit bits+      --    i: number of set bits in p+      computeExponent+            | es == 0   = (,,)+            | otherwise = go (1 `shiftL` (es - 1))+         where+            go e y p i+               | i > nbits || e == 0 = (y,p,i)+               | y >= pow2e          = go (e `uncheckedShiftR` 1) (y / pow2e) ((p `uncheckedShiftL` 1) .|. 1) (i+1)+               | otherwise           = go (e `uncheckedShiftR` 1) y            (p `uncheckedShiftL` 1)        (i+1)+               where+                  pow2e = fromIntegral (1 `shiftL` e :: Integer)++      -- compute fraction bits; return (y,p)+      --    y: remaining value to convert+      --    p: current posit bits+      computeFraction y' = go (y'-1) -- subtract hidden bit. Now y is in [0,1) if there are enough available bits+         where+            go y p i+               | i > nbits = (y,p)+               | y <= 0    = (y, p `shiftL` (nbits+1-i)) -- add remaining 0s fraction bits+               | y2 > 1    = go (y2-1) (p `shiftL` 1 + 1) (i+1)+               | otherwise = go y2     (p `shiftL` 1)     (i+1)+               where+                  y2 = 2*y++      -- at this stage, p contains an additional fraction bit.+      -- We remove it and we round accordingly.+      computeRounding y p =+         let p' = p `uncheckedShiftR` 1+         in if | not (p `testBit` 0) -> p'                                     -- closer to lower value+               | y == 1 || y == 0    -> p' + (if p' `testBit` 0 then 1 else 0) -- tie goes to nearest even+               | otherwise           -> p' + 1                                 -- closer to upper value+++      -- fixup the sign bit (and use 2's complement for the other bits)+      computeSign p+         | x < 0     = negate p+         | otherwise = p+++-- | Factor of approximation for a given Rational when encoded as a Posit.+-- The closer to 1, the better.+--+-- Usage:+--+--    positApproxFactor @(Posit 8 2) (52 % 137)+--+positApproxFactor :: forall p n es.+   ( Posit n es ~ p+   , Num (IntN n)+   , Bits (IntN n)+   , Integral (IntN n)+   , KnownNat es+   , KnownNat n+   ) => Rational -> Double+positApproxFactor r = fromRational ((positToRational (positFromRational r ::  p)) / r)++-- | Compute the decimal error if the given Rational is encoded as a Posit.+--+-- Usage:+--+--    positDecimalError @(Posit 8 2) (52 % 137)+--+positDecimalError :: forall p n es.+   ( Posit n es ~ p+   , Num (IntN n)+   , Bits (IntN n)+   , Integral (IntN n)+   , KnownNat es+   , KnownNat n+   ) => Rational -> Double+positDecimalError r = abs (logBase 10 (positApproxFactor @p r))++-- | Compute the number of decimals of accuracy if the given Rational is encoded+-- as a Posit.+--+-- Usage:+--+--    positDecimalAccuracy @(Posit 8 2) (52 % 137)+--+positDecimalAccuracy :: forall p n es.+   ( Posit n es ~ p+   , Num (IntN n)+   , Bits (IntN n)+   , Integral (IntN n)+   , KnownNat es+   , KnownNat n+   ) => Rational -> Double+positDecimalAccuracy r = -1 * logBase 10 (positDecimalError @p r)+++-- | Compute the binary error if the given Rational is encoded as a Posit.+--+-- Usage:+--+--    positBinaryError @(Posit 8 2) (52 % 137)+--+positBinaryError :: forall p n es.+   ( Posit n es ~ p+   , Num (IntN n)+   , Bits (IntN n)+   , Integral (IntN n)+   , KnownNat es+   , KnownNat n+   ) => Rational -> Double+positBinaryError r = abs (logBase 2 (positApproxFactor @p r))++-- | Compute the number of bits of accuracy if the given Rational is encoded+-- as a Posit.+--+-- Usage:+--+--    positBinaryAccuracy @(Posit 8 2) (52 % 137)+--+positBinaryAccuracy :: forall p n es.+   ( Posit n es ~ p+   , Num (IntN n)+   , Bits (IntN n)+   , Integral (IntN n)+   , KnownNat es+   , KnownNat n+   ) => Rational -> Double+positBinaryAccuracy r = -1 * logBase 2 (positBinaryError @p r)+++-- | Compute the number of bits of accuracy if the given Rational is encoded+-- as a Float/Double.+--+-- Usage:+--+--    floatBinaryAccuracy @Double (52 % 137)+--+floatBinaryAccuracy :: forall f.+   ( Fractional f+   , Real f+   ) => Rational -> Double+floatBinaryAccuracy r = -1 * logBase 2 floatError+   where+      floatApprox = fromRational (toRational (fromRational r :: f) / r)+      floatError  = abs (logBase 2 floatApprox)

@@ -81,7 +81,7 @@    RecordAlignment '[]                    a = a    RecordAlignment (Field name typ ': fs) a =       RecordAlignment fs-         (IfNat (a <=? Alignment typ) (Alignment typ) a)+         (If (a <=? Alignment typ) (Alignment typ) a)  -- | Return offset from a field path type family FieldPathOffset (fs :: [*]) (path :: [Symbol]) (off :: Nat) where

@@ -13,7 +13,7 @@ -- -- Unions are storable and can contain any storable data. -- --- Use 'fromUnion' to read a alternative:+-- Use 'fromUnion' to read an alternative: -- -- @ -- {-# LANGUAGE DataKinds #-}@@ -34,12 +34,13 @@ -- @ -- -- Use 'toUnion' to create a new union:--- @ --+-- @ -- let --    u2 :: Union '[Word32, Vector 4 Word8] --    u2 = toUnion (0x12345678 :: Word32) -- @+-- module Haskus.Format.Binary.Union    ( Union    , fromUnion

@@ -231,10 +231,10 @@    show (U w) = unumLabels @u !! fromIntegral w  unumBits :: forall u.-   ( FiniteBits (BackingWord u)+   ( Bits (BackingWord u)    , KnownNat (UnumSize u)    ) => U u -> String-unumBits (U w) = drop (finiteBitSize w - fromIntegral (unumSize @u)) (bitsToString w)+unumBits (U w) = drop (fromIntegral (bitSize w - unumSize @u)) (bitsToString w)  type Encodable x u =    ( KnownNat (IndexOf (Simplify x) (UnumIndexables u)))@@ -263,7 +263,7 @@  -- | Negate a number unumNegate :: forall u.-   ( FiniteBits (BackingWord u)+   ( Bits (BackingWord u)    , Num (BackingWord u)    , KnownNat (UnumSize u)    ) => U u -> U u@@ -275,7 +275,7 @@  -- | Reciprocate a number unumReciprocate :: forall u.-   ( FiniteBits (BackingWord u)+   ( Bits (BackingWord u)    , Num (BackingWord u)    , KnownNat (UnumSize u)    ) => U u -> U u@@ -344,12 +344,12 @@  -- | Show SORN bits sornBits :: forall u s.-   ( FiniteBits (SORNBackingWord u)+   ( Bits (SORNBackingWord u)    , KnownNat (UnumSize u)    , s ~ SORNSize u    , KnownNat s    ) => SORN u -> String-sornBits (SORN w) = drop (finiteBitSize w - natValue @s) (bitsToString w)+sornBits (SORN w) = drop (bitSize w - natValue @s) (bitsToString w)   @@ -366,7 +366,7 @@  -- | Full SORN sornFull :: forall u.-   ( FiniteBits (SORNBackingWord u)+   ( Bits (SORNBackingWord u)    , KnownNat (SORNSize u)    ) => SORN u sornFull = SORN (maskLeastBits s (complement zeroBits))@@ -441,8 +441,8 @@  -- | Negate a SORN sornNegate :: forall u.-   ( FiniteBits (SORNBackingWord u)-   , FiniteBits (BackingWord u)+   ( Bits (SORNBackingWord u)+   , Bits (BackingWord u)    , Integral (BackingWord u)    , KnownNat (SORNSize u)    , KnownNat (UnumSize u)@@ -475,7 +475,7 @@ sornFromTo :: forall u.    ( Integral (BackingWord u)    , Bits (SORNBackingWord u)-   , FiniteBits (BackingWord u)+   , Bits (BackingWord u)    , KnownNat (UnumSize u)    ) => U u -> U u -> SORN u sornFromTo (U a) (U b) = go sornEmpty a@@ -516,7 +516,7 @@     -- | Subtract two Unums    sornSubU :: -      ( FiniteBits (BackingWord u)+      ( Bits (BackingWord u)       , Num (BackingWord u)       , KnownNat (UnumSize u)       ) => U u -> U u -> SORN u@@ -526,7 +526,7 @@    sornSub ::       ( KnownNat (SORNSize u)       , Bits (SORNBackingWord u)-      , FiniteBits (BackingWord u)+      , Bits (BackingWord u)       , Num (BackingWord u)       , KnownNat (UnumSize u)       ) => SORN u -> SORN u -> SORN u@@ -540,7 +540,7 @@    sornSubDep ::       ( KnownNat (SORNSize u)       , Bits (SORNBackingWord u)-      , FiniteBits (BackingWord u)+      , Bits (BackingWord u)       , Num (BackingWord u)       , KnownNat (UnumSize u)       ) => SORN u -> SORN u@@ -613,7 +613,7 @@ instance forall u v.    ( KnownNat (SORNSize u)    , KnownNat (UnumSize u)-   , FiniteBits (BackingWord u)+   , Bits (BackingWord u)    , Bits (CSORNBackingWord u)    , Integral (CSORNBackingWord u)    , Num (BackingWord u)@@ -621,7 +621,7 @@    , HFoldr' GetLabel [String] v [String]    , Field (BackingWord u)    , Bits (SORNBackingWord u)-   , FiniteBits (SORNBackingWord u)+   , Bits (SORNBackingWord u)    , v ~ UnumMembers u    ) => Show (CSORN u) where    show = show . csornToSorn @@ -633,11 +633,11 @@    , Integral (BackingWord u)    , Integral (CSORNBackingWord u)    , Bits (CSORNBackingWord u)-   , FiniteBits (BackingWord u)+   , Bits (BackingWord u)    , Bits (SORNBackingWord u)    , Field (BackingWord u)    , KnownNat (SORNSize u)-   , FiniteBits (SORNBackingWord u)+   , Bits (SORNBackingWord u)    ) => CSORN u -> SORN u csornToSorn c =    if csornCount c == 0@@ -659,12 +659,12 @@  -- | Show contiguous SORN bits csornBits :: forall u s.-   ( FiniteBits (CSORNBackingWord u)+   ( Bits (CSORNBackingWord u)    , KnownNat (UnumSize u)    , s ~ CSORNSize u    , KnownNat s    ) => CSORN u -> String-csornBits (CSORN (BitFields w)) = drop (finiteBitSize w - natValue @s) (bitsToString w)+csornBits (CSORN (BitFields w)) = drop (bitSize w - natValue @s) (bitsToString w)   -- | Empty contigiuous SORN@@ -686,7 +686,7 @@    , Bits (BackingWord u)    , KnownNat (UnumSize u)    , KnownNat (SORNSize u)-   , FiniteBits (BackingWord u)+   , Bits (BackingWord u)    , Integral (CSORNBackingWord u)    , Bits (CSORNBackingWord u)    , Field (BackingWord u)

@@ -1,3 +1,5 @@+{-# LANGUAGE FlexibleContexts #-}+ -- | Variable length encodings module Haskus.Format.Binary.VariableLength    ( getULEB128

@@ -9,12 +9,15 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE BangPatterns #-}   -- | Vector with size in the type module Haskus.Format.Binary.Vector    ( Vector (..)    , vectorBuffer+   , vectorReverse    , take    , drop    , index@@ -24,19 +27,24 @@    , toList    , replicate    , concat+   , zipWith    ) where -import Prelude hiding (replicate, head, last,-                       tail, init, map, length, drop, take, concat)+import Prelude hiding ( replicate, head, last+                      , tail, init, map, length, drop, take, concat+                      , zipWith ) import System.IO.Unsafe (unsafePerformIO)  import qualified Haskus.Utils.List as List import Haskus.Utils.Types import Haskus.Utils.HList+import Haskus.Utils.Maybe+import Haskus.Utils.Flow import Haskus.Format.Binary.Storable import Haskus.Format.Binary.Ptr import Haskus.Format.Binary.Buffer+import Haskus.Format.Binary.Bits  -- | Vector with type-checked size data Vector (n :: Nat) a = Vector Buffer@@ -48,12 +56,16 @@ vectorBuffer :: Vector n a -> Buffer vectorBuffer (Vector b) = b +-- | Reverse a vector+vectorReverse :: (KnownNat n, Storable a) => Vector n a -> Vector n a+vectorReverse = fromJust . fromList . reverse . toList+ -- | Offset of the i-th element in a stored vector type family ElemOffset a i n where-   ElemOffset a i n = IfNat (i+1 <=? n)+   ElemOffset a i n = Assert (i+1 <=? n)       (i * (SizeOf a))-      (TypeError ('Text "Invalid vector index: " ':<>: 'ShowType i-                 ':$$: 'Text "Vector size: "     ':<>: 'ShowType n))+      (('Text "Invalid vector index: " ':<>: 'ShowType i+       ':$$: 'Text "Vector size: "     ':<>: 'ShowType n))  instance forall a n.    ( KnownNat (SizeOf a * n)@@ -192,3 +204,145 @@    p <- mallocBytes (fromIntegral sz) :: IO (Ptr ())    _ <- hFoldr StoreVector (return (castPtr p `indexPtr'` sz) :: IO (Ptr a)) vs :: IO (Ptr a)    Vector <$> bufferUnsafePackPtr (fromIntegral sz) p+++-- | Zip two vectors+zipWith ::+   ( KnownNat n+   , Storable a+   , Storable b+   , Storable c+   ) => (a -> b -> c) -> Vector n a -> Vector n b -> Vector n c+zipWith f u v = fromJust . fromList <| List.zipWith f (toList u) (toList v)++-- | map+map ::+   ( KnownNat n+   , Storable a+   , Storable b+   ) => (a -> b) -> Vector n a -> Vector n b+map f = fromJust . fromList . fmap f . toList++instance+   ( KnownNat n+   , Storable a+   , Eq a+   )+   => Eq (Vector n a)+   where+      u == v = toList u == toList v+++instance+   ( KnownNat n+   , Bitwise a+   , Storable a+   ) => Bitwise (Vector n a)+   where+      u .&. v        = zipWith (.&.) u v+      u .|. v        = zipWith (.|.) u v+      u `xor` v      = zipWith xor u v+      complement u   = map complement u+++instance+   ( KnownNat (BitSize a)+   , FiniteBits a+   , KnownNat n+   , Storable a+   ) => FiniteBits (Vector n a)+   where+      type BitSize (Vector n a) = n * BitSize a+      zeroBits = fromJust (fromList (List.replicate (natValue @n) zeroBits))+      oneBits  = fromJust (fromList (List.replicate (natValue @n) oneBits))+      countLeadingZeros = go 0 . toList+         where+            go !n []     = n+            go !n (x:xs) = let c = countLeadingZeros x+                           in if c == natValue @(BitSize a)+                                 then go (n+c) xs+                                 else n+c++      countTrailingZeros = go 0 . reverse . toList+         where+            go !n []     = n+            go !n (x:xs) = let c = countTrailingZeros x+                           in if c == natValue @(BitSize a)+                                 then go (n+c) xs+                                 else n+c++instance+   ( Storable a+   , ShiftableBits a+   , Bitwise a+   , FiniteBits a+   , KnownNat (BitSize a)+   , KnownNat (n * BitSize a)+   , KnownNat n+   ) => ShiftableBits (Vector n a)+   where+      shiftL u c = uncheckedShiftL u (c `mod` natValue @(BitSize (Vector n a)))+      shiftR u c = uncheckedShiftR u (c `mod` natValue @(BitSize (Vector n a)))++      uncheckedShiftL u c =+         let n  = natValue @n+             sa = natValue @(BitSize a)+             go _ 0 _       = []+             go 0 k xs      = List.take k xs+             go s k xs+                | s >= sa   = go (s-sa) k (List.tail xs)+                | otherwise =+                   let (x:y:zs) = xs+                   in ((x `shiftL` s) .|. (y `shiftR` (sa-s))) : go s (k-1) (y:zs)+         in fromJust (fromList (go c n (toList u ++ List.repeat zeroBits)))++      uncheckedShiftR u c  =+         let n  = natValue @n+             sa = natValue @(BitSize a)+             go _ 0 _       = []+             go 0 k xs      = List.take k (List.tail xs)+             go s k xs+                | s >= sa   = zeroBits : go (s-sa) (k-1) xs+                | otherwise =+                   let (x:y:zs) = xs+                   in ((x `shiftL` (sa-s)) .|. (y `shiftR` s)) : go s (k-1) (y:zs)+         in fromJust (fromList (go c n (zeroBits : toList u)))+++instance+   ( Storable a+   , IndexableBits a+   , FiniteBits a+   , KnownNat (BitSize a)+   , KnownNat n+   , Bitwise a+   ) => IndexableBits (Vector n a) where++      popCount = sum . fmap popCount . toList++      bit i    = let n     = natValue @n+                     sa    = natValue @(BitSize a)+                     (f,r) = i `divMod` sa+                     toRep = fromIntegral (n - f - 1)+                     xs    = List.replicate toRep zeroBits+                              ++ [bit r]+                              ++ List.replicate (fromIntegral f) zeroBits+                 in fromJust <| fromList <| if i >= n * sa+                     then List.replicate (fromIntegral n) zeroBits+                     else xs++      testBit u i = let n      = natValue @n+                        sa     = natValue @(BitSize a)+                        (f,r)  = i `divMod` sa+                        toDrop = fromIntegral (n - f - 1)+                    in if i >= n * sa+                        then False+                        else testBit (List.head (List.drop toDrop (toList u))) r+++instance+   ( Storable a+   , Bits a+   , KnownNat n+   , KnownNat (n * BitSize a)+   ) => RotatableBits (Vector n a)

@@ -7,12 +7,10 @@  -- | Unsigned and signed words module Haskus.Format.Binary.Word-   ( Int8-   , Int16-   , Int32-   , Int64-   , BitSize-   , WordAtLeast+   ( WordAtLeast+   , IntAtLeast+   , WordN+   , IntN    -- * Some C types    , CSize(..)    , CUShort@@ -23,6 +21,7 @@    , CLong    -- * Unlifted    , module GHC.Word+   , module GHC.Int    , Word#    , Int#    , plusWord#@@ -47,6 +46,7 @@ import Data.Int import Foreign.C.Types import GHC.Word+import GHC.Int import GHC.Exts  import Haskus.Utils.Types@@ -57,13 +57,32 @@        If (n <=? 8) Word8       (If (n <=? 16) Word16       (If (n <=? 32) Word32-      (If (n <=? 64) Word64-      (TypeError ('Text "Cannot find Word with size " ':<>: 'ShowType n))+      (Assert (n <=? 64) Word64+      ('Text "Cannot find Word with size " ':<>: 'ShowType n)       ))) --- | Bit size-type family BitSize a :: Nat-type instance BitSize Word8  = 8-type instance BitSize Word16 = 16-type instance BitSize Word32 = 32-type instance BitSize Word64 = 64+-- | Return a Int with at least 'n' bits+type family IntAtLeast (n :: Nat) where+   IntAtLeast n =+       If (n <=? 8) Int8+      (If (n <=? 16) Int16+      (If (n <=? 32) Int32+      (Assert (n <=? 64) Int64+      ('Text "Cannot find Int with size " ':<>: 'ShowType n)+      )))++-- | Return a Word with exactly 'n' bits+type family WordN (n :: Nat) where+   WordN 8  = Word8+   WordN 16 = Word16+   WordN 32 = Word32+   WordN 64 = Word64+   WordN n  = TypeError ('Text "Cannot find Word with size " ':<>: 'ShowType n)++-- | Return a Int with exactly 'n' bits+type family IntN (n :: Nat) where+   IntN 8  = Int8+   IntN 16 = Int16+   IntN 32 = Int32+   IntN 64 = Int64+   IntN n  = TypeError ('Text "Cannot find Int with size " ':<>: 'ShowType n)

@@ -1,13 +1,18 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE BinaryLiterals #-}+{-# LANGUAGE ScopedTypeVariables #-}+ module Haskus.Tests.Format.Binary.Bits     ( testsBits    ) where  import Test.Tasty-import Test.Tasty.QuickCheck as QC+import Test.Tasty.QuickCheck (Arbitrary(..),testProperty) import Test.QuickCheck.Gen (elements,choose,vectorOf)  import Haskus.Tests.Common+import Haskus.Utils.Flow  import Haskus.Format.Binary.Bits.Put import Haskus.Format.Binary.Bits.Get@@ -23,13 +28,179 @@  testsBits :: TestTree testsBits = testGroup "Binary bits" $-   [ testGroup "Bits to/from string"+   [ testGroup "Finite"+      [ testGroup "Finite bitSize"+         [ testProperty "bitSize Word8"  (bitSize (5 :: Word8)  == (8 :: Word))+         , testProperty "bitSize Word16" (bitSize (5 :: Word16) == (16 :: Word))+         , testProperty "bitSize Word32" (bitSize (5 :: Word32) == (32 :: Word))+         , testProperty "bitSize Word64" (bitSize (5 :: Word64) == (64 :: Word))+         , testProperty "bitSize Int8"   (bitSize (5 :: Int8)   == (8 :: Word))+         , testProperty "bitSize Int16"  (bitSize (5 :: Int16)  == (16 :: Word))+         , testProperty "bitSize Int32"  (bitSize (5 :: Int32)  == (32 :: Word))+         , testProperty "bitSize Int64"  (bitSize (5 :: Int64)  == (64 :: Word))+         ]+      , testGroup "Finite zeroBits"+         [ testProperty "zeroBits Word8"  ((zeroBits :: Word8)  == 0)+         , testProperty "zeroBits Word16" ((zeroBits :: Word16) == 0)+         , testProperty "zeroBits Word32" ((zeroBits :: Word32) == 0)+         , testProperty "zeroBits Word64" ((zeroBits :: Word64) == 0)+         , testProperty "zeroBits Int8"   ((zeroBits :: Int8)   == 0)+         , testProperty "zeroBits Int16"  ((zeroBits :: Int16)  == 0)+         , testProperty "zeroBits Int32"  ((zeroBits :: Int32)  == 0)+         , testProperty "zeroBits Int64"  ((zeroBits :: Int64)  == 0)+         ]+      , testGroup "Finite oneBits"+         [ testProperty "oneBits Word8"  ((oneBits :: Word8)  == 0xff)+         , testProperty "oneBits Word16" ((oneBits :: Word16) == 0xffff)+         , testProperty "oneBits Word32" ((oneBits :: Word32) == 0xffffffff)+         , testProperty "oneBits Word64" ((oneBits :: Word64) == 0xffffffffffffffff)+         , testProperty "oneBits Int8"   ((oneBits :: Int8)   == -1)+         , testProperty "oneBits Int16"  ((oneBits :: Int16)  == -1)+         , testProperty "oneBits Int32"  ((oneBits :: Int32)  == -1)+         , testProperty "oneBits Int64"  ((oneBits :: Int64)  == -1)+         ]+      , testGroup "Finite countLeadingZeros"+         [ testProperty "countLeadingZeros Word8"  (countLeadingZeros (0x10 :: Word8)  == 3)+         , testProperty "countLeadingZeros Word16" (countLeadingZeros (0x1000 :: Word16) == 3)+         , testProperty "countLeadingZeros Word32" (countLeadingZeros (0x10000000 :: Word32) == 3)+         , testProperty "countLeadingZeros Word64" (countLeadingZeros (0x1000000000000000 :: Word64) == 3)+         , testProperty "countLeadingZeros Int8"   (countLeadingZeros (0x10 :: Int8)  == 3)+         , testProperty "countLeadingZeros Int16"  (countLeadingZeros (0x1000 :: Int16) == 3)+         , testProperty "countLeadingZeros Int32"  (countLeadingZeros (0x10000000 :: Int32) == 3)+         , testProperty "countLeadingZeros Int64"  (countLeadingZeros (0x1000000000000000 :: Int64) == 3)+         , testProperty "countLeadingZeros Word8"  (countLeadingZeros (0x0 :: Word8)  == 8)+         , testProperty "countLeadingZeros Word16" (countLeadingZeros (0x0 :: Word16) == 16)+         , testProperty "countLeadingZeros Word32" (countLeadingZeros (0x0 :: Word32) == 32)+         , testProperty "countLeadingZeros Word64" (countLeadingZeros (0x0 :: Word64) == 64)+         , testProperty "countLeadingZeros Int8"   (countLeadingZeros (0x0 :: Int8)  == 8)+         , testProperty "countLeadingZeros Int16"  (countLeadingZeros (0x0 :: Int16) == 16)+         , testProperty "countLeadingZeros Int32"  (countLeadingZeros (0x0 :: Int32) == 32)+         , testProperty "countLeadingZeros Int64"  (countLeadingZeros (0x0 :: Int64) == 64)+         ]+      , testGroup "Finite countTrailingZeros"+         [ testProperty "countTrailingZeros Word8"  (countTrailingZeros (0x10 :: Word8)  == 4)+         , testProperty "countTrailingZeros Word16" (countTrailingZeros (0x1000 :: Word16) == 3*4)+         , testProperty "countTrailingZeros Word32" (countTrailingZeros (0x10000000 :: Word32) == 7*4)+         , testProperty "countTrailingZeros Word64" (countTrailingZeros (0x1000000000000000 :: Word64) == 15*4)+         , testProperty "countTrailingZeros Word"   (countTrailingZeros (0x10000000 :: Word) == 7*4)+         , testProperty "countTrailingZeros Int8"   (countTrailingZeros (0x10 :: Int8)  == 4)+         , testProperty "countTrailingZeros Int16"  (countTrailingZeros (0x1000 :: Int16) == 3*4)+         , testProperty "countTrailingZeros Int32"  (countTrailingZeros (0x10000000 :: Int32) == 7*4)+         , testProperty "countTrailingZeros Int64"  (countTrailingZeros (0x1000000000000000 :: Int64) == 15*4)+         , testProperty "countTrailingZeros Int"    (countTrailingZeros (0x10000000 :: Int) == 7*4)+         , testProperty "countTrailingZeros Word8"  (countTrailingZeros (0x0 :: Word8)  == 8)+         , testProperty "countTrailingZeros Word16" (countTrailingZeros (0x0 :: Word16) == 16)+         , testProperty "countTrailingZeros Word32" (countTrailingZeros (0x0 :: Word32) == 32)+         , testProperty "countTrailingZeros Word64" (countTrailingZeros (0x0 :: Word64) == 64)+         , testProperty "countTrailingZeros Int8"   (countTrailingZeros (0x0 :: Int8)  == 8)+         , testProperty "countTrailingZeros Int16"  (countTrailingZeros (0x0 :: Int16) == 16)+         , testProperty "countTrailingZeros Int32"  (countTrailingZeros (0x0 :: Int32) == 32)+         , testProperty "countTrailingZeros Int64"  (countTrailingZeros (0x0 :: Int64) == 64)+         ]+      ]+   , testGroup "Bitwise"+      [ testGroup "AND"+         [ testProperty "and Word8"  (0x04 .&. (5 :: Word8)  == 0x04)+         , testProperty "and Word16" (0x04 .&. (5 :: Word16) == 0x04)+         , testProperty "and Word32" (0x04 .&. (5 :: Word32) == 0x04)+         , testProperty "and Word64" (0x04 .&. (5 :: Word64) == 0x04)+         , testProperty "and Int8"   (0x04 .&. (5 :: Int8)   == 0x04)+         , testProperty "and Int16"  (0x04 .&. (5 :: Int16)  == 0x04)+         , testProperty "and Int32"  (0x04 .&. (5 :: Int32)  == 0x04)+         , testProperty "and Int64"  (0x04 .&. (5 :: Int64)  == 0x04)+         ]+      , testGroup "OR"+         [ testProperty "or Word8"  (0x02 .|. (5 :: Word8)  == 0x07)+         , testProperty "or Word16" (0x02 .|. (5 :: Word16) == 0x07)+         , testProperty "or Word32" (0x02 .|. (5 :: Word32) == 0x07)+         , testProperty "or Word64" (0x02 .|. (5 :: Word64) == 0x07)+         , testProperty "or Int8"   (0x02 .|. (5 :: Int8)   == 0x07)+         , testProperty "or Int16"  (0x02 .|. (5 :: Int16)  == 0x07)+         , testProperty "or Int32"  (0x02 .|. (5 :: Int32)  == 0x07)+         , testProperty "or Int64"  (0x02 .|. (5 :: Int64)  == 0x07)+         ]+      , testGroup "XOR"+         [ testProperty "xor Word8"  (0x03 `xor` (5 :: Word8)  == 0x06)+         , testProperty "xor Word16" (0x03 `xor` (5 :: Word16) == 0x06)+         , testProperty "xor Word32" (0x03 `xor` (5 :: Word32) == 0x06)+         , testProperty "xor Word64" (0x03 `xor` (5 :: Word64) == 0x06)+         , testProperty "xor Int8"   (0x03 `xor` (5 :: Int8)   == 0x06)+         , testProperty "xor Int16"  (0x03 `xor` (5 :: Int16)  == 0x06)+         , testProperty "xor Int32"  (0x03 `xor` (5 :: Int32)  == 0x06)+         , testProperty "xor Int64"  (0x03 `xor` (5 :: Int64)  == 0x06)+         ]+      , testGroup "complement"+         [ testProperty "complement Word8"  (complement (2 :: Word8)  == maxBound - 2)+         , testProperty "complement Word16" (complement (2 :: Word16) == maxBound - 2)+         , testProperty "complement Word32" (complement (2 :: Word32) == maxBound - 2)+         , testProperty "complement Word64" (complement (2 :: Word64) == maxBound - 2)+         , testProperty "complement Int8"   (complement (2 :: Int8)   == -3)+         , testProperty "complement Int16"  (complement (2 :: Int16)  == -3)+         , testProperty "complement Int32"  (complement (2 :: Int32)  == -3)+         , testProperty "complement Int64"  (complement (2 :: Int64)  == -3)+         ]+      ]+   , testGroup "Shift"+      [ testGroup "shiftR"+         [ testProperty "shiftR Word8"  ((0b00101000 :: Word8)  `shiftR` 2 == 0b00001010)+         , testProperty "shiftR Word16" ((0b00101000 :: Word16) `shiftR` 2 == 0b00001010)+         , testProperty "shiftR Word32" ((0b00101000 :: Word32) `shiftR` 2 == 0b00001010)+         , testProperty "shiftR Word64" ((0b00101000 :: Word64) `shiftR` 2 == 0b00001010)+         , testProperty "shiftR Int8"   ((0b00101000 :: Int8)   `shiftR` 2 == 0b00001010)+         , testProperty "shiftR Int16"  ((0b00101000 :: Int16)  `shiftR` 2 == 0b00001010)+         , testProperty "shiftR Int32"  ((0b00101000 :: Int32)  `shiftR` 2 == 0b00001010)+         , testProperty "shiftR Int64"  ((0b00101000 :: Int64)  `shiftR` 2 == 0b00001010)+         , testProperty "shiftR Int"    (((-1) :: Int)    `shiftR` 1 == fromIntegral (maxBound `div` 2 :: Word))+         , testProperty "shiftR Int8"   (((-1) :: Int8)   `shiftR` 1 == fromIntegral (maxBound `div` 2 :: Word8))+         , testProperty "shiftR Int16"  (((-1) :: Int16)  `shiftR` 1 == fromIntegral (maxBound `div` 2 :: Word16))+         , testProperty "shiftR Int32"  (((-1) :: Int32)  `shiftR` 1 == fromIntegral (maxBound `div` 2 :: Word32))+         , testProperty "shiftR Int64"  (((-1) :: Int64)  `shiftR` 1 == fromIntegral (maxBound `div` 2 :: Word64))+         ]+      , testGroup "shiftL"+         [ testProperty "shiftL Word8"  ((0b00101000 :: Word8)  `shiftL` 2 == 0b10100000)+         , testProperty "shiftL Word16" ((0b00101000 :: Word16) `shiftL` 2 == 0b10100000)+         , testProperty "shiftL Word32" ((0b00101000 :: Word32) `shiftL` 2 == 0b10100000)+         , testProperty "shiftL Word64" ((0b00101000 :: Word64) `shiftL` 2 == 0b10100000)+         , testProperty "shiftL Int8"   ((0b00011000 :: Int8)   `shiftL` 2 == 0b01100000)+         , testProperty "shiftL Int16"  ((0b00101000 :: Int16)  `shiftL` 2 == 0b10100000)+         , testProperty "shiftL Int32"  ((0b00101000 :: Int32)  `shiftL` 2 == 0b10100000)+         , testProperty "shiftL Int64"  ((0b00101000 :: Int64)  `shiftL` 2 == 0b10100000)+         , testProperty "shiftL Int8"   ((0b00101000 :: Int8)   `shiftL` 3 == 0b01000000)+         , testProperty "shiftL -1 Int"    (((-1) :: Int)    `shiftL` 1 == -2)+         , testProperty "shiftL -1 Int8"   (((-1) :: Int8)   `shiftL` 1 == -2)+         , testProperty "shiftL -1 Int16"  (((-1) :: Int16)  `shiftL` 1 == -2)+         , testProperty "shiftL -1 Int32"  (((-1) :: Int32)  `shiftL` 1 == -2)+         , testProperty "shiftL -1 Int64"  (((-1) :: Int64)  `shiftL` 1 == -2)+         , testProperty "signedShiftL Int8"   ((0b00101000 :: Int8)   `signedShiftL` 3 == 0b01000000)+         ]+      ]+   , testGroup "Rotate"+      [ testGroup "rotate i . rotate (n-i) == id"+         [ testProperty "rotate Word8"  (\(x :: Word8)  i -> (x `rotate` i) `rotate` (bitSize x - i) == x)+         , testProperty "rotate Word16" (\(x :: Word16) i -> (x `rotate` i) `rotate` (bitSize x - i) == x)+         , testProperty "rotate Word32" (\(x :: Word32) i -> (x `rotate` i) `rotate` (bitSize x - i) == x)+         , testProperty "rotate Word64" (\(x :: Word64) i -> (x `rotate` i) `rotate` (bitSize x - i) == x)+         , testProperty "rotate Int8"   (\(x :: Int8)   i -> (x `rotate` i) `rotate` (bitSize x - i) == x)+         , testProperty "rotate Int16"  (\(x :: Int16)  i -> (x `rotate` i) `rotate` (bitSize x - i) == x)+         , testProperty "rotate Int32"  (\(x :: Int32)  i -> (x `rotate` i) `rotate` (bitSize x - i) == x)+         , testProperty "rotate Int64"  (\(x :: Int64)  i -> (x `rotate` i) `rotate` (bitSize x - i) == x)+         ]+      ]+   , testGroup "Bits to/from string"       [ testProperty "Bits from string \"01010011\" (Word8)" (bitsFromString "01010011" == (83 :: Word8))-      , testProperty "Bits from string reverse (Word64)" prop_bits_from_string+++      -- Test that a random BitString (i.e. a string with length 64 and only+      -- composed of 0s and 1s) can be converted into a Word64 and back into a string+      , testProperty "Bits from string reverse (Word64)" <|+         \(BitString s) -> bitsToString (bitsFromString s :: Word64) == s+       , testProperty "Bits to string (Word8)"            (prop_bits_to_string :: Word8  -> Bool)       , testProperty "Bits to string (Word16)"           (prop_bits_to_string :: Word16 -> Bool)       , testProperty "Bits to string (Word32)"           (prop_bits_to_string :: Word32 -> Bool)       , testProperty "Bits to string (Word64)"           (prop_bits_to_string :: Word64 -> Bool)++      , testProperty "N bits to string"                  (bitsToStringN 4 (0x06 :: Word8) == "0110")       ]    , testGroup "Bit put/bit get"       [ testProperty "Bit put/get Word8  - 8  bits"      (prop_reverse_word 8  :: Word8  -> ArbitraryBitOrder -> Bool)@@ -146,18 +317,13 @@ instance Arbitrary BitString where    arbitrary = fmap BitString $ vectorOf 64 (elements ['0','1']) --- | Test that a random BitString (i.e. a string with length 64 and only--- composed of 0s and 1s) can be converted into a Word64 and back into a string-prop_bits_from_string :: BitString -> Bool-prop_bits_from_string (BitString s) = bitsToString (bitsFromString s :: Word64) == s- -- | Test that a word can be converted into a BitString and back-prop_bits_to_string :: FiniteBits a => a -> Bool+prop_bits_to_string :: Bits a => a -> Bool prop_bits_to_string x = bitsFromString (bitsToString x) == x  -- | Test that words of the given length can be written and read back with -- BitGet/BitPut. Test every bit ordering.-prop_reverse_word :: (Integral a, FiniteBits a, BitReversable a) => Word -> a -> ArbitraryBitOrder -> Bool+prop_reverse_word :: (Integral a, Bits a, ReversableBits a) => Word -> a -> ArbitraryBitOrder -> Bool prop_reverse_word n w (ArbitraryBitOrder bo) = maskLeastBits n w == dec    where       enc = getBitPutBuffer  $ putBits n w $ newBitPutState bo@@ -179,12 +345,12 @@  -- | Test that words with arbitrary (but still valid) lengths can be written and -- read back with BitGet/BitPut. Test every bit ordering.-prop_reverse_word_size :: (Integral a, FiniteBits a, BitReversable a, Size s) => s -> a -> ArbitraryBitOrder -> Bool+prop_reverse_word_size :: (Integral a, Bits a, ReversableBits a, Size s) => s -> a -> ArbitraryBitOrder -> Bool prop_reverse_word_size n w bo = prop_reverse_word (fromSize n) w bo  -- | Write two parts of two words and read them back-prop_split_word :: (Num a, Integral a, FiniteBits a, BitReversable a,-                    Num b, Integral b, FiniteBits b, BitReversable b,+prop_split_word :: (Num a, Integral a, Bits a, ReversableBits a,+                    Num b, Integral b, Bits b, ReversableBits b,                     Size s1, Size s2) => s1 -> s2 -> a -> b -> ArbitraryBitOrder -> Bool prop_split_word s1 s2 w1 w2 (ArbitraryBitOrder bo) = runBitGet bo dec (runBitPut bo enc)    where

@@ -16,6 +16,7 @@ import Haskus.Utils.HList import Haskus.Format.Binary.Vector import Haskus.Format.Binary.Word+import Haskus.Format.Binary.Bits  v1234 :: Vector 4 Word32 v1234 = fromJust $ fromList [1,2,3,4]@@ -72,4 +73,10 @@     , testProperty "concat 4 vectors" $          toList (concat (v1234 `HCons` v567 `HCons` v567 `HCons` v1234 `HCons` HNil)) == [1,2,3,4,5,6,7,5,6,7,1,2,3,4]++   , testProperty "rotateR/rotateL" $+         (\n -> (v1234 `rotateR` n) `rotateL` n == v1234)++   , testProperty "bit/testBit" $+         (\n -> n >= 320 || testBit (bit n :: Vector 10 Word32) n)    ]