packages feed

binary-strict 0.2 → 0.2.1

raw patch · 4 files changed

+393/−4 lines, 4 files

Files

binary-strict.cabal view
@@ -1,5 +1,5 @@ name:            binary-strict-version:         0.2+version:         0.2.1 license:         BSD3 license-file:    LICENSE author:          Lennart Kolmodin <kolmodin@dtek.chalmers.se>@@ -13,8 +13,12 @@ category:        Data, Parsing build-depends:   base, containers, array, bytestring>=0.9 stability:       provisional-tested-with:     GHC == 6.8.1-exposed-modules: Data.Binary.Strict.Get, Data.Binary.Strict.IncrementalGet+tested-with:     GHC == 6.8.2+exposed-modules: Data.Binary.Strict.Get,+                 Data.Binary.Strict.IncrementalGet,+                 Data.Binary.Strict.BitGet extensions:      CPP, FlexibleContexts hs-source-dirs:  src+extra-source-files: tests/BitGetTest.hs ghc-options:     -Wall+build-type:      Simple
+ src/Data/Binary/Strict/BitGet.hs view
@@ -0,0 +1,337 @@+{-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -fglasgow-exts #-}+-- for unboxed shifts+-----------------------------------------------------------------------------+-- |+-- Module      : Data.Binary.Strict.BitGet+-- Copyright   : Adam Langley+-- License     : BSD3-style (see LICENSE)+--+-- Maintainer  : Adam Langley <agl@imperialviolet.org>+-- Stability   : experimental+--+-- This is a reader monad for parsing bit-aligned data. The usual Get monad+-- handles byte aligned data well.+--+-- In this monad, the current offset into the input is a number of bits, and+-- fetching n bits from the current position will shift everything correctly.+-- Bit vectors are represented as ByteStrings here either the first @n@ bits+-- are valid (left aligned) or the last @n@ bits are (right aligned).+--+-- If one is looking to parse integers etc, right alignment is the easist to+-- work with, however left alignment makes more sense in some situations.+-----------------------------------------------------------------------------++module Data.Binary.Strict.BitGet (+  -- * Get @BitGet@ type+    BitGet+  , runBitGet++  -- * Utility+  , skip+  , remaining+  , isEmpty++  -- * Generic parsing+  , getBit+  , getLeftByteString+  , getRightByteString++  -- ** Interpreting some number of bits as an integer+  , getAsWord8+  , getAsWord16+  , getAsWord32+  , getAsWord64++  -- ** Parsing particular types+  , getWord8+  , getWord16le+  , getWord16be+  , getWord16host+  , getWord32le+  , getWord32be+  , getWord32host+  , getWord64le+  , getWord64be+  , getWord64host+  , getWordhost+) where++import qualified Data.ByteString as B+import qualified Data.ByteString.Internal as B+import Foreign+import Data.Bits++#if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__)+import GHC.Base+import GHC.Word+#endif++data S = S {-# UNPACK #-} !B.ByteString  -- ^ input+           {-# UNPACK #-} !Word8  -- ^ bit offset in current byte+           deriving (Show)++newtype BitGet a = BitGet { unGet :: S -> (Either String a, S) }++instance Monad BitGet where+  return a = BitGet (\s -> (Right a, s))+  m >>= k = BitGet (\s -> case unGet m s of+                            (Left err, s') -> (Left err, s')+                            (Right a, s') -> unGet (k a) s')+  fail err = BitGet (\s -> (Left err, s))++-- | Run a BitGet on a ByteString+runBitGet :: B.ByteString -> BitGet a -> Either String a+runBitGet input m =+  case unGet m (S input 0) of+    (a, _) -> a++get :: BitGet S+get = BitGet (\s -> (Right s, s))++put :: S -> BitGet ()+put s = BitGet (const (Right (), s))++-- | This is used for masking the last byte of a ByteString so that extra+--   bits don't leak in+topNBits :: Int -> Word8+topNBits 0 = 0+topNBits 1 = 0x80+topNBits 2 = 0xc0+topNBits 3 = 0xe0+topNBits 4 = 0xf0+topNBits 5 = 0xf8+topNBits 6 = 0xfc+topNBits 7 = 0xfe+topNBits x = error ("topNBits undefined for " ++ show x)++bottomNBits :: Int -> Word8+bottomNBits 0 = 0+bottomNBits 1 = 0x01+bottomNBits 2 = 0x03+bottomNBits 3 = 0x07+bottomNBits 4 = 0x0f+bottomNBits 5 = 0x1f+bottomNBits 6 = 0x3f+bottomNBits 7 = 0x7f+bottomNBits x = error ("bottomNBits undefined for " ++ show x)++-- | Truncate a ByteString to a given number of bits (counting from the left)+--   by masking out extra bits in the last byte+leftTruncateBits :: Int -> B.ByteString -> B.ByteString+leftTruncateBits n = B.take ((n + 7) `div` 8) . snd . B.mapAccumL f n where+  f bits w | bits >= 8 = (bits - 8, w)+           | bits == 0 = (0, 0)+           | otherwise = (0, w .&. topNBits bits)++-- | Truncate a ByteString to a given number of bits (counting from the right)+--   by masking out extra bits in the first byte+rightTruncateBits :: Int -> B.ByteString -> B.ByteString+rightTruncateBits n bs = B.drop (B.length bs - ((n + 7) `div` 8)) $ snd $ B.mapAccumR f n bs where+  f bits w | bits >= 8 = (bits - 8, w)+           | bits == 0 = (0, 0)+           | otherwise = (0, w .&. bottomNBits bits)++-- | Shift the whole ByteString some number of bits left where 0 <= @n@ < 8+leftShift :: Int -> B.ByteString -> B.ByteString+leftShift 0 = id+leftShift n = snd . B.mapAccumR f 0 where+  f acc b = (b `shiftR` (8 - n), (b `shiftL` n) .|. acc)++-- | Shift the whole ByteString some number of bits right where 0 <= @n@ < 8+rightShift :: Int -> B.ByteString -> B.ByteString+rightShift 0 = id+rightShift n = snd . B.mapAccumL f 0 where+  f acc b = (b .&. (bottomNBits n), (b `shiftR` n) .|. (acc `shiftL` (8 - n)))++-- | Same as the standard splitAt, but in this version both parts share a byte+--   so that splitting [1,2,3,4] at 2 results in ([1,2], [2, 3, 4]).+splitAtWithDupByte :: Int -> B.ByteString -> (B.ByteString, B.ByteString)+splitAtWithDupByte n bs = (B.take n bs, B.drop (n - 1) bs)++-- | Used as a flag argument to readN to control weather the resulting+--   ByteString is left or right aligned+data Direction = BLeft | BRight deriving (Show)++-- | Fetch some number of bits from the input and return them as a ByteString+--   after applying the given function+readN :: Direction -> Int -> (B.ByteString -> a) -> BitGet a+readN d n f = do+  S bytes boff <- get+  let bitsRemaining = B.length bytes * 8 - boffInt+      boffInt = fromIntegral boff+      (shiftFunction, truncateFunction) =+        case d of+             BLeft -> (leftShift, leftTruncateBits)+             BRight -> (\off -> rightShift $ (((8 - (n `mod` 8)) `mod` 8) - off) `mod` 8,+                        rightTruncateBits)+  if bitsRemaining < n+     then fail "Too few bits remain"+     else do let bytesRequired = (n `div` 8) + (if boffInt + (n `mod` 8) > 0 then 1 else 0)+                 boff' = (boffInt + n) `mod` 8+             let (r, rest) = if boff' == 0+                                then B.splitAt bytesRequired bytes+                                else splitAtWithDupByte bytesRequired bytes+             put $ S rest $ fromIntegral boff'+             return $ f $ truncateFunction n $ shiftFunction boffInt r++-- | Skip @n@ bits of the input. Fails if less then @n@ bits remain+skip :: Int -> BitGet ()+skip n = readN BLeft (fromIntegral n) (const ())++-- | Return the number of bits remaining to be parsed+remaining :: BitGet Int+remaining = do+  S bytes boff <- get+  return $ B.length bytes * 8 - fromIntegral boff++-- | Return true if there are no more bits to parse+isEmpty :: BitGet Bool+isEmpty = do+  S bytes _ <- get+  return $ B.null bytes++getPtr :: Storable a => Int -> BitGet a+getPtr n = do+    (fp, o, _) <- readN BRight n B.toForeignPtr+    return . B.inlinePerformIO $ withForeignPtr fp $ \p -> peek (castPtr $ p `plusPtr` o)+{-# INLINE getPtr #-}++-- | Get a single bit from the input+getBit :: BitGet Bool+getBit = readN BRight 1 (not . ((==) 0) . B.head)++-- | Get a ByteString with the given number of bits, left aligned.+getLeftByteString :: Int -> BitGet B.ByteString+getLeftByteString n = readN BLeft n id++-- | Get a ByteString with the given number of bits in, right aligned.+getRightByteString :: Int -> BitGet B.ByteString+getRightByteString n = readN BRight n id++getWord8 :: BitGet Word8+getWord8 = getPtr (8 * sizeOf (undefined :: Word8))++------------------------------------------------------------------------+-- Host-endian reads++-- | /O(1)./ Read a single native machine word. The word is read in+-- host order, host endian form, for the machine you're on. On a 64 bit+-- machine the Word is an 8 byte value, on a 32 bit machine, 4 bytes.+getWordhost :: BitGet Word+getWordhost = getPtr (8 * sizeOf (undefined :: Word))+{-# INLINE getWordhost #-}++-- | /O(1)./ Read a 2 byte Word16 in native host order and host endianness.+getWord16host :: BitGet Word16+getWord16host = getPtr (8 * sizeOf (undefined :: Word16))+{-# INLINE getWord16host #-}++-- | /O(1)./ Read a Word32 in native host order and host endianness.+getWord32host :: BitGet Word32+getWord32host = getPtr  (8 * sizeOf (undefined :: Word32))+{-# INLINE getWord32host #-}++-- | /O(1)./ Read a Word64 in native host order and host endianess.+getWord64host   :: BitGet Word64+getWord64host = getPtr  (8 * sizeOf (undefined :: Word64))+{-# INLINE getWord64host #-}+++leftPad :: Int -> B.ByteString -> B.ByteString+leftPad len bs = if B.length bs < len then padded else bs where+  padded = (B.pack $ take extraBytes $ repeat 0) `B.append` bs+  extraBytes = len - B.length bs++getAsWord8 :: Int -> BitGet Word8+getAsWord8 n = readN BRight n $ (flip B.index) 0++-- | Read a Word16 in big endian format+getAsWord16 :: Int -> BitGet Word16+getAsWord16 n = do+    s <- readN BRight n id >>= return . leftPad 2+    return $! (fromIntegral (s `B.index` 0) `shiftl_w16` 8) .|.+              (fromIntegral (s `B.index` 1))++-- | Read a Word16 in little endian format+getWord16le :: BitGet Word16+getWord16le = do+    s <- readN BRight 16 id+    return $! (fromIntegral (s `B.index` 1) `shiftl_w16` 8) .|.+              (fromIntegral (s `B.index` 0) )++-- | Read a Word32 in big endian format+getAsWord32 :: Int -> BitGet Word32+getAsWord32 n = do+    s <- readN BRight n id >>= return . leftPad 4+    return $! (fromIntegral (s `B.index` 0) `shiftl_w32` 24) .|.+              (fromIntegral (s `B.index` 1) `shiftl_w32` 16) .|.+              (fromIntegral (s `B.index` 2) `shiftl_w32`  8) .|.+              (fromIntegral (s `B.index` 3) )+{-# INLINE getWord32be #-}++-- | Read a Word32 in little endian format+getWord32le :: BitGet Word32+getWord32le = do+    s <- readN BRight 32 id+    return $! (fromIntegral (s `B.index` 3) `shiftl_w32` 24) .|.+              (fromIntegral (s `B.index` 2) `shiftl_w32` 16) .|.+              (fromIntegral (s `B.index` 1) `shiftl_w32`  8) .|.+              (fromIntegral (s `B.index` 0) )+{-# INLINE getWord32le #-}++-- | Read a Word64 in big endian format+getAsWord64 :: Int -> BitGet Word64+getAsWord64 n = do+    s <- readN BRight n id >>= return . leftPad 8+    return $! (fromIntegral (s `B.index` 0) `shiftl_w64` 56) .|.+              (fromIntegral (s `B.index` 1) `shiftl_w64` 48) .|.+              (fromIntegral (s `B.index` 2) `shiftl_w64` 40) .|.+              (fromIntegral (s `B.index` 3) `shiftl_w64` 32) .|.+              (fromIntegral (s `B.index` 4) `shiftl_w64` 24) .|.+              (fromIntegral (s `B.index` 5) `shiftl_w64` 16) .|.+              (fromIntegral (s `B.index` 6) `shiftl_w64`  8) .|.+              (fromIntegral (s `B.index` 7) )+{-# INLINE getWord64be #-}++-- | Read a Word64 in little endian format+getWord64le :: BitGet Word64+getWord64le = do+    s <- readN BRight 64 id+    return $! (fromIntegral (s `B.index` 7) `shiftl_w64` 56) .|.+              (fromIntegral (s `B.index` 6) `shiftl_w64` 48) .|.+              (fromIntegral (s `B.index` 5) `shiftl_w64` 40) .|.+              (fromIntegral (s `B.index` 4) `shiftl_w64` 32) .|.+              (fromIntegral (s `B.index` 3) `shiftl_w64` 24) .|.+              (fromIntegral (s `B.index` 2) `shiftl_w64` 16) .|.+              (fromIntegral (s `B.index` 1) `shiftl_w64`  8) .|.+              (fromIntegral (s `B.index` 0) )++getWord16be :: BitGet Word16+getWord16be = getAsWord16 16++getWord32be :: BitGet Word32+getWord32be = getAsWord32 32++getWord64be :: BitGet Word64+getWord64be = getAsWord64 64++shiftl_w16 :: Word16 -> Int -> Word16+shiftl_w32 :: Word32 -> Int -> Word32+shiftl_w64 :: Word64 -> Int -> Word64++#if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__)+shiftl_w16 (W16# w) (I# i) = W16# (w `uncheckedShiftL#`   i)+shiftl_w32 (W32# w) (I# i) = W32# (w `uncheckedShiftL#`   i)++#if WORD_SIZE_IN_BITS < 64+shiftl_w64 (W64# w) (I# i) = W64# (w `uncheckedShiftL64#` i)+#else+shiftl_w64 (W64# w) (I# i) = W64# (w `uncheckedShiftL#` i)+#endif++#else+shiftl_w16 = shiftL+shiftl_w32 = shiftL+shiftl_w64 = shiftL+#endif
src/Data/Binary/Strict/Get.hs view
@@ -4,7 +4,7 @@  ----------------------------------------------------------------------------- -- |--- Module      : Data.Binary.Get+-- Module      : Data.Binary.Strict.Get -- Copyright   : Lennart Kolmodin -- License     : BSD3-style (see LICENSE) --@@ -70,6 +70,10 @@     , getWord16host     , getWord32host     , getWord64host++    -- ** Floating point+    , getFloat32host+    , getFloat64host ) where  import Control.Monad (when)@@ -79,6 +83,7 @@ import qualified Data.ByteString.Internal as B  import Foreign+import Foreign.C.Types  #if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__) import GHC.Base@@ -321,3 +326,12 @@ shiftl_w32 = shiftL shiftl_w64 = shiftL #endif++------------------------------------------------------------------------+-- Floating point support++getFloat32host :: Get Float+getFloat32host = (getPtr :: Int -> Get CFloat) 4 >>= return . fromRational . toRational++getFloat64host :: Get Double+getFloat64host = (getPtr :: Int -> Get CDouble) 8 >>= return . fromRational . toRational
+ tests/BitGetTest.hs view
@@ -0,0 +1,34 @@+module Main where++import qualified Data.ByteString as B+import Data.Word++import qualified Data.Binary.Strict.BitGet as BG++t :: (Eq a, Show a) => [Word8] -> BG.BitGet a -> a -> Bool+t bytes m v = if result == v then True else error (show (bytes, v, result)) where+  Right result = BG.runBitGet (B.pack bytes) m++tests = [+    t [1] BG.getWord8 1+  , t [128] BG.getBit True+  , t [64] BG.getBit False+  , t [1, 0] BG.getWord16be 256+  , t [1, 2] BG.getWord16be 258+  , t [1, 0] BG.getWord16le 1+  , t [2, 1] BG.getWord16le 258+  , t [192, 0] (BG.getBit >> BG.getWord8) 128+  , t [193, 0] (BG.getBit >> BG.getWord8) 130+  , t [193, 42] (sequence (take 8 $ repeat BG.getBit) >> BG.getWord8) 42+  , t [193] (BG.getAsWord8 3) 6+  , t [193] (BG.getAsWord8 4) 12+  , t [193, 128] (BG.skip 4 >> BG.getAsWord8 4) 1+  , t [193, 128] (BG.skip 8 >> BG.getAsWord8 4) 8+  , t [1, 2, 3, 0] (BG.getAsWord32 24) 66051+  , t [1, 2, 3, 0] (BG.getAsWord32 8) 1+  , t [1, 2, 3, 4, 5] (BG.getAsWord64 40) 4328719365+  ]++main = do+  print $ length $ filter id tests+  putStrLn "PASS"