diff --git a/COPYING b/COPYING new file mode 100644 --- /dev/null +++ b/COPYING @@ -0,0 +1,29 @@ + + + + + bitstream + + + PHO + + + + + + + + + + + + diff --git a/Data/Bitstream.hs b/Data/Bitstream.hs new file mode 100644 --- /dev/null +++ b/Data/Bitstream.hs @@ -0,0 +1,602 @@ +{-# LANGUAGE + BangPatterns + , FlexibleContexts + , ScopedTypeVariables + , UndecidableInstances + , UnicodeSyntax + #-} +-- | Fast, packed, strict bit streams (i.e. list of 'Bool's) with +-- semi-automatic stream fusion. +-- +-- This module is intended to be imported @qualified@, to avoid name +-- clashes with "Prelude" functions. e.g. +-- +-- > import qualified Data.BitStream as BS +-- +-- Strict 'Bitstream's are made of strict 'SV.Vector' of 'Packet's, +-- and each 'Packet's have at least 1 bit. +module Data.Bitstream + ( -- * Types + Bitstream + , Left + , Right + + -- * Introducing and eliminating 'Bitstream's + , empty + , (∅) + , singleton + , pack + , unpack + , fromPackets + , toPackets + + -- ** Converting from\/to strict 'BS.ByteString's + , fromByteString + , toByteString + + -- ** Converting from\/to 'S.Stream's + , stream + , unstream + + -- * Changing bit order in octets + , directionLToR + , directionRToL + + -- * Basic interface + , cons + , snoc + , append + , (⧺) + , head + , last + , tail + , init + , null + , length + + -- * Transforming 'Bitstream's + , map + , reverse + + -- * Reducing 'Bitstream's + , foldl + , foldl' + , foldl1 + , foldl1' + , foldr + , foldr1 + + -- ** Special folds + , concat + , concatMap + , and + , or + , any + , all + + -- * Building lists + -- ** Scans + , scanl + , scanl1 + , scanr + , scanr1 + + -- ** Replication + , replicate + + -- ** Unfolding + , unfoldr + , unfoldrN + + -- * Substreams + , take + , drop + , takeWhile + , dropWhile + , span + , break + + -- * Searching streams + -- ** Searching by equality + , elem + , (∈) + , (∋) + , notElem + , (∉) + , (∌) + + -- ** Searching with a predicate + , find + , filter + , partition + + -- ** Indexing streams + , (!!) + , elemIndex + , elemIndices + , findIndex + , findIndices + + -- * Zipping and unzipping streams + , zip + , zip3 + , zip4 + , zip5 + , zip6 + , zipWith + , zipWith3 + , zipWith4 + , zipWith5 + , zipWith6 + , unzip + , unzip3 + , unzip4 + , unzip5 + , unzip6 + + -- * I/O with 'Bitstream's + -- ** Standard input and output + , getContents + , putBits + , interact + + -- ** Files + , readFile + , writeFile + , appendFile + + -- ** I/O with 'Handle's + , hGetContents + , hGet + , hGetSome + , hGetNonBlocking + , hPut + ) + where +import Data.Bitstream.Generic hiding (Bitstream) +import qualified Data.Bitstream.Generic as G +import Data.Bitstream.Internal +import Data.Bitstream.Packet +import qualified Data.ByteString as BS +import qualified Data.List as L +import Data.Monoid +import qualified Data.Vector.Generic as GV +import qualified Data.Vector.Storable as SV +import qualified Data.Vector.Fusion.Stream as S +import Data.Vector.Fusion.Stream.Monadic (Stream(..), Step(..)) +import Data.Vector.Fusion.Stream.Size +import Data.Vector.Fusion.Util +import Prelude ( Bool(..), Eq(..), Int, Integral, Maybe(..), Monad(..), Num(..) + , Ord(..), Show(..), ($), div, error, fmap + , fromIntegral, fst, mod, otherwise + ) +import Prelude.Unicode hiding ((⧺), (∈), (∉)) +import System.IO (FilePath, Handle, IO) + +-- | A space-efficient representation of a 'Bool' vector, supporting +-- many efficient operations. 'Bitstream's have an idea of +-- /directions/ controlling how octets are interpreted as bits. There +-- are two types of concrete 'Bitstream's: @'Bitstream' 'Left'@ and +-- @'Bitstream' 'Right'@. +newtype Bitstream d + = Bitstream (SV.Vector (Packet d)) + +instance Show (Packet d) ⇒ Show (Bitstream d) where + {-# INLINEABLE show #-} + show (Bitstream v0) + = L.concat + [ "(S" + , L.concat (L.unfoldr go v0) + , ")" + ] + where + {-# INLINE go #-} + go v | SV.null v = Nothing + | otherwise = Just (show (SV.head v), SV.tail v) + +instance G.Bitstream (Packet d) ⇒ Eq (Bitstream d) where + {-# INLINE (==) #-} + x == y = stream x ≡ stream y + +-- | 'Bitstream's are lexicographically ordered. +-- +-- @ +-- let x = 'pack' ['True' , 'False', 'False'] +-- y = 'pack' ['False', 'True' , 'False'] +-- z = 'pack' ['False'] +-- in +-- [ 'compare' x y -- 'GT' +-- , 'compare' z y -- 'LT' +-- ] +-- @ +instance G.Bitstream (Packet d) ⇒ Ord (Bitstream d) where + {-# INLINE compare #-} + x `compare` y = stream x `compare` stream y + +-- | 'Bitstream' forms 'Monoid' in the same way as ordinary lists: +-- +-- @ +-- 'mempty' = 'empty' +-- 'mappend' = 'append' +-- 'mconcat' = 'concat' +-- @ +instance G.Bitstream (Packet d) ⇒ Monoid (Bitstream d) where + mempty = (∅) + mappend = (⧺) + mconcat = concat + +instance G.Bitstream (Packet d) ⇒ G.Bitstream (Bitstream d) where + {-# INLINE [0] stream #-} + stream (Bitstream v) + = {-# CORE "Bitstream stream" #-} + S.concatMap stream (GV.stream v) + `S.sized` + Exact (length (Bitstream v)) + + {-# INLINE [0] unstream #-} + unstream + = {-# CORE "Bitstream unstream" #-} + Bitstream ∘ GV.unstream ∘ packPackets + + {-# INLINEABLE [2] cons #-} + cons b (Bitstream v) + | SV.null v = Bitstream (SV.singleton (singleton b)) + | otherwise = case SV.head v of + p | length p < (8 ∷ Int) + → Bitstream ((b `cons` p) `SV.cons` SV.tail v) + | otherwise + → Bitstream (singleton b `SV.cons` v) + + {-# INLINEABLE [2] snoc #-} + snoc (Bitstream v) b + | SV.null v = Bitstream (SV.singleton (singleton b)) + | otherwise = case SV.last v of + p | length p < (8 ∷ Int) + → Bitstream (SV.init v `SV.snoc` (p `snoc` b)) + | otherwise + → Bitstream (v `SV.snoc` singleton b) + + {-# INLINE [2] append #-} + append (Bitstream x) (Bitstream y) + = Bitstream (x SV.++ y) + + {-# INLINEABLE [2] tail #-} + tail (Bitstream v) + | SV.null v = emptyStream + | otherwise = case tail (SV.head v) of + p' | null p' → Bitstream (SV.tail v) + | otherwise → Bitstream (p' `SV.cons` SV.tail v) + + {-# INLINEABLE [2] init #-} + init (Bitstream v) + | SV.null v = emptyStream + | otherwise = case init (SV.last v) of + p' | null p' → Bitstream (SV.init v) + | otherwise → Bitstream (SV.init v `SV.snoc` p') + + {-# INLINE [2] map #-} + map f (Bitstream v) + = Bitstream (SV.map (map f) v) + + {-# INLINE [2] reverse #-} + reverse (Bitstream v) + = Bitstream (SV.reverse (SV.map reverse v)) + + {-# INLINE [1] scanl #-} + scanl f b + = unstream ∘ S.scanl f b ∘ stream + + {-# INLINE [2] concat #-} + concat = Bitstream ∘ SV.concat ∘ L.map toPackets + + {-# INLINEABLE replicate #-} + replicate n0 b + | n0 ≤ 0 = (∅) + | n0 `mod` 8 ≡ 0 = Bitstream anterior + | otherwise = Bitstream (anterior `SV.snoc` posterior) + where + {-# INLINE anterior #-} + anterior = SV.replicate n p + where + n ∷ Int + {-# INLINE n #-} + n = fromIntegral (n0 `div` 8) + {-# INLINE p #-} + p = replicate (8 ∷ Int) b + + {-# INLINE posterior #-} + posterior = replicate n b + where + n ∷ Int + {-# INLINE n #-} + n = fromIntegral (n0 `mod` 8) + + {-# INLINEABLE [2] take #-} + take n0 (Bitstream v0) + | n0 ≤ 0 = (∅) + | otherwise = Bitstream (SV.unfoldrN nOctets go (n0, v0)) + where + {-# INLINE nOctets #-} + nOctets ∷ Int + nOctets = fromIntegral (min n0 (fromIntegral (SV.length v0))) + {-# INLINE go #-} + go (0, _) = Nothing + go (n, v) + | SV.null v = Nothing + | otherwise = let p = SV.head v + v' = SV.tail v + p' = take n p + n' = n - length p' + in + return (p', (n', v')) + + {-# INLINEABLE [2] drop #-} + drop n0 (Bitstream v0) + | n0 ≤ 0 = Bitstream v0 + | otherwise = Bitstream (go n0 v0) + where + {-# INLINE go #-} + go 0 v = v + go n v + | SV.null v = v + | otherwise = case SV.head v of + p | n ≥ length p → go (n - length p) (SV.tail v) + | otherwise → drop n p `SV.cons` (SV.tail v) + + {-# INLINEABLE [2] takeWhile #-} + takeWhile f (Bitstream v0) + = Bitstream (GV.unstream (takeWhilePS (GV.stream v0))) + where + {-# INLINE takeWhilePS #-} + takeWhilePS (Stream step s0 sz) = Stream step' (Just s0) (toMax sz) + where + {-# INLINE step' #-} + step' Nothing = return Done + step' (Just s) + = do r ← step s + case r of + Yield p s' + → case takeWhile f p of + p' | p ≡ p' → return $ Yield p' (Just s') + | otherwise → return $ Yield p' Nothing + Skip s' + → return $ Skip (Just s') + Done + → return Done + + {-# INLINEABLE [2] dropWhile #-} + dropWhile f (Bitstream v0) = Bitstream (go v0) + where + {-# INLINE go #-} + go v | SV.null v = v + | otherwise = case dropWhile f (SV.head v) of + p' | null p' → go (SV.tail v) + | otherwise → p' `SV.cons` SV.tail v + + {-# INLINEABLE [2] filter #-} + filter f (Bitstream v0) + = Bitstream (GV.unstream (filterPS (GV.stream v0))) + where + {-# INLINE filterPS #-} + filterPS (Stream step s0 sz) = Stream step' s0 (toMax sz) + where + {-# INLINE step' #-} + step' s + = do r ← step s + case r of + Yield p s' → case filter f p of + p' | null p' → return $ Skip s' + | otherwise → return $ Yield p' s' + Skip s' → return $ Skip s' + Done → return Done + +strictHead ∷ G.Bitstream (Packet d) ⇒ Bitstream d → Bool +{-# RULES "head → strictHead" [2] + ∀(v ∷ G.Bitstream (Packet d) ⇒ Bitstream d). + head v = strictHead v #-} +{-# INLINE strictHead #-} +strictHead (Bitstream v) = head (SV.head v) + +strictLast ∷ G.Bitstream (Packet d) ⇒ Bitstream d → Bool +{-# RULES "last → strictLast" [2] + ∀(v ∷ G.Bitstream (Packet d) ⇒ Bitstream d). + last v = strictLast v #-} +{-# INLINE strictLast #-} +strictLast (Bitstream v) = last (SV.last v) + +strictNull ∷ Bitstream d → Bool +{-# RULES "null → strictNull" [2] null = strictNull #-} +{-# INLINE strictNull #-} +strictNull (Bitstream v) = SV.null v + +strictLength ∷ (G.Bitstream (Packet d), Num n) ⇒ Bitstream d → n +{-# RULES "length → strictLength" [2] + ∀(v ∷ G.Bitstream (Packet d) ⇒ Bitstream d). + length v = strictLength v #-} +{-# INLINEABLE strictLength #-} +strictLength (Bitstream v) + = SV.foldl' (\n p → n + length p) 0 v + +strictAnd ∷ G.Bitstream (Packet d) ⇒ Bitstream d → Bool +{-# RULES "and → strictAnd" [2] + ∀(v ∷ G.Bitstream (Packet d) ⇒ Bitstream d). + and v = strictAnd v #-} +{-# INLINE strictAnd #-} +strictAnd (Bitstream v) + = SV.all and v + +strictOr ∷ G.Bitstream (Packet d) ⇒ Bitstream d → Bool +{-# RULES "or → strictOr" [2] + ∀(v ∷ G.Bitstream (Packet d) ⇒ Bitstream d). + or v = strictOr v #-} +{-# INLINE strictOr #-} +strictOr (Bitstream v) + = SV.any or v + +strictIndex ∷ (G.Bitstream (Packet d), Integral n) ⇒ Bitstream d → n → Bool +{-# RULES "(!!) → strictIndex" [2] + ∀(v ∷ G.Bitstream (Packet d) ⇒ Bitstream d) n. + v !! n = strictIndex v n #-} +{-# INLINEABLE strictIndex #-} +strictIndex (Bitstream v0) i0 + | i0 < 0 = indexOutOfRange i0 + | otherwise = go v0 i0 + where + {-# INLINE go #-} + go v i + | SV.null v = indexOutOfRange i + | otherwise = case SV.head v of + p | i < length p → p !! i + | otherwise → go (SV.tail v) (i - length p) + +emptyStream ∷ α +emptyStream + = error "Data.Bitstream: empty stream" + +{-# INLINE indexOutOfRange #-} +indexOutOfRange ∷ Integral n ⇒ n → α +indexOutOfRange n = error ("Data.Bitstream: index out of range: " L.++ show n) + +-- | /O(n)/ Convert a strict 'BS.ByteString' into a strict +-- 'Bitstream'. +{-# INLINE fromByteString #-} +fromByteString ∷ BS.ByteString → Bitstream d +fromByteString bs0 = Bitstream (SV.unfoldrN nOctets go bs0) + where + {-# INLINE nOctets #-} + nOctets ∷ Int + nOctets = BS.length bs0 + {-# INLINE go #-} + go bs = do (o, bs') ← BS.uncons bs + return (fromOctet o, bs') + +-- | /O(n)/ @'toByteString' bits@ converts a strict 'Bitstream' @bits@ +-- into a strict 'BS.ByteString'. The resulting octets will be padded +-- with zeroes if the 'length' of @bs@ is not multiple of 8. +{-# INLINEABLE toByteString #-} +toByteString ∷ ∀d. G.Bitstream (Packet d) ⇒ Bitstream d → BS.ByteString +toByteString = unstreamBS + ∘ (packPackets ∷ Stream Id Bool → Stream Id (Packet d)) + ∘ stream + +unstreamBS ∷ Stream Id (Packet d) → BS.ByteString +{-# INLINE unstreamBS #-} +unstreamBS (Stream step s0 sz) + = case upperBound sz of + Just n → fst $ BS.unfoldrN n (unId ∘ go) s0 + Nothing → BS.unfoldr (unId ∘ go) s0 + where + {-# INLINE go #-} + go s = do r ← step s + case r of + Yield p s' → return $ Just (toOctet p, s') + Skip s' → go s' + Done → return Nothing + +-- | /O(1)/ Convert a 'SV.Vector' of 'Packet's into a 'Bitstream'. +fromPackets ∷ SV.Vector (Packet d) → Bitstream d +{-# INLINE fromPackets #-} +fromPackets = Bitstream + +-- | /O(1)/ Convert a 'Bitstream' into a 'SV.Vector' of 'Packet's. +toPackets ∷ Bitstream d → SV.Vector (Packet d) +{-# INLINE toPackets #-} +toPackets (Bitstream d) = d + +-- | /O(n)/ Convert a @'Bitstream' 'Left'@ into a @'Bitstream' +-- 'Right'@. Bit directions only affect octet-based operations such as +-- 'toByteString'. +directionLToR ∷ Bitstream Left → Bitstream Right +{-# INLINE directionLToR #-} +directionLToR (Bitstream v) = Bitstream (SV.map packetLToR v) + +-- | /O(n)/ Convert a @'Bitstream' 'Right'@ into a @'Bitstream' +-- 'Left'@. Bit directions only affect octet-based operations such as +-- 'toByteString'. +directionRToL ∷ Bitstream Right → Bitstream Left +{-# INLINE directionRToL #-} +directionRToL (Bitstream v) = Bitstream (SV.map packetRToL v) + +-- | /O(n)/ Read a 'Bitstream' from the stdin strictly, equivalent to +-- 'hGetContents' @stdin@. The 'Handle' is closed after the contents +-- have been read. +getContents ∷ G.Bitstream (Packet d) ⇒ IO (Bitstream d) +{-# INLINE getContents #-} +getContents = fmap fromByteString BS.getContents + +-- | /O(n)/ Write a 'Bitstream' to the stdout, equivalent to 'hPut' +-- @stdout@. +putBits ∷ G.Bitstream (Packet d) ⇒ Bitstream d → IO () +{-# INLINE putBits #-} +putBits = BS.putStr ∘ toByteString + +-- | The 'interact' function takes a function of type @'Bitstream' d +-- -> 'Bitstream' d@ as its argument. The entire input from the stdin +-- is passed to this function as its argument, and the resulting +-- 'Bitstream' is output on the stdout. +interact ∷ G.Bitstream (Packet d) ⇒ (Bitstream d → Bitstream d) → IO () +{-# INLINE interact #-} +interact = BS.interact ∘ lift' + where + {-# INLINE lift' #-} + lift' f = toByteString ∘ f ∘ fromByteString + +-- | /O(n)/ Read an entire file strictly into a 'Bitstream'. +readFile ∷ G.Bitstream (Packet d) ⇒ FilePath → IO (Bitstream d) +{-# INLINE readFile #-} +readFile = fmap fromByteString ∘ BS.readFile + +-- | /O(n)/ Write a 'Bitstream' to a file. +writeFile ∷ G.Bitstream (Packet d) ⇒ FilePath → Bitstream d → IO () +{-# INLINE writeFile #-} +writeFile = (∘ toByteString) ∘ BS.writeFile + +-- | /O(n)/ Append a 'Bitstream' to a file. +appendFile ∷ G.Bitstream (Packet d) ⇒ FilePath → Bitstream d → IO () +{-# INLINE appendFile #-} +appendFile = (∘ toByteString) ∘ BS.appendFile + +-- | /O(n)/ Read entire handle contents strictly into a 'Bitstream'. +-- +-- This function reads chunks at a time, doubling the chunksize on each +-- read. The final buffer is then realloced to the appropriate size. For +-- files > half of available memory, this may lead to memory exhaustion. +-- Consider using 'readFile' in this case. +-- +-- The 'Handle' is closed once the contents have been read, or if an +-- exception is thrown. +hGetContents ∷ G.Bitstream (Packet d) ⇒ Handle → IO (Bitstream d) +{-# INLINE hGetContents #-} +hGetContents = fmap fromByteString ∘ BS.hGetContents + +-- | /O(n)/ @'hGet' h n@ reads a 'Bitstream' directly from the +-- specified 'Handle' @h@. First argument @h@ is the 'Handle' to read +-- from, and the second @n@ is the number of /octets/ to read, not +-- /bits/. It returns the octets read, up to @n@, or null if EOF has +-- been reached. +-- +-- If the handle is a pipe or socket, and the writing end is closed, +-- 'hGet' will behave as if EOF was reached. +hGet ∷ G.Bitstream (Packet d) ⇒ Handle → Int → IO (Bitstream d) +{-# INLINE hGet #-} +hGet = (fmap fromByteString ∘) ∘ BS.hGet + +-- | /O(n)/ Like 'hGet', except that a shorter 'Bitstream' may be +-- returned if there are not enough octets immediately available to +-- satisfy the whole request. 'hGetSome' only blocks if there is no +-- data available, and EOF has not yet been reached. +hGetSome ∷ G.Bitstream (Packet d) ⇒ Handle → Int → IO (Bitstream d) +{-# INLINE hGetSome #-} +hGetSome = (fmap fromByteString ∘) ∘ BS.hGetSome + +-- | /O(n)/ 'hGetNonBlocking' is similar to 'hGet', except that it +-- will never block waiting for data to become available. If there is +-- no data available to be read, 'hGetNonBlocking' returns 'empty'. +hGetNonBlocking ∷ G.Bitstream (Packet d) ⇒ Handle → Int → IO (Bitstream d) +{-# INLINE hGetNonBlocking #-} +hGetNonBlocking = (fmap fromByteString ∘) ∘ BS.hGetNonBlocking + +-- | /O(n)/ Write a 'Bitstream' to the given 'Handle'. +hPut ∷ G.Bitstream (Packet d) ⇒ Handle → Bitstream d → IO () +{-# INLINE hPut #-} +hPut = (∘ toByteString) ∘ BS.hPut diff --git a/Data/Bitstream/Fusion.hs b/Data/Bitstream/Fusion.hs new file mode 100644 --- /dev/null +++ b/Data/Bitstream/Fusion.hs @@ -0,0 +1,53 @@ +{-# LANGUAGE + UnicodeSyntax + #-} +-- | Some functions currently missing from +-- "Data.Vector.Fusion.Stream". +module Data.Bitstream.Fusion + ( genericLength + , genericTake + , genericDrop + , genericIndex + , genericReplicate + , genericUnfoldrN + , genericFindIndex + , genericIndexed + ) + where +import qualified Data.Bitstream.Fusion.Monadic as M +import Data.Vector.Fusion.Stream +import Data.Vector.Fusion.Util +import Prelude hiding (replicate) +import Prelude.Unicode + +genericLength ∷ Num n ⇒ Stream α → n +{-# INLINE genericLength #-} +genericLength = unId ∘ M.genericLength + +genericTake ∷ Integral n ⇒ n → Stream α → Stream α +{-# INLINE genericTake #-} +genericTake = M.genericTake + +genericDrop ∷ Integral n ⇒ n → Stream α → Stream α +{-# INLINE genericDrop #-} +genericDrop = M.genericDrop + +genericIndex ∷ Integral n ⇒ Stream α → n → α +{-# INLINE genericIndex #-} +genericIndex s = unId ∘ M.genericIndex s + +genericReplicate ∷ Integral n ⇒ n → α → Stream α +{-# INLINE genericReplicate #-} +genericReplicate = M.genericReplicate + +genericUnfoldrN ∷ Integral n ⇒ n → (β → Maybe (α, β)) → β → Stream α +{-# INLINE genericUnfoldrN #-} +genericUnfoldrN = M.genericUnfoldrN + +genericFindIndex ∷ Integral n ⇒ (α → Bool) → Stream α → Maybe n +{-# INLINE genericFindIndex #-} +genericFindIndex f = unId ∘ M.genericFindIndex f + +genericIndexed ∷ Integral n ⇒ Stream α → Stream (n, α) +{-# INLINE genericIndexed #-} +genericIndexed = M.genericIndexed diff --git a/Data/Bitstream/Fusion/Monadic.hs b/Data/Bitstream/Fusion/Monadic.hs new file mode 100644 --- /dev/null +++ b/Data/Bitstream/Fusion/Monadic.hs @@ -0,0 +1,146 @@ +{-# LANGUAGE + BangPatterns + , UnicodeSyntax + #-} +-- | Some functions currently missing from +-- "Data.Vector.Fusion.Stream.Monadic". +module Data.Bitstream.Fusion.Monadic + ( genericLength + , genericTake + , genericDrop + , genericIndex + , genericReplicate + , genericReplicateM + , genericUnfoldrN + , genericUnfoldrNM + , genericFindIndex + , genericFindIndexM + , genericIndexed + ) + where +import Data.Vector.Fusion.Stream.Monadic +import Data.Vector.Fusion.Stream.Size +import Prelude hiding ((!!), drop, replicate, take) +import Prelude.Unicode + +genericLength ∷ (Monad m, Num n) ⇒ Stream m α → m n +{-# INLINE genericLength #-} +genericLength = foldl' (\n _ → n+1) 0 + +genericTake ∷ (Monad m, Integral n) ⇒ n → Stream m α → Stream m α +{-# INLINE [0] genericTake #-} +{-# RULES "genericTake → take" genericTake = take #-} +genericTake n (Stream step s0 sz) = Stream step' (s0, 0) (toMax sz) + where + {-# INLINE step' #-} + step' (s, i) + | i < n + = do r ← step s + case r of + Yield α s' → return $ Yield α (s', i+1) + Skip s' → return $ Skip (s', i ) + Done → return Done + | otherwise + = return Done + +genericDrop ∷ (Monad m, Integral n) ⇒ n → Stream m α → Stream m α +{-# INLINE [0] genericDrop #-} +{-# RULES "genericDrop → drop" genericDrop = drop #-} +genericDrop n0 (Stream step s0 sz) = Stream step' (s0, Just n0) (toMax sz) + where + {-# INLINE step' #-} + step' (s, Just n) + | n > 0 + = do r ← step s + case r of + Yield _ s' → return $ Skip (s', Just (n-1)) + Skip s' → return $ Skip (s', Just n) + Done → return Done + | otherwise + = return $ Skip (s, Nothing) + + step' (s, Nothing) + = do r ← step s + case r of + Yield α s' → return $ Yield α (s', Nothing) + Skip s' → return $ Skip (s', Nothing) + Done → return Done + +genericIndex ∷ (Monad m, Integral n) ⇒ Stream m α → n → m α +{-# INLINE [0] genericIndex #-} +{-# RULES "genericIndex → (!!)" genericIndex = (!!) #-} +genericIndex (Stream step s0 _) i0 + | i0 < 0 = fail ("genericIndex: out of range: " ⧺ show i0) + | otherwise = index_loop s0 0 + where + {-# INLINE index_loop #-} + index_loop s i + = do r ← step s + case r of + Yield α s' + | i ≡ i0 → return α + | otherwise → index_loop s' (i+1) + Skip s' → index_loop s' i + Done → fail ("genericIndex: out of range: " ⧺ show i) + +genericReplicate ∷ (Monad m, Integral n) ⇒ n → α → Stream m α +{-# INLINE genericReplicate #-} +genericReplicate n = genericReplicateM n ∘ return + +genericReplicateM ∷ (Monad m, Integral n) ⇒ n → m α → Stream m α +{-# INLINE [0] genericReplicateM #-} +{-# RULES "genericReplicateM → replicateM" genericReplicateM = replicateM #-} +genericReplicateM n0 mα = unfoldrM go n0 + where + {-# INLINE go #-} + go n | n ≤ 0 = return Nothing + | otherwise = do α ← mα + return $ Just (α, n-1) + +genericUnfoldrN ∷ (Monad m, Integral n) ⇒ n → (β → Maybe (α, β)) → β → Stream m α +{-# INLINE genericUnfoldrN #-} +genericUnfoldrN n f = genericUnfoldrNM n (return ∘ f) + +genericUnfoldrNM ∷ (Monad m, Integral n) ⇒ n → (β → m (Maybe (α, β))) → β → Stream m α +{-# INLINE [0] genericUnfoldrNM #-} +{-# RULES "genericUnfoldrNM → unfoldrNM" genericUnfoldrNM = unfoldrNM #-} +genericUnfoldrNM n0 f β0 = unfoldrM go (n0, β0) + where + {-# INLINE go #-} + go (!n, β) + | n ≤ 0 = return Nothing + | otherwise = do r ← f β + return $ do (α, β') ← r + return (α, (n-1, β')) + +genericFindIndex ∷ (Monad m, Integral n) ⇒ (α → Bool) → Stream m α → m (Maybe n) +{-# INLINE genericFindIndex #-} +genericFindIndex f = genericFindIndexM (return ∘ f) + +genericFindIndexM ∷ (Monad m, Integral n) ⇒ (α → m Bool) → Stream m α → m (Maybe n) +{-# INLINE [0] genericFindIndexM #-} +{-# RULES "genericFindIndexM → findIndexM" genericFindIndexM = findIndexM #-} +genericFindIndexM f (Stream step s0 _) = findIndex_loop s0 0 + where + {-# INLINE findIndex_loop #-} + findIndex_loop s i + = do r ← step s + case r of + Yield α s' → do b ← f α + if b then return $ Just i + else findIndex_loop s' (i+1) + Skip s' → findIndex_loop s' i + Done → return Nothing + +genericIndexed ∷ (Monad m, Integral n) ⇒ Stream m α → Stream m (n, α) +{-# INLINE [0] genericIndexed #-} +{-# RULES "genericIndexed → indexed" genericIndexed = indexed #-} +genericIndexed (Stream step s0 sz) = Stream step' (s0, 0) sz + where + {-# INLINE step' #-} + step' (s, i) + = do r ← step s + case r of + Yield α s' → return $ Yield (i, α) (s', i+1) + Skip s' → return $ Skip (s', i ) + Done → return Done diff --git a/Data/Bitstream/Generic.hs b/Data/Bitstream/Generic.hs new file mode 100644 --- /dev/null +++ b/Data/Bitstream/Generic.hs @@ -0,0 +1,883 @@ +{-# LANGUAGE + BangPatterns + , RankNTypes + , UnicodeSyntax + #-} +-- | Generic interface to diverse types of 'Bitstream'. +module Data.Bitstream.Generic + ( Bitstream(..) + + , pack + , unpack + + , empty + , singleton + + , head + , last + , null + , length + + , concatMap + + , foldl + , foldl' + , foldl1 + , foldl1' + , foldr + , foldr1 + + , and + , or + , any + , all + + , unfoldr + , unfoldrN + + , scanl1 + , scanr + , scanr1 + + , span + , break + + , elem + , notElem + + , find + + , (!!) + , elemIndex + , elemIndices + , findIndex + , findIndices + + , zip + , zip3 + , zip4 + , zip5 + , zip6 + , zipWith + , zipWith3 + , zipWith4 + , zipWith5 + , zipWith6 + , unzip + , unzip3 + , unzip4 + , unzip5 + , unzip6 + + , (∅) + , (⧺) + , (∈) + , (∋) + , (∉) + , (∌) + ) + where +import qualified Data.List as L +import Data.Bitstream.Fusion +import Data.Maybe +import Data.Vector.Fusion.Stream (Stream) +import qualified Data.Vector.Fusion.Stream as S +import Prelude ( Bool(..), Integer, Integral(..), Num(..), ($) + , fst, flip, otherwise, snd + ) +import Prelude.Unicode hiding ((∈), (∉), (⧺)) + +infix 4 ∈, ∋, ∉, ∌, `elem`, `notElem` +infixr 5 ⧺, `append` +infixl 9 !! + +{- Notes about inlining / rewriting phase control: + + 1. We want "*/unstream fusion" rules always fire. + 2. Unfused form specialisations should occur at phase 2 and later. + 3. Fusible form inlinings should occur at phase 1 and later. + 4. stream / unstream inlinings should occur last i.e. phase 0. + -} + +-- | Class of diverse types of 'Bitstream'. +-- +-- Methods of this class are functions of 'Bitstream's that is either +-- basic functions to implement other ones, or have to preserve their +-- packet/chunk structure for efficiency and strictness behaviour. +-- +-- Minimum complete implementation: /All but/ 'cons'', 'concat', +-- 'replicate' and 'partition'. +class Bitstream α where + -- | /O(n)/ Explicitly convert a 'Bitstream' into a 'Stream' of + -- 'Bool'. + -- + -- 'Bitstream' operations are automatically fused whenever it's + -- possible, safe, and effective to do so, but sometimes you may + -- find the rules are too conservative. These two functions + -- 'stream' and 'unstream' provide a means for coercive stream + -- fusion. + -- + -- You should be careful when you use 'stream'. Most functions in + -- this package are optimised to minimise frequency of memory + -- allocations and copyings, but getting 'Bitstream's back from + -- @'Stream' 'Bool'@ requires the whole 'Bitstream' to be + -- constructed from scratch. Moreover, for lazy 'Bitstream's this + -- leads to be an incorrect strictness behaviour because lazy + -- 'Bitstream's are represented as lists of strict 'Bitstream' + -- chunks but 'stream' can't preserve the original chunk + -- structure. Let's say you have a lazy 'Bitstream' with the + -- following chunks: + -- + -- @ + -- bs = [chunk1, chunk2, chunk3, ...] + -- @ + -- + -- and you want to drop the first bit of such stream. Our 'tail' + -- is only strict on the @chunk1@ and will produce the following + -- chunks: + -- + -- @ + -- 'tail' bs = [chunk0, chunk1', chunk2, chunk3, ...] + -- @ + -- + -- where @chunk0@ is a singleton vector of the first packet of + -- @chunk1@ whose first bit is dropped, and @chunk1'@ is a vector + -- of remaining packets of the @chunk1@. Neither @chunk2@ nor + -- @chunk3@ have to be evaluated here as you might expect. + -- + -- But think about the following expression: + -- + -- @ + -- import qualified Data.Vector.Fusion.Stream as Stream + -- 'unstream' $ Stream.tail $ 'stream' bs + -- @ + -- + -- the resulting chunk structure will be: + -- + -- @ + -- [chunk1', chunk2', chunk3', ...] + -- @ + -- + -- where each and every chunks are slightly different from the + -- original chunks, and this time @chunk1'@ has the same length as + -- @chunk1@ but the last bit of @chunk1'@ is from the first bit of + -- @chunk2@. This means when you next time apply some functions + -- strict on the first chunk, you end up fully evaluating @chunk2@ + -- as well as @chunk1@ and this can be a serious misbehaviour for + -- lazy 'Bitstream's. + -- + -- The automatic fusion rules are carefully designed to fire only + -- when there aren't any reason to preserve the original packet / + -- chunk structure. + stream ∷ α → Stream Bool + + -- | /O(n)/ Convert a 'S.Stream' of 'Bool' into a 'Bitstream'. + unstream ∷ Stream Bool → α + + -- | /strict: O(n), lazy: O(1)/ 'cons' is an analogous to (':') + -- for lists. + cons ∷ Bool → α → α + + -- | /O(n)/ For strict 'Bitstream's, 'cons'' is exactly the same + -- as 'cons'. + -- + -- For lazy ones, 'cons'' is strict in the 'Bitstream' we are + -- consing onto. More precisely, it forces the first chunk to be + -- evaluated. It does this because, for space efficiency, it may + -- coalesce the new bit onto the first chunk rather than starting + -- a new chunk. + cons' ∷ Bool → α → α + {-# INLINE cons' #-} + cons' = cons + + -- | /O(n)/ Append a bit to the end of a 'Bitstream'. + snoc ∷ α → Bool → α + + -- | /O(n)/ Append two 'Bitstream's. + append ∷ α → α → α + + -- | /O(1)/ Extract the bits after the 'head' of a non-empty + -- 'Bitstream'. An exception will be thrown if empty. + tail ∷ α → α + + -- | /O(n)/ Return all the bits of a 'Bitstream' except the last + -- one. An exception will be thrown if empty. + init ∷ α → α + + -- | /O(n)/ Map a function over a 'Bitstream'. + map ∷ (Bool → Bool) → α → α + + -- | /O(n)/ Reverse a 'Bitstream'. + reverse ∷ α → α + + -- | /O(n)/ Concatenate all 'Bitstream's in the list. + concat ∷ [α] → α + {-# INLINE concat #-} + concat [] = (∅) + concat (α:αs) = α ⧺ concat αs + + -- | /O(n)/ 'scanl' is similar to 'foldl', but returns a + -- 'Bitstream' of successive reduced bits from the left: + -- + -- @ + -- 'scanl' f z [x1, x2, ...] == [z, z `f` x1, (z `f` x1) `f` x2, ...] + -- @ + -- + -- Note that + -- + -- @ + -- 'last' ('scanl' f z xs) == 'foldl' f z xs + -- @ + scanl ∷ (Bool → Bool → Bool) → Bool → α → α + + -- | /O(n)/ @'replicate' n x@ is a 'Bitstream' of length @n@ with + -- @x@ the value of every bit. + replicate ∷ Integral n ⇒ n → Bool → α + {-# INLINE replicate #-} + replicate n = unstream ∘ genericReplicate n + + -- | /O(n)/ 'take' @n@, applied to a 'Bitstream' @xs@, returns the + -- prefix of @xs@ of length @n@, or @xs@ itself if @n > 'length' + -- xs@. + take ∷ Integral n ⇒ n → α → α + + -- | /O(n)/ 'drop' @n xs@ returns the suffix of @xs@ after the + -- first @n@ bits, or 'empty' if @n > 'length' xs@. + drop ∷ Integral n ⇒ n → α → α + + -- | /O(n)/ 'takeWhile', applied to a predicate @p@ and a + -- 'Bitstream' @xs@, returns the longest prefix (possibly 'empty') + -- of @xs@ of bits that satisfy @p@. + takeWhile ∷ (Bool → Bool) → α → α + + -- | /O(n)/ 'dropWhile' @p xs@ returns the suffix remaining after + -- 'takeWhile' @p xs@. + dropWhile ∷ (Bool → Bool) → α → α + + -- | /O(n)/ 'filter', applied to a predicate and a 'Bitstream', + -- returns the 'Bitstream' of those bits that satisfy the + -- predicate. + filter ∷ (Bool → Bool) → α → α + + -- | /O(n)/ The 'partition' function takes a predicate and a + -- 'Bitstream' and returns the pair of 'Bitstream's of bits which + -- do and do not satisfy the predicate, respectively. + partition ∷ (Bool → Bool) → α → (α, α) + {-# INLINEABLE partition #-} + partition f α = (filter f α, filter ((¬) ∘ f) α) + +-- | (∅) = 'empty' +-- +-- U+2205, EMPTY SET +{-# INLINE (∅) #-} +(∅) ∷ Bitstream α ⇒ α +(∅) = empty + +-- | (⧺) = 'append' +-- +-- U+29FA, DOUBLE PLUS +(⧺) ∷ Bitstream α ⇒ α → α → α +(⧺) = append +{-# INLINE (⧺) #-} + +-- | (∈) = 'elem' +-- +-- U+2208, ELEMENT OF +(∈) ∷ Bitstream α ⇒ Bool → α → Bool +{-# INLINE (∈) #-} +(∈) = elem + +-- | (∋) = 'flip' (∈) +-- +-- U+220B, CONTAINS AS MEMBER +(∋) ∷ Bitstream α ⇒ α → Bool → Bool +(∋) = flip elem +{-# INLINE (∋) #-} + +-- | (∉) = 'notElem' +-- +-- U+2209, NOT AN ELEMENT OF +(∉) ∷ Bitstream α ⇒ Bool → α → Bool +(∉) = notElem +{-# INLINE (∉) #-} + +-- | (∌) = 'flip' (∉) +-- +-- U+220C, DOES NOT CONTAIN AS MEMBER +(∌) ∷ Bitstream α ⇒ α → Bool → Bool +(∌) = flip notElem +{-# INLINE (∌) #-} + +-- | /O(n)/ Convert a ['Bool'] into a 'Bitstream'. +{-# INLINE [1] pack #-} +pack ∷ Bitstream α ⇒ [Bool] → α +pack = unstream ∘ S.fromList + +-- | /O(n)/ Convert a 'Bitstream' into a ['Bool']. +unpack ∷ Bitstream α ⇒ α → [Bool] +{-# RULES "Bitstream unpack/unstream fusion" + ∀s. unpack (unstream s) = S.toList s + #-} +{-# INLINE [1] unpack #-} +unpack = S.toList ∘ stream + +-- | /O(1)/ The empty 'Bitstream'. +empty ∷ Bitstream α ⇒ α +{-# INLINE [1] empty #-} +empty = unstream S.empty + +-- | /O(1)/ Convert a 'Bool' into a 'Bitstream'. +singleton ∷ Bitstream α ⇒ Bool → α +{-# INLINE [1] singleton #-} +singleton = unstream ∘ S.singleton + +-- | /O(1)/ Extract the first bit of a non-empty 'Bitstream'. An +-- exception will be thrown if empty. +head ∷ Bitstream α ⇒ α → Bool +{-# RULES "Bitstream head/unstream fusion" + ∀s. head (unstream s) = S.head s + #-} +{-# INLINE [1] head #-} +head = S.head ∘ stream + +-- | /strict: O(1), lazy: O(n)/ Extract the last bit of a finite +-- 'Bitstream'. An exception will be thrown if empty. +last ∷ Bitstream α ⇒ α → Bool +{-# RULES "Bitstream last/unstream fusion" + ∀s. last (unstream s) = S.last s + #-} +{-# INLINE [1] last #-} +last = S.last ∘ stream + +-- | /O(1)/ Test whether a 'Bitstream' is empty. +null ∷ Bitstream α ⇒ α → Bool +{-# RULES "Bitstream null/unstream fusion" + ∀s. null (unstream s) = S.null s + #-} +{-# INLINE [1] null #-} +null = S.null ∘ stream + +-- | /O(n)/ Retern the length of a finite 'Bitstream'. +length ∷ Bitstream α ⇒ Num n ⇒ α → n +{-# RULES "Bitstream length/unstream fusion" + ∀s. length (unstream s) = genericLength s + #-} +{-# INLINE [1] length #-} +length = genericLength ∘ stream + +-- | Map a function over a 'Bitstream' and concatenate the results. +concatMap ∷ Bitstream α ⇒ (Bool → α) → α → α +{-# RULES "Bitstream concatMap/unstream fusion" + ∀f s. concatMap f (unstream s) = unstream (S.concatMap f s) + #-} +{-# INLINE [1] concatMap #-} +concatMap f = concat ∘ L.map f ∘ unpack + +-- | /O(n)/ 'and' returns the conjunction of a 'Bool' list. For the +-- result to be 'True', the 'Bitstream' must be finite; 'False', +-- however, results from a 'False' value at a finite index of a finite +-- or infinite 'Bitstream'. Note that strict 'Bitstream's are always +-- finite. +and ∷ Bitstream α ⇒ α → Bool +{-# RULES "Bitstream and/unstream fusion" + ∀s. and (unstream s) = S.and s + #-} +{-# INLINE [1] and #-} +and = S.and ∘ stream + +-- | /O(n)/ 'or' returns the disjunction of a 'Bool' list. For the +-- result to be 'False', the 'Bitstream' must be finite; 'True', +-- however, results from a 'True' value at a finite index of a finite +-- or infinite 'Bitstream'. Note that strict 'Bitstream's are always +-- finite. +or ∷ Bitstream α ⇒ α → Bool +{-# RULES "Bitstream or/unstream fusion" + ∀s. or (unstream s) = S.or s + #-} +{-# INLINE [1] or #-} +or = S.or ∘ stream + +-- | /O(n)/ Applied to a predicate and a 'Bitstream', 'any' determines +-- if any bit of the 'Bitstream' satisfies the predicate. For the +-- result to be 'False', the 'Bitstream' must be finite; 'True', +-- however, results from a 'True' value for the predicate applied to a +-- bit at a finite index of a finite or infinite 'Bitstream'. +any ∷ Bitstream α ⇒ (Bool → Bool) → α → Bool +{-# RULES "Bitstream any/unstream fusion" + ∀f s. any f (unstream s) = S.or (S.map f s) + #-} +{-# INLINE [1] any #-} +any f = S.or ∘ S.map f ∘ stream + +-- | /O(n)/ Applied to a predicate and a 'Bitstream', 'all' determines +-- if all bits of the 'Bitstream' satisfy the predicate. For the +-- result to be 'True', the 'Bitstream' must be finite; 'False', +-- however, results from a 'False' value for the predicate applied to +-- a bit at a finite index of a finite or infinite 'Bitstream'. +all ∷ Bitstream α ⇒ (Bool → Bool) → α → Bool +{-# RULES "Bitstream all/unstream fusion" + ∀f s. all f (unstream s) = S.and (S.map f s) + #-} +{-# INLINE [1] all #-} +all f = S.and ∘ S.map f ∘ stream + +-- | /O(n)/ 'scanl1' is a variant of 'scanl' that has no starting +-- value argument: +-- +-- @ +-- 'scanl1' f [x1, x2, ...] == [x1, x1 `f` x2, ...] +-- @ +scanl1 ∷ Bitstream α ⇒ (Bool → Bool → Bool) → α → α +{-# RULES "Bitstream scanl1/unstream fusion" + ∀f s. scanl1 f (unstream s) = S.scanl1 f s + #-} +{-# INLINE [1] scanl1 #-} +scanl1 f α + | null α = α + | otherwise = scanl f (head α) (tail α) + +-- | /O(n)/ 'scanr' is the right-to-left dual of 'scanl'. Note that +-- +-- @ +-- 'head' ('scanr' f z xs) == 'foldr' f z xs +-- @ +scanr ∷ Bitstream α ⇒ (Bool → Bool → Bool) → Bool → α → α +{-# INLINE [1] scanr #-} +scanr f b = reverse ∘ scanl (flip f) b ∘ reverse + +-- | /O(n)/ 'scanr1' is a variant of 'scanr' that has no starting +-- value argument. +scanr1 ∷ Bitstream α ⇒ (Bool → Bool → Bool) → α → α +{-# INLINE [1] scanr1 #-} +scanr1 f = reverse ∘ scanl1 (flip f) ∘ reverse + +-- | /O(n)/ 'foldl', applied to a binary operator, a starting value +-- (typically the left-identity of the operator), and a 'Bitstream', +-- reduces the 'Bitstream' using the binary operator, from left to +-- right: +-- +-- @ +-- 'foldl' f z [x1, x2, ..., xn] == (...((z `f` x1) `f` x2) `f`...) `f` xn +-- @ +-- +-- The 'Bitstream' must be finite. +foldl ∷ Bitstream α ⇒ (β → Bool → β) → β → α → β +{-# RULES "Bitstream foldl/unstream fusion" + ∀f β s. foldl f β (unstream s) = S.foldl f β s + #-} +{-# INLINE [1] foldl #-} +foldl f β = S.foldl f β ∘ stream + +-- | /O(n)/ 'foldl'' is a variant of 'foldl' that is strict on the +-- accumulator. +foldl' ∷ Bitstream α ⇒ (β → Bool → β) → β → α → β +{-# RULES "Bitstream foldl'/unstream fusion" + ∀f β s. foldl' f β (unstream s) = S.foldl' f β s + #-} +{-# INLINE [1] foldl' #-} +foldl' f β = S.foldl' f β ∘ stream + +-- | /O(n)/ 'foldl1' is a variant of 'foldl' that has no starting +-- value argument, and thus must be applied to non-empty 'Bitstream's. +foldl1 ∷ Bitstream α ⇒ (Bool → Bool → Bool) → α → Bool +{-# RULES "Bitstream foldl1/unstream fusion" + ∀f s. foldl1 f (unstream s) = S.foldl1 f s + #-} +{-# INLINE [1] foldl1 #-} +foldl1 f = S.foldl1 f ∘ stream + +-- | /O(n)/ A strict version of 'foldl1'. +foldl1' ∷ Bitstream α ⇒ (Bool → Bool → Bool) → α → Bool +{-# RULES "Bitstream foldl1'/unstream fusion" + ∀f s. foldl1' f (unstream s) = S.foldl1' f s + #-} +{-# INLINE [1] foldl1' #-} +foldl1' f = S.foldl1' f ∘ stream + +-- | /O(n)/ 'foldr', applied to a binary operator, a starting value +-- (typically the right-identity of the operator), and a 'Bitstream', +-- reduces the 'Bitstream' using the binary operator, from right to +-- left: +-- +-- @ +-- 'foldr' f z [x1, x2, ..., xn] == x1 `f` (x2 `f` ... (xn `f` z)...) +-- @ +foldr ∷ Bitstream α ⇒ (Bool → β → β) → β → α → β +{-# RULES "Bitstream foldr/unstream fusion" + ∀f β s. foldr f β (unstream s) = S.foldr f β s + #-} +{-# INLINE [1] foldr #-} +foldr f β = S.foldr f β ∘ stream + +-- | /O(n)/ 'foldr1' is a variant of 'foldr' that has no starting +-- value argument, and thus must be applied to non-empty 'Bitstream's. +foldr1 ∷ Bitstream α ⇒ (Bool → Bool → Bool) → α → Bool +{-# RULES "Bitstream foldr1/unstream fusion" + ∀f s. foldr1 f (unstream s) = S.foldr1 f s + #-} +{-# INLINE [1] foldr1 #-} +foldr1 f = S.foldr1 f ∘ stream + +-- | /O(n)/ The 'unfoldr' function is a \`dual\' to 'foldr': while +-- 'foldr' reduces a 'Bitstream' to a summary value, 'unfoldr' builds +-- a 'Bitstream' from a seed value. The function takes the element and +-- returns 'Nothing' if it is done producing the 'Bitstream' or +-- returns 'Just' @(a, b)@, in which case, @a@ is a prepended to the +-- 'Bitstream' and @b@ is used as the next element in a recursive +-- call. +unfoldr ∷ Bitstream α ⇒ (β → Maybe (Bool, β)) → β → α +{-# INLINE [1] unfoldr #-} +unfoldr f = unstream ∘ S.unfoldr f + +-- | /O(n)/ 'unfoldrN' is a variant of 'unfoldr' but constructs a +-- 'Bitstream' with at most @n@ bits. +unfoldrN ∷ (Bitstream α, Integral n) ⇒ n → (β → Maybe (Bool, β)) → β → α +{-# INLINE [1] unfoldrN #-} +unfoldrN n f = unstream ∘ genericUnfoldrN n f + +-- | /O(n)/ 'Bitstream' index (subscript) operator, starting from 0. +(!!) ∷ (Bitstream α, Integral n) ⇒ α → n → Bool +{-# RULES "Bitstream (!!)/unstream fusion" + ∀s n. (unstream s) !! n = genericIndex s n + #-} +{-# INLINE [1] (!!) #-} +α !! n = genericIndex (stream α) n + +-- | /O(n)/ 'span', applied to a predicate @p@ and a 'Bitstream' @xs@, +-- returns a tuple where first element is longest prefix (possibly +-- 'empty') of @xs@ of bits that satisfy @p@ and second element is the +-- remainder of the 'Bitstream'. +-- +-- 'span' @p xs@ is equivalent to @('takeWhile' p xs, 'dropWhile' p +-- xs)@ +span ∷ Bitstream α ⇒ (Bool → Bool) → α → (α, α) +{-# INLINE [1] span #-} +span f α + = let hd = takeWhile f α + tl = drop (length hd ∷ Integer) α + in + (hd, tl) + +-- | /O(n)/ 'break', applied to a predicate @p@ and a 'Bitstream' +-- @xs@, returns a tuple where first element is longest prefix +-- (possibly 'empty') of @xs@ of bits that /do not satisfy/ @p@ and +-- second element is the remainder of the 'Bitstream'. +-- +-- 'break' @p@ is equivalent to @'span' ('not' . p)@. +break ∷ Bitstream α ⇒ (Bool → Bool) → α → (α, α) +{-# INLINE [1] break #-} +break f = span ((¬) ∘ f) + +-- | /O(n)/ 'elem' is the 'Bitstream' membership predicate, usually +-- written in infix form, e.g., @x \`elem\` xs@. For the result to be +-- 'False', the 'Bitstream' must be finite; 'True', however, results +-- from an bit equal to @x@ found at a finite index of a finite or +-- infinite 'Bitstream'. +elem ∷ Bitstream α ⇒ Bool → α → Bool +{-# RULES "Bitstream elem/unstream fusion" + ∀b s. elem b (unstream s) = S.elem b s + #-} +{-# INLINE [1] elem #-} +elem True = or +elem False = (¬) ∘ and + +-- | /O(n)/ 'notElem' is the negation of 'elem'. +notElem ∷ Bitstream α ⇒ Bool → α → Bool +{-# RULES "Bitstream notElem/unstream fusion" + ∀b s. notElem b (unstream s) = S.notElem b s + #-} +{-# INLINE [1] notElem #-} +notElem = ((¬) ∘) ∘ (∈) + +-- | /O(n)/ The 'find' function takes a predicate and a 'Bitstream' +-- and returns the bit in the 'Bitstream' matching the predicate, or +-- 'Nothing' if there is no such bit. +find ∷ Bitstream α ⇒ (Bool → Bool) → α → Maybe Bool +{-# RULES "Bitstream find/unstream fusion" + ∀f s. find f (unstream s) = S.find f s + #-} +{-# INLINE [1] find #-} +find f = S.find f ∘ stream + +-- | /O(n)/ The 'elemIndex' function returns the index of the first +-- bit in the given 'Bitstream' which is equal to the query bit, or +-- 'Nothing' if there is no such bit. +elemIndex ∷ (Bitstream α, Integral n) ⇒ Bool → α → Maybe n +{-# RULES "Bitstream elemIndex/unstream fusion" + ∀b s. elemIndex b (unstream s) = genericFindIndex (≡ b) s + #-} +{-# INLINE [1] elemIndex #-} +elemIndex = findIndex ∘ (≡) + +-- | /O(n)/ The 'elemIndices' function extends 'elemIndex', by +-- returning the indices of all bits equal to the query bit, in +-- ascending order. +elemIndices ∷ (Bitstream α, Integral n) ⇒ Bool → α → [n] +{-# RULES "Bitstream elemIndices/unstream fusion" + ∀b s. elemIndices b (unstream s) + = S.toList + $ S.map fst + $ S.filter ((≡ b) ∘ snd) + $ genericIndexed s + #-} +{-# INLINE [1] elemIndices #-} +elemIndices = findIndices ∘ (≡) + +-- | /O(n)/ The 'findIndex' function takes a predicate and a +-- 'Bitstream' and returns the index of the first bit in the +-- 'Bitstream' satisfying the predicate, or 'Nothing' if there is no +-- such bit. +findIndex ∷ (Bitstream α, Integral n) ⇒ (Bool → Bool) → α → Maybe n +{-# RULES "Bitstream findIndex/unstream fusion" + ∀f s. findIndex f (unstream s) = genericFindIndex f s + #-} +{-# INLINE [1] findIndex #-} +findIndex f = genericFindIndex f ∘ stream + +-- | /O(n)/ The 'findIndices' function extends 'findIndex', by +-- returning the indices of all bits satisfying the predicate, in +-- ascending order. +findIndices ∷ (Bitstream α, Integral n) ⇒ (Bool → Bool) → α → [n] +{-# RULES "Bitstream findIndices/unstream fusion" + ∀f s. findIndices f (unstream s) + = S.toList + $ S.map fst + $ S.filter (f ∘ snd) + $ genericIndexed s + #-} +{-# INLINE [1] findIndices #-} +findIndices f + = S.toList + ∘ S.map fst + ∘ S.filter (f ∘ snd) + ∘ genericIndexed + ∘ stream + +-- | /O(min(m, n))/ 'zip' takes two 'Bitstream's and returns a list of +-- corresponding bit pairs. If one input 'Bitstream' is short, excess +-- bits of the longer 'Bitstream' are discarded. +zip ∷ Bitstream α ⇒ α → α → [(Bool, Bool)] +{-# RULES "Bitstream zip/unstream fusion" ∀s1 s2. + zip (unstream s1) (unstream s2) + = S.toList (S.zip s1 s2) + #-} +{-# INLINE [1] zip #-} +zip = zipWith (,) + +-- | The 'zip3' function takes three 'Bitstream's and returns a list +-- of triples, analogous to 'zip'. +zip3 ∷ Bitstream α ⇒ α → α → α → [(Bool, Bool, Bool)] +{-# RULES "Bitstream zip3/unstream fusion" ∀s1 s2 s3. + zip3 (unstream s1) (unstream s2) (unstream s3) + = S.toList (S.zip3 s1 s2 s3) + #-} +{-# INLINE [1] zip3 #-} +zip3 = zipWith3 (,,) + +-- | The 'zip4' function takes four lists and returns a list of +-- quadruples, analogous to 'zip'. +zip4 ∷ Bitstream α ⇒ α → α → α → α → [(Bool, Bool, Bool, Bool)] +{-# RULES "Bitstream zip4/unstream fusion" ∀s1 s2 s3 s4. + zip4 (unstream s1) (unstream s2) (unstream s3) (unstream s4) + = S.toList (S.zip4 s1 s2 s3 s4) + #-} +{-# INLINE [1] zip4 #-} +zip4 = zipWith4 (,,,) + +-- | The 'zip5' function takes five 'Bitstream's and returns a list of +-- five-tuples, analogous to 'zip'. +zip5 ∷ Bitstream α ⇒ α → α → α → α → α → [(Bool, Bool, Bool, Bool, Bool)] +{-# RULES "Bitstream zip5/unstream fusion" ∀s1 s2 s3 s4 s5. + zip5 (unstream s1) (unstream s2) (unstream s3) (unstream s4) (unstream s5) + = S.toList (S.zip5 s1 s2 s3 s4 s5) + #-} +{-# INLINE [1] zip5 #-} +zip5 = zipWith5 (,,,,) + +-- | The 'zip6' function takes six 'Bitstream's and returns a list of +-- six-tuples, analogous to 'zip'. +zip6 ∷ Bitstream α ⇒ α → α → α → α → α → α → [(Bool, Bool, Bool, Bool, Bool, Bool)] +{-# RULES "Bitstream zip6/unstream fusion" ∀s1 s2 s3 s4 s5 s6. + zip6 (unstream s1) (unstream s2) (unstream s3) (unstream s4) (unstream s5) (unstream s6) + = S.toList (S.zip6 s1 s2 s3 s4 s5 s6) + #-} +{-# INLINE [1] zip6 #-} +zip6 = zipWith6 (,,,,,) + +-- | /O(min(m, n))/ 'zipWith' generalises 'zip' by zipping with the +-- function given as the first argument, instead of a tupling +-- function. +zipWith ∷ Bitstream α ⇒ (Bool → Bool → β) → α → α → [β] +{-# RULES "Bitstream zipWith/unstream fusion" ∀f s1 s2. + zipWith f (unstream s1) (unstream s2) + = S.toList (S.zipWith f s1 s2) + #-} +{-# INLINEABLE [1] zipWith #-} +zipWith f α β = S.toList $ + S.zipWith f + (stream α) + (stream β) + +-- | The 'zipWith3' function takes a function which combines three +-- bits, as well as three 'Bitstream's and returns a list of their +-- point-wise combination, analogous to 'zipWith'. +zipWith3 ∷ Bitstream α ⇒ (Bool → Bool → Bool → β) → α → α → α → [β] +{-# RULES "Bitstream zipWith3/unstream fusion" ∀f s1 s2 s3. + zipWith3 f (unstream s1) (unstream s2) (unstream s3) + = S.toList (S.zipWith3 f s1 s2 s3) + #-} +{-# INLINEABLE [1] zipWith3 #-} +zipWith3 f α β γ = S.toList $ + S.zipWith3 f + (stream α) + (stream β) + (stream γ) + +-- | The 'zipWith4' function takes a function which combines four +-- bits, as well as four 'Bitstream's and returns a list of their +-- point-wise combination, analogous to 'zipWith'. +zipWith4 ∷ Bitstream α ⇒ (Bool → Bool → Bool → Bool → β) → α → α → α → α → [β] +{-# RULES "Bitstream zipWith4/unstream fusion" ∀f s1 s2 s3 s4. + zipWith4 f (unstream s1) (unstream s2) (unstream s3) (unstream s4) + = S.toList (S.zipWith4 f s1 s2 s3 s4) + #-} +{-# INLINEABLE [1] zipWith4 #-} +zipWith4 f α β γ δ = S.toList $ + S.zipWith4 f + (stream α) + (stream β) + (stream γ) + (stream δ) + +-- | The 'zipWith5' function takes a function which combines five +-- bits, as well as five 'Bitstream's and returns a list of their +-- point-wise combination, analogous to 'zipWith'. +zipWith5 ∷ Bitstream α ⇒ (Bool → Bool → Bool → Bool → Bool → β) → α → α → α → α → α → [β] +{-# RULES "Bitstream zipWith5/unstream fusion" ∀f s1 s2 s3 s4 s5. + zipWith5 f (unstream s1) (unstream s2) (unstream s3) (unstream s4) (unstream s5) + = S.toList (S.zipWith5 f s1 s2 s3 s4 s5) + #-} +{-# INLINEABLE [1] zipWith5 #-} +zipWith5 f α β γ δ ε = S.toList $ + S.zipWith5 f + (stream α) + (stream β) + (stream γ) + (stream δ) + (stream ε) + +-- | The 'zipWith6' function takes a function which combines six bits, +-- as well as six 'Bitstream's and returns a list of their point-wise +-- combination, analogous to 'zipWith'. +zipWith6 ∷ Bitstream α ⇒ (Bool → Bool → Bool → Bool → Bool → Bool → β) → α → α → α → α → α → α → [β] +{-# RULES "Bitstream zipWith6/unstream fusion" ∀f s1 s2 s3 s4 s5 s6. + zipWith6 f (unstream s1) (unstream s2) (unstream s3) (unstream s4) (unstream s5) (unstream s6) + = S.toList (S.zipWith6 f s1 s2 s3 s4 s5 s6) + #-} +{-# INLINEABLE [1] zipWith6 #-} +zipWith6 f α β γ δ ε ζ = S.toList $ + S.zipWith6 f + (stream α) + (stream β) + (stream γ) + (stream δ) + (stream ε) + (stream ζ) + +-- | /O(min(m, n))/ 'unzip' transforms a list of bit pairs into a +-- 'Bitstream' of first components and a 'Bitstream' of second +-- components. +unzip ∷ Bitstream α ⇒ [(Bool, Bool)] → (α, α) +{-# INLINEABLE [1] unzip #-} +unzip xs = ( unstream $ S.map fst $ S.fromList xs + , unstream $ S.map snd $ S.fromList xs ) + +-- | The 'unzip3' function takes a list of triples and returns three +-- 'Bitstream's, analogous to 'unzip'. +unzip3 ∷ Bitstream α ⇒ [(Bool, Bool, Bool)] → (α, α, α) +{-# INLINEABLE [1] unzip3 #-} +unzip3 xs = ( unstream $ S.map (\(α, _, _) → α) $ S.fromList xs + , unstream $ S.map (\(_, β, _) → β) $ S.fromList xs + , unstream $ S.map (\(_, _, γ) → γ) $ S.fromList xs ) + +-- | The 'unzip4' function takes a list of quadruples and returns +-- four 'Bitstream's, analogous to 'unzip'. +unzip4 ∷ Bitstream α ⇒ [(Bool, Bool, Bool, Bool)] → (α, α, α, α) +{-# INLINEABLE [1] unzip4 #-} +unzip4 xs = ( unstream $ S.map (\(α, _, _, _) → α) $ S.fromList xs + , unstream $ S.map (\(_, β, _, _) → β) $ S.fromList xs + , unstream $ S.map (\(_, _, γ, _) → γ) $ S.fromList xs + , unstream $ S.map (\(_, _, _, δ) → δ) $ S.fromList xs ) + +-- | The 'unzip5' function takes a list of five-tuples and returns +-- five 'Bitstream's, analogous to 'unzip'. +unzip5 ∷ Bitstream α ⇒ [(Bool, Bool, Bool, Bool, Bool)] → (α, α, α, α, α) +{-# INLINEABLE [1] unzip5 #-} +unzip5 xs = ( unstream $ S.map (\(α, _, _, _, _) → α) $ S.fromList xs + , unstream $ S.map (\(_, β, _, _, _) → β) $ S.fromList xs + , unstream $ S.map (\(_, _, γ, _, _) → γ) $ S.fromList xs + , unstream $ S.map (\(_, _, _, δ, _) → δ) $ S.fromList xs + , unstream $ S.map (\(_, _, _, _, ε) → ε) $ S.fromList xs ) + +-- | The 'unzip6' function takes a list of six-tuples and returns six +-- 'Bitstream's, analogous to 'unzip'. +unzip6 ∷ Bitstream α ⇒ [(Bool, Bool, Bool, Bool, Bool, Bool)] → (α, α, α, α, α, α) +{-# INLINEABLE [1] unzip6 #-} +unzip6 xs = ( unstream $ S.map (\(α, _, _, _, _, _) → α) $ S.fromList xs + , unstream $ S.map (\(_, β, _, _, _, _) → β) $ S.fromList xs + , unstream $ S.map (\(_, _, γ, _, _, _) → γ) $ S.fromList xs + , unstream $ S.map (\(_, _, _, δ, _, _) → δ) $ S.fromList xs + , unstream $ S.map (\(_, _, _, _, ε, _) → ε) $ S.fromList xs + , unstream $ S.map (\(_, _, _, _, _, ζ) → ζ) $ S.fromList xs ) + +{-# RULES +"Bitstream stream/unstream fusion" + ∀s. stream (unstream s) = s + +"Bitstream unstream/stream fusion" + ∀v. unstream (stream v) = v + #-} + +{-# RULES +"Bitstream cons/unstream fusion" + ∀b s. cons b (unstream s) = unstream (S.cons b s) + +"Bitstream cons'/unstream fusion" + ∀b s. cons' b (unstream s) = unstream (S.cons b s) + +"Bitstream snoc/unstream fusion" + ∀s b. snoc (unstream s) b = unstream (S.snoc s b) + +"Bitstream append/unstream fusion" + ∀s1 s2. append (unstream s1) (unstream s2) = unstream (s1 S.++ s2) + +"Bitstream tail/unstream fusion" + ∀s. tail (unstream s) = unstream (S.tail s) + +"Bitstream init/unstream fusion" + ∀s. init (unstream s) = unstream (S.init s) + +"Bitstream map/unstream fusion" + ∀f s. map f (unstream s) = unstream (S.map f s) + +"Bitstream scanl/unstream fusion" + ∀f b s. scanl f b (unstream s) = unstream (S.scanl f b s) + +"Bitstream scanl1/unstream fusion" + ∀f s. scanl1 f (unstream s) = unstream (S.scanl1 f s) + +"Bitstream take/unstream fusion" + ∀n s. take n (unstream s) = unstream (genericTake n s) + +"Bitstream drop/unstream fusion" + ∀n s. drop n (unstream s) = unstream (genericDrop n s) + +"Bitstream takeWhile/unstream fusion" + ∀f s. takeWhile f (unstream s) = unstream (S.takeWhile f s) + +"Bitstream dropWhile/unstream fusion" + ∀f s. dropWhile f (unstream s) = unstream (S.dropWhile f s) + +"Bitstream filter/unstream fusion" + ∀f s. filter f (unstream s) = unstream (S.filter f s) + #-} diff --git a/Data/Bitstream/Internal.hs b/Data/Bitstream/Internal.hs new file mode 100644 --- /dev/null +++ b/Data/Bitstream/Internal.hs @@ -0,0 +1,38 @@ +{-# LANGUAGE + FlexibleContexts + , UnicodeSyntax + #-} +module Data.Bitstream.Internal + ( packPackets + ) + where +import Data.Bitstream.Generic +import Data.Bitstream.Packet +import Data.Vector.Fusion.Stream.Monadic (Stream(..), Step(..)) +import Data.Vector.Fusion.Stream.Size +import Prelude hiding (null) +import Prelude.Unicode + +packPackets ∷ (Bitstream (Packet d), Monad m) ⇒ Stream m Bool → Stream m (Packet d) +{-# INLINE packPackets #-} +packPackets (Stream step s0 sz) = Stream step' ((∅), Just s0) sz' + where + sz' ∷ Size + {-# INLINE sz' #-} + sz' = case sz of + Exact n → Exact (n+7 `div` 8) + Max n → Max (n+7 `div` 8) + Unknown → Unknown + {-# INLINE step' #-} + step' (p, Just s) + = do r ← step s + case r of + Yield b s' + | full p → return $ Yield p (singleton b, Just s') + | otherwise → return $ Skip (p `snoc` b , Just s') + Skip s' → return $ Skip (p , Just s') + Done + | null p → return Done + | otherwise → return $ Yield p ((⊥) , Nothing) + step' (_, Nothing) + = return Done diff --git a/Data/Bitstream/Lazy.hs b/Data/Bitstream/Lazy.hs new file mode 100644 --- /dev/null +++ b/Data/Bitstream/Lazy.hs @@ -0,0 +1,683 @@ +{-# LANGUAGE + BangPatterns + , FlexibleContexts + , ScopedTypeVariables + , UndecidableInstances + , UnicodeSyntax + #-} +-- | Fast, packed, lazy bit streams (i.e. list of 'Bool's) with +-- semi-automatic stream fusion. +-- +-- This module is intended to be imported @qualified@, to avoid name +-- clashes with "Prelude" functions. e.g. +-- +-- > import qualified Data.BitStream.Lazy as LS +-- +-- Lazy 'Bitstream's are made of possibly infinite list of strict +-- 'SB.Bitstream's as chunks, and each chunks have at least 1 bit. +module Data.Bitstream.Lazy + ( -- * Types + Bitstream + , Left + , Right + + -- * Introducing and eliminating 'Bitstream's + , empty + , (∅) + , singleton + , pack + , unpack + , fromChunks + , toChunks + + -- ** Converting from\/to lazy 'LS.ByteString's + , fromByteString + , toByteString + + -- ** Converting from\/to 'S.Stream's + , stream + , unstream + + -- * Changing bit order in octets + , directionLToR + , directionRToL + + -- * Basic interface + , cons + , cons' + , snoc + , append + , (⧺) + , head + , last + , tail + , init + , null + , length + + -- * Transforming 'Bitstream's + , map + , reverse + + -- * Reducing 'Bitstream's + , foldl + , foldl' + , foldl1 + , foldl1' + , foldr + , foldr1 + + -- ** Special folds + , concat + , concatMap + , and + , or + , any + , all + + -- * Building lists + -- ** Scans + , scanl + , scanl1 + , scanr + , scanr1 + + -- ** Replications + , iterate + , repeat + , replicate + , cycle + + -- ** Unfolding + , unfoldr + , unfoldrN + + -- * Substreams + , take + , drop + , takeWhile + , dropWhile + , span + , break + + -- * Searching streams + -- ** Searching by equality + , elem + , (∈) + , (∋) + , notElem + , (∉) + , (∌) + + -- ** Searching with a predicate + , find + , filter + , partition + + -- ** Indexing streams + , (!!) + , elemIndex + , elemIndices + , findIndex + , findIndices + + -- * Zipping and unzipping streams + , zip + , zip3 + , zip4 + , zip5 + , zip6 + , zipWith + , zipWith3 + , zipWith4 + , zipWith5 + , zipWith6 + , unzip + , unzip3 + , unzip4 + , unzip5 + , unzip6 + + -- * I/O with 'Bitstream's + -- ** Standard input and output + , getContents + , putBits + , interact + + -- ** Files + , readFile + , writeFile + , appendFile + + -- ** I/O with 'Handle's + , hGetContents + , hGet + , hGetNonBlocking + , hPut + ) + where +import qualified Data.Bitstream as SB +import Data.Bitstream.Generic hiding (Bitstream) +import qualified Data.Bitstream.Generic as G +import Data.Bitstream.Internal +import Data.Bitstream.Packet +import qualified Data.ByteString.Lazy as LS +import qualified Data.List as L +import Data.Monoid +import qualified Data.Vector.Fusion.Stream as S +import Data.Vector.Fusion.Stream.Monadic (Stream(..), Step(..)) +import Data.Vector.Fusion.Stream.Size +import Data.Vector.Fusion.Util +import qualified Data.Vector.Generic as GV +import qualified Data.Vector.Generic.New as New +import qualified Data.Vector.Generic.Mutable as MVector +import qualified Data.Vector.Storable as SV +import Prelude ( Bool(..), Eq(..), Int, Integral, Maybe(..) + , Monad(..), Num(..), Ord(..), Show(..) + , ($), div, error, fmap, otherwise + ) +import Prelude.Unicode hiding ((⧺), (∈), (∉)) +import System.IO (FilePath, Handle, IO) + +-- 32 KiB * sizeOf (Packet d) == 64 KiB +chunkSize ∷ Num α ⇒ α +chunkSize = fromInteger (32 ⋅ 1024) +{-# INLINE chunkSize #-} + +chunkBits ∷ Num α ⇒ α +chunkBits = chunkSize ⋅ 8 + +-- | A space-efficient representation of a 'Bool' vector, supporting +-- many efficient operations. 'Bitstream's have an idea of +-- /directions/ controlling how octets are interpreted as bits. There +-- are two types of concrete 'Bitstream's: @'Bitstream' 'Left'@ and +-- @'Bitstream' 'Right'@. +data Bitstream d + = Empty + | Chunk {-# UNPACK #-} !(SB.Bitstream d) (Bitstream d) + +instance Show (Packet d) ⇒ Show (Bitstream d) where + {-# INLINEABLE show #-} + show ch + = L.concat + [ "[L: " + , L.concat (L.intersperse " " (L.map show (toChunks ch))) + , " ]" + ] + +instance G.Bitstream (Packet d) ⇒ Eq (Bitstream d) where + {-# INLINE (==) #-} + x == y = stream x ≡ stream y + +-- | 'Bitstream's are lexicographically ordered. +-- +-- @ +-- let x = 'pack' ['True' , 'False', 'False'] +-- y = 'pack' ['False', 'True' , 'False'] +-- z = 'pack' ['False'] +-- in +-- [ 'compare' x y -- 'GT' +-- , 'compare' z y -- 'LT' +-- ] +-- @ +instance G.Bitstream (Packet d) ⇒ Ord (Bitstream d) where + {-# INLINE compare #-} + x `compare` y = stream x `compare` stream y + +-- | 'Bitstream' forms 'Monoid' in the same way as ordinary lists: +-- +-- @ +-- 'mempty' = 'empty' +-- 'mappend' = 'append' +-- 'mconcat' = 'concat' +-- @ +instance G.Bitstream (Packet d) ⇒ Monoid (Bitstream d) where + mempty = (∅) + mappend = (⧺) + mconcat = concat + +instance G.Bitstream (Packet d) ⇒ G.Bitstream (Bitstream d) where + {-# INLINE [0] stream #-} + stream + = {-# CORE "Lazy Bitstream stream" #-} + S.concatMap stream ∘ streamChunks + + {-# INLINE [0] unstream #-} + unstream + = {-# CORE "Lazy Bitstream unstream" #-} + unId ∘ unstreamChunks ∘ packChunks ∘ packPackets + + {-# INLINE [2] cons #-} + cons b = Chunk (singleton b) + + {-# INLINEABLE [2] cons' #-} + cons' b Empty + = Chunk (SB.singleton b) Empty + cons' b (Chunk x xs) + | length x < (chunkBits ∷ Int) + = Chunk (b `cons` x) xs + | otherwise + = Chunk (singleton b) (Chunk x xs) + + {-# INLINEABLE [2] snoc #-} + snoc Empty b + = Chunk (SB.singleton b) Empty + snoc (Chunk x Empty) b + | length x < (chunkBits ∷ Int) + = Chunk (x `snoc` b) Empty + | otherwise + = Chunk x (Chunk (singleton b) Empty) + snoc (Chunk x xs) b + = Chunk x (xs `snoc` b) + + {-# INLINE [2] append #-} + append Empty ch = ch + append (Chunk x xs) ch = Chunk x (append xs ch) + + {-# INLINEABLE [2] tail #-} + tail Empty = emptyStream + tail (Chunk x xs) = case tail x of + x' | null x' → xs + | otherwise → Chunk x' xs + + {-# INLINEABLE [2] init #-} + init Empty = emptyStream + init (Chunk x Empty) = case init x of + x' | null x' → Empty + | otherwise → Chunk x' Empty + init (Chunk x xs ) = Chunk x (init xs) + + {-# INLINE [2] map #-} + map _ Empty = Empty + map f (Chunk x xs) = Chunk (map f x) (map f xs) + + {-# INLINEABLE [2] reverse #-} + reverse ch0 = go ch0 Empty + where + {-# INLINE go #-} + go Empty ch = ch + go (Chunk x xs) ch = go xs (Chunk (reverse x) ch) + + {-# INLINE [2] scanl #-} + scanl f b ch + = Chunk (singleton b) + (case ch of + Empty → Empty + Chunk x xs → let h = head x + x' = scanl f (f b h) (tail x) + l = last x' + x'' = init x' + xs' = scanl f l xs + in + if null x'' + then xs' + else Chunk x'' xs') + + {-# INLINE [2] concat #-} + concat = fromChunks ∘ L.concatMap toChunks + + {-# INLINEABLE replicate #-} + replicate n b + | n ≤ 0 = Empty + | n < chunkBits = Chunk (replicate n b) Empty + | otherwise = Chunk x (replicate (n - chunkBits) b) + where + x = replicate (chunkBits ∷ Int) b + + {-# INLINEABLE [2] take #-} + take _ Empty = Empty + take n (Chunk x xs) + | n ≤ 0 = Empty + | n ≥ length x = Chunk x (take (n - length x) xs) + | otherwise = Chunk (take n x) Empty + + {-# INLINEABLE [2] drop #-} + drop _ Empty = Empty + drop n (Chunk x xs) + | n ≤ 0 = Chunk x xs + | n ≥ length x = drop (n - length x) xs + | otherwise = Chunk (drop n x) xs + + {-# INLINEABLE [2] takeWhile #-} + takeWhile _ Empty = Empty + takeWhile f (Chunk x xs) = case takeWhile f x of + x' | x ≡ x' → Chunk x' (takeWhile f xs) + | otherwise → Chunk x' Empty + + {-# INLINEABLE [2] dropWhile #-} + dropWhile _ Empty = Empty + dropWhile f (Chunk x xs) = case dropWhile f x of + x' | null x' → dropWhile f xs + | otherwise → Chunk x' xs + + {-# INLINEABLE [2] filter #-} + filter _ Empty = Empty + filter f (Chunk x xs) = case filter f x of + x' | null x' → filter f xs + | otherwise → Chunk x' (filter f xs) + +lazyHead ∷ G.Bitstream (Packet d) ⇒ Bitstream d → Bool +{-# RULES "head → lazyHead" [2] + ∀(v ∷ G.Bitstream (Packet d) ⇒ Bitstream d). + head v = lazyHead v #-} +{-# INLINE lazyHead #-} +lazyHead Empty = emptyStream +lazyHead (Chunk x _) = head x + +lazyLast ∷ G.Bitstream (Packet d) ⇒ Bitstream d → Bool +{-# RULES "last → lazyLast" [2] + ∀(v ∷ G.Bitstream (Packet d) ⇒ Bitstream d). + last v = lazyLast v #-} +{-# INLINE lazyLast #-} +lazyLast Empty = emptyStream +lazyLast (Chunk x Empty) = last x +lazyLast (Chunk _ xs ) = lazyLast xs + +lazyNull ∷ Bitstream d → Bool +{-# RULES "null → lazyNull" [2] null = lazyNull #-} +{-# INLINE lazyNull #-} +lazyNull Empty = True +lazyNull _ = False + +lazyLength ∷ (G.Bitstream (Packet d), Num n) ⇒ Bitstream d → n +{-# RULES "length → lazyLength" [2] + ∀(v ∷ G.Bitstream (Packet d) ⇒ Bitstream d). + length v = lazyLength v #-} +{-# INLINE lazyLength #-} +lazyLength = go 0 + where + {-# INLINE go #-} + go !soFar Empty = soFar + go !soFar (Chunk x xs) = go (soFar + length x) xs + +lazyAnd ∷ G.Bitstream (Packet d) ⇒ Bitstream d → Bool +{-# RULES "and → lazyAnd" [2] + ∀(v ∷ G.Bitstream (Packet d) ⇒ Bitstream d). + and v = lazyAnd v #-} +{-# INLINEABLE lazyAnd #-} +lazyAnd Empty = False +lazyAnd (Chunk x xs) + | and x = lazyAnd xs + | otherwise = False + +lazyOr ∷ G.Bitstream (Packet d) ⇒ Bitstream d → Bool +{-# RULES "or → lazyOr" [2] + ∀(v ∷ G.Bitstream (Packet d) ⇒ Bitstream d). + or v = lazyOr v #-} +{-# INLINEABLE lazyOr #-} +lazyOr Empty = True +lazyOr (Chunk x xs) + | or x = True + | otherwise = lazyOr xs + +lazyIndex ∷ (G.Bitstream (Packet d), Integral n) ⇒ Bitstream d → n → Bool +{-# RULES "(!!) → lazyIndex" [2] + ∀(v ∷ G.Bitstream (Packet d) ⇒ Bitstream d) n. + v !! n = lazyIndex v n #-} +{-# INLINEABLE lazyIndex #-} +lazyIndex ch0 i0 + | i0 < 0 = indexOutOfRange i0 + | otherwise = go ch0 i0 + where + {-# INLINE go #-} + go Empty _ = indexOutOfRange i0 + go (Chunk x xs) i + | i < length x = x !! i + | otherwise = go xs (i - length x) + +emptyStream ∷ α +emptyStream + = error "Data.Bitstream.Lazy: empty stream" + +{-# INLINE indexOutOfRange #-} +indexOutOfRange ∷ Integral n ⇒ n → α +indexOutOfRange n = error ("Data.Bitstream.Lazy: index out of range: " L.++ show n) + +-- | /O(n)/ Convert a list of chunks, strict 'SB.Bitstream's, into a +-- lazy 'Bitstream'. +fromChunks ∷ G.Bitstream (Packet d) ⇒ [SB.Bitstream d] → Bitstream d +{-# INLINE fromChunks #-} +fromChunks [] = Empty +fromChunks (x:xs) + | null x = fromChunks xs + | otherwise = Chunk x (fromChunks xs) + +-- | /O(n)/ Convert a lazy 'Bitstream' into a list of chunks, strict +-- 'SB.Bitstream's. +toChunks ∷ Bitstream d → [SB.Bitstream d] +{-# INLINE toChunks #-} +toChunks Empty = [] +toChunks (Chunk x xs) = x : toChunks xs + +-- | /O(n)/ Convert a lazy 'LS.ByteString' into a lazy 'Bitstream'. +fromByteString ∷ G.Bitstream (Packet d) ⇒ LS.ByteString → Bitstream d +{-# INLINE fromByteString #-} +fromByteString = fromChunks ∘ L.map SB.fromByteString ∘ LS.toChunks + +-- | /O(n)/ @'toByteString' bits@ converts a lazy 'Bitstream' @bits@ +-- into a lazy 'LS.ByteString'. The resulting octets will be padded +-- with zeroes if @bs@ is finite and its 'length' is not multiple of +-- 8. +toByteString ∷ G.Bitstream (Packet d) ⇒ Bitstream d → LS.ByteString +{-# INLINE toByteString #-} +toByteString = LS.fromChunks ∘ L.map SB.toByteString ∘ toChunks + +streamChunks ∷ Monad m ⇒ Bitstream d → Stream m (SB.Bitstream d) +{-# INLINE [0] streamChunks #-} +streamChunks ch0 = Stream step ch0 Unknown + where + {-# INLINE step #-} + step Empty = return Done + step (Chunk x xs) = return $ Yield x xs + +unstreamChunks ∷ (G.Bitstream (Packet d), Monad m) + ⇒ Stream m (SB.Bitstream d) + → m (Bitstream d) +{-# INLINE [0] unstreamChunks #-} +unstreamChunks (Stream step s0 _) = go s0 + where + {-# INLINE go #-} + go s = do r ← step s + case r of + Yield x s' → do xs ← go s' + if null x + then return xs + else return $ Chunk x xs + Skip s' → go s' + Done → return Empty + +{-# RULES +"Lazy Bitstream streamChunks/unstreamChunks fusion" + ∀s. streamChunks (unId (unstreamChunks s)) = s + +"Lazy Bitstream unstreamChunks/streamChunks fusion" + ∀v. unId (unstreamChunks (streamChunks v)) = v + #-} + +-- Awful implementation to gain speed... +packChunks ∷ ∀m d. Monad m + ⇒ Stream m (Packet d) + → Stream m (SB.Bitstream d) +{-# INLINE packChunks #-} +packChunks (Stream step s0 sz) + = Stream step' (emptyChunk, 0, Just s0) sz' + where + emptyChunk ∷ New.New SV.Vector (Packet d) + {-# INLINE emptyChunk #-} + emptyChunk + = New.create (MVector.new chunkSize) + + newChunk ∷ New.New SV.Vector (Packet d) + → Int + → SB.Bitstream d + {-# INLINE newChunk #-} + newChunk ch len + = SB.fromPackets + $ GV.new + $ New.apply (MVector.take len) ch + + writePacket ∷ New.New SV.Vector (Packet d) + → Int + → Packet d + → New.New SV.Vector (Packet d) + {-# INLINE writePacket #-} + writePacket ch len p + = New.modify (\mv → MVector.write mv len p) ch + + sz' ∷ Size + {-# INLINE sz' #-} + sz' = case sz of + Exact n → Exact (n + chunkSize - 1 `div` chunkSize) + Max n → Max (n + chunkSize - 1 `div` chunkSize) + Unknown → Unknown + + {-# INLINE step' #-} + step' (ch, len, Just s) + = do r ← step s + case r of + Yield p s' + | len ≡ chunkSize + → return $ Yield (newChunk ch len) + (emptyChunk, 0, Just s') + | otherwise + → return $ Skip (writePacket ch len p, len+1, Just s') + Skip s' → return $ Skip (ch , len , Just s') + Done + | len ≡ 0 + → return Done + | otherwise + → return $ Yield (newChunk ch len) + ((⊥), (⊥), Nothing) + step' (_, _, Nothing) + = return Done + +-- | /O(n)/ Convert a @'Bitstream' 'Left'@ into a @'Bitstream' +-- 'Right'@. Bit directions only affect octet-based operations such as +-- 'toByteString'. +directionLToR ∷ Bitstream Left → Bitstream Right +{-# INLINE directionLToR #-} +directionLToR Empty = Empty +directionLToR (Chunk x xs) = Chunk (SB.directionLToR x) (directionLToR xs) + +-- | /O(n)/ Convert a @'Bitstream' 'Right'@ into a @'Bitstream' +-- 'Left'@. Bit directions only affect octet-based operations such as +-- 'toByteString'. +directionRToL ∷ Bitstream Right → Bitstream Left +{-# INLINE directionRToL #-} +directionRToL Empty = Empty +directionRToL (Chunk x xs) = Chunk (SB.directionRToL x) (directionRToL xs) + +{- There are only 4 functions of the type Bool → Bool. + + * iterate id b == [b , b , b , b , ...] + * iterate (const True ) _ == [True , True , True , True , ...] + * iterate (const False) _ == [False, False, False, False, ...] + * iterate not True == [True , False, True , False, ...] + * iterate not False == [False, True , False, True , ...] + + As seen above, all of them are cyclic so we just replicate the + first 8 bits i.e. a single Packet. Dunno when the given function + involves unsafeInlineIO and produces random bits. + -} +-- | /O(n)/ 'iterate' @f x@ returns an infinite 'Bitstream' of +-- repeated applications of @f@ to @x@: +-- +-- @ +-- 'iterate' f x == [x, f x, f (f x), ...] +-- @ +iterate ∷ G.Bitstream (Packet d) ⇒ (Bool → Bool) → Bool → Bitstream d +{-# INLINE iterate #-} +iterate f b = xs + where + xs = Chunk x xs + x = SB.fromPackets (SV.replicate chunkSize p) + p = pack (L.take 8 (L.iterate f b)) + +-- | /O(n)/ 'repeat' @x@ is an infinite 'Bitstream', with @x@ the +-- value of every bits. +repeat ∷ G.Bitstream (Packet d) ⇒ Bool → Bitstream d +{-# INLINE repeat #-} +repeat b = xs + where + xs = Chunk x xs + x = replicate (chunkBits ∷ Int) b + +-- | /O(n)/ 'cycle' ties a finite 'Bitstream' into a circular one, or +-- equivalently, the infinite repetition of the original 'Bitstream'. +-- It is the identity on infinite 'Bitstream's. +cycle ∷ G.Bitstream (Packet d) ⇒ Bitstream d → Bitstream d +{-# INLINE cycle #-} +cycle Empty = emptyStream +cycle ch = ch ⧺ cycle ch + +-- | /O(n)/ 'getContents' is equivalent to 'hGetContents' +-- @stdin@. Will read /lazily/. +getContents ∷ G.Bitstream (Packet d) ⇒ IO (Bitstream d) +{-# INLINE getContents #-} +getContents = fmap fromByteString LS.getContents + +-- | /O(n)/ Write a 'Bitstream' to @stdout@, equivalent to 'hPut' +-- @stdout@. +putBits ∷ G.Bitstream (Packet d) ⇒ Bitstream d → IO () +{-# INLINE putBits #-} +putBits = LS.putStr ∘ toByteString + +-- | The 'interact' function takes a function of type @'Bitstream' d +-- -> 'Bitstream' d@ as its argument. The entire input from the stdin +-- is lazily passed to this function as its argument, and the +-- resulting 'Bitstream' is output on the stdout. +interact ∷ G.Bitstream (Packet d) ⇒ (Bitstream d → Bitstream d) → IO () +{-# INLINE interact #-} +interact = LS.interact ∘ lift' + where + {-# INLINE lift' #-} + lift' f = toByteString ∘ f ∘ fromByteString + +-- | /O(n)/ Read an entire file lazily into a 'Bitstream'. +readFile ∷ G.Bitstream (Packet d) ⇒ FilePath → IO (Bitstream d) +{-# INLINE readFile #-} +readFile = fmap fromByteString ∘ LS.readFile + +-- | /O(n)/ Write a 'Bitstream' to a file. +writeFile ∷ G.Bitstream (Packet d) ⇒ FilePath → Bitstream d → IO () +{-# INLINE writeFile #-} +writeFile = (∘ toByteString) ∘ LS.writeFile + +-- | /O(n)/ Append a 'Bitstream' to a file. +appendFile ∷ G.Bitstream (Packet d) ⇒ FilePath → Bitstream d → IO () +{-# INLINE appendFile #-} +appendFile = (∘ toByteString) ∘ LS.appendFile + +-- | /O(n)/ Read entire handle contents /lazily/ into a +-- 'Bitstream'. Chunks are read on demand, using the default chunk +-- size. +-- +-- Once EOF is encountered, the 'Handle' is closed. +hGetContents ∷ G.Bitstream (Packet d) ⇒ Handle → IO (Bitstream d) +{-# INLINE hGetContents #-} +hGetContents = fmap fromByteString ∘ LS.hGetContents + +-- |@'hGet' h n@ reads a 'Bitstream' directly from the specified +-- 'Handle' @h@. First argument @h@ is the 'Handle' to read from, and +-- the second @n@ is the number of /octets/ to read, not /bits/. It +-- returns the octets read, up to @n@, or null if EOF has been +-- reached. +-- +-- If the handle is a pipe or socket, and the writing end is closed, +-- 'hGet' will behave as if EOF was reached. +-- +{-# INLINE hGet #-} +hGet ∷ G.Bitstream (Packet d) ⇒ Handle → Int → IO (Bitstream d) +hGet = (fmap fromByteString ∘) ∘ LS.hGet + +-- | /O(n)/ 'hGetNonBlocking' is similar to 'hGet', except that it +-- will never block waiting for data to become available, instead it +-- returns only whatever data is available. +{-# INLINE hGetNonBlocking #-} +hGetNonBlocking ∷ G.Bitstream (Packet d) ⇒ Handle → Int → IO (Bitstream d) +hGetNonBlocking = (fmap fromByteString ∘) ∘ LS.hGetNonBlocking + +-- | /O(n)/ Write a 'Bitstream' to the given 'Handle'. +hPut ∷ G.Bitstream (Packet d) ⇒ Handle → Bitstream d → IO () +{-# INLINE hPut #-} +hPut = (∘ toByteString) ∘ LS.hPut diff --git a/Data/Bitstream/Packet.hs b/Data/Bitstream/Packet.hs new file mode 100644 --- /dev/null +++ b/Data/Bitstream/Packet.hs @@ -0,0 +1,521 @@ +{-# LANGUAGE + BangPatterns + , EmptyDataDecls + , FlexibleContexts + , FlexibleInstances + , RankNTypes + , UnicodeSyntax + #-} +-- | For internal use only. +module Data.Bitstream.Packet + ( Left + , Right + + , Packet + + , full + + , fromOctet + , toOctet + + , packetLToR + , packetRToL + ) + where +import Data.Bitstream.Generic +import Data.Bits +import qualified Data.List as L +import Data.Ord +import qualified Data.Vector.Fusion.Stream as S +import Data.Vector.Fusion.Stream.Monadic (Stream(..), Step(..)) +import Data.Vector.Fusion.Stream.Size +import Data.Vector.Fusion.Util +import Data.Word +import Foreign.Storable +import Prelude ( Bool(..), Eq(..), Int, Integral, Ord(..), Maybe(..) + , Monad(..), Num(..), Show(..), ($!), error, fromIntegral + , otherwise + ) +import Prelude.Unicode + +-- | 'Left' bitstreams interpret an octet as a vector of bits whose +-- LSB comes first and MSB comes last e.g. +-- +-- * 11110000 => [False, False, False, False, True, True , True , True] +-- +-- * 10010100 => [False, False, True , False, True, False, False, True] +-- +data Left + +-- | 'Right' bitstreams interpret an octet as a vector of bits whose +-- MSB comes first and LSB comes last e.g. +-- +-- * 11110000 => [True, True , True , True, False, False, False, False] +-- +-- * 10010100 => [True, False, False, True, False, True , False, False] +-- +data Right + +-- | 'Packet's are strict 'Bitstream's having at most 8 bits. +data Packet d = Packet {-# UNPACK #-} !Int + {-# UNPACK #-} !Word8 + deriving (Eq) + +instance Storable (Packet d) where + sizeOf _ = 2 + alignment = sizeOf + {-# INLINE peek #-} + peek p + = do n ← peekByteOff p 0 + o ← peekByteOff p 1 + return $! Packet (fromIntegral (n ∷ Word8)) o + {-# INLINE poke #-} + poke p (Packet n o) + = do pokeByteOff p 0 (fromIntegral n ∷ Word8) + pokeByteOff p 1 o + +instance Show (Packet Left) where + {-# INLINEABLE show #-} + show (Packet n0 o0) + = L.concat + [ "[" + , L.unfoldr go (n0, o0) + , "←]" + ] + where + {-# INLINE go #-} + go (0, _) = Nothing + go (n, o) + | o `testBit` (n-1) = Just ('1', (n-1, o)) + | otherwise = Just ('0', (n-1, o)) + +instance Show (Packet Right) where + {-# INLINEABLE show #-} + show (Packet n0 o0) + = L.concat + [ "[→" + , L.unfoldr go (n0, o0) + , "]" + ] + where + {-# INLINE δ #-} + δ ∷ Int + δ = 7 - n0 + {-# INLINE go #-} + go (0, _) = Nothing + go (n, o) + | o `testBit` (n+δ) = Just ('1', (n-1, o)) + | otherwise = Just ('0', (n-1, o)) + +instance Ord (Packet Left) where + {-# INLINE compare #-} + px `compare` py + = comparing packetLToR px py + +instance Ord (Packet Right) where + {-# INLINE compare #-} + (Packet nx ox) `compare` (Packet ny oy) + = compare + (ox `shiftR` (8-nx)) + (oy `shiftR` (8-ny)) + +instance Bitstream (Packet Left) where + {-# INLINE [0] stream #-} + stream (Packet n o) = {-# CORE "Packet Left stream" #-} + Stream step 0 (Exact n) + where + {-# INLINE step #-} + step !i + | i ≥ n = return Done + | otherwise = return $! Yield (o `testBit` i) (i+1) + + {-# INLINE [0] unstream #-} + unstream (Stream step s0 sz) + = {-# CORE "Packet Left unstream" #-} + case upperBound sz of + Just n + | n ≤ 8 → unId (unsafeConsume s0 0 0) + | otherwise → packetOverflow + Nothing → unId (safeConsume s0 0 0) + where + {-# INLINE unsafeConsume #-} + unsafeConsume s !i !o + = do r ← step s + case r of + Yield True s' → unsafeConsume s' (i+1) (o `setBit` i) + Yield False s' → unsafeConsume s' (i+1) o + Skip s' → unsafeConsume s' i o + Done → return $! Packet i o + {-# INLINE safeConsume #-} + safeConsume s !i !o + = do r ← step s + case r of + Yield b s' + | i < 8 → safeConsume s' (i+1) (if b + then o `setBit` i + else o) + | otherwise → packetOverflow + Skip s' → safeConsume s' i o + Done → return $! Packet i o + + {-# INLINE [2] cons #-} + cons b p + | full p = packetOverflow + | otherwise = b `unsafeConsL` p + + {-# INLINE [2] snoc #-} + snoc p b + | full p = packetOverflow + | otherwise = p `unsafeSnocL` b + + {-# INLINE [2] append #-} + append (Packet nx ox) (Packet ny oy) + | nx + ny > 8 = packetOverflow + | otherwise = Packet (nx + ny) (ox .|. (oy `shiftL` nx)) + + {-# INLINE [2] tail #-} + tail (Packet 0 _) = emptyNotAllowed + tail (Packet n o) = Packet (n-1) (o `shiftR` 1) + + {-# INLINE [2] init #-} + init (Packet 0 _) = emptyNotAllowed + init (Packet n o) = Packet (n-1) o + + {-# INLINE [2] map #-} + map f (Packet n o0) = Packet n (go 0 o0) + where + {-# INLINE go #-} + go i o + | i ≥ n = o + | f (o `testBit` i) = go (i+1) (o `setBit` i) + | otherwise = go (i+1) (o `clearBit` i) + + {-# INLINE [2] reverse #-} + reverse (Packet n o) + = Packet n (reverseBits o `shiftR` (8-n)) + + {-# INLINE [1] scanl #-} + scanl = scanlPacket + + {-# INLINE [2] replicate #-} + replicate n b + | n > 8 = packetOverflow + | b = Packet (fromIntegral n) (0xFF `shiftR` (8 - fromIntegral n)) + | otherwise = Packet (fromIntegral n) 0 + + {-# INLINE [2] take #-} + take l (Packet n o) + | l ≤ 0 = (∅) + | otherwise + = let n' = fromIntegral (min (fromIntegral n) l) + o' = (0xFF `shiftR` (8-n')) .&. o + in + Packet n' o' + + {-# INLINE [2] drop #-} + drop l (Packet n o) + | l ≤ 0 = Packet n o + | otherwise + = let d = fromIntegral (min (fromIntegral n) l) + n' = n-d + o' = o `shiftR` d + in + Packet n' o' + + {-# INLINE [2] takeWhile #-} + takeWhile = takeWhilePacket + + {-# INLINE [2] dropWhile #-} + dropWhile = dropWhilePacket + + {-# INLINE [1] filter #-} + filter = filterPacket + +instance Bitstream (Packet Right) where + {-# INLINE [0] stream #-} + stream (Packet n o) = {-# CORE "Packet Right stream" #-} + Stream step 0 (Exact n) + where + {-# INLINE step #-} + step !i + | i ≥ n = return Done + | otherwise = return $! Yield (o `testBit` (7-i)) (i+1) + + {-# INLINE [0] unstream #-} + unstream (Stream step s0 sz) + = {-# CORE "Packet Right unstream" #-} + case upperBound sz of + Just n + | n ≤ 8 → unId (unsafeConsume s0 0 0) + | otherwise → packetOverflow + Nothing → unId (safeConsume s0 0 0) + where + {-# INLINE unsafeConsume #-} + unsafeConsume s i o + = do r ← step s + case r of + Yield True s' → unsafeConsume s' (i+1) (o `setBit` (7-i)) + Yield False s' → unsafeConsume s' (i+1) o + Skip s' → unsafeConsume s' i o + Done → return $! Packet i o + {-# INLINE safeConsume #-} + safeConsume s i o + = do r ← step s + case r of + Yield b s' + | i < 8 → safeConsume s' (i+1) (if b + then o `setBit` (7-i) + else o) + | otherwise → packetOverflow + Skip s' → safeConsume s' i o + Done → return $! Packet i o + + {-# INLINE [2] cons #-} + cons b p + | full p = packetOverflow + | otherwise = b `unsafeConsR` p + + {-# INLINE [2] snoc #-} + snoc p b + | full p = packetOverflow + | otherwise = p `unsafeSnocR` b + + {-# INLINE [2] append #-} + append (Packet nx ox) (Packet ny oy) + | nx + ny > 8 = packetOverflow + | otherwise = Packet (nx + ny) (ox .|. (oy `shiftR` nx)) + + {-# INLINE [2] tail #-} + tail (Packet 0 _) = emptyNotAllowed + tail (Packet n o) = Packet (n-1) (o `shiftL` 1) + + {-# INLINE [2] init #-} + init (Packet 0 _) = emptyNotAllowed + init (Packet n o) = Packet (n-1) o + + {-# INLINE [2] map #-} + map f (Packet n o0) = Packet n (go 0 o0) + where + {-# INLINE go #-} + go i o + | i ≥ n = o + | f (o `testBit` (7-i)) = go (i+1) (o `setBit` (7-i)) + | otherwise = go (i+1) (o `clearBit` (7-i)) + + {-# INLINE [2] reverse #-} + reverse (Packet n o) + = Packet n (reverseBits o `shiftL` (8-n)) + + {-# INLINE [1] scanl #-} + scanl = scanlPacket + + {-# INLINE [2] replicate #-} + replicate n b + | n > 8 = packetOverflow + | b = Packet (fromIntegral n) (0xFF `shiftL` (8 - fromIntegral n)) + | otherwise = Packet (fromIntegral n) 0 + + {-# INLINE [2] take #-} + take l (Packet n o) + | l ≤ 0 = (∅) + | otherwise + = let n' = fromIntegral (min (fromIntegral n) l) + o' = (0xFF `shiftL` (8-n')) .&. o + in + Packet n' o' + + {-# INLINE [2] drop #-} + drop l (Packet n o) + | l ≤ 0 = Packet n o + | otherwise + = let d = fromIntegral (min (fromIntegral n) l) + n' = n-d + o' = o `shiftL` d + in + Packet n' o' + + {-# INLINE [2] takeWhile #-} + takeWhile = takeWhilePacket + + {-# INLINE [2] dropWhile #-} + dropWhile = dropWhilePacket + + {-# INLINE [1] filter #-} + filter = filterPacket + +packetHeadL ∷ Packet Left → Bool +{-# RULES "head → packetHeadL" [2] head = packetHeadL #-} +{-# INLINE packetHeadL #-} +packetHeadL (Packet 0 _) = emptyNotAllowed +packetHeadL (Packet _ o) = o `testBit` 0 + +packetHeadR ∷ Packet Right → Bool +{-# RULES "head → packetHeadR" [2] head = packetHeadR #-} +{-# INLINE packetHeadR #-} +packetHeadR (Packet 0 _) = emptyNotAllowed +packetHeadR (Packet _ o) = o `testBit` 7 + +packetLastL ∷ Packet Left → Bool +{-# RULES "last → packetLastL" [2] last = packetLastL #-} +{-# INLINE packetLastL #-} +packetLastL (Packet 0 _) = emptyNotAllowed +packetLastL (Packet n o) = o `testBit` (n-1) + +packetLastR ∷ Packet Right → Bool +{-# RULES "head → packetLastR" [2] last = packetLastR #-} +{-# INLINE packetLastR #-} +packetLastR (Packet 0 _) = emptyNotAllowed +packetLastR (Packet n o) = o `testBit` (8-n) + +packetAndL ∷ Packet Left → Bool +{-# RULES "and → packetAndL" [2] and = packetAndL #-} +{-# INLINE packetAndL #-} +packetAndL (Packet n o) = (0xFF `shiftR` (8-n)) ≡ o + +packetAndR ∷ Packet Right → Bool +{-# RULES "and → packetAndR" [2] and = packetAndR #-} +{-# INLINE packetAndR #-} +packetAndR (Packet n o) = (0xFF `shiftL` (8-n)) ≡ o + +packetIndexL ∷ Integral n ⇒ Packet Left → n → Bool +{-# RULES "(!!) → packetIndexL" [2] (!!) = packetIndexL #-} +{-# INLINE packetIndexL #-} +packetIndexL p i + | i < 0 ∨ i ≥ length p = indexOutOfRange i + | otherwise = unsafePacketIndexL p i + +packetIndexR ∷ Integral n ⇒ Packet Right → n → Bool +{-# RULES "(!!) → packetIndexR" [2] (!!) = packetIndexR #-} +{-# INLINE packetIndexR #-} +packetIndexR p i + | i < 0 ∨ i ≥ length p = indexOutOfRange i + | otherwise = unsafePacketIndexR p i + +unsafePacketIndexL ∷ Integral n ⇒ Packet Left → n → Bool +{-# INLINE unsafePacketIndexL #-} +unsafePacketIndexL (Packet _ o) i + = o `testBit` fromIntegral i + +unsafePacketIndexR ∷ Integral n ⇒ Packet Right → n → Bool +{-# INLINE unsafePacketIndexR #-} +unsafePacketIndexR (Packet _ o) i + = o `testBit` (7 - fromIntegral i) + +packetNull ∷ Packet d → Bool +{-# RULES "null → packetNull" [2] null = packetNull #-} +{-# INLINE packetNull #-} +packetNull (Packet 0 _) = True +packetNull _ = False + +packetLength ∷ Num n ⇒ Packet d → n +{-# RULES "length → packetLength" [2] length = packetLength #-} +{-# INLINE packetLength #-} +packetLength (Packet n _) = fromIntegral n + +packetOr ∷ Packet d → Bool +{-# RULES "or → packetOr" [2] or = packetOr #-} +{-# INLINE packetOr #-} +packetOr (Packet _ o) = o ≢ 0 + +{-# INLINE emptyNotAllowed #-} +emptyNotAllowed ∷ α +emptyNotAllowed = error "Data.Bitstream.Packet: packet is empty" + +{-# INLINE packetOverflow #-} +packetOverflow ∷ α +packetOverflow = error "Data.Bitstream.Packet: packet size overflow" + +{-# INLINE indexOutOfRange #-} +indexOutOfRange ∷ Integral n ⇒ n → α +indexOutOfRange n = error ("Data.Bitstream.Packet: index out of range: " L.++ show n) + +-- | /O(1)/ @'full' p == 'True'@ iff @'length' p == 8@, otherwise it +-- returns 'False'. +full ∷ Packet d → Bool +{-# INLINE full #-} +full (Packet 8 _) = True +full _ = False + +-- | /O(1)/ Convert an octet to 'Packet'. +fromOctet ∷ Word8 → Packet d +{-# INLINE fromOctet #-} +fromOctet = Packet 8 + +-- | /O(1)/ 'toOctet' @p@ converts a 'Packet' @p@ to an octet, padding +-- with zeroes if @'length' p < 8@. +toOctet ∷ Packet d → Word8 +{-# INLINE toOctet #-} +toOctet (Packet _ o) = o + +{-# INLINE unsafeConsL #-} +unsafeConsL ∷ Bool → Packet Left → Packet Left +unsafeConsL True (Packet n o) = Packet (n+1) ((o `shiftL` 1) .|. 1) +unsafeConsL False (Packet n o) = Packet (n+1) (o `shiftL` 1) + +{-# INLINE unsafeConsR #-} +unsafeConsR ∷ Bool → Packet Right → Packet Right +unsafeConsR True (Packet n o) = Packet (n+1) ((o `shiftR` 1) .|. 0x80) +unsafeConsR False (Packet n o) = Packet (n+1) (o `shiftR` 1) + +{-# INLINE unsafeSnocL #-} +unsafeSnocL ∷ Packet Left → Bool → Packet Left +unsafeSnocL (Packet n o) True = Packet (n+1) (o `setBit` n) +unsafeSnocL (Packet n o) False = Packet (n+1) o + +{-# INLINE unsafeSnocR #-} +unsafeSnocR ∷ Packet Right → Bool → Packet Right +unsafeSnocR (Packet n o) True = Packet (n+1) (o `setBit` (7-n)) +unsafeSnocR (Packet n o) False = Packet (n+1) o + +-- | /O(1)/ Change the direction of 'Packet' from 'Left' to +-- 'Right'. Bit directions only affect octet-based operations such as +-- 'toOctet'. +packetLToR ∷ Packet Left → Packet Right +{-# INLINE packetLToR #-} +packetLToR (Packet n o) = Packet n (reverseBits o) + +-- | /O(1)/ Change the direction of 'Packet' from 'Right' to +-- 'Left'. Bit directions only affect octet-based operations such as +-- 'toOctet'. +packetRToL ∷ Packet Right → Packet Left +{-# INLINE packetRToL #-} +packetRToL (Packet n o) = Packet n (reverseBits o) + +{-# INLINE reverseBits #-} +reverseBits ∷ Word8 → Word8 +reverseBits x + = ((x .&. 0x01) `shiftL` 7) .|. + ((x .&. 0x02) `shiftL` 5) .|. + ((x .&. 0x04) `shiftL` 3) .|. + ((x .&. 0x08) `shiftL` 1) .|. + ((x .&. 0x10) `shiftR` 1) .|. + ((x .&. 0x20) `shiftR` 3) .|. + ((x .&. 0x40) `shiftR` 5) .|. + ((x .&. 0x80) `shiftR` 7) + +{-# INLINE scanlPacket #-} +scanlPacket ∷ Bitstream (Packet d) ⇒ (Bool → Bool → Bool) → Bool → Packet d → Packet d +scanlPacket f b + = unstream ∘ S.scanl f b ∘ stream + +{-# INLINEABLE takeWhilePacket #-} +takeWhilePacket ∷ Bitstream (Packet d) ⇒ (Bool → Bool) → Packet d → Packet d +takeWhilePacket f α = take (go 0 ∷ Int) α + where + {-# INLINE go #-} + go i | i ≥ length α = i + | f (α !! i) = go (i+1) + | otherwise = i + +{-# INLINEABLE dropWhilePacket #-} +dropWhilePacket ∷ Bitstream (Packet d) ⇒ (Bool → Bool) → Packet d → Packet d +dropWhilePacket f α = drop (go 0 ∷ Int) α + where + {-# INLINE go #-} + go i | i ≥ length α = i + | f (α !! i) = go (i+1) + | otherwise = i + +filterPacket ∷ Bitstream (Packet d) ⇒ (Bool → Bool) → Packet d → Packet d +{-# INLINE filterPacket #-} +filterPacket f = unstream ∘ S.filter f ∘ stream diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,4 @@ +#!/usr/bin/env runghc + +import Distribution.Simple +main = defaultMain diff --git a/bitstream.cabal b/bitstream.cabal new file mode 100644 --- /dev/null +++ b/bitstream.cabal @@ -0,0 +1,83 @@ +Name: bitstream +Synopsis: Fast, packed, strict and lazy bit streams with stream fusion +Description: + + Fast, packed, strict and lazy bit vectors with stream + fusion. This is like @bytestring@ but stores bits instead of + bytes. + + NOTE: GHC 7.0.1 fails to fuse almost every cases of bitstream + fusion, producing very large and not-so-fast object code. See: + + +Version: 0.1 +License: PublicDomain +License-File: COPYING +Author: PHO +Maintainer: PHO +Stability: experimental +Homepage: http://cielonegro.org/Bitstream.html +Category: Data +Tested-With: GHC == 7.0.1 +Cabal-Version: >= 1.10 +Build-Type: Simple +Extra-Source-Files: + COPYING + +Source-Repository head + Type: git + Location: git://git.cielonegro.org/bitstream.git + +Library + Build-Depends: + base == 4.*, + base-unicode-symbols == 0.2.*, + bytestring == 0.9.*, + vector == 0.7.* + + Exposed-Modules: + Data.Bitstream + Data.Bitstream.Fusion + Data.Bitstream.Fusion.Monadic + Data.Bitstream.Generic + Data.Bitstream.Lazy + Data.Bitstream.Packet + + Other-Modules: + Data.Bitstream.Internal + + Default-Language: + Haskell2010 + + GHC-Options: + -Wall + +Test-Suite test-strict-bitstream + Type: exitcode-stdio-1.0 + Main-Is: Test/Bitstream.hs + Other-Modules: + Test.Bitstream.Utils + Build-Depends: + QuickCheck == 2.4.*, + base == 4.*, + base-unicode-symbols == 0.2.*, + bytestring == 0.9.*, + vector == 0.7.* + Default-Language: Haskell2010 + GHC-Options: + -Wall -fno-warn-orphans + +Test-Suite test-lazy-bitstream + Type: exitcode-stdio-1.0 + Main-Is: Test/Bitstream/Lazy.hs + Other-Modules: + Test.Bitstream.Utils + Build-Depends: + QuickCheck == 2.4.*, + base == 4.*, + base-unicode-symbols == 0.2.*, + bytestring == 0.9.*, + vector == 0.7.* + Default-Language: Haskell2010 + GHC-Options: + -Wall -fno-warn-orphans