ilyakooo0/binary-bits
1
0
Fork 0
mirror of https://github.com/ilyakooo0/binary-bits.git synced 2024-09-11 06:35:26 +03:00
Code Issues Packages Projects Releases Wiki Activity

Add helper modules

Browse Source
This commit is contained in:
Sylvain HENRY 2015-03-06 09:33:09 +01:00
parent c64ffc682c
commit 9358c44428
5 changed files with 192 additions and 147 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

28
Data/Binary/Bits/BitOrder.hs Normal file
View File

@ -0,0 +1,28 @@
-----------------------------------------------------------------------------
-- |
-- Module : Data.Binary.Bits.Get
-- Copyright : (c) Lennart Kolmodin 2010-2011
-- License : BSD3-style (see LICENSE)
--
-- Maintainer : kolmodin@gmail.com
-- Stability : experimental
-- Portability : portable (should run where the package binary runs)
module Data.Binary.Bits.BitOrder
( BitOrder(..)
)
where
-- | Bit order
--
-- E.g. two words of 5 bits: ABCDE, VWXYZ
-- - BB: ABCDEVWX YZxxxxxx
-- - LB: XYZABCDE xxxxxxVW
-- - BL: EDCBAZYX WVxxxxxx
-- - LL: XWVEDCBA xxxxxxZY
data BitOrder
= BB -- ^ Big-endian bytes and bits
| LB -- ^ Little-endian bytes, big-endian bits
| BL -- ^ Big-endian bytes, little-endian bits
| LL -- ^ Little-endian bytes and bits
deriving (Show)

142
Data/Binary/Bits/Get.hs
View File

@ -55,7 +55,6 @@ module Data.Binary.Bits.Get
-- $bitget
BitGet
, BitOrder(..)
, runBitGet
, getBitOrder
, selectBitOrder
@ -99,6 +98,8 @@ module Data.Binary.Bits.Get
import Data.Binary.Get as B ( Get, getLazyByteString, isEmpty )
import Data.Binary.Get.Internal as B ( get, put, ensureN )
import Data.Binary.Bits.BitOrder
import Data.Binary.Bits.Internal
import Data.ByteString as B
import qualified Data.ByteString.Lazy as L
@ -115,12 +116,6 @@ import Control.Monad (when,foldM_)
import Prelude as P
#if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__)
import GHC.Base
import GHC.Word
#endif
-- $bitget
-- Parse bits using a monad.
--
@ -172,16 +167,6 @@ data S = S {-# UNPACK #-} !ByteString -- Input
!BitOrder -- Bit order
deriving (Show)
-- | Compute bit offset (equivalent to x `mod` 8 but faster)
bit_offset :: Int -> Int
bit_offset n = make_mask 3 .&. n
{-# INLINE bit_offset #-}
-- | Compute byte offset (equivalent to x `div` 8 but faster)
byte_offset :: Int -> Int
byte_offset n = n `shiftR` 3
{-# INLINE byte_offset #-}
-- | Increment the current bit offset
incS :: Int -> S -> S
incS o (S bs n bo) = S (unsafeDrop d bs) n' bo
@ -194,42 +179,6 @@ incS o (S bs n bo) = S (unsafeDrop d bs) n' bo
selectBitOrderS :: BitOrder -> S -> S
selectBitOrderS bo (S bs o _) = S bs o bo
-- | make_mask 3 = 00000111
make_mask :: (Bits a, Num a) => Int -> a
make_mask n = (1 `shiftL` fromIntegral n) - 1
{-# SPECIALIZE make_mask :: Int -> Int #-}
{-# SPECIALIZE make_mask :: Int -> Word #-}
{-# SPECIALIZE make_mask :: Int -> Word8 #-}
{-# SPECIALIZE make_mask :: Int -> Word16 #-}
{-# SPECIALIZE make_mask :: Int -> Word32 #-}
{-# SPECIALIZE make_mask :: Int -> Word64 #-}
-- | Keep only the n least-significant bits of the given value
mask :: (Bits a, Num a) => Int -> a -> a
mask n v = v .&. make_mask n
{-# INLINE mask #-}
-- | Bit order
--
-- E.g. two words of 5 bits: ABCDE, VWXYZ
-- - BB: ABCDEVWX YZxxxxxx
-- - LB: XYZABCDE xxxxxxVW
-- - BL: EDCBAZYX WVxxxxxx
-- - LL: XWVEDCBA xxxxxxZY
data BitOrder = BB | LB | BL | LL deriving (Show)
-- | Reverse the @n@ least important bits of the given value
reverseBits :: (Num a, FastBits a, Bits a) => Int -> a -> a
reverseBits n value = rec value n 0
where
-- rec v i r, where
-- v is orginal value shifted
-- i is the remaining number of bits
-- r is current value
rec 0 0 r = r
rec 0 i r = r `fastShiftL` i
rec v i r = rec (v `fastShiftR` 1) (i-1) ((r `fastShiftL` 1) .|. (v .&. 0x1))
-- | Read a single bit
readBool :: S -> Bool
readBool (S bs o bo) = case bo of
@ -241,7 +190,7 @@ readBool (S bs o bo) = case bo of
-- | Extract a range of bits from (ws :: ByteString)
--
-- Constraint: 8 * (length ws -1 ) < o+n <= 8 * length ws
extract :: (Num a, Bits a, FastBits a) => BitOrder -> ByteString -> Int -> Int -> a
extract :: (Num a, FastBits a) => BitOrder -> ByteString -> Int -> Int -> a
extract bo bs o n
| n == 0 = 0
| B.length bs == 0 = error "Empty ByteString"
@ -273,7 +222,7 @@ extract bo bs o n
-- | Generic readWord
readWord :: (Num a, Bits a, FastBits a) => Int -> S -> a
readWord :: (Num a, FastBits a) => Int -> S -> a
readWord n (S bs o bo)
| n == 0 = 0
| otherwise = extract bo (unsafeTake nbytes bs) o n
@ -281,7 +230,7 @@ readWord n (S bs o bo)
-- | Check that the number of bits to read is not greater than the first parameter
{-# INLINE readWordChecked #-}
readWordChecked :: (Num a, Bits a, FastBits a) => Int -> Int -> S -> a
readWordChecked :: (Num a, FastBits a) => Int -> Int -> S -> a
readWordChecked m n s
| n > m = error $ "Tried to read more than " ++ show m ++ " bits (" ++ show n ++")"
| otherwise = readWord n s
@ -538,84 +487,3 @@ byteString :: Int -> Block ByteString
byteString n | n > 0 = Block (n*8) (readByteString n)
| otherwise = Block 0 (\_ -> B.empty)
---------------------------------------------------------------------
-- Unchecked shifts, from the "binary" package
-- | Class for types supporting fast bit shifting
class FastBits a where
fastShiftR :: a -> Int -> a
fastShiftL :: a -> Int -> a
{-# INLINE fastShift #-}
fastShift :: a -> Int -> a
fastShift x n
| n > 0 = fastShiftL x n
| n < 0 = fastShiftR x (negate n)
| otherwise = x
instance FastBits Word8 where
fastShiftR = shiftr_w8
fastShiftL = shiftl_w8
instance FastBits Word16 where
fastShiftR = shiftr_w16
fastShiftL = shiftl_w16
instance FastBits Word32 where
fastShiftR = shiftr_w32
fastShiftL = shiftl_w32
instance FastBits Word64 where
fastShiftR = shiftr_w64
fastShiftL = shiftl_w64
shiftl_w8 :: Word8 -> Int -> Word8
shiftl_w16 :: Word16 -> Int -> Word16
shiftl_w32 :: Word32 -> Int -> Word32
shiftl_w64 :: Word64 -> Int -> Word64
shiftr_w8 :: Word8 -> Int -> Word8
shiftr_w16 :: Word16 -> Int -> Word16
shiftr_w32 :: Word32 -> Int -> Word32
shiftr_w64 :: Word64 -> Int -> Word64
#if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__)
shiftl_w8 (W8# w) (I# i) = W8# (w `uncheckedShiftL#` i)
shiftl_w16 (W16# w) (I# i) = W16# (w `uncheckedShiftL#` i)
shiftl_w32 (W32# w) (I# i) = W32# (w `uncheckedShiftL#` i)
shiftr_w8 (W8# w) (I# i) = W8# (w `uncheckedShiftRL#` i)
shiftr_w16 (W16# w) (I# i) = W16# (w `uncheckedShiftRL#` i)
shiftr_w32 (W32# w) (I# i) = W32# (w `uncheckedShiftRL#` i)
#if WORD_SIZE_IN_BITS < 64
shiftl_w64 (W64# w) (I# i) = W64# (w `uncheckedShiftL64#` i)
shiftr_w64 (W64# w) (I# i) = W64# (w `uncheckedShiftRL64#` i)
#if __GLASGOW_HASKELL__ <= 606
-- Exported by GHC.Word in GHC 6.8 and higher
foreign import ccall unsafe "stg_uncheckedShiftL64"
uncheckedShiftL64# :: Word64# -> Int# -> Word64#
foreign import ccall unsafe "stg_uncheckedShiftRL64"
uncheckedShiftRL64# :: Word64# -> Int# -> Word64#
#endif
#else
shiftl_w64 (W64# w) (I# i) = W64# (w `uncheckedShiftL#` i)
shiftr_w64 (W64# w) (I# i) = W64# (w `uncheckedShiftRL#` i)
#endif
#else
shiftl_w8 = shiftL
shiftl_w16 = shiftL
shiftl_w32 = shiftL
shiftl_w64 = shiftL
shiftr_w8 = shiftR
shiftr_w16 = shiftR
shiftr_w32 = shiftR
shiftr_w64 = shiftR
#endif

155
Data/Binary/Bits/Internal.hs Normal file
View File

@ -0,0 +1,155 @@
{-# LANGUAGE RankNTypes, MagicHash, BangPatterns, CPP #-}
-----------------------------------------------------------------------------
-- |
-- Module : Data.Binary.Bits.Get
-- Copyright : (c) Lennart Kolmodin 2010-2011
-- License : BSD3-style (see LICENSE)
--
-- Maintainer : kolmodin@gmail.com
-- Stability : experimental
-- Portability : portable (should run where the package binary runs)
module Data.Binary.Bits.Internal
( make_mask
, mask
, bit_offset
, byte_offset
, reverseBits
, FastBits(..)
)
where
import Data.Word
import Data.Bits
#if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__)
import GHC.Base
import GHC.Word
#endif
-- | make_mask 3 = 00000111
make_mask :: (FastBits a, Num a) => Int -> a
make_mask n = (1 `fastShiftL` fromIntegral n) - 1
{-# SPECIALIZE make_mask :: Int -> Int #-}
{-# SPECIALIZE make_mask :: Int -> Word #-}
{-# SPECIALIZE make_mask :: Int -> Word8 #-}
{-# SPECIALIZE make_mask :: Int -> Word16 #-}
{-# SPECIALIZE make_mask :: Int -> Word32 #-}
{-# SPECIALIZE make_mask :: Int -> Word64 #-}
-- | Keep only the n least-significant bits of the given value
mask :: (FastBits a, Num a) => Int -> a -> a
mask n v = v .&. make_mask n
{-# INLINE mask #-}
-- | Compute bit offset (equivalent to x `mod` 8 but faster)
bit_offset :: Int -> Int
bit_offset n = make_mask 3 .&. n
{-# INLINE bit_offset #-}
-- | Compute byte offset (equivalent to x `div` 8 but faster)
byte_offset :: Int -> Int
byte_offset n = n `shiftR` 3
{-# INLINE byte_offset #-}
-- | Reverse the @n@ least important bits of the given value
reverseBits :: (Num a, FastBits a, Bits a) => Int -> a -> a
reverseBits n value = rec value n 0
where
-- rec v i r, where
-- v is orginal value shifted
-- i is the remaining number of bits
-- r is current value
rec 0 0 r = r
rec 0 i r = r `fastShiftL` i
rec v i r = rec (v `fastShiftR` 1) (i-1) ((r `fastShiftL` 1) .|. (v .&. 0x1))
---------------------------------------------------------------------
-- Unchecked shifts, from the "binary" package
-- | Class for types supporting fast bit shifting
class Bits a => FastBits a where
fastShiftR :: a -> Int -> a
fastShiftR = shiftR
fastShiftL :: a -> Int -> a
fastShiftL = shiftL
{-# INLINE fastShift #-}
fastShift :: a -> Int -> a
fastShift x n
| n > 0 = fastShiftL x n
| n < 0 = fastShiftR x (negate n)
| otherwise = x
instance FastBits Word8 where
fastShiftR = shiftr_w8
fastShiftL = shiftl_w8
instance FastBits Word16 where
fastShiftR = shiftr_w16
fastShiftL = shiftl_w16
instance FastBits Word32 where
fastShiftR = shiftr_w32
fastShiftL = shiftl_w32
instance FastBits Word64 where
fastShiftR = shiftr_w64
fastShiftL = shiftl_w64
instance FastBits Int
instance FastBits Word
shiftl_w8 :: Word8 -> Int -> Word8
shiftl_w16 :: Word16 -> Int -> Word16
shiftl_w32 :: Word32 -> Int -> Word32
shiftl_w64 :: Word64 -> Int -> Word64
shiftr_w8 :: Word8 -> Int -> Word8
shiftr_w16 :: Word16 -> Int -> Word16
shiftr_w32 :: Word32 -> Int -> Word32
shiftr_w64 :: Word64 -> Int -> Word64
#if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__)
shiftl_w8 (W8# w) (I# i) = W8# (w `uncheckedShiftL#` i)
shiftl_w16 (W16# w) (I# i) = W16# (w `uncheckedShiftL#` i)
shiftl_w32 (W32# w) (I# i) = W32# (w `uncheckedShiftL#` i)
shiftr_w8 (W8# w) (I# i) = W8# (w `uncheckedShiftRL#` i)
shiftr_w16 (W16# w) (I# i) = W16# (w `uncheckedShiftRL#` i)
shiftr_w32 (W32# w) (I# i) = W32# (w `uncheckedShiftRL#` i)
#if WORD_SIZE_IN_BITS < 64
shiftl_w64 (W64# w) (I# i) = W64# (w `uncheckedShiftL64#` i)
shiftr_w64 (W64# w) (I# i) = W64# (w `uncheckedShiftRL64#` i)
#if __GLASGOW_HASKELL__ <= 606
-- Exported by GHC.Word in GHC 6.8 and higher
foreign import ccall unsafe "stg_uncheckedShiftL64"
uncheckedShiftL64# :: Word64# -> Int# -> Word64#
foreign import ccall unsafe "stg_uncheckedShiftRL64"
uncheckedShiftRL64# :: Word64# -> Int# -> Word64#
#endif
#else
shiftl_w64 (W64# w) (I# i) = W64# (w `uncheckedShiftL#` i)
shiftr_w64 (W64# w) (I# i) = W64# (w `uncheckedShiftRL#` i)
#endif
#else
shiftl_w8 = shiftL
shiftl_w16 = shiftL
shiftl_w32 = shiftL
shiftl_w64 = shiftL
shiftr_w8 = shiftR
shiftr_w16 = shiftR
shiftr_w32 = shiftR
shiftr_w64 = shiftR
#endif

10
Data/Binary/Bits/Put.hs
View File

@ -35,6 +35,7 @@ import qualified Data.Binary.Builder as B
import Data.Binary.Builder ( Builder )
import qualified Data.Binary.Put as Put
import Data.Binary.Put ( Put )
import Data.Binary.Bits.Internal
import Data.ByteString
@ -53,15 +54,6 @@ data S = S !Builder !Word8 !Int
putBool :: Bool -> BitPut ()
putBool b = putWord8 1 (if b then 0xff else 0x00)
-- | make_mask 3 = 00000111
make_mask :: (Bits a, Num a) => Int -> a
make_mask n = (1 `shiftL` fromIntegral n) - 1
{-# SPECIALIZE make_mask :: Int -> Int #-}
{-# SPECIALIZE make_mask :: Int -> Word #-}
{-# SPECIALIZE make_mask :: Int -> Word8 #-}
{-# SPECIALIZE make_mask :: Int -> Word16 #-}
{-# SPECIALIZE make_mask :: Int -> Word32 #-}
{-# SPECIALIZE make_mask :: Int -> Word64 #-}
-- | Put the @n@ lower bits of a 'Word8'.
putWord8 :: Int -> Word8 -> BitPut ()

4
binary-bits.cabal
View File

@ -24,7 +24,9 @@ library
exposed-modules: Data.Binary.Bits ,
Data.Binary.Bits.Put ,
Data.Binary.Bits.Get
Data.Binary.Bits.Get ,
Data.Binary.Bits.BitOrder
other-modules: Data.Binary.Bits.Internal
default-language: Haskell98