diff --git a/Data/BitString.hs b/Data/BitString.hs new file mode 100644 --- /dev/null +++ b/Data/BitString.hs @@ -0,0 +1,690 @@ + + +{-# 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 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 + +-------------------------------------------------------------------------------- diff --git a/Data/BitString/BigEndian.hs b/Data/BitString/BigEndian.hs new file mode 100644 --- /dev/null +++ b/Data/BitString/BigEndian.hs @@ -0,0 +1,692 @@ +-- DO NOT EDIT THIS FILE +{-# OPTIONS_GHC -DBITSTRING_BIGENDIAN #-} + + +{-# 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 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 + +-------------------------------------------------------------------------------- diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,29 @@ +Copyright (c) 2010, Balazs Komuves +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +- Redistributions of source code must retain the above copyright notice, +this list of conditions and the following disclaimer. + +- Redistributions in binary form must reproduce the above copyright notice, +this list of conditions and the following disclaimer in the documentation +and/or other materials provided with the distribution. + +- Neither names of the copyright holders nor the names of the contributors +may be used to endorse or promote products derived from this software without +specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER +OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,39 @@ +#! /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 +> diff --git a/bitstring.cabal b/bitstring.cabal new file mode 100644 --- /dev/null +++ b/bitstring.cabal @@ -0,0 +1,46 @@ +Name: bitstring +Version: 0.0.0 +Synopsis: Lazy bit strings +Description: Lazy bit strings, built on the top of bytestrings. +License: BSD3 +License-file: LICENSE +Author: Balazs Komuves +Maintainer: bkomuves (plus) hackage (at) gmail (dot) com +Homepage: http://code.haskell.org/~bkomuves/ +Stability: Experimental +Category: Data +Tested-With: GHC == 6.10.1 +Cabal-Version: >= 1.6 +Build-Type: Custom + +Flag base4 + Description: Base v4 + +Flag withQuickCheck + Description: Build with QuickCheck test. Note that Show instances will be different. + Default: False + +Library + + if flag(base4) + Build-Depends: base >= 4 && < 5 + cpp-options: -DBASE_MAJOR_VERSION=4 + else + Build-Depends: base >= 3 && < 4 + cpp-options: -DBASE_MAJOR_VERSION=3 + + if flag(withQuickCheck) + Build-Depends: QuickCheck == 2.* + cpp-options: -DWITH_QUICKCHECK + + Build-Depends: bytestring + + Exposed-Modules: Data.BitString, + Data.BitString.BigEndian + + Hs-Source-Dirs: . + + Extensions: CPP + ghc-options: -Wall + +