bitstring 0.0.0 → 0.0.1

raw patch · 5 files changed

+717/−1419 lines, 5 filesdep ~bytestringsetup-changedPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: bytestring

API changes (from Hackage documentation)

Files

• Data/BitString.hs +3/−684
• Data/BitString/BigEndian.hs +11/−686
• Setup.lhs +0/−39
• bitstring.cabal +15/−10
• include/BitString.inc +688/−0

@@ -1,690 +1,9 @@-- {-# LANGUAGE CPP, BangPatterns #-} --- #define BITSTRING_BIGENDIAN--- #define WITH_QUICKCHECK--#ifndef BITSTRING_BIGENDIAN -- | Lazy bitstrings, somewhat similar to lazy bytestrings. -- This module is intended to be imported qualified.-module Data.BitString -#else--- | Big-endian bitstrings. In this context, \"big-endian\" means that--- the bits in the bytes are in the opposite order than what would be--- logical. If you ask me, this is just plain stupid, but some people--- apparently still use it...-module Data.BitString.BigEndian-#endif--  (-    BitString-    ---  , empty-  , bitString-  , bitStringLazy-  , unsafeBitString'-    ---  , take-  , drop-  , splitAt-  , append-  , concat-    ---  , toList-  , fromList-  , to01List-  , from01List-    ---  , null-  , length-    ---  , foldl'-  , findSubstring-    ---  , realizeBitStringLazy-  , realizeBitStringStrict-  , realizeBitString'  -    ---#ifdef WITH_QUICKCHECK-  , runAllTest-  , BitChunk (..)-  , BitString ( BitString )-  , mypack-  , prop_fromToList -  , prop_toFromList -  , prop_append     -  , prop_drop       -  , prop_take       -  , prop_dropChunk  -  , prop_takeChunk  -  , prop_realign    -  , prop_realizeChunk -  , prop_realize      -  , prop_realizeLen      -  , prop_findSubstring1 -  , prop_findSubstring1a -  , prop_findSubstring1b -  , prop_findSubstring2 -#endif        -  )-  where-  -----------------------------------------------------------------------------------import Prelude hiding (take,drop,last,length,splitAt,concat,null,rem,init)--import Control.Monad-import Control.Applicative hiding ( empty )--import Data.Bits ()-import Data.Int  ()-import Data.Word ()-import Data.Maybe-import qualified Data.List as List--import Data.ByteString (ByteString)-import qualified Data.ByteString          as B-import qualified Data.ByteString.Internal as B--- import qualified Data.ByteString.Unsafe   as U-import qualified Data.ByteString.Lazy     as L--#ifdef WITH_QUICKCHECK-import Test.QuickCheck hiding ( (.&.) )-import qualified Data.ByteString.Char8 as BC-import Data.Char (ord)-#endif--import Foreign-import System.IO.Unsafe------------------------------------------------------------------------------------flippedFoldM_ :: Monad m => a -> [b] -> (a -> b -> m a) -> m () -flippedFoldM_ x ys f = foldM_ f x ys--flippedFoldM ::  Monad m => a -> [b] -> (a -> b -> m a) -> m a -flippedFoldM x ys f = foldM f x ys------------------------------------------------------------------------------------#ifdef BITSTRING_BIGENDIAN--{--bitReverseWord8_naive :: Word8 -> Word8-bitReverseWord8_naive x -  = shiftR (x .&. 0x80) 7-  + shiftR (x .&. 0x40) 5-  + shiftR (x .&. 0x20) 3-  + shiftR (x .&. 0x10) 1-  + shiftL (x .&. 0x08) 1-  + shiftL (x .&. 0x04) 3-  + shiftL (x .&. 0x02) 5-  + shiftL (x .&. 0x01) 7-     -bitReverseWord8_table :: ByteString     -bitReverseWord8_table = B.pack $ map reverseWord8_naive [0..255]--bitReverseWord8 :: Word8 -> Word8-bitReverseWord8 = U.unsafeIndex reverseWord8_table . fromIntegral--}--byteReverseWord32 :: Word32 -> Word32-byteReverseWord32 w -  = shiftR w 24 -  + shiftR w 8  .&. 0x0000ff00 -  + shiftL w 8  .&. 0x00ff0000 -  + shiftL w 24--#endif // BITSTRING_BIGENDIAN------------------------------------------------------------------------------------data BitChunk = BitChunk-  { bitChunkOffset :: !Int64-  , bitChunkLength :: !Int64-  , bitChunkData   :: !ByteString-  }--#ifdef WITH_QUICKCHECK--mypack :: String -> ByteString-mypack = B.pack . map c2w where-  c2w = fromIntegral . ord--instance Show BitChunk where-  show (BitChunk ofs len dat) = "BitChunk " ++ show ofs ++ " " ++ show len ++ " (mypack " ++ show dat ++ ")"--#else  --instance Show BitChunk where-  show chunk = "BitChunk <" ++ map f (bitChunkTo01List chunk) ++ ">" where -    f 0 = '0'-    f 1 = '1'--#endif // WITH_QUICKCHECK--emptyBitChunk :: BitChunk-emptyBitChunk = BitChunk 0 0 B.empty--{-  -bitChunk' :: Int64 -> ByteString -> BitChunk  -bitChunk' ofs bs = BitString ofs (len-ofs) bs where -  len = 8 * fromIntegral (B.length bs)--}---- | warning! no boundary checks-unsafeBitChunk'  -  :: Int64      -- ^ offset -  -> Int64      -- ^ length-  -> ByteString  -- ^ source-  -> BitChunk -unsafeBitChunk' ofs len dat = BitChunk ofs len dat where --bitChunk :: ByteString -> BitChunk  -bitChunk bs = unsafeBitChunk' 0 (8 * fromIntegral (B.length bs)) bs------------------------------------------------------------------------------------bitChunkDrop :: Int64 -> BitChunk -> BitChunk-bitChunkDrop k (BitChunk ofs len dat) = if k<len-  then BitChunk (ofs+k) (len-k) dat-  else emptyBitChunk--bitChunkTake :: Int64 -> BitChunk -> BitChunk-bitChunkTake k bc@(BitChunk ofs len dat) -  | k==0      = emptyBitChunk-  | k<=len    = BitChunk ofs k dat-  | otherwise = bc---- TODO: better implementation    -splitBitChunkAt :: Int64 -> BitChunk -> (BitChunk,BitChunk)    -splitBitChunkAt k b = (bitChunkTake k b, bitChunkDrop k b)  ------------------------------------------------------------------------------------{-# INLINE boolToWord8 #-}-boolToWord8 :: Bool -> Word8-boolToWord8 bool = case bool of-  True  -> 1-  False -> 0--{-# INLINE word8ToBool #-}-word8ToBool :: Word8 -> Bool-word8ToBool w = (w/=0)------------------------------------------------------------------------------------unsafeLookupBitChunk :: BitChunk -> Int64 -> Bool-unsafeLookupBitChunk chunk j = unsafeLookupBitChunk01 chunk j /= 0--unsafeLookupBitChunk01 :: BitChunk -> Int64 -> Word8-unsafeLookupBitChunk01 (BitChunk ofs len dat) j = bit where-  (n,k) = divMod (ofs+j) 8-  byte = B.index dat (fromIntegral n)-#ifndef BITSTRING_BIGENDIAN-  bit = ((shiftR byte (fromIntegral k)) .&. 1) -#else-  bit = ((shiftR byte (fromIntegral (7-k))) .&. 1) -#endif-----------------------------------------------------------------------------------  -bitChunkToList :: BitChunk -> [Bool]-bitChunkToList chunk@(BitChunk ofs len dat) = -  [ unsafeLookupBitChunk chunk k | k<-[0..len-1] ]--bitChunkFromList :: [Bool] -> BitChunk-bitChunkFromList bits = BitChunk 0 (fromIntegral len) (B.pack bytes) where-  (len,bytes) = worker bits-  worker []   = ( 0, [] )-  worker bits = ( len' + List.length this , byte:ys ) where-    (this,rest) = List.splitAt 8 bits-#ifndef BITSTRING_BIGENDIAN-    byte = List.foldl' (+) 0 $ zipWith shiftL (map boolToWord8 this) [0..7]-#else-    byte = List.foldl' (+) 0 $ zipWith shiftL (map boolToWord8 this) [7,6..0]-#endif-    (len' , ys) = worker rest--bitChunkTo01List :: BitChunk -> [Word8]-bitChunkTo01List chunk@(BitChunk ofs len dat) = -  [ unsafeLookupBitChunk01 chunk k | k<-[0..len-1] ]--bitChunkFrom01List :: [Word8] -> BitChunk-bitChunkFrom01List bits = BitChunk 0 (fromIntegral len) (B.pack bytes) where-  (len,bytes) = worker bits-  worker []   = ( 0, [] )-  worker bits = ( len' + List.length this , byte:ys ) where-    (this,rest) = List.splitAt 8 bits-#ifndef BITSTRING_BIGENDIAN-    byte = List.foldl' (+) 0 $ zipWith shiftL (map (.&. 1) this) [0..7]-#else-    byte = List.foldl' (+) 0 $ zipWith shiftL (map (.&. 1) this) [7,6..0]-#endif-    (len' , ys) = worker rest-    -instance Eq BitChunk where-  -- | warning! very slow! TODO: make a better routine---  (==) :: BitChunk -> BitChunk -> Bool-  (==) x y = bitChunkToList x == bitChunkToList y-    ------------------------------------------------------------------------------------- | Creates a new 'BitChunk' with offset field 0-realignBitChunk :: BitChunk -> BitChunk -realignBitChunk (BitChunk ofs len dat) = -  BitChunk 0 len $ case ofsFrac of -    0 -> dat'-    _ -> B.pack $ B.zipWith f dat' (B.snoc (B.tail dat') 0) -  where -    ofsFrac2 = 8 - ofsFrac-#ifndef BITSTRING_BIGENDIAN-    f b1 b2 = shiftR b1 (fromIntegral ofsFrac) + shiftL b2 (fromIntegral ofsFrac2)-#else-    f b1 b2 = shiftL b1 (fromIntegral ofsFrac) + shiftR b2 (fromIntegral ofsFrac2)-#endif    -    dat' = B.drop (fromIntegral ofsInt) dat-    (ofsInt, ofsFrac) = divMod ofs 8 -    -realizeBitChunk :: BitChunk -> (ByteString, Maybe (Word8,Int))-realizeBitChunk orig = (whole, end) where-  chunk@(BitChunk 0 len dat) = realignBitChunk orig-  (n,k) = divMod len 8-  whole = B.take (fromIntegral n) dat-  end = case k of-    0 -> Nothing-    _ -> let w' = B.index dat (fromIntegral n)-#ifndef BITSTRING_BIGENDIAN-             mask = 2^k - 1 :: Word8-             w = w' .&. mask-#else--- and at this point, the the inventor and users of big endianness deserve an extra fuck!-             kk = fromIntegral k :: Int-             mask = shiftL (2^kk-1) (8-kk) -             w = w' .&. mask-#endif-         in  Just (w, fromIntegral k) -           -----------------------------------------------------------------------------------unBitString :: BitString -> [BitChunk]-unBitString (BitString xs) = xs-  -newtype BitString = BitString [BitChunk] -#ifdef WITH_QUICKCHECK -  deriving Show-#else-instance Show BitString where-  show bits = "BitString <" ++ map f (to01List bits) ++ ">" where -    f 0 = '0'-    f 1 = '1'-    f _ = error "BitString/show: impossible"-#endif--empty :: BitString-empty = BitString [] -- emptyChunk]---- | Create a 'BitString' from a portion of a 'ByteString'.--- Warning! No boundary checks are performed!-unsafeBitString' -  :: Int64      -- ^ offset -  -> Int64      -- ^ length-  -> ByteString  -- ^ source -  -> BitString-unsafeBitString' ofs len bs = BitString [unsafeBitChunk' ofs len bs] ---- | Create a 'BitString' from a strict 'ByteString'-bitString :: ByteString -> BitString  -bitString bs = unsafeBitString' 0 (8 * fromIntegral (B.length bs)) bs---- | Create a 'BitString' from a lazy 'ByteString'-bitStringLazy :: L.ByteString -> BitString  -bitStringLazy = concat . map bitString . L.toChunks --drop :: Int64 -> BitString -> BitString-drop k (BitString cs) = BitString (worker k cs) where-  worker _ [] = []-  worker k (BitChunk ofs len dat : cs) = if k < len -    then BitChunk (ofs+k) (len-k) dat : cs-    else worker (k-len) cs--take :: Int64 -> BitString -> BitString-take k (BitString cs) = BitString (worker k cs) where-  worker 0 _  = []-  worker _ [] = []-  worker k (c@(BitChunk ofs len dat) : cs) = if k <= len -    then [ BitChunk ofs k dat ]-    else c : worker (k-len) cs---- TODO: better implementation    -splitAt :: Int64 -> BitString -> (BitString,BitString)    -splitAt k b = (take k b, drop k b)--append :: BitString -> BitString -> BitString    -append (BitString chunks1) (BitString chunks2) = BitString (chunks1 ++ chunks2)--concat :: [BitString] -> BitString-concat xs = case xs of-  [] -> empty-  _  -> (BitString . List.concat . map unBitString) xs   -- hmm how strict or lazy this should be?--toList :: BitString -> [Bool]-toList (BitString chunks) = List.concatMap bitChunkToList chunks--fromList :: [Bool] -> BitString-fromList digits = BitString [bitChunkFromList digits]--to01List :: BitString -> [Word8]-to01List (BitString chunks) = List.concatMap bitChunkTo01List chunks--from01List :: [Word8] -> BitString-from01List digits = BitString [bitChunkFrom01List digits]------------------------------------------------------------------------------------length :: BitString -> Int64-length (BitString chunks) = List.foldl' (+) 0 (map bitChunkLength chunks)--null :: BitString -> Bool-null bits = (length bits == 0)---- | warning! very slow! TODO: make a better routine-instance Eq BitString where-  -- (==) :: BitString -> BitString -> Bool-  (==) = fallbackEqual-  --- | slow, fallback equality test, via converting to list-fallbackEqual :: BitString -> BitString -> Bool-fallbackEqual x y = (toList x == toList y)------------------------------------------------------------------------------------foldl' :: (a -> Bool -> a) -> a -> BitString -> a-foldl' fun init bits = List.foldl' fun init (toList bits)------------------------------------------------------------------------------------findSubstring-  :: BitString    -- ^ the string to search for-  -> BitString    -- ^ the string to search in-  -> Maybe Int64  -- ^ the index of the first substring, if exists-findSubstring = findSubstring32---- the basic unit is a Word32-findSubstring32 -  :: BitString    -- ^ the string to search for-  -> BitString    -- ^ the string to search in-  -> Maybe Int64  -- ^ the index of the first substring, if exists-findSubstring32 small large = -  unsafePerformIO $ do-    withForeignPtr fptr_b_small $ \p'' -> do-      let p' = (plusPtr p'' ofs_b_small) :: Ptr Word8-      allocaArray (k+1) $ \q -> allocaArray (k+1) $ \p -> do-        -- we store in 'q' the last 'm' bits-        -- and in 'p' the bits we are searching for-        -#ifndef BITSTRING_BIGENDIAN-        let p8 = (castPtr :: Ptr Word32 -> Ptr Word8) p-        forM_ [0..len_b_small-1] $ \i -> do { x <- peekElemOff p' i ; pokeElemOff p8 i x }-        peekElemOff p k >>= \x -> pokeElemOff p k (x .&. mask)-        pokeElemOff q k 0   -- this is quite important, because of the shifts!-#else -        pokeElemOff p k 0   -- just to be on the safe side-        let p8 = (castPtr :: Ptr Word32 -> Ptr Word8) p-        forM_ [0..len_b_small-1] $ \i -> do { x <- peekElemOff p' i ; pokeElemOff p8 i x }-        forM_ [0..k] $ \j -> do { y <- peekElemOff p j ; pokeElemOff p j (byteReverseWord32 y) }-        peekElemOff p k >>= \x -> pokeElemOff p k (x .&. mask)-        pokeElemOff q k 0   -- this is quite important, because of the shifts!-#endif         --{--        print (m,m32)-        print len_b_small-        print hmm-        peekArray ((k+1)*4) (castPtr p :: Ptr Word8) >>= print       --}--        worker p q 0 (to01List large)-      -  where-    m = length small-    m32 = fromIntegral (mod m 32) :: Int    -    d32 = fromIntegral (div m 32) :: Int--    hmm :: (Int, Word32, Int)-    hmm@(k,mask,initShift) = case m32 of-#ifndef BITSTRING_BIGENDIAN    -      0 -> ( d32 - 1  , 0xffffffff     , 31                          )-      _ -> ( d32      , 2^m32  - 1     , fromIntegral (mod (m-1) 32) )-#else-      0 -> ( d32 - 1  , 0xffffffff                , 0                              )  -      _ -> ( d32      , shiftL (2^m32-1) (32-m32) , fromIntegral ( 32 - mod m 32 ) )-#endif    --    b_small = realizeBitStringStrict small-    (fptr_b_small, ofs_b_small, len_b_small) = B.toForeignPtr b_small-    -    worker :: Ptr Word32 -> Ptr Word32 -> Int64 -> [Word8] -> IO (Maybe Int64)-    worker !p !q !pos !bits = do----      peekArray ((k+1)*4) (castPtr q :: Ptr Word8) >>= print       --      conds <- forM [0..k-1] $ \j -> do { x <- peekElemOff p j ; y <- peekElemOff q j ; return (x==y) }-      cond  <- do { x <- peekElemOff p k ; y <- peekElemOff q k ; return (x .&. mask == y .&. mask) }-      if and (cond:conds) && pos >= m-        then return (Just (pos - m))-        else case bits of-          [] -> return Nothing-          (b:bs) -> do--#ifndef BITSTRING_BIGENDIAN-            let init_cr = (fromIntegral b , initShift)-            flippedFoldM_ init_cr [k,k-1..0] $ \(c,r) j -> do-              y <- peekElemOff q j-              let cr' = ( y .&. 1 , 31 )-              pokeElemOff q j (shiftR y 1 + shiftL c r)-              return cr'-            worker p q (pos+1) bs -#else-            let init_cr = (fromIntegral b , initShift)-            flippedFoldM_ init_cr [k,k-1..0] $ \(c,r) j -> do-              y <- peekElemOff q j-              let cr' = ( shiftR y 31 , 0 )-              pokeElemOff q j (shiftL y 1 + shiftL c r)-              return cr'-            worker p q (pos+1) bs -#endif-      -----------------------------------------------------------------------------------realizeBitString' :: BitString -> [ByteString]   -realizeBitString' (BitString chunks) = worker Nothing chunks where-  worker :: Maybe (Word8,Int) -> [BitChunk] -> [ByteString]-  worker rem (b:bs) = -    case rem of -      Nothing -> -        let (s, rem') = realizeBitChunk b-        in  s : worker rem' bs-      Just (w,k) -> -        if r >= q-          then B.singleton t : s : worker rem' bs-               -- (B.cons t s) : worker rem' bs-          else worker (Just (t, k+fromIntegral r)) bs-        where-          q = 8 - fromIntegral k-          r = bitChunkLength b-          (x,y) = splitBitChunkAt q b-          (s, rem') = realizeBitChunk y-#ifndef BITSTRING_BIGENDIAN          -          t = List.foldl' (+) w-            $ zipWith shiftL (bitChunkTo01List x) [k..]-#else-          -- also, fuck. and fuck, again.-          u = 7-k-          t = List.foldl' (+) w-            $ zipWith shiftL (bitChunkTo01List x) [u,u-1..]-#endif-  worker rem [] = case rem of-    Nothing    -> []-    Just (w,_) -> [B.singleton w] ---realizeBitStringLazy :: BitString -> L.ByteString-realizeBitStringLazy = L.fromChunks . realizeBitString'--realizeBitStringStrict :: BitString -> B.ByteString-realizeBitStringStrict = B.concat . realizeBitString'------------------------------------------------------------------------------------#ifdef WITH_QUICKCHECK--newtype Size     = Size     Int64  deriving Show-newtype BoolList = BoolList [Bool] deriving Show--newtype SearchFor = SearchFor BitString deriving Show--instance Arbitrary Size where-  arbitrary = Size <$> (fromIntegral :: Int -> Int64) <$> choose (0,64) -- 192)--instance Arbitrary BoolList where-  arbitrary = do-    Size k <- arbitrary -    BoolList <$> vector (fromIntegral k) --instance Arbitrary BitChunk where-  arbitrary = do-    k <- choose (0,24) :: Gen Int-    l <- choose (0,15) :: Gen Int-    BoolList list <- arbitrary-    let bits1 = bitChunkDrop (fromIntegral k) $ bitChunkFromList list-        len = bitChunkLength bits1-        bits2 = bitChunkTake (max 0 $ len - fromIntegral l) bits1-    return bits2---- with 48 bits, it's unlikely that there are other random appearances -instance Arbitrary SearchFor where-  arbitrary = do-    b <- arbitrary-    let l = length b-    if l >= 48 && l < 96 -      then return (SearchFor b) -      else arbitrary-    -instance Arbitrary BitString where-  arbitrary = do-    k <- choose (0,7)-    BitString <$> vector k --runAllTest :: IO ()     -runAllTest = do-  let mytest (text,prop) = do-        print text-        quickCheck prop-        -  mytest ("fromToList"    , prop_fromToList )-  mytest ("toFromList"    , prop_toFromList )-  mytest ("append"       , prop_append     )-  mytest ("drop"         , prop_drop       )-  mytest ("take"         , prop_take       )-  mytest ("dropChunk"    , prop_dropChunk  )-  mytest ("takeChunk"    , prop_takeChunk  )-  mytest ("realign"      , prop_realign    )-  mytest ("realizeChunk" , prop_realizeChunk )-  mytest ("realize"      , prop_realize      )-  mytest ("realize"      , prop_realize      )-  mytest ("realize"      , prop_realize      )-  mytest ("realize"      , prop_realize      )-  mytest ("realizeLen"   , prop_realizeLen   )--  mytest ("findSubstring1"  , prop_findSubstring1  )-  mytest ("findSubstring1"  , prop_findSubstring1  )-  mytest ("findSubstring1"  , prop_findSubstring1  )-  mytest ("findSubstring1"  , prop_findSubstring1  )-  mytest ("findSubstring1a" , prop_findSubstring1a )-  mytest ("findSubstring1b" , prop_findSubstring1b )-  mytest ("findSubstring2"  , prop_findSubstring2  )--prop_fromToList :: BitString -> Bool-prop_fromToList bits = fromList (toList bits) == bits--prop_toFromList :: BoolList -> Bool-prop_toFromList (BoolList list) = toList (fromList list) == list--prop_append :: [BitString] -> Bool-prop_append xs = toList (concat xs) == List.concat (map toList xs)--prop_drop :: Size -> BitString -> Bool-prop_drop (Size k) xs = toList (drop k xs) == List.drop (fromIntegral k) (toList xs)--prop_take :: Size -> BitString -> Bool-prop_take (Size k) xs = toList (take k xs) == List.take (fromIntegral k) (toList xs)--prop_dropChunk :: Size -> BitChunk -> Bool-prop_dropChunk (Size k) xs = bitChunkToList (bitChunkDrop k xs) == List.drop (fromIntegral k) (bitChunkToList xs)--prop_takeChunk :: Size -> BitChunk -> Bool-prop_takeChunk (Size k) xs = bitChunkToList (bitChunkTake k xs) == List.take (fromIntegral k) (bitChunkToList xs)--prop_realign :: BitChunk -> Bool-prop_realign chunk = realignBitChunk chunk == chunk--prop_realizeChunk :: BitChunk -> Bool-prop_realizeChunk chunk = append (bitString whole) (BitString [end]) == BitString [chunk] where-  (whole,remain) = realizeBitChunk chunk-  end = case remain of-    Nothing -> emptyBitChunk-    Just (w,k) -> BitChunk 0 (fromIntegral k) (B.singleton w)--prop_realize :: BitString -> Bool-prop_realize bits = let n = length bits in unsafeBitString' 0 n (realizeBitStringStrict bits) == bits--prop_realizeLen :: BitString -> Bool-prop_realizeLen bits = let n = length bits in div (n+7) 8 == (fromIntegral $ B.length $ realizeBitStringStrict bits) -    -prop_findSubstring1 :: SearchFor -> BitString -> BitString -> Bool-prop_findSubstring1 (SearchFor what) pre post = findSubstring what big == Just (length pre) where-  big = concat [ pre , what , post ] --prop_findSubstring1a :: SearchFor -> BitString -> Bool-prop_findSubstring1a (SearchFor what) pre = findSubstring what big == Just (length pre) where-  big = concat [ pre , what ] --prop_findSubstring1b :: SearchFor -> BitString -> Bool-prop_findSubstring1b (SearchFor what) post = findSubstring what big == Just 0 where-  big = concat [ what , post  ] --prop_findSubstring2 :: SearchFor -> BitString -> BitString -> Bool-prop_findSubstring2 (SearchFor what) pre post = findSubstring what big == Nothing where-  big = concat [ pre , post ] ---------  -{-  -test = BitString xxx--xxx =-  [ BitChunk 17 49 (mypack "9\176N\152%\f\STX\144\ETX")-  , BitChunk 22 50 (mypack "\148\&6\184\RS\134\144+\241\210")-  , BitChunk 0 0 (mypack "")-  , BitChunk 0 0 (mypack "")-  , BitChunk 0 9 (mypack "$\NUL")-  ]  - -yyy = map (bitChunk) $ realizeBitString' test--}--{--let what = (BitString [BitChunk 0 16 (mypack "c\229W"),BitChunk 0 0 (mypack ""),BitChunk 20 13 (mypack "\169\188\"\DLEf\EOT"),BitChunk 0 0 (mypack ""),BitChunk 3 9 (mypack "/\FS+"),BitChunk 21 26 (mypack "&,\159\249\158&h\STX"),BitChunk 0 0 (mypack "")])--let pre = BitString [BitChunk 3 13 (mypack "\245\200\180\NUL"),BitChunk 17 4 (mypack "{\SI\DC2"),BitChunk 24 33 (mypack "\207\135W\RS\240\180{\SOH")]--let post = BitString [BitChunk 16 19 (mypack "e\142\&0z\209m\NUL"),BitChunk 14 27 (mypack "\248m\207\146\&8\224\NUL")]--}+-- --------  -#endif // WITH_QUICKCHECK+module Data.BitString ---------------------------------------------------------------------------------+#include "BitString.inc"

@@ -1,692 +1,17 @@--- DO NOT EDIT THIS FILE-{-# OPTIONS_GHC -DBITSTRING_BIGENDIAN #-}-- {-# LANGUAGE CPP, BangPatterns #-} --- #define BITSTRING_BIGENDIAN--- #define WITH_QUICKCHECK+#define BITSTRING_BIGENDIAN -#ifndef BITSTRING_BIGENDIAN--- | Lazy bitstrings, somewhat similar to lazy bytestrings.+-- | Lazy, big-endian bitstrings, somewhat similar to lazy bytestrings.+--+-- In this context, \"big-endian\" means that the bits in the bytes +-- are in the opposite order than what would be logical. If you ask me, +-- this is doesn't make too much sense, but this convention apparently still +-- have usage...+-- -- This module is intended to be imported qualified.-module Data.BitString -#else--- | Big-endian bitstrings. In this context, \"big-endian\" means that--- the bits in the bytes are in the opposite order than what would be--- logical. If you ask me, this is just plain stupid, but some people--- apparently still use it...-module Data.BitString.BigEndian-#endif--  (-    BitString-    ---  , empty-  , bitString-  , bitStringLazy-  , unsafeBitString'-    ---  , take-  , drop-  , splitAt-  , append-  , concat-    ---  , toList-  , fromList-  , to01List-  , from01List-    ---  , null-  , length-    ---  , foldl'-  , findSubstring-    ---  , realizeBitStringLazy-  , realizeBitStringStrict-  , realizeBitString'  -    ---#ifdef WITH_QUICKCHECK-  , runAllTest-  , BitChunk (..)-  , BitString ( BitString )-  , mypack-  , prop_fromToList -  , prop_toFromList -  , prop_append     -  , prop_drop       -  , prop_take       -  , prop_dropChunk  -  , prop_takeChunk  -  , prop_realign    -  , prop_realizeChunk -  , prop_realize      -  , prop_realizeLen      -  , prop_findSubstring1 -  , prop_findSubstring1a -  , prop_findSubstring1b -  , prop_findSubstring2 -#endif        -  )-  where-  -----------------------------------------------------------------------------------import Prelude hiding (take,drop,last,length,splitAt,concat,null,rem,init)--import Control.Monad-import Control.Applicative hiding ( empty )--import Data.Bits ()-import Data.Int  ()-import Data.Word ()-import Data.Maybe-import qualified Data.List as List--import Data.ByteString (ByteString)-import qualified Data.ByteString          as B-import qualified Data.ByteString.Internal as B--- import qualified Data.ByteString.Unsafe   as U-import qualified Data.ByteString.Lazy     as L--#ifdef WITH_QUICKCHECK-import Test.QuickCheck hiding ( (.&.) )-import qualified Data.ByteString.Char8 as BC-import Data.Char (ord)-#endif--import Foreign-import System.IO.Unsafe------------------------------------------------------------------------------------flippedFoldM_ :: Monad m => a -> [b] -> (a -> b -> m a) -> m () -flippedFoldM_ x ys f = foldM_ f x ys--flippedFoldM ::  Monad m => a -> [b] -> (a -> b -> m a) -> m a -flippedFoldM x ys f = foldM f x ys------------------------------------------------------------------------------------#ifdef BITSTRING_BIGENDIAN--{--bitReverseWord8_naive :: Word8 -> Word8-bitReverseWord8_naive x -  = shiftR (x .&. 0x80) 7-  + shiftR (x .&. 0x40) 5-  + shiftR (x .&. 0x20) 3-  + shiftR (x .&. 0x10) 1-  + shiftL (x .&. 0x08) 1-  + shiftL (x .&. 0x04) 3-  + shiftL (x .&. 0x02) 5-  + shiftL (x .&. 0x01) 7-     -bitReverseWord8_table :: ByteString     -bitReverseWord8_table = B.pack $ map reverseWord8_naive [0..255]--bitReverseWord8 :: Word8 -> Word8-bitReverseWord8 = U.unsafeIndex reverseWord8_table . fromIntegral--}--byteReverseWord32 :: Word32 -> Word32-byteReverseWord32 w -  = shiftR w 24 -  + shiftR w 8  .&. 0x0000ff00 -  + shiftL w 8  .&. 0x00ff0000 -  + shiftL w 24--#endif // BITSTRING_BIGENDIAN------------------------------------------------------------------------------------data BitChunk = BitChunk-  { bitChunkOffset :: !Int64-  , bitChunkLength :: !Int64-  , bitChunkData   :: !ByteString-  }--#ifdef WITH_QUICKCHECK--mypack :: String -> ByteString-mypack = B.pack . map c2w where-  c2w = fromIntegral . ord--instance Show BitChunk where-  show (BitChunk ofs len dat) = "BitChunk " ++ show ofs ++ " " ++ show len ++ " (mypack " ++ show dat ++ ")"--#else  --instance Show BitChunk where-  show chunk = "BitChunk <" ++ map f (bitChunkTo01List chunk) ++ ">" where -    f 0 = '0'-    f 1 = '1'--#endif // WITH_QUICKCHECK--emptyBitChunk :: BitChunk-emptyBitChunk = BitChunk 0 0 B.empty--{-  -bitChunk' :: Int64 -> ByteString -> BitChunk  -bitChunk' ofs bs = BitString ofs (len-ofs) bs where -  len = 8 * fromIntegral (B.length bs)--}---- | warning! no boundary checks-unsafeBitChunk'  -  :: Int64      -- ^ offset -  -> Int64      -- ^ length-  -> ByteString  -- ^ source-  -> BitChunk -unsafeBitChunk' ofs len dat = BitChunk ofs len dat where --bitChunk :: ByteString -> BitChunk  -bitChunk bs = unsafeBitChunk' 0 (8 * fromIntegral (B.length bs)) bs------------------------------------------------------------------------------------bitChunkDrop :: Int64 -> BitChunk -> BitChunk-bitChunkDrop k (BitChunk ofs len dat) = if k<len-  then BitChunk (ofs+k) (len-k) dat-  else emptyBitChunk--bitChunkTake :: Int64 -> BitChunk -> BitChunk-bitChunkTake k bc@(BitChunk ofs len dat) -  | k==0      = emptyBitChunk-  | k<=len    = BitChunk ofs k dat-  | otherwise = bc---- TODO: better implementation    -splitBitChunkAt :: Int64 -> BitChunk -> (BitChunk,BitChunk)    -splitBitChunkAt k b = (bitChunkTake k b, bitChunkDrop k b)  ------------------------------------------------------------------------------------{-# INLINE boolToWord8 #-}-boolToWord8 :: Bool -> Word8-boolToWord8 bool = case bool of-  True  -> 1-  False -> 0--{-# INLINE word8ToBool #-}-word8ToBool :: Word8 -> Bool-word8ToBool w = (w/=0)------------------------------------------------------------------------------------unsafeLookupBitChunk :: BitChunk -> Int64 -> Bool-unsafeLookupBitChunk chunk j = unsafeLookupBitChunk01 chunk j /= 0--unsafeLookupBitChunk01 :: BitChunk -> Int64 -> Word8-unsafeLookupBitChunk01 (BitChunk ofs len dat) j = bit where-  (n,k) = divMod (ofs+j) 8-  byte = B.index dat (fromIntegral n)-#ifndef BITSTRING_BIGENDIAN-  bit = ((shiftR byte (fromIntegral k)) .&. 1) -#else-  bit = ((shiftR byte (fromIntegral (7-k))) .&. 1) -#endif-----------------------------------------------------------------------------------  -bitChunkToList :: BitChunk -> [Bool]-bitChunkToList chunk@(BitChunk ofs len dat) = -  [ unsafeLookupBitChunk chunk k | k<-[0..len-1] ]--bitChunkFromList :: [Bool] -> BitChunk-bitChunkFromList bits = BitChunk 0 (fromIntegral len) (B.pack bytes) where-  (len,bytes) = worker bits-  worker []   = ( 0, [] )-  worker bits = ( len' + List.length this , byte:ys ) where-    (this,rest) = List.splitAt 8 bits-#ifndef BITSTRING_BIGENDIAN-    byte = List.foldl' (+) 0 $ zipWith shiftL (map boolToWord8 this) [0..7]-#else-    byte = List.foldl' (+) 0 $ zipWith shiftL (map boolToWord8 this) [7,6..0]-#endif-    (len' , ys) = worker rest--bitChunkTo01List :: BitChunk -> [Word8]-bitChunkTo01List chunk@(BitChunk ofs len dat) = -  [ unsafeLookupBitChunk01 chunk k | k<-[0..len-1] ]--bitChunkFrom01List :: [Word8] -> BitChunk-bitChunkFrom01List bits = BitChunk 0 (fromIntegral len) (B.pack bytes) where-  (len,bytes) = worker bits-  worker []   = ( 0, [] )-  worker bits = ( len' + List.length this , byte:ys ) where-    (this,rest) = List.splitAt 8 bits-#ifndef BITSTRING_BIGENDIAN-    byte = List.foldl' (+) 0 $ zipWith shiftL (map (.&. 1) this) [0..7]-#else-    byte = List.foldl' (+) 0 $ zipWith shiftL (map (.&. 1) this) [7,6..0]-#endif-    (len' , ys) = worker rest-    -instance Eq BitChunk where-  -- | warning! very slow! TODO: make a better routine---  (==) :: BitChunk -> BitChunk -> Bool-  (==) x y = bitChunkToList x == bitChunkToList y-    ------------------------------------------------------------------------------------- | Creates a new 'BitChunk' with offset field 0-realignBitChunk :: BitChunk -> BitChunk -realignBitChunk (BitChunk ofs len dat) = -  BitChunk 0 len $ case ofsFrac of -    0 -> dat'-    _ -> B.pack $ B.zipWith f dat' (B.snoc (B.tail dat') 0) -  where -    ofsFrac2 = 8 - ofsFrac-#ifndef BITSTRING_BIGENDIAN-    f b1 b2 = shiftR b1 (fromIntegral ofsFrac) + shiftL b2 (fromIntegral ofsFrac2)-#else-    f b1 b2 = shiftL b1 (fromIntegral ofsFrac) + shiftR b2 (fromIntegral ofsFrac2)-#endif    -    dat' = B.drop (fromIntegral ofsInt) dat-    (ofsInt, ofsFrac) = divMod ofs 8 -    -realizeBitChunk :: BitChunk -> (ByteString, Maybe (Word8,Int))-realizeBitChunk orig = (whole, end) where-  chunk@(BitChunk 0 len dat) = realignBitChunk orig-  (n,k) = divMod len 8-  whole = B.take (fromIntegral n) dat-  end = case k of-    0 -> Nothing-    _ -> let w' = B.index dat (fromIntegral n)-#ifndef BITSTRING_BIGENDIAN-             mask = 2^k - 1 :: Word8-             w = w' .&. mask-#else--- and at this point, the the inventor and users of big endianness deserve an extra fuck!-             kk = fromIntegral k :: Int-             mask = shiftL (2^kk-1) (8-kk) -             w = w' .&. mask-#endif-         in  Just (w, fromIntegral k) -           -----------------------------------------------------------------------------------unBitString :: BitString -> [BitChunk]-unBitString (BitString xs) = xs-  -newtype BitString = BitString [BitChunk] -#ifdef WITH_QUICKCHECK -  deriving Show-#else-instance Show BitString where-  show bits = "BitString <" ++ map f (to01List bits) ++ ">" where -    f 0 = '0'-    f 1 = '1'-    f _ = error "BitString/show: impossible"-#endif--empty :: BitString-empty = BitString [] -- emptyChunk]---- | Create a 'BitString' from a portion of a 'ByteString'.--- Warning! No boundary checks are performed!-unsafeBitString' -  :: Int64      -- ^ offset -  -> Int64      -- ^ length-  -> ByteString  -- ^ source -  -> BitString-unsafeBitString' ofs len bs = BitString [unsafeBitChunk' ofs len bs] ---- | Create a 'BitString' from a strict 'ByteString'-bitString :: ByteString -> BitString  -bitString bs = unsafeBitString' 0 (8 * fromIntegral (B.length bs)) bs---- | Create a 'BitString' from a lazy 'ByteString'-bitStringLazy :: L.ByteString -> BitString  -bitStringLazy = concat . map bitString . L.toChunks --drop :: Int64 -> BitString -> BitString-drop k (BitString cs) = BitString (worker k cs) where-  worker _ [] = []-  worker k (BitChunk ofs len dat : cs) = if k < len -    then BitChunk (ofs+k) (len-k) dat : cs-    else worker (k-len) cs--take :: Int64 -> BitString -> BitString-take k (BitString cs) = BitString (worker k cs) where-  worker 0 _  = []-  worker _ [] = []-  worker k (c@(BitChunk ofs len dat) : cs) = if k <= len -    then [ BitChunk ofs k dat ]-    else c : worker (k-len) cs---- TODO: better implementation    -splitAt :: Int64 -> BitString -> (BitString,BitString)    -splitAt k b = (take k b, drop k b)--append :: BitString -> BitString -> BitString    -append (BitString chunks1) (BitString chunks2) = BitString (chunks1 ++ chunks2)--concat :: [BitString] -> BitString-concat xs = case xs of-  [] -> empty-  _  -> (BitString . List.concat . map unBitString) xs   -- hmm how strict or lazy this should be?--toList :: BitString -> [Bool]-toList (BitString chunks) = List.concatMap bitChunkToList chunks--fromList :: [Bool] -> BitString-fromList digits = BitString [bitChunkFromList digits]--to01List :: BitString -> [Word8]-to01List (BitString chunks) = List.concatMap bitChunkTo01List chunks--from01List :: [Word8] -> BitString-from01List digits = BitString [bitChunkFrom01List digits]------------------------------------------------------------------------------------length :: BitString -> Int64-length (BitString chunks) = List.foldl' (+) 0 (map bitChunkLength chunks)--null :: BitString -> Bool-null bits = (length bits == 0)---- | warning! very slow! TODO: make a better routine-instance Eq BitString where-  -- (==) :: BitString -> BitString -> Bool-  (==) = fallbackEqual-  --- | slow, fallback equality test, via converting to list-fallbackEqual :: BitString -> BitString -> Bool-fallbackEqual x y = (toList x == toList y)------------------------------------------------------------------------------------foldl' :: (a -> Bool -> a) -> a -> BitString -> a-foldl' fun init bits = List.foldl' fun init (toList bits)------------------------------------------------------------------------------------findSubstring-  :: BitString    -- ^ the string to search for-  -> BitString    -- ^ the string to search in-  -> Maybe Int64  -- ^ the index of the first substring, if exists-findSubstring = findSubstring32---- the basic unit is a Word32-findSubstring32 -  :: BitString    -- ^ the string to search for-  -> BitString    -- ^ the string to search in-  -> Maybe Int64  -- ^ the index of the first substring, if exists-findSubstring32 small large = -  unsafePerformIO $ do-    withForeignPtr fptr_b_small $ \p'' -> do-      let p' = (plusPtr p'' ofs_b_small) :: Ptr Word8-      allocaArray (k+1) $ \q -> allocaArray (k+1) $ \p -> do-        -- we store in 'q' the last 'm' bits-        -- and in 'p' the bits we are searching for-        -#ifndef BITSTRING_BIGENDIAN-        let p8 = (castPtr :: Ptr Word32 -> Ptr Word8) p-        forM_ [0..len_b_small-1] $ \i -> do { x <- peekElemOff p' i ; pokeElemOff p8 i x }-        peekElemOff p k >>= \x -> pokeElemOff p k (x .&. mask)-        pokeElemOff q k 0   -- this is quite important, because of the shifts!-#else -        pokeElemOff p k 0   -- just to be on the safe side-        let p8 = (castPtr :: Ptr Word32 -> Ptr Word8) p-        forM_ [0..len_b_small-1] $ \i -> do { x <- peekElemOff p' i ; pokeElemOff p8 i x }-        forM_ [0..k] $ \j -> do { y <- peekElemOff p j ; pokeElemOff p j (byteReverseWord32 y) }-        peekElemOff p k >>= \x -> pokeElemOff p k (x .&. mask)-        pokeElemOff q k 0   -- this is quite important, because of the shifts!-#endif         --{--        print (m,m32)-        print len_b_small-        print hmm-        peekArray ((k+1)*4) (castPtr p :: Ptr Word8) >>= print       --}--        worker p q 0 (to01List large)-      -  where-    m = length small-    m32 = fromIntegral (mod m 32) :: Int    -    d32 = fromIntegral (div m 32) :: Int--    hmm :: (Int, Word32, Int)-    hmm@(k,mask,initShift) = case m32 of-#ifndef BITSTRING_BIGENDIAN    -      0 -> ( d32 - 1  , 0xffffffff     , 31                          )-      _ -> ( d32      , 2^m32  - 1     , fromIntegral (mod (m-1) 32) )-#else-      0 -> ( d32 - 1  , 0xffffffff                , 0                              )  -      _ -> ( d32      , shiftL (2^m32-1) (32-m32) , fromIntegral ( 32 - mod m 32 ) )-#endif    --    b_small = realizeBitStringStrict small-    (fptr_b_small, ofs_b_small, len_b_small) = B.toForeignPtr b_small-    -    worker :: Ptr Word32 -> Ptr Word32 -> Int64 -> [Word8] -> IO (Maybe Int64)-    worker !p !q !pos !bits = do----      peekArray ((k+1)*4) (castPtr q :: Ptr Word8) >>= print       --      conds <- forM [0..k-1] $ \j -> do { x <- peekElemOff p j ; y <- peekElemOff q j ; return (x==y) }-      cond  <- do { x <- peekElemOff p k ; y <- peekElemOff q k ; return (x .&. mask == y .&. mask) }-      if and (cond:conds) && pos >= m-        then return (Just (pos - m))-        else case bits of-          [] -> return Nothing-          (b:bs) -> do--#ifndef BITSTRING_BIGENDIAN-            let init_cr = (fromIntegral b , initShift)-            flippedFoldM_ init_cr [k,k-1..0] $ \(c,r) j -> do-              y <- peekElemOff q j-              let cr' = ( y .&. 1 , 31 )-              pokeElemOff q j (shiftR y 1 + shiftL c r)-              return cr'-            worker p q (pos+1) bs -#else-            let init_cr = (fromIntegral b , initShift)-            flippedFoldM_ init_cr [k,k-1..0] $ \(c,r) j -> do-              y <- peekElemOff q j-              let cr' = ( shiftR y 31 , 0 )-              pokeElemOff q j (shiftL y 1 + shiftL c r)-              return cr'-            worker p q (pos+1) bs -#endif-      -----------------------------------------------------------------------------------realizeBitString' :: BitString -> [ByteString]   -realizeBitString' (BitString chunks) = worker Nothing chunks where-  worker :: Maybe (Word8,Int) -> [BitChunk] -> [ByteString]-  worker rem (b:bs) = -    case rem of -      Nothing -> -        let (s, rem') = realizeBitChunk b-        in  s : worker rem' bs-      Just (w,k) -> -        if r >= q-          then B.singleton t : s : worker rem' bs-               -- (B.cons t s) : worker rem' bs-          else worker (Just (t, k+fromIntegral r)) bs-        where-          q = 8 - fromIntegral k-          r = bitChunkLength b-          (x,y) = splitBitChunkAt q b-          (s, rem') = realizeBitChunk y-#ifndef BITSTRING_BIGENDIAN          -          t = List.foldl' (+) w-            $ zipWith shiftL (bitChunkTo01List x) [k..]-#else-          -- also, fuck. and fuck, again.-          u = 7-k-          t = List.foldl' (+) w-            $ zipWith shiftL (bitChunkTo01List x) [u,u-1..]-#endif-  worker rem [] = case rem of-    Nothing    -> []-    Just (w,_) -> [B.singleton w] ---realizeBitStringLazy :: BitString -> L.ByteString-realizeBitStringLazy = L.fromChunks . realizeBitString'--realizeBitStringStrict :: BitString -> B.ByteString-realizeBitStringStrict = B.concat . realizeBitString'------------------------------------------------------------------------------------#ifdef WITH_QUICKCHECK--newtype Size     = Size     Int64  deriving Show-newtype BoolList = BoolList [Bool] deriving Show--newtype SearchFor = SearchFor BitString deriving Show--instance Arbitrary Size where-  arbitrary = Size <$> (fromIntegral :: Int -> Int64) <$> choose (0,64) -- 192)--instance Arbitrary BoolList where-  arbitrary = do-    Size k <- arbitrary -    BoolList <$> vector (fromIntegral k) --instance Arbitrary BitChunk where-  arbitrary = do-    k <- choose (0,24) :: Gen Int-    l <- choose (0,15) :: Gen Int-    BoolList list <- arbitrary-    let bits1 = bitChunkDrop (fromIntegral k) $ bitChunkFromList list-        len = bitChunkLength bits1-        bits2 = bitChunkTake (max 0 $ len - fromIntegral l) bits1-    return bits2---- with 48 bits, it's unlikely that there are other random appearances -instance Arbitrary SearchFor where-  arbitrary = do-    b <- arbitrary-    let l = length b-    if l >= 48 && l < 96 -      then return (SearchFor b) -      else arbitrary-    -instance Arbitrary BitString where-  arbitrary = do-    k <- choose (0,7)-    BitString <$> vector k --runAllTest :: IO ()     -runAllTest = do-  let mytest (text,prop) = do-        print text-        quickCheck prop-        -  mytest ("fromToList"    , prop_fromToList )-  mytest ("toFromList"    , prop_toFromList )-  mytest ("append"       , prop_append     )-  mytest ("drop"         , prop_drop       )-  mytest ("take"         , prop_take       )-  mytest ("dropChunk"    , prop_dropChunk  )-  mytest ("takeChunk"    , prop_takeChunk  )-  mytest ("realign"      , prop_realign    )-  mytest ("realizeChunk" , prop_realizeChunk )-  mytest ("realize"      , prop_realize      )-  mytest ("realize"      , prop_realize      )-  mytest ("realize"      , prop_realize      )-  mytest ("realize"      , prop_realize      )-  mytest ("realizeLen"   , prop_realizeLen   )--  mytest ("findSubstring1"  , prop_findSubstring1  )-  mytest ("findSubstring1"  , prop_findSubstring1  )-  mytest ("findSubstring1"  , prop_findSubstring1  )-  mytest ("findSubstring1"  , prop_findSubstring1  )-  mytest ("findSubstring1a" , prop_findSubstring1a )-  mytest ("findSubstring1b" , prop_findSubstring1b )-  mytest ("findSubstring2"  , prop_findSubstring2  )--prop_fromToList :: BitString -> Bool-prop_fromToList bits = fromList (toList bits) == bits--prop_toFromList :: BoolList -> Bool-prop_toFromList (BoolList list) = toList (fromList list) == list--prop_append :: [BitString] -> Bool-prop_append xs = toList (concat xs) == List.concat (map toList xs)--prop_drop :: Size -> BitString -> Bool-prop_drop (Size k) xs = toList (drop k xs) == List.drop (fromIntegral k) (toList xs)--prop_take :: Size -> BitString -> Bool-prop_take (Size k) xs = toList (take k xs) == List.take (fromIntegral k) (toList xs)--prop_dropChunk :: Size -> BitChunk -> Bool-prop_dropChunk (Size k) xs = bitChunkToList (bitChunkDrop k xs) == List.drop (fromIntegral k) (bitChunkToList xs)--prop_takeChunk :: Size -> BitChunk -> Bool-prop_takeChunk (Size k) xs = bitChunkToList (bitChunkTake k xs) == List.take (fromIntegral k) (bitChunkToList xs)--prop_realign :: BitChunk -> Bool-prop_realign chunk = realignBitChunk chunk == chunk--prop_realizeChunk :: BitChunk -> Bool-prop_realizeChunk chunk = append (bitString whole) (BitString [end]) == BitString [chunk] where-  (whole,remain) = realizeBitChunk chunk-  end = case remain of-    Nothing -> emptyBitChunk-    Just (w,k) -> BitChunk 0 (fromIntegral k) (B.singleton w)--prop_realize :: BitString -> Bool-prop_realize bits = let n = length bits in unsafeBitString' 0 n (realizeBitStringStrict bits) == bits--prop_realizeLen :: BitString -> Bool-prop_realizeLen bits = let n = length bits in div (n+7) 8 == (fromIntegral $ B.length $ realizeBitStringStrict bits) -    -prop_findSubstring1 :: SearchFor -> BitString -> BitString -> Bool-prop_findSubstring1 (SearchFor what) pre post = findSubstring what big == Just (length pre) where-  big = concat [ pre , what , post ] --prop_findSubstring1a :: SearchFor -> BitString -> Bool-prop_findSubstring1a (SearchFor what) pre = findSubstring what big == Just (length pre) where-  big = concat [ pre , what ] --prop_findSubstring1b :: SearchFor -> BitString -> Bool-prop_findSubstring1b (SearchFor what) post = findSubstring what big == Just 0 where-  big = concat [ what , post  ] --prop_findSubstring2 :: SearchFor -> BitString -> BitString -> Bool-prop_findSubstring2 (SearchFor what) pre post = findSubstring what big == Nothing where-  big = concat [ pre , post ] ---------  -{-  -test = BitString xxx--xxx =-  [ BitChunk 17 49 (mypack "9\176N\152%\f\STX\144\ETX")-  , BitChunk 22 50 (mypack "\148\&6\184\RS\134\144+\241\210")-  , BitChunk 0 0 (mypack "")-  , BitChunk 0 0 (mypack "")-  , BitChunk 0 9 (mypack "$\NUL")-  ]  - -yyy = map (bitChunk) $ realizeBitString' test--}--{--let what = (BitString [BitChunk 0 16 (mypack "c\229W"),BitChunk 0 0 (mypack ""),BitChunk 20 13 (mypack "\169\188\"\DLEf\EOT"),BitChunk 0 0 (mypack ""),BitChunk 3 9 (mypack "/\FS+"),BitChunk 21 26 (mypack "&,\159\249\158&h\STX"),BitChunk 0 0 (mypack "")])--let pre = BitString [BitChunk 3 13 (mypack "\245\200\180\NUL"),BitChunk 17 4 (mypack "{\SI\DC2"),BitChunk 24 33 (mypack "\207\135W\RS\240\180{\SOH")]--let post = BitString [BitChunk 16 19 (mypack "e\142\&0z\209m\NUL"),BitChunk 14 27 (mypack "\248m\207\146\&8\224\NUL")]--}+-- --------  -#endif // WITH_QUICKCHECK+module Data.BitString.BigEndian  ---------------------------------------------------------------------------------+#include "BitString.inc"

@@ -1,39 +0,0 @@-#! /usr/bin/env runhaskell->-> import Control.Monad-> import Distribution.Simple-> import Distribution.PackageDescription-> import System.IO-> import System.Directory->-> copyFileWithPrefix src tgt prefix = ->   readFile src >>= \txt -> writeFile tgt (prefix ++ txt)->-> copyFiles srcdir tgtdir prefix = do->   files <- getDirectoryContents srcdir->   forM_ files $ \fname -> do->     let src = srcdir ++ fname->         tgt = tgtdir ++ fname->     doesFileExist src >>= \b -> when b $ copyFileWithPrefix src tgt prefix->     doesDirectoryExist src>>= \b -> when ( b && fname /= "." && fname /= ".." ) $ do->       createDirectoryIfMissing False tgt->       copyFiles (src ++ "/") (tgt ++ "/") prefix->-> thePrefix = "-- DO NOT EDIT THIS FILE\n{-# OPTIONS_GHC -DBITSTRING_BIGENDIAN #-}\n"->-> myPreBuildHook args buildflags = do->   createDirectoryIfMissing False "Data/BitString"->   copyFileWithPrefix "Data/BitString.hs" "Data/BitString/BigEndian.hs" thePrefix->   return $ emptyHookedBuildInfo  ->-> myPostCleanHook args cleanflags pdep mlocalbuildinfo = do->   removeDirectoryRecursive "Data/BitString"->-> myUserHooks = simpleUserHooks ->   { preBuild = myPreBuildHook ->   , postClean = myPostCleanHook->   }->-> main = do->   defaultMainWithHooks myUserHooks->

@@ -1,18 +1,20 @@+Cabal-Version:       2.2 Name:                bitstring-Version:             0.0.0+Version:             0.0.1 Synopsis:            Lazy bit strings Description:         Lazy bit strings, built on the top of bytestrings.-License:             BSD3+License:             BSD-3-Clause License-file:        LICENSE Author:              Balazs Komuves Maintainer:          bkomuves (plus) hackage (at) gmail (dot) com-Homepage:            http://code.haskell.org/~bkomuves/+Homepage:            https://github.com/bkomuves/bitstring Stability:           Experimental Category:            Data-Tested-With:         GHC == 6.10.1 -Cabal-Version:       >= 1.6-Build-Type:          Custom+Tested-With:         GHC == 9.12.1+Build-Type:          Simple +extra-source-files:  ./include/BitString.inc+ Flag base4   Description: Base v4  @@ -20,6 +22,7 @@   Description: Build with QuickCheck test. Note that Show instances will be different.   Default: False + Library    if flag(base4)@@ -33,14 +36,16 @@     Build-Depends:        QuickCheck == 2.*     cpp-options:          -DWITH_QUICKCHECK -  Build-Depends:       bytestring+  Build-Depends:       bytestring >= 0.10 && < 0.13      Exposed-Modules:     Data.BitString,                        Data.BitString.BigEndian      Hs-Source-Dirs:      .-    -  Extensions:          CPP-  ghc-options:         -Wall +  include-dirs:        ./include++  default-language:    Haskell2010+  other-extensions:    CPP+  ghc-options:         -Wno-name-shadowing -Wno-duplicate-exports      

@@ -0,0 +1,688 @@++  (+    BitString+    --+  , empty+  , bitString+  , bitStringLazy+  , unsafeBitString'+    --+  , showBitString+  , debugShowBitString+    --+  , take+  , drop+  , splitAt+  , append+  , concat+    --+  , toList+  , fromList+  , to01List+  , from01List+    --+  , null+  , length+    --+  , foldl'+  , findSubstring+    --+  , realizeBitStringLazy+  , realizeBitStringStrict+  , realizeBitString'  +    --+#ifdef WITH_QUICKCHECK+  , runAllTest+  , runAllTest'+  , BitChunk (..)+  , BitString ( MkBitString )+  , showBitChunk+  , debugShowBitChunk+  , mypack+  , prop_fromToList +  , prop_toFromList +  , prop_append     +  , prop_drop       +  , prop_take       +  , prop_dropChunk  +  , prop_takeChunk  +  , prop_realign    +  , prop_realizeChunk +  , prop_realize      +  , prop_realizeLen      +  , prop_findSubstring1 +  , prop_findSubstring1a +  , prop_findSubstring1b +  , prop_findSubstring2 +#endif        +  )+  where+  +--------------------------------------------------------------------------------++import qualified Prelude+import Prelude hiding (take,drop,last,length,splitAt,concat,null,rem,init,foldl')++import Control.Monad+import Control.Applicative hiding ( empty )++import Data.Bits ()+import Data.Int  ()+import Data.Word ()+import Data.Char (ord)+import Data.Maybe+import qualified Data.List as List++import Data.ByteString (ByteString)+import qualified Data.ByteString          as B+import qualified Data.ByteString.Internal as B+import qualified Data.ByteString.Lazy     as L++#ifdef WITH_QUICKCHECK+import Test.QuickCheck hiding ( (.&.) )+import qualified Data.ByteString.Char8 as BC+#endif++import Foreign+import System.IO.Unsafe++--------------------------------------------------------------------------------++flippedFoldM_ :: Monad m => a -> [b] -> (a -> b -> m a) -> m () +flippedFoldM_ x ys f = foldM_ f x ys++flippedFoldM ::  Monad m => a -> [b] -> (a -> b -> m a) -> m a +flippedFoldM x ys f = foldM f x ys++--------------------------------------------------------------------------------++#ifdef BITSTRING_BIGENDIAN++{-+bitReverseWord8_naive :: Word8 -> Word8+bitReverseWord8_naive x +  = shiftR (x .&. 0x80) 7+  + shiftR (x .&. 0x40) 5+  + shiftR (x .&. 0x20) 3+  + shiftR (x .&. 0x10) 1+  + shiftL (x .&. 0x08) 1+  + shiftL (x .&. 0x04) 3+  + shiftL (x .&. 0x02) 5+  + shiftL (x .&. 0x01) 7+     +bitReverseWord8_table :: ByteString     +bitReverseWord8_table = B.pack $ map reverseWord8_naive [0..255]++bitReverseWord8 :: Word8 -> Word8+bitReverseWord8 = U.unsafeIndex reverseWord8_table . fromIntegral+-}++byteReverseWord32 :: Word32 -> Word32+byteReverseWord32 w +  = shiftR w 24 +  + shiftR w 8  .&. 0x0000ff00 +  + shiftL w 8  .&. 0x00ff0000 +  + shiftL w 24++#endif +-- #define BITSTRING_BIGENDIAN++--------------------------------------------------------------------------------++data BitChunk = MkBitChunk+  { bitChunkOffset :: !Int64+  , bitChunkLength :: !Int64+  , bitChunkData   :: !ByteString+  }++mypack :: String -> ByteString+mypack = B.pack . map c2w where+  c2w = fromIntegral . ord++debugShowBitChunk :: BitChunk -> String+debugShowBitChunk (MkBitChunk ofs len dat) = "BitChunk " ++ show ofs ++ " " ++ show len ++ " (mypack " ++ show dat ++ ")"++showBitChunk :: BitChunk -> String+showBitChunk chunk = "MkBitChunk <" ++ map f (bitChunkTo01List chunk) ++ ">" where +  f 0 = '0'+  f 1 = '1'++instance Show BitChunk where+  show = showBitChunk++emptyBitChunk :: BitChunk+emptyBitChunk = MkBitChunk 0 0 B.empty++{-  +bitChunk' :: Int64 -> ByteString -> BitChunk  +bitChunk' ofs bs = MkBitString ofs (len-ofs) bs where +  len = 8 * fromIntegral (B.length bs)+-}++-- | warning! no boundary checks+unsafeBitChunk'  +  :: Int64        -- ^ offset +  -> Int64        -- ^ length+  -> ByteString   -- ^ source+  -> BitChunk +unsafeBitChunk' ofs len dat = MkBitChunk ofs len dat where ++bitChunk :: ByteString -> BitChunk  +bitChunk bs = unsafeBitChunk' 0 (8 * fromIntegral (B.length bs)) bs++--------------------------------------------------------------------------------++bitChunkDrop :: Int64 -> BitChunk -> BitChunk+bitChunkDrop k (MkBitChunk ofs len dat) = if k<len+  then MkBitChunk (ofs+k) (len-k) dat+  else emptyBitChunk++bitChunkTake :: Int64 -> BitChunk -> BitChunk+bitChunkTake k bc@(MkBitChunk ofs len dat) +  | k==0      = emptyBitChunk+  | k<=len    = MkBitChunk ofs k dat+  | otherwise = bc++-- TODO: better implementation    +splitBitChunkAt :: Int64 -> BitChunk -> (BitChunk,BitChunk)    +splitBitChunkAt k b = (bitChunkTake k b, bitChunkDrop k b)  ++--------------------------------------------------------------------------------++{-# INLINE boolToWord8 #-}+boolToWord8 :: Bool -> Word8+boolToWord8 bool = case bool of+  True  -> 1+  False -> 0++{-# INLINE word8ToBool #-}+word8ToBool :: Word8 -> Bool+word8ToBool w = (w/=0)++--------------------------------------------------------------------------------++unsafeLookupBitChunk :: BitChunk -> Int64 -> Bool+unsafeLookupBitChunk chunk j = unsafeLookupBitChunk01 chunk j /= 0++unsafeLookupBitChunk01 :: BitChunk -> Int64 -> Word8+unsafeLookupBitChunk01 (MkBitChunk ofs len dat) j = bit where+  (n,k) = divMod (ofs+j) 8+  byte = B.index dat (fromIntegral n)+#ifndef BITSTRING_BIGENDIAN+  bit = ((shiftR byte (fromIntegral k)) .&. 1) +#else+  bit = ((shiftR byte (fromIntegral (7-k))) .&. 1) +#endif++--------------------------------------------------------------------------------+  +bitChunkToList :: BitChunk -> [Bool]+bitChunkToList chunk@(MkBitChunk ofs len dat) = +  [ unsafeLookupBitChunk chunk k | k<-[0..len-1] ]++bitChunkFromList :: [Bool] -> BitChunk+bitChunkFromList bits = MkBitChunk 0 (fromIntegral len) (B.pack bytes) where+  (len,bytes) = worker bits+  worker []   = ( 0, [] )+  worker bits = ( len' + List.length this , byte:ys ) where+    (this,rest) = List.splitAt 8 bits+#ifndef BITSTRING_BIGENDIAN+    byte = List.foldl' (+) 0 $ zipWith shiftL (map boolToWord8 this) [0..7]+#else+    byte = List.foldl' (+) 0 $ zipWith shiftL (map boolToWord8 this) [7,6..0]+#endif+    (len' , ys) = worker rest++bitChunkTo01List :: BitChunk -> [Word8]+bitChunkTo01List chunk@(MkBitChunk ofs len dat) = +  [ unsafeLookupBitChunk01 chunk k | k<-[0..len-1] ]++bitChunkFrom01List :: [Word8] -> BitChunk+bitChunkFrom01List bits = MkBitChunk 0 (fromIntegral len) (B.pack bytes) where+  (len,bytes) = worker bits+  worker []   = ( 0, [] )+  worker bits = ( len' + List.length this , byte:ys ) where+    (this,rest) = List.splitAt 8 bits+#ifndef BITSTRING_BIGENDIAN+    byte = List.foldl' (+) 0 $ zipWith shiftL (map (.&. 1) this) [0..7]+#else+    byte = List.foldl' (+) 0 $ zipWith shiftL (map (.&. 1) this) [7,6..0]+#endif+    (len' , ys) = worker rest+    +instance Eq BitChunk where+  -- | warning! very slow! TODO: make a better routine+--  (==) :: BitChunk -> BitChunk -> Bool+  (==) = bitChunkIsEqualNaive+    +  -- | warning! very slow! TODO: make a better routine+bitChunkIsEqualNaive ::  BitChunk -> BitChunk -> Bool+bitChunkIsEqualNaive x y = bitChunkToList x == bitChunkToList y++--------------------------------------------------------------------------------++-- | Creates a new 'BitChunk' with offset field 0+realignBitChunk :: BitChunk -> BitChunk +realignBitChunk (MkBitChunk ofs len dat) = +  MkBitChunk 0 len $ case ofsFrac of +    0 -> dat'+    _ -> B.pack $ B.zipWith f dat' (B.snoc (B.tail dat') 0) +  where +    ofsFrac2 = 8 - ofsFrac+#ifndef BITSTRING_BIGENDIAN+    f b1 b2 = shiftR b1 (fromIntegral ofsFrac) + shiftL b2 (fromIntegral ofsFrac2)+#else+    f b1 b2 = shiftL b1 (fromIntegral ofsFrac) + shiftR b2 (fromIntegral ofsFrac2)+#endif    +    dat' = B.drop (fromIntegral ofsInt) dat+    (ofsInt, ofsFrac) = divMod ofs 8 +    +realizeBitChunk :: BitChunk -> (ByteString, Maybe (Word8,Int))+realizeBitChunk orig = (whole, end) where+  chunk@(MkBitChunk 0 len dat) = realignBitChunk orig+  (n,k) = divMod len 8+  whole = B.take (fromIntegral n) dat+  end = case k of+    0 -> Nothing+    _ -> let w' = B.index dat (fromIntegral n)+#ifndef BITSTRING_BIGENDIAN+             mask = 2^k - 1 :: Word8+             w = w' .&. mask+#else+-- and at this point, the the inventor and users of big endianness deserve an extra fuck!+             kk = fromIntegral k :: Int+             mask = shiftL (2^kk-1) (8-kk) +             w = w' .&. mask+#endif+         in  Just (w, fromIntegral k) +           +--------------------------------------------------------------------------------++unBitString :: BitString -> [BitChunk]+unBitString (MkBitString xs) = xs+  +newtype BitString = MkBitString [BitChunk] ++debugShowBitString :: BitString -> String+debugShowBitString (MkBitString list) = "MkBitString " ++ show list++showBitString :: BitString -> String+showBitString bits = "MkBitString <" ++ map f (to01List bits) ++ ">" where +  f 0 = '0'+  f 1 = '1'+  f _ = error "BitString/show: impossible"++instance Show BitString where +  show = showBitString++empty :: BitString+empty = MkBitString [] ++-- | Create a 'BitString' from a portion of a 'ByteString'.+-- Warning! No boundary checks are performed!+unsafeBitString' +  :: Int64       -- ^ offset +  -> Int64       -- ^ length+  -> ByteString  -- ^ source +  -> BitString+unsafeBitString' ofs len bs = MkBitString [unsafeBitChunk' ofs len bs] ++-- | Create a 'BitString' from a strict 'ByteString'+bitString :: ByteString -> BitString  +bitString bs = unsafeBitString' 0 (8 * fromIntegral (B.length bs)) bs++-- | Create a 'BitString' from a lazy 'ByteString'+bitStringLazy :: L.ByteString -> BitString  +bitStringLazy = concat . map bitString . L.toChunks ++drop :: Int64 -> BitString -> BitString+drop k (MkBitString cs) = MkBitString (worker k cs) where+  worker _ [] = []+  worker k (MkBitChunk ofs len dat : cs) = if k < len +    then MkBitChunk (ofs+k) (len-k) dat : cs+    else worker (k-len) cs++take :: Int64 -> BitString -> BitString+take k (MkBitString cs) = MkBitString (worker k cs) where+  worker 0 _  = []+  worker _ [] = []+  worker k (c@(MkBitChunk ofs len dat) : cs) = if k <= len +    then [ MkBitChunk ofs k dat ]+    else c : worker (k-len) cs++-- TODO: better implementation    +splitAt :: Int64 -> BitString -> (BitString,BitString)    +splitAt k b = (take k b, drop k b)++append :: BitString -> BitString -> BitString    +append (MkBitString chunks1) (MkBitString chunks2) = MkBitString (chunks1 ++ chunks2)++concat :: [BitString] -> BitString+concat xs = case xs of+  [] -> empty+  _  -> (MkBitString . List.concat . map unBitString) xs   -- hmm how strict or lazy this should be?++toList :: BitString -> [Bool]+toList (MkBitString chunks) = List.concatMap bitChunkToList chunks++fromList :: [Bool] -> BitString+fromList digits = MkBitString [bitChunkFromList digits]++to01List :: BitString -> [Word8]+to01List (MkBitString chunks) = List.concatMap bitChunkTo01List chunks++from01List :: [Word8] -> BitString+from01List digits = MkBitString [bitChunkFrom01List digits]++--------------------------------------------------------------------------------++length :: BitString -> Int64+length (MkBitString chunks) = List.foldl' (+) 0 (map bitChunkLength chunks)++null :: BitString -> Bool+null bits = (length bits == 0)++-- | warning! very slow! TODO: make a better routine+instance Eq BitString where+  -- (==) :: BitString -> BitString -> Bool+  (==) = fallbackEqual+  +-- | slow, fallback equality test, via converting to list+fallbackEqual :: BitString -> BitString -> Bool+fallbackEqual x y = (toList x == toList y)++--------------------------------------------------------------------------------++foldl' :: (a -> Bool -> a) -> a -> BitString -> a+foldl' fun init bits = List.foldl' fun init (toList bits)++--------------------------------------------------------------------------------++findSubstring+  :: BitString    -- ^ the string to search for+  -> BitString    -- ^ the string to search in+  -> Maybe Int64  -- ^ the index of the first substring, if exists+findSubstring = findSubstring32++-- the basic unit is a Word32+findSubstring32 +  :: BitString    -- ^ the string to search for+  -> BitString    -- ^ the string to search in+  -> Maybe Int64  -- ^ the index of the first substring, if exists+findSubstring32 small large = +  unsafePerformIO $ do+    withForeignPtr fptr_b_small $ \p'' -> do+      let p' = (plusPtr p'' ofs_b_small) :: Ptr Word8+      allocaArray (k+1) $ \q -> allocaArray (k+1) $ \p -> do+        -- we store in 'q' the last 'm' bits+        -- and in 'p' the bits we are searching for+        +#ifndef BITSTRING_BIGENDIAN+        let p8 = (castPtr :: Ptr Word32 -> Ptr Word8) p+        forM_ [0..len_b_small-1] $ \i -> do { x <- peekElemOff p' i ; pokeElemOff p8 i x }+        peekElemOff p k >>= \x -> pokeElemOff p k (x .&. mask)+        pokeElemOff q k 0   -- this is quite important, because of the shifts!+#else +        pokeElemOff p k 0   -- just to be on the safe side+        let p8 = (castPtr :: Ptr Word32 -> Ptr Word8) p+        forM_ [0..len_b_small-1] $ \i -> do { x <- peekElemOff p' i ; pokeElemOff p8 i x }+        forM_ [0..k] $ \j -> do { y <- peekElemOff p j ; pokeElemOff p j (byteReverseWord32 y) }+        peekElemOff p k >>= \x -> pokeElemOff p k (x .&. mask)+        pokeElemOff q k 0   -- this is quite important, because of the shifts!+#endif         ++{-+        print (m,m32)+        print len_b_small+        print hmm+        peekArray ((k+1)*4) (castPtr p :: Ptr Word8) >>= print       +-}++        worker p q 0 (to01List large)+      +  where+    m = length small+    m32 = fromIntegral (mod m 32) :: Int    +    d32 = fromIntegral (div m 32) :: Int++    hmm :: (Int, Word32, Int)+    hmm@(k,mask,initShift) = case m32 of+#ifndef BITSTRING_BIGENDIAN    +      0 -> ( d32 - 1  , 0xffffffff     , 31                          )+      _ -> ( d32      , 2^m32  - 1     , fromIntegral (mod (m-1) 32) )+#else+      0 -> ( d32 - 1  , 0xffffffff                , 0                              )  +      _ -> ( d32      , shiftL (2^m32-1) (32-m32) , fromIntegral ( 32 - mod m 32 ) )+#endif    ++    b_small = realizeBitStringStrict small+    (fptr_b_small, ofs_b_small, len_b_small) = B.toForeignPtr b_small+    +    worker :: Ptr Word32 -> Ptr Word32 -> Int64 -> [Word8] -> IO (Maybe Int64)+    worker !p !q !pos !bits = do++--      peekArray ((k+1)*4) (castPtr q :: Ptr Word8) >>= print       ++      conds <- forM [0..k-1] $ \j -> do { x <- peekElemOff p j ; y <- peekElemOff q j ; return (x==y) }+      cond  <- do { x <- peekElemOff p k ; y <- peekElemOff q k ; return (x .&. mask == y .&. mask) }+      if and (cond:conds) && pos >= m+        then return (Just (pos - m))+        else case bits of+          [] -> return Nothing+          (b:bs) -> do++#ifndef BITSTRING_BIGENDIAN+            let init_cr = (fromIntegral b , initShift)+            flippedFoldM_ init_cr [k,k-1..0] $ \(c,r) j -> do+              y <- peekElemOff q j+              let cr' = ( y .&. 1 , 31 )+              pokeElemOff q j (shiftR y 1 + shiftL c r)+              return cr'+            worker p q (pos+1) bs +#else+            let init_cr = (fromIntegral b , initShift)+            flippedFoldM_ init_cr [k,k-1..0] $ \(c,r) j -> do+              y <- peekElemOff q j+              let cr' = ( shiftR y 31 , 0 )+              pokeElemOff q j (shiftL y 1 + shiftL c r)+              return cr'+            worker p q (pos+1) bs +#endif+      +--------------------------------------------------------------------------------++realizeBitString' :: BitString -> [ByteString]   +realizeBitString' (MkBitString chunks) = worker Nothing chunks where+  worker :: Maybe (Word8,Int) -> [BitChunk] -> [ByteString]+  worker rem (b:bs) = +    case rem of +      Nothing -> +        let (s, rem') = realizeBitChunk b+        in  s : worker rem' bs+      Just (w,k) -> +        if r >= q+          then B.singleton t : s : worker rem' bs+               -- (B.cons t s) : worker rem' bs+          else worker (Just (t, k+fromIntegral r)) bs+        where+          q = 8 - fromIntegral k+          r = bitChunkLength b+          (x,y) = splitBitChunkAt q b+          (s, rem') = realizeBitChunk y+#ifndef BITSTRING_BIGENDIAN          +          t = List.foldl' (+) w+            $ zipWith shiftL (bitChunkTo01List x) [k..]+#else+          -- also, fuck. and fuck, again.+          u = 7-k+          t = List.foldl' (+) w+            $ zipWith shiftL (bitChunkTo01List x) [u,u-1..]+#endif+  worker rem [] = case rem of+    Nothing    -> []+    Just (w,_) -> [B.singleton w] +++realizeBitStringLazy :: BitString -> L.ByteString+realizeBitStringLazy = L.fromChunks . realizeBitString'++realizeBitStringStrict :: BitString -> B.ByteString+realizeBitStringStrict = B.concat . realizeBitString'++--------------------------------------------------------------------------------++#ifdef WITH_QUICKCHECK++newtype Size     = Size     Int64  deriving Show+newtype BoolList = BoolList [Bool] deriving Show++newtype SearchFor = SearchFor BitString deriving Show++instance Arbitrary Size where+  arbitrary = Size <$> (fromIntegral :: Int -> Int64) <$> choose (0,64) -- 192)++instance Arbitrary BoolList where+  arbitrary = do+    Size k <- arbitrary +    BoolList <$> vector (fromIntegral k) ++instance Arbitrary BitChunk where+  arbitrary = do+    k <- choose (0,24) :: Gen Int+    l <- choose (0,15) :: Gen Int+    BoolList list <- arbitrary+    let bits1 = bitChunkDrop (fromIntegral k) $ bitChunkFromList list+        len = bitChunkLength bits1+        bits2 = bitChunkTake (max 0 $ len - fromIntegral l) bits1+    return bits2++-- with 48 bits, it's unlikely that there are other random appearances +instance Arbitrary SearchFor where+  arbitrary = do+    b <- arbitrary+    let l = length b+    if l >= 48 && l < 96 +      then return (SearchFor b) +      else arbitrary+    +instance Arbitrary BitString where+  arbitrary = do+    k <- choose (0,7)+    MkBitString <$> vector k ++runAllTest :: IO ()     +runAllTest = runAllTest' 500++runAllTest' :: Int -> IO ()     +runAllTest' n = do+  let mytest (text,prop) = do+        putStr text+        putStr (": " ++ replicate (20 - Prelude.length text) ' ')+        quickCheckWith (stdArgs { maxSuccess = n }) prop+        +  mytest ("fromToList"   , prop_fromToList )+  mytest ("toFromList"   , prop_toFromList )+  mytest ("append"       , prop_append     )+  mytest ("drop"         , prop_drop       )+  mytest ("take"         , prop_take       )+  mytest ("dropChunk"    , prop_dropChunk  )+  mytest ("takeChunk"    , prop_takeChunk  )+  mytest ("realign"      , prop_realign    )+  mytest ("realizeChunk" , prop_realizeChunk )+  mytest ("realize"      , prop_realize      )+  mytest ("realize"      , prop_realize      )+  mytest ("realize"      , prop_realize      )+  mytest ("realize"      , prop_realize      )+  mytest ("realizeLen"   , prop_realizeLen   )++  mytest ("findSubstring1"  , prop_findSubstring1  )+  mytest ("findSubstring1"  , prop_findSubstring1  )+  mytest ("findSubstring1"  , prop_findSubstring1  )+  mytest ("findSubstring1"  , prop_findSubstring1  )+  mytest ("findSubstring1a" , prop_findSubstring1a )+  mytest ("findSubstring1b" , prop_findSubstring1b )+  mytest ("findSubstring2"  , prop_findSubstring2  )++prop_fromToList :: BitString -> Bool+prop_fromToList bits = fromList (toList bits) == bits++prop_toFromList :: BoolList -> Bool+prop_toFromList (BoolList list) = toList (fromList list) == list++prop_append :: [BitString] -> Bool+prop_append xs = toList (concat xs) == List.concat (map toList xs)++prop_drop :: Size -> BitString -> Bool+prop_drop (Size k) xs = toList (drop k xs) == List.drop (fromIntegral k) (toList xs)++prop_take :: Size -> BitString -> Bool+prop_take (Size k) xs = toList (take k xs) == List.take (fromIntegral k) (toList xs)++prop_dropChunk :: Size -> BitChunk -> Bool+prop_dropChunk (Size k) xs = bitChunkToList (bitChunkDrop k xs) == List.drop (fromIntegral k) (bitChunkToList xs)++prop_takeChunk :: Size -> BitChunk -> Bool+prop_takeChunk (Size k) xs = bitChunkToList (bitChunkTake k xs) == List.take (fromIntegral k) (bitChunkToList xs)++prop_realign :: BitChunk -> Bool+prop_realign chunk = realignBitChunk chunk == chunk++prop_realizeChunk :: BitChunk -> Bool+prop_realizeChunk chunk = append (bitString whole) (MkBitString [end]) == MkBitString [chunk] where+  (whole,remain) = realizeBitChunk chunk+  end = case remain of+    Nothing -> emptyBitChunk+    Just (w,k) -> MkBitChunk 0 (fromIntegral k) (B.singleton w)++prop_realize :: BitString -> Bool+prop_realize bits = let n = length bits in unsafeBitString' 0 n (realizeBitStringStrict bits) == bits++prop_realizeLen :: BitString -> Bool+prop_realizeLen bits = let n = length bits in div (n+7) 8 == (fromIntegral $ B.length $ realizeBitStringStrict bits) +    +prop_findSubstring1 :: SearchFor -> BitString -> BitString -> Bool+prop_findSubstring1 (SearchFor what) pre post = findSubstring what big == Just (length pre) where+  big = concat [ pre , what , post ] ++prop_findSubstring1a :: SearchFor -> BitString -> Bool+prop_findSubstring1a (SearchFor what) pre = findSubstring what big == Just (length pre) where+  big = concat [ pre , what ] ++prop_findSubstring1b :: SearchFor -> BitString -> Bool+prop_findSubstring1b (SearchFor what) post = findSubstring what big == Just 0 where+  big = concat [ what , post  ] ++prop_findSubstring2 :: SearchFor -> BitString -> BitString -> Bool+prop_findSubstring2 (SearchFor what) pre post = findSubstring what big == Nothing where+  big = concat [ pre , post ] ++------+  +{-  +test = BitString xxx++xxx =+  [ BitChunk 17 49 (mypack "9\176N\152%\f\STX\144\ETX")+  , BitChunk 22 50 (mypack "\148\&6\184\RS\134\144+\241\210")+  , BitChunk 0 0 (mypack "")+  , BitChunk 0 0 (mypack "")+  , BitChunk 0 9 (mypack "$\NUL")+  ]  + +yyy = map (bitChunk) $ realizeBitString' test+-}++{-+let what = (BitString [BitChunk 0 16 (mypack "c\229W"),BitChunk 0 0 (mypack ""),BitChunk 20 13 (mypack "\169\188\"\DLEf\EOT"),BitChunk 0 0 (mypack ""),BitChunk 3 9 (mypack "/\FS+"),BitChunk 21 26 (mypack "&,\159\249\158&h\STX"),BitChunk 0 0 (mypack "")])++let pre = BitString [BitChunk 3 13 (mypack "\245\200\180\NUL"),BitChunk 17 4 (mypack "{\SI\DC2"),BitChunk 24 33 (mypack "\207\135W\RS\240\180{\SOH")]++let post = BitString [BitChunk 16 19 (mypack "e\142\&0z\209m\NUL"),BitChunk 14 27 (mypack "\248m\207\146\&8\224\NUL")]+-}++------+  +#endif +-- #define WITH_QUICKCHECK++--------------------------------------------------------------------------------