bitstream (empty) → 0.1
raw patch · 10 files changed
+3042/−0 lines, 10 filesdep +QuickCheckdep +basedep +base-unicode-symbolssetup-changed
Dependencies added: QuickCheck, base, base-unicode-symbols, bytestring, vector
Files
- COPYING +29/−0
- Data/Bitstream.hs +602/−0
- Data/Bitstream/Fusion.hs +53/−0
- Data/Bitstream/Fusion/Monadic.hs +146/−0
- Data/Bitstream/Generic.hs +883/−0
- Data/Bitstream/Internal.hs +38/−0
- Data/Bitstream/Lazy.hs +683/−0
- Data/Bitstream/Packet.hs +521/−0
- Setup.hs +4/−0
- bitstream.cabal +83/−0
+ COPYING view
@@ -0,0 +1,29 @@+<!-- -*- xml -*-++Haskell のパッケージ "bitstream" はパブリックドメインに在ります。+The Haskell package "bitstream" is in the public domain.++See http://creativecommons.org/licenses/publicdomain/++-->++<rdf:RDF xmlns="http://web.resource.org/cc/"+ xmlns:dc="http://purl.org/dc/elements/1.1/"+ xmlns:rdf="http://www.w3.org/1999/02/22-rdf-syntax-ns#">+ <Work rdf:about="http://cielonegro.org/Bitstream.html">+ <dc:title>bitstream</dc:title>+ <dc:rights>+ <Agent>+ <dc:title>PHO</dc:title>+ </Agent>+ </dc:rights>+ <license rdf:resource="http://web.resource.org/cc/PublicDomain" />+ </Work>+ + <License rdf:about="http://web.resource.org/cc/PublicDomain">+ <permits rdf:resource="http://web.resource.org/cc/Reproduction" />+ <permits rdf:resource="http://web.resource.org/cc/Distribution" />+ <permits rdf:resource="http://web.resource.org/cc/DerivativeWorks" />+ </License>++</rdf:RDF>
+ Data/Bitstream.hs view
@@ -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
+ Data/Bitstream/Fusion.hs view
@@ -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
+ Data/Bitstream/Fusion/Monadic.hs view
@@ -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
+ Data/Bitstream/Generic.hs view
@@ -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)+ #-}
+ Data/Bitstream/Internal.hs view
@@ -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
+ Data/Bitstream/Lazy.hs view
@@ -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
+ Data/Bitstream/Packet.hs view
@@ -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
+ Setup.hs view
@@ -0,0 +1,4 @@+#!/usr/bin/env runghc++import Distribution.Simple+main = defaultMain
+ bitstream.cabal view
@@ -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:+ <http://hackage.haskell.org/trac/ghc/ticket/4397>++Version: 0.1+License: PublicDomain+License-File: COPYING+Author: PHO <pho at cielonegro dot org>+Maintainer: PHO <pho at cielonegro dot org>+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