diff --git a/ChangeLog b/ChangeLog new file mode 100644 --- /dev/null +++ b/ChangeLog @@ -0,0 +1,6 @@ +== bitstream-0.2 / 2011-07-08 +* bugfix: Make stream fusion actually work +* Implement fromBits / toBits +* Strict Bitstreams' bit length should only be a hint, just like stream size. +* Strict Bitstream should keep bit-length maintained +* Strict bitstrems should use unstreamPackets instead of hand-written unfoldr-based unstreamers. diff --git a/Data/Bitstream.hs b/Data/Bitstream.hs --- a/Data/Bitstream.hs +++ b/Data/Bitstream.hs @@ -1,7 +1,9 @@ {-# LANGUAGE BangPatterns , FlexibleContexts + , FlexibleInstances , ScopedTypeVariables + , UnboxedTuples , UndecidableInstances , UnicodeSyntax #-} @@ -16,7 +18,7 @@ -- 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 + ( -- * Data types Bitstream , Left , Right @@ -28,15 +30,23 @@ , pack , unpack , fromPackets + , unsafeFromPackets , toPackets -- ** Converting from\/to strict 'BS.ByteString's , fromByteString , toByteString + -- ** Converting from\/to 'Bits'' + , fromBits + , fromNBits + , toBits + -- ** Converting from\/to 'S.Stream's , stream , unstream + , streamPackets + , unstreamPackets -- * Changing bit order in octets , directionLToR @@ -74,7 +84,7 @@ , any , all - -- * Building lists + -- * Building 'Bitstream's -- ** Scans , scanl , scanl1 @@ -161,14 +171,16 @@ import qualified Data.List as L import Data.Monoid 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 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 + , Ord(..), Show(..), ($), error, fmap, fromIntegral, fst + , otherwise ) import Prelude.Unicode hiding ((⧺), (∈), (∉)) import System.IO (FilePath, Handle, IO) @@ -178,12 +190,15 @@ -- /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)) +data Bitstream d + = Bitstream {-# UNPACK #-} !Int -- bit length + {-# UNPACK #-} !(SV.Vector (Packet d)) +-- THINKME: The bit length should only be a hint, just like stream +-- size. instance Show (Packet d) ⇒ Show (Bitstream d) where {-# INLINEABLE show #-} - show (Bitstream v0) + show (Bitstream _ v0) = L.concat [ "(S" , L.concat (L.unfoldr go v0) @@ -194,7 +209,7 @@ go v | SV.null v = Nothing | otherwise = Just (show (SV.head v), SV.tail v) -instance G.Bitstream (Packet d) ⇒ Eq (Bitstream d) where +instance G.Bitstream (Bitstream d) ⇒ Eq (Bitstream d) where {-# INLINE (==) #-} x == y = stream x ≡ stream y @@ -209,7 +224,7 @@ -- , 'compare' z y -- 'LT' -- ] -- @ -instance G.Bitstream (Packet d) ⇒ Ord (Bitstream d) where +instance G.Bitstream (Bitstream d) ⇒ Ord (Bitstream d) where {-# INLINE compare #-} x `compare` y = stream x `compare` stream y @@ -220,225 +235,353 @@ -- 'mappend' = 'append' -- 'mconcat' = 'concat' -- @ -instance G.Bitstream (Packet d) ⇒ Monoid (Bitstream d) where +instance G.Bitstream (Bitstream 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)) +instance G.Bitstream (Bitstream Left) where + {-# INLINE basicStream #-} + basicStream = strictStream - {-# INLINE [0] unstream #-} - unstream - = {-# CORE "Bitstream unstream" #-} - Bitstream ∘ GV.unstream ∘ packPackets + {-# INLINE basicUnstream #-} + basicUnstream = strictUnstream - {-# 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) + {-# INLINE basicCons #-} + basicCons = strictCons - {-# 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 basicSnoc #-} + basicSnoc = strictSnoc - {-# INLINE [2] append #-} - append (Bitstream x) (Bitstream y) - = Bitstream (x SV.++ y) + {-# INLINE basicAppend #-} + basicAppend = strictAppend - {-# 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) + {-# INLINE basicTail #-} + basicTail = strictTail - {-# 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 basicInit #-} + basicInit = strictInit - {-# INLINE [2] map #-} - map f (Bitstream v) - = Bitstream (SV.map (map f) v) + {-# INLINE basicMap #-} + basicMap = strictMap - {-# INLINE [2] reverse #-} - reverse (Bitstream v) - = Bitstream (SV.reverse (SV.map reverse v)) + {-# INLINE basicReverse #-} + basicReverse = strictReverse - {-# INLINE [1] scanl #-} - scanl f b - = unstream ∘ S.scanl f b ∘ stream + {-# INLINE basicConcat #-} + basicConcat = strictConcat - {-# INLINE [2] concat #-} - concat = Bitstream ∘ SV.concat ∘ L.map toPackets + {-# INLINE basicScanl #-} + basicScanl = strictScanl - {-# 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 basicTake #-} + basicTake = strictTake - {-# INLINE posterior #-} - posterior = replicate n b - where - n ∷ Int - {-# INLINE n #-} - n = fromIntegral (n0 `mod` 8) + {-# INLINE basicDrop #-} + basicDrop = strictDrop - {-# 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' + {-# INLINE basicTakeWhile #-} + basicTakeWhile = strictTakeWhile + + {-# INLINE basicDropWhile #-} + basicDropWhile = strictDropWhile + + {-# INLINE basicFilter #-} + basicFilter = strictFilter + + {-# INLINE basicFromNBits #-} + basicFromNBits = (unstreamPackets ∘) ∘ lePacketsFromNBits + + {-# INLINE basicToBits #-} + basicToBits = unId ∘ lePacketsToBits ∘ streamPackets + +instance G.Bitstream (Bitstream Right) where + {-# INLINE basicStream #-} + basicStream = strictStream + + {-# INLINE basicUnstream #-} + basicUnstream = strictUnstream + + {-# INLINE basicCons #-} + basicCons = strictCons + + {-# INLINE basicSnoc #-} + basicSnoc = strictSnoc + + {-# INLINE basicAppend #-} + basicAppend = strictAppend + + {-# INLINE basicTail #-} + basicTail = strictTail + + {-# INLINE basicInit #-} + basicInit = strictInit + + {-# INLINE basicMap #-} + basicMap = strictMap + + {-# INLINE basicReverse #-} + basicReverse = strictReverse + + {-# INLINE basicConcat #-} + basicConcat = strictConcat + + {-# INLINE basicScanl #-} + basicScanl = strictScanl + + {-# INLINE basicTake #-} + basicTake = strictTake + + {-# INLINE basicDrop #-} + basicDrop = strictDrop + + {-# INLINE basicTakeWhile #-} + basicTakeWhile = strictTakeWhile + + {-# INLINE basicDropWhile #-} + basicDropWhile = strictDropWhile + + {-# INLINE basicFilter #-} + basicFilter = strictFilter + + {-# INLINEABLE basicFromNBits #-} + basicFromNBits = (unstreamPackets ∘) ∘ bePacketsFromNBits + + {-# INLINEABLE basicToBits #-} + basicToBits = unId ∘ bePacketsToBits ∘ streamPackets + +strictStream ∷ G.Bitstream (Packet d) ⇒ Bitstream d → S.Stream Bool +{-# INLINE strictStream #-} +strictStream (Bitstream l v) + = {-# CORE "Strict Bitstream stream" #-} + S.concatMap stream (GV.stream v) + `S.sized` + Exact l + +strictUnstream ∷ G.Bitstream (Packet d) ⇒ S.Stream Bool → Bitstream d +{-# INLINE strictUnstream #-} +strictUnstream + = {-# CORE "Strict Bitstream unstream" #-} + unstreamPackets ∘ packPackets + +strictCons ∷ G.Bitstream (Packet d) ⇒ Bool → Bitstream d → Bitstream d +{-# INLINEABLE strictCons #-} +strictCons b (Bitstream 0 _) = Bitstream 1 (SV.singleton (singleton b)) +strictCons b (Bitstream l v) + = case SV.head v of + p | length p < (8 ∷ Int) + → Bitstream (l+1) ((b `cons` p) `SV.cons` SV.tail v) + | otherwise + → Bitstream (l+1) (singleton b `SV.cons` v) + +strictSnoc ∷ G.Bitstream (Packet d) ⇒ Bitstream d → Bool → Bitstream d +{-# INLINEABLE strictSnoc #-} +strictSnoc (Bitstream 0 _) b = Bitstream 1 (SV.singleton (singleton b)) +strictSnoc (Bitstream l v) b + = case SV.last v of + p | length p < (8 ∷ Int) + → Bitstream (l+1) (SV.init v `SV.snoc` (p `snoc` b)) + | otherwise + → Bitstream (l+1) (v `SV.snoc` singleton b) + +strictAppend ∷ G.Bitstream (Packet d) ⇒ Bitstream d → Bitstream d → Bitstream d +{-# INLINE strictAppend #-} +strictAppend (Bitstream lx x) (Bitstream ly y) + = Bitstream (lx + ly) (x SV.++ y) + +strictTail ∷ G.Bitstream (Packet d) ⇒ Bitstream d → Bitstream d +{-# INLINEABLE strictTail #-} +strictTail (Bitstream 0 _) = emptyStream +strictTail (Bitstream l v) + = case tail (SV.head v) of + p' | null p' → Bitstream (l-1) (SV.tail v) + | otherwise → Bitstream (l-1) (p' `SV.cons` SV.tail v) + +strictInit ∷ G.Bitstream (Packet d) ⇒ Bitstream d → Bitstream d +{-# INLINEABLE strictInit #-} +strictInit (Bitstream 0 _) = emptyStream +strictInit (Bitstream l v) + = case init (SV.last v) of + p' | null p' → Bitstream (l-1) (SV.init v) + | otherwise → Bitstream (l-1) (SV.init v `SV.snoc` p') + +strictMap ∷ G.Bitstream (Packet d) ⇒ (Bool → Bool) → Bitstream d → Bitstream d +{-# INLINE strictMap #-} +strictMap f (Bitstream l v) + = Bitstream l (SV.map (map f) v) + +strictReverse ∷ G.Bitstream (Packet d) ⇒ Bitstream d → Bitstream d +{-# INLINE strictReverse #-} +strictReverse (Bitstream l v) + = Bitstream l (SV.reverse (SV.map reverse v)) + +strictConcat ∷ G.Bitstream (Bitstream d) ⇒ [Bitstream d] → Bitstream d +{-# INLINEABLE strictConcat #-} +strictConcat xs + = let (!l, !vs) = L.mapAccumL (\n x → (n + length x, toPackets x)) 0 xs + !v = SV.concat vs + in + Bitstream l v + +strictScanl ∷ G.Bitstream (Bitstream d) ⇒ (Bool → Bool → Bool) → Bool → Bitstream d → Bitstream d +{-# INLINE strictScanl #-} +strictScanl f b + = unstream ∘ S.scanl f b ∘ stream + +strictTake ∷ ( Integral n + , G.Bitstream (Bitstream d) + , G.Bitstream (Packet d) + ) + ⇒ n + → Bitstream d + → Bitstream d +{-# INLINEABLE strictTake #-} +strictTake n0 (Bitstream l0 v0) + | l0 ≡ 0 = (∅) + | n0 ≤ 0 = (∅) + | otherwise = let !e = New.create (MVector.new (SV.length v0)) + in + case go n0 v0 0 0 e of + (# l, np, mv #) + → let !mv' = New.apply (MVector.take np) mv + !v = GV.new mv' in - return (p', (n', v')) + Bitstream l v + where + {-# INLINE go #-} + go 0 _ l np mv = (# l, np, mv #) + go n v l np mv + | SV.null v = (# l, np, mv #) + | otherwise = let !p = SV.head v + !p' = take n p + !n' = n - length p' + !v' = SV.tail v + !l' = l + length p' + !np' = np + 1 + !mv' = New.modify (\x → MVector.write x np p') mv + in + go n' v' l' np' mv' - {-# 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) +strictDrop ∷ (Integral n, G.Bitstream (Packet d)) ⇒ n → Bitstream d → Bitstream d +{-# INLINEABLE strictDrop #-} +strictDrop n0 (Bitstream l0 v0) + | n0 ≤ 0 = Bitstream l0 v0 + | otherwise = case go n0 l0 v0 of + (# l, v #) → Bitstream l v + where + {-# INLINE go #-} + go 0 l v = (# l, v #) + go _ 0 v = (# 0, v #) + go n l v = let !p = SV.head v + in + case drop n p of + p' | null p' → go (n - length p) (l - length p) (SV.tail v) + | otherwise → (# l - length p + length p' + , 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 +strictTakeWhile ∷ G.Bitstream (Packet d) ⇒ (Bool → Bool) → Bitstream d → Bitstream d +{-# INLINEABLE strictTakeWhile #-} +strictTakeWhile f + = unstreamPackets ∘ takeWhilePS ∘ streamPackets + 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 +strictDropWhile ∷ G.Bitstream (Packet d) ⇒ (Bool → Bool) → Bitstream d → Bitstream d +{-# INLINEABLE strictDropWhile #-} +strictDropWhile _ (Bitstream 0 v0) = Bitstream 0 v0 +strictDropWhile f (Bitstream l0 v0) = case go l0 v0 of + (# l, v #) → Bitstream l v + where + {-# INLINE go #-} + go 0 v = (# 0, v #) + go l v = let !p = SV.head v + !pLen = length p + in + case dropWhile f p of + p' | null p' → go (l - pLen) (SV.tail v) + | otherwise → (# l - pLen + length p' + , 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 +strictFilter ∷ G.Bitstream (Packet d) ⇒ (Bool → Bool) → Bitstream d → Bitstream d +{-# INLINEABLE strictFilter #-} +strictFilter f + = unstreamPackets ∘ filterPS ∘ streamPackets + 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] +{-# RULES "head → strictHead" [1] ∀(v ∷ G.Bitstream (Packet d) ⇒ Bitstream d). head v = strictHead v #-} {-# INLINE strictHead #-} -strictHead (Bitstream v) = head (SV.head v) +strictHead (Bitstream _ v) = head (SV.head v) strictLast ∷ G.Bitstream (Packet d) ⇒ Bitstream d → Bool -{-# RULES "last → strictLast" [2] +{-# RULES "last → strictLast" [1] ∀(v ∷ G.Bitstream (Packet d) ⇒ Bitstream d). last v = strictLast v #-} {-# INLINE strictLast #-} -strictLast (Bitstream v) = last (SV.last v) +strictLast (Bitstream _ v) = last (SV.last v) strictNull ∷ Bitstream d → Bool -{-# RULES "null → strictNull" [2] null = strictNull #-} +{-# RULES "null → strictNull" [1] null = strictNull #-} {-# INLINE strictNull #-} -strictNull (Bitstream v) = SV.null v +strictNull (Bitstream 0 _) = True +strictNull _ = False -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 +strictLength ∷ Num n ⇒ Bitstream d → n +{-# RULES "length → strictLength" [1] length = strictLength #-} +{-# INLINE strictLength #-} +strictLength (Bitstream len _) = fromIntegral len strictAnd ∷ G.Bitstream (Packet d) ⇒ Bitstream d → Bool -{-# RULES "and → strictAnd" [2] +{-# RULES "and → strictAnd" [1] ∀(v ∷ G.Bitstream (Packet d) ⇒ Bitstream d). and v = strictAnd v #-} {-# INLINE strictAnd #-} -strictAnd (Bitstream v) +strictAnd (Bitstream _ v) = SV.all and v strictOr ∷ G.Bitstream (Packet d) ⇒ Bitstream d → Bool -{-# RULES "or → strictOr" [2] +{-# RULES "or → strictOr" [1] ∀(v ∷ G.Bitstream (Packet d) ⇒ Bitstream d). or v = strictOr v #-} {-# INLINE strictOr #-} -strictOr (Bitstream v) +strictOr (Bitstream _ v) = SV.any or v strictIndex ∷ (G.Bitstream (Packet d), Integral n) ⇒ Bitstream d → n → Bool -{-# RULES "(!!) → strictIndex" [2] +{-# RULES "(!!) → strictIndex" [1] ∀(v ∷ G.Bitstream (Packet d) ⇒ Bitstream d) n. v !! n = strictIndex v n #-} {-# INLINEABLE strictIndex #-} -strictIndex (Bitstream v0) i0 +strictIndex (Bitstream _ v0) i0 | i0 < 0 = indexOutOfRange i0 | otherwise = go v0 i0 where @@ -461,10 +604,11 @@ -- 'Bitstream'. {-# INLINE fromByteString #-} fromByteString ∷ BS.ByteString → Bitstream d -fromByteString bs0 = Bitstream (SV.unfoldrN nOctets go bs0) +fromByteString bs0 + = Bitstream (nOctets ⋅ 8) (SV.unfoldrN nOctets go bs0) where - {-# INLINE nOctets #-} nOctets ∷ Int + {-# INLINE nOctets #-} nOctets = BS.length bs0 {-# INLINE go #-} go bs = do (o, bs') ← BS.uncons bs @@ -474,7 +618,9 @@ -- 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 ∷ ∀d. ( G.Bitstream (Bitstream d) + , G.Bitstream (Packet d) + ) ⇒ Bitstream d → BS.ByteString toByteString = unstreamBS ∘ (packPackets ∷ Stream Id Bool → Stream Id (Packet d)) ∘ stream @@ -493,29 +639,64 @@ 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 +-- WARNING: countBits is rather slow. +countBits ∷ (G.Bitstream (Packet d), Num n) ⇒ SV.Vector (Packet d) → n +{-# INLINE countBits #-} +countBits = SV.foldl' (\n p → n + length p) 0 + +-- | /O(n)/ Convert a 'SV.Vector' of 'Packet's into a 'Bitstream'. +fromPackets ∷ G.Bitstream (Packet d) ⇒ SV.Vector (Packet d) → Bitstream d {-# INLINE fromPackets #-} -fromPackets = Bitstream +fromPackets v = Bitstream (countBits v) v +-- | /O(1)/ Convert a 'SV.Vector' of 'Packet's into a 'Bitstream', +-- with provided overall bit length. The correctness of the bit length +-- isn't checked, so you MUST be sure your bit length is absolutely +-- correct. +unsafeFromPackets ∷ G.Bitstream (Packet d) ⇒ Int → SV.Vector (Packet d) → Bitstream d +{-# INLINE unsafeFromPackets #-} +unsafeFromPackets = 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 +toPackets (Bitstream _ d) = d +-- | /O(1)/ Convert a 'Bitstream' into a 'S.Stream' of 'Packet's. +streamPackets ∷ Bitstream d → S.Stream (Packet d) +{-# NOINLINE streamPackets #-} +streamPackets (Bitstream _ v) = GV.stream v + +-- | /O(n)/ Convert a 'S.Stream' of 'Packet's into 'Bitstream'. +unstreamPackets ∷ G.Bitstream (Packet d) ⇒ S.Stream (Packet d) → Bitstream d +{-# NOINLINE unstreamPackets #-} +unstreamPackets s + = let !v = GV.unstream s + !l = countBits v + in + Bitstream l v + +{-# RULES +"Strict Bitstream streamPackets/unstreamPackets fusion" + ∀s. streamPackets (unstreamPackets s) = s + +"Strict Bitstream unstreamPackets/streamPackets fusion" + ∀v. unstreamPackets (streamPackets v) = v + #-} + -- | /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) +directionLToR (Bitstream l v) = Bitstream l (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) +directionRToL (Bitstream l v) = Bitstream l (SV.map packetRToL v) -- | /O(n)/ Read a 'Bitstream' from the stdin strictly, equivalent to -- 'hGetContents' @stdin@. The 'Handle' is closed after the contents @@ -526,7 +707,11 @@ -- | /O(n)/ Write a 'Bitstream' to the stdout, equivalent to 'hPut' -- @stdout@. -putBits ∷ G.Bitstream (Packet d) ⇒ Bitstream d → IO () +putBits ∷ ( G.Bitstream (Bitstream d) + , G.Bitstream (Packet d) + ) + ⇒ Bitstream d + → IO () {-# INLINE putBits #-} putBits = BS.putStr ∘ toByteString @@ -534,7 +719,11 @@ -- -> '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 () +interact ∷ ( G.Bitstream (Bitstream d) + , G.Bitstream (Packet d) + ) + ⇒ (Bitstream d → Bitstream d) + → IO () {-# INLINE interact #-} interact = BS.interact ∘ lift' where @@ -547,12 +736,22 @@ readFile = fmap fromByteString ∘ BS.readFile -- | /O(n)/ Write a 'Bitstream' to a file. -writeFile ∷ G.Bitstream (Packet d) ⇒ FilePath → Bitstream d → IO () +writeFile ∷ ( G.Bitstream (Bitstream d) + , 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 () +appendFile ∷ ( G.Bitstream (Bitstream d) + , G.Bitstream (Packet d) + ) + ⇒ FilePath + → Bitstream d + → IO () {-# INLINE appendFile #-} appendFile = (∘ toByteString) ∘ BS.appendFile @@ -597,6 +796,11 @@ hGetNonBlocking = (fmap fromByteString ∘) ∘ BS.hGetNonBlocking -- | /O(n)/ Write a 'Bitstream' to the given 'Handle'. -hPut ∷ G.Bitstream (Packet d) ⇒ Handle → Bitstream d → IO () +hPut ∷ ( G.Bitstream (Bitstream d) + , G.Bitstream (Packet d) + ) + ⇒ Handle + → Bitstream d + → IO () {-# INLINE hPut #-} hPut = (∘ toByteString) ∘ BS.hPut diff --git a/Data/Bitstream/Generic.hs b/Data/Bitstream/Generic.hs --- a/Data/Bitstream/Generic.hs +++ b/Data/Bitstream/Generic.hs @@ -5,21 +5,43 @@ #-} -- | Generic interface to diverse types of 'Bitstream'. module Data.Bitstream.Generic - ( Bitstream(..) + ( -- * The type class + Bitstream(..) + -- * Introducing and eliminating 'Bitstream's + , empty + , (∅) + , singleton , pack , unpack - , empty - , singleton + -- ** Converting from\/to 'Bits'' + , fromBits + , fromNBits + , toBits + -- ** Converting from\/to 'S.Stream's + , stream + , unstream + + -- * Basic interface + , cons + , cons' + , snoc + , append + , (⧺) , head , last + , tail + , init , null , length - , concatMap + -- * Transforming 'Bitstream's + , map + , reverse + -- * Reducing 'Bitstream's , foldl , foldl' , foldl1 @@ -27,32 +49,57 @@ , foldr , foldr1 + -- ** Special folds + , concat + , concatMap , and , or , any , all - , unfoldr - , unfoldrN - + -- * Building 'Bitstream's + -- ** scans + , scanl , scanl1 , scanr , scanr1 + -- ** Replication + , replicate + + -- ** Unfolding + , unfoldr + , unfoldrN + + -- * Substreams + , take + , drop + , takeWhile + , dropWhile , span , break + -- * Searching streams , elem + , (∈) + , (∋) , notElem + , (∉) + , (∌) + -- ** Searching with a predicate , find + , filter + , partition + -- ** Indexing streams , (!!) , elemIndex , elemIndices , findIndex , findIndices + -- * Zipping and unzipping streams , zip , zip3 , zip4 @@ -68,16 +115,10 @@ , unzip4 , unzip5 , unzip6 - - , (∅) - , (⧺) - , (∈) - , (∋) - , (∉) - , (∌) ) where import qualified Data.List as L +import Data.Bits import Data.Bitstream.Fusion import Data.Maybe import Data.Vector.Fusion.Stream (Stream) @@ -94,177 +135,62 @@ {- 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. + 2. Fusible producer inlinings should always occur. + 3. Unfused form specialisations should occur at phase 1 and later. + 4. Fusible consumer/filter inlinings should occur last i.e. phase 0. + 5. stream/unstream inlinings should never occur. -} -- | Class of diverse types of 'Bitstream'. -- --- Methods of this class are functions of 'Bitstream's that is either +-- Methods of this class are functions of 'Bitstream's that are 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'. +-- Minimum complete implementation: /All but/ 'basicCons'', +-- 'basicConcat', 'basicReplicate', 'basicPartition' and +-- 'basicFromBits'. 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 + basicStream ∷ α → Stream Bool + basicUnstream ∷ Stream Bool → α - -- | /O(n)/ Convert a 'S.Stream' of 'Bool' into a 'Bitstream'. - unstream ∷ Stream Bool → α + basicCons ∷ Bool → α → α + basicCons' ∷ Bool → α → α + {-# INLINE basicCons' #-} + basicCons' = basicCons + basicSnoc ∷ α → Bool → α + basicAppend ∷ α → α → α + basicTail ∷ α → α + basicInit ∷ α → α - -- | /strict: O(n), lazy: O(1)/ 'cons' is an analogous to (':') - -- for lists. - cons ∷ Bool → α → α + basicMap ∷ (Bool → Bool) → α → α + basicReverse ∷ α → α - -- | /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 + basicConcat ∷ [α] → α + {-# INLINE basicConcat #-} + basicConcat [] = (∅) + basicConcat (α:αs) = α ⧺ concat αs - -- | /O(n)/ Append a bit to the end of a 'Bitstream'. - snoc ∷ α → Bool → α + basicScanl ∷ (Bool → Bool → Bool) → Bool → α → α - -- | /O(n)/ Append two 'Bitstream's. - append ∷ α → α → α + basicTake ∷ Integral n ⇒ n → α → α + basicDrop ∷ Integral n ⇒ n → α → α + basicTakeWhile ∷ (Bool → Bool) → α → α + basicDropWhile ∷ (Bool → Bool) → α → α - -- | /O(1)/ Extract the bits after the 'head' of a non-empty - -- 'Bitstream'. An exception will be thrown if empty. - tail ∷ α → α + basicFilter ∷ (Bool → Bool) → α → α + basicPartition ∷ (Bool → Bool) → α → (α, α) + {-# INLINE basicPartition #-} + basicPartition f α = (filter f α, filter ((¬) ∘ f) α) - -- | /O(n)/ Return all the bits of a 'Bitstream' except the last - -- one. An exception will be thrown if empty. - init ∷ α → α + basicFromNBits ∷ (Integral n, Integral β, Bits β) ⇒ n → β → α + basicToBits ∷ Bits β ⇒ α → β - -- | /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) α) +-- | /O(1)/ The empty 'Bitstream'. +empty ∷ Bitstream α ⇒ α +{-# INLINE empty #-} +empty = unstream S.empty -- | (∅) = 'empty' -- @@ -273,43 +199,13 @@ (∅) ∷ 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(1)/ Convert a 'Bool' into a 'Bitstream'. +singleton ∷ Bitstream α ⇒ Bool → α +{-# INLINE singleton #-} +singleton = unstream ∘ S.singleton -- | /O(n)/ Convert a ['Bool'] into a 'Bitstream'. -{-# INLINE [1] pack #-} +{-# INLINE pack #-} pack ∷ Bitstream α ⇒ [Bool] → α pack = unstream ∘ S.fromList @@ -318,26 +214,160 @@ {-# RULES "Bitstream unpack/unstream fusion" ∀s. unpack (unstream s) = S.toList s #-} -{-# INLINE [1] unpack #-} +{-# INLINE [0] unpack #-} unpack = S.toList ∘ stream --- | /O(1)/ The empty 'Bitstream'. -empty ∷ Bitstream α ⇒ α -{-# INLINE [1] empty #-} -empty = unstream S.empty +-- | /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 ∷ Bitstream α ⇒ α → Stream Bool +{-# NOINLINE stream #-} +stream = basicStream --- | /O(1)/ Convert a 'Bool' into a 'Bitstream'. -singleton ∷ Bitstream α ⇒ Bool → α -{-# INLINE [1] singleton #-} -singleton = unstream ∘ S.singleton +-- | /O(n)/ Convert a 'S.Stream' of 'Bool' into a 'Bitstream'. +unstream ∷ Bitstream α ⇒ Stream Bool → α +{-# NOINLINE unstream #-} +unstream = basicUnstream +{-# RULES +"Bitstream stream/unstream fusion" + ∀s. stream (unstream s) = s + +"Bitstream unstream/stream fusion" + ∀v. unstream (stream v) = v + #-} + +-- | /O(n)/ Convert a 'Bits' into a 'Bitstream'. Note that this +-- function is undefined for instances of 'Bits' which have no fixed +-- 'bitSize' (like 'Integer'). +fromBits ∷ (Integral β, Bits β, Bitstream α) ⇒ β → α +{-# INLINE fromBits #-} +fromBits β = basicFromNBits (bitSize β) β + +-- | /O(n)/ Convert the lower 'n' bits of the given 'Bits'. In the +-- case that more bits are requested than the 'Bits' provides, this +-- acts as if the 'Bits' has an infinite number of leading 0 bits. +fromNBits ∷ (Integral n, Integral β, Bits β, Bitstream α) ⇒ n → β → α +{-# INLINE fromNBits #-} +fromNBits = basicFromNBits + +-- | /O(n)/ Convert a 'Bitstream' into a 'Bits'. +toBits ∷ (Bitstream α, Bits β) ⇒ α → β +{-# INLINE [0] toBits #-} +toBits = basicToBits + +-- | /strict: O(n), lazy: O(1)/ 'cons' is an analogous to (':') for +-- lists. +cons ∷ Bitstream α ⇒ Bool → α → α +{-# RULES +"Bitstream cons/unstream fusion" + ∀b s. cons b (unstream s) = unstream (S.cons b s) + #-} +{-# INLINE [0] cons #-} +cons = basicCons + +-- | /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' ∷ Bitstream α ⇒ Bool → α → α +{-# RULES +"Bitstream cons'/unstream fusion" + ∀b s. cons' b (unstream s) = unstream (S.cons b s) + #-} +{-# INLINE [0] cons' #-} +cons' = basicCons' + +-- | /O(n)/ Append a bit to the end of a 'Bitstream'. +snoc ∷ Bitstream α ⇒ α → Bool → α +{-# RULES +"Bitstream snoc/unstream fusion" + ∀s b. snoc (unstream s) b = unstream (S.snoc s b) + #-} +{-# INLINE [0] snoc #-} +snoc = basicSnoc + +-- | /O(n)/ Append two 'Bitstream's. +append ∷ Bitstream α ⇒ α → α → α +{-# RULES +"Bitstream append/unstream fusion" + ∀s1 s2. append (unstream s1) (unstream s2) = unstream (s1 S.++ s2) + #-} +{-# INLINE [0] append #-} +append = basicAppend + +-- | (⧺) = 'append' +-- +-- U+29FA, DOUBLE PLUS +(⧺) ∷ Bitstream α ⇒ α → α → α +{-# INLINE (⧺) #-} +(⧺) = append + -- | /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 #-} +{-# INLINE [0] head #-} head = S.head ∘ stream -- | /strict: O(1), lazy: O(n)/ Extract the last bit of a finite @@ -346,31 +376,138 @@ {-# RULES "Bitstream last/unstream fusion" ∀s. last (unstream s) = S.last s #-} -{-# INLINE [1] last #-} +{-# INLINE [0] last #-} last = S.last ∘ stream +-- | /O(1)/ Extract the bits after the 'head' of a non-empty +-- 'Bitstream'. An exception will be thrown if empty. +tail ∷ Bitstream α ⇒ α → α +{-# RULES +"Bitstream tail/unstream fusion" + ∀s. tail (unstream s) = unstream (S.tail s) + #-} +{-# INLINE [0] tail #-} +tail = basicTail + +-- | /O(n)/ Return all the bits of a 'Bitstream' except the last +-- one. An exception will be thrown if empty. +init ∷ Bitstream α ⇒ α → α +{-# RULES +"Bitstream init/unstream fusion" + ∀s. init (unstream s) = unstream (S.init s) + #-} +{-# INLINE [0] init #-} +init = basicInit + -- | /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 #-} +{-# INLINE [0] null #-} null = S.null ∘ stream --- | /O(n)/ Retern the length of a finite 'Bitstream'. +-- | /strict: O(1), lazy: O(n)/ Return 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 #-} +{-# INLINE [0] length #-} length = genericLength ∘ stream +-- | /O(n)/ Map a function over a 'Bitstream'. +map ∷ Bitstream α ⇒ (Bool → Bool) → α → α +{-# RULES +"Bitstream map/unstream fusion" + ∀f s. map f (unstream s) = unstream (S.map f s) + #-} +{-# INLINE [0] map #-} +map = basicMap + +-- | /O(n)/ Reverse a 'Bitstream'. +reverse ∷ Bitstream α ⇒ α → α +{-# INLINE [0] reverse #-} +reverse = basicReverse + +-- | /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 [0] 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 [0] 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 [0] 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 [0] 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 [0] 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 [0] foldr1 #-} +foldr1 f = S.foldr1 f ∘ stream + +-- | /O(n)/ Concatenate all 'Bitstream's in the list. +concat ∷ Bitstream α ⇒ [α] → α +{-# INLINE [0] concat #-} +concat = basicConcat + -- | 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 #-} +{-# INLINE [0] concatMap #-} concatMap f = concat ∘ L.map f ∘ unpack -- | /O(n)/ 'and' returns the conjunction of a 'Bool' list. For the @@ -382,7 +519,7 @@ {-# RULES "Bitstream and/unstream fusion" ∀s. and (unstream s) = S.and s #-} -{-# INLINE [1] and #-} +{-# INLINE [0] and #-} and = S.and ∘ stream -- | /O(n)/ 'or' returns the disjunction of a 'Bool' list. For the @@ -394,7 +531,7 @@ {-# RULES "Bitstream or/unstream fusion" ∀s. or (unstream s) = S.or s #-} -{-# INLINE [1] or #-} +{-# INLINE [0] or #-} or = S.or ∘ stream -- | /O(n)/ Applied to a predicate and a 'Bitstream', 'any' determines @@ -406,7 +543,7 @@ {-# RULES "Bitstream any/unstream fusion" ∀f s. any f (unstream s) = S.or (S.map f s) #-} -{-# INLINE [1] any #-} +{-# INLINE [0] any #-} any f = S.or ∘ S.map f ∘ stream -- | /O(n)/ Applied to a predicate and a 'Bitstream', 'all' determines @@ -418,9 +555,29 @@ {-# RULES "Bitstream all/unstream fusion" ∀f s. all f (unstream s) = S.and (S.map f s) #-} -{-# INLINE [1] all #-} +{-# INLINE [0] all #-} all f = S.and ∘ S.map f ∘ stream +-- | /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 ∷ Bitstream α ⇒ (Bool → Bool → Bool) → Bool → α → α +{-# RULES +"Bitstream scanl/unstream fusion" + ∀f b s. scanl f b (unstream s) = unstream (S.scanl f b s) + #-} +{-# INLINE [0] scanl #-} +scanl = basicScanl + -- | /O(n)/ 'scanl1' is a variant of 'scanl' that has no starting -- value argument: -- @@ -428,10 +585,7 @@ -- '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 #-} +{-# INLINE [0] scanl1 #-} scanl1 f α | null α = α | otherwise = scanl f (head α) (tail α) @@ -442,81 +596,20 @@ -- 'head' ('scanr' f z xs) == 'foldr' f z xs -- @ scanr ∷ Bitstream α ⇒ (Bool → Bool → Bool) → Bool → α → α -{-# INLINE [1] scanr #-} +{-# INLINE [0] 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 #-} +{-# INLINE [0] 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)/ @'replicate' n x@ is a 'Bitstream' of length @n@ with @x@ +-- the value of every bit. +replicate ∷ (Integral n, Bitstream α) ⇒ n → Bool → α +{-# INLINE replicate #-} +replicate n = unstream ∘ genericReplicate n -- | /O(n)/ The 'unfoldr' function is a \`dual\' to 'foldr': while -- 'foldr' reduces a 'Bitstream' to a summary value, 'unfoldr' builds @@ -526,23 +619,56 @@ -- 'Bitstream' and @b@ is used as the next element in a recursive -- call. unfoldr ∷ Bitstream α ⇒ (β → Maybe (Bool, β)) → β → α -{-# INLINE [1] unfoldr #-} +{-# INLINE 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 ∷ (Integral n, Bitstream α) ⇒ n → (β → Maybe (Bool, β)) → β → α +{-# INLINE 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 +-- | /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, Bitstream α) ⇒ n → α → α +{-# RULES +"Bitstream take/unstream fusion" + ∀n s. take n (unstream s) = unstream (genericTake n s) #-} -{-# INLINE [1] (!!) #-} -α !! n = genericIndex (stream α) n +{-# INLINE [0] take #-} +take = basicTake +-- | /O(n)/ 'drop' @n xs@ returns the suffix of @xs@ after the first +-- @n@ bits, or 'empty' if @n > 'length' xs@. +drop ∷ (Integral n, Bitstream α) ⇒ n → α → α +{-# RULES +"Bitstream drop/unstream fusion" + ∀n s. drop n (unstream s) = unstream (genericDrop n s) + #-} +{-# INLINE [0] drop #-} +drop = basicDrop + +-- | /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 ∷ Bitstream α ⇒ (Bool → Bool) → α → α +{-# RULES +"Bitstream takeWhile/unstream fusion" + ∀f s. takeWhile f (unstream s) = unstream (S.takeWhile f s) + #-} +{-# INLINE [0] takeWhile #-} +takeWhile = basicTakeWhile + +-- | /O(n)/ 'dropWhile' @p xs@ returns the suffix remaining after +-- 'takeWhile' @p xs@. +dropWhile ∷ Bitstream α ⇒ (Bool → Bool) → α → α +{-# RULES +"Bitstream dropWhile/unstream fusion" + ∀f s. dropWhile f (unstream s) = unstream (S.dropWhile f s) + #-} +{-# INLINE [0] dropWhile #-} +dropWhile = basicDropWhile + -- | /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 @@ -551,7 +677,7 @@ -- 'span' @p xs@ is equivalent to @('takeWhile' p xs, 'dropWhile' p -- xs)@ span ∷ Bitstream α ⇒ (Bool → Bool) → α → (α, α) -{-# INLINE [1] span #-} +{-# INLINE span #-} span f α = let hd = takeWhile f α tl = drop (length hd ∷ Integer) α @@ -565,7 +691,7 @@ -- -- 'break' @p@ is equivalent to @'span' ('not' . p)@. break ∷ Bitstream α ⇒ (Bool → Bool) → α → (α, α) -{-# INLINE [1] break #-} +{-# INLINE break #-} break f = span ((¬) ∘ f) -- | /O(n)/ 'elem' is the 'Bitstream' membership predicate, usually @@ -577,18 +703,46 @@ {-# RULES "Bitstream elem/unstream fusion" ∀b s. elem b (unstream s) = S.elem b s #-} -{-# INLINE [1] elem #-} +{-# INLINE [0] elem #-} elem True = or elem False = (¬) ∘ and +-- | (∈) = 'elem' +-- +-- U+2208, ELEMENT OF +(∈) ∷ Bitstream α ⇒ Bool → α → Bool +{-# INLINE (∈) #-} +(∈) = elem + +-- | (∋) = 'flip' (∈) +-- +-- U+220B, CONTAINS AS MEMBER +(∋) ∷ Bitstream α ⇒ α → Bool → Bool +{-# INLINE (∋) #-} +(∋) = flip elem + -- | /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 #-} +{-# INLINE [0] notElem #-} notElem = ((¬) ∘) ∘ (∈) +-- | (∉) = 'notElem' +-- +-- U+2209, NOT AN ELEMENT OF +(∉) ∷ Bitstream α ⇒ Bool → α → Bool +{-# INLINE (∉) #-} +(∉) = notElem + +-- | (∌) = 'flip' (∉) +-- +-- U+220C, DOES NOT CONTAIN AS MEMBER +(∌) ∷ Bitstream α ⇒ α → Bool → Bool +(∌) = flip notElem +{-# INLINE (∌) #-} + -- | /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. @@ -596,9 +750,34 @@ {-# RULES "Bitstream find/unstream fusion" ∀f s. find f (unstream s) = S.find f s #-} -{-# INLINE [1] find #-} +{-# INLINE [0] find #-} find f = S.find f ∘ stream +-- | /O(n)/ 'filter', applied to a predicate and a 'Bitstream', +-- returns the 'Bitstream' of those bits that satisfy the predicate. +filter ∷ Bitstream α ⇒ (Bool → Bool) → α → α +{-# RULES +"Bitstream filter/unstream fusion" + ∀f s. filter f (unstream s) = unstream (S.filter f s) + #-} +{-# INLINE [0] filter #-} +filter = basicFilter + +-- | /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 ∷ Bitstream α ⇒ (Bool → Bool) → α → (α, α) +{-# INLINE [0] partition #-} +partition = basicPartition + +-- | /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 [0] (!!) #-} +α !! n = genericIndex (stream α) n + -- | /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. @@ -606,7 +785,7 @@ {-# RULES "Bitstream elemIndex/unstream fusion" ∀b s. elemIndex b (unstream s) = genericFindIndex (≡ b) s #-} -{-# INLINE [1] elemIndex #-} +{-# INLINE [0] elemIndex #-} elemIndex = findIndex ∘ (≡) -- | /O(n)/ The 'elemIndices' function extends 'elemIndex', by @@ -620,7 +799,7 @@ $ S.filter ((≡ b) ∘ snd) $ genericIndexed s #-} -{-# INLINE [1] elemIndices #-} +{-# INLINE [0] elemIndices #-} elemIndices = findIndices ∘ (≡) -- | /O(n)/ The 'findIndex' function takes a predicate and a @@ -631,7 +810,7 @@ {-# RULES "Bitstream findIndex/unstream fusion" ∀f s. findIndex f (unstream s) = genericFindIndex f s #-} -{-# INLINE [1] findIndex #-} +{-# INLINE [0] findIndex #-} findIndex f = genericFindIndex f ∘ stream -- | /O(n)/ The 'findIndices' function extends 'findIndex', by @@ -645,7 +824,7 @@ $ S.filter (f ∘ snd) $ genericIndexed s #-} -{-# INLINE [1] findIndices #-} +{-# INLINE [0] findIndices #-} findIndices f = S.toList ∘ S.map fst @@ -661,7 +840,7 @@ zip (unstream s1) (unstream s2) = S.toList (S.zip s1 s2) #-} -{-# INLINE [1] zip #-} +{-# INLINE [0] zip #-} zip = zipWith (,) -- | The 'zip3' function takes three 'Bitstream's and returns a list @@ -671,7 +850,7 @@ zip3 (unstream s1) (unstream s2) (unstream s3) = S.toList (S.zip3 s1 s2 s3) #-} -{-# INLINE [1] zip3 #-} +{-# INLINE [0] zip3 #-} zip3 = zipWith3 (,,) -- | The 'zip4' function takes four lists and returns a list of @@ -681,7 +860,7 @@ zip4 (unstream s1) (unstream s2) (unstream s3) (unstream s4) = S.toList (S.zip4 s1 s2 s3 s4) #-} -{-# INLINE [1] zip4 #-} +{-# INLINE [0] zip4 #-} zip4 = zipWith4 (,,,) -- | The 'zip5' function takes five 'Bitstream's and returns a list of @@ -691,7 +870,7 @@ zip5 (unstream s1) (unstream s2) (unstream s3) (unstream s4) (unstream s5) = S.toList (S.zip5 s1 s2 s3 s4 s5) #-} -{-# INLINE [1] zip5 #-} +{-# INLINE [0] zip5 #-} zip5 = zipWith5 (,,,,) -- | The 'zip6' function takes six 'Bitstream's and returns a list of @@ -701,7 +880,7 @@ 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 #-} +{-# INLINE [0] zip6 #-} zip6 = zipWith6 (,,,,,) -- | /O(min(m, n))/ 'zipWith' generalises 'zip' by zipping with the @@ -712,7 +891,7 @@ zipWith f (unstream s1) (unstream s2) = S.toList (S.zipWith f s1 s2) #-} -{-# INLINEABLE [1] zipWith #-} +{-# INLINEABLE [0] zipWith #-} zipWith f α β = S.toList $ S.zipWith f (stream α) @@ -726,7 +905,7 @@ zipWith3 f (unstream s1) (unstream s2) (unstream s3) = S.toList (S.zipWith3 f s1 s2 s3) #-} -{-# INLINEABLE [1] zipWith3 #-} +{-# INLINEABLE [0] zipWith3 #-} zipWith3 f α β γ = S.toList $ S.zipWith3 f (stream α) @@ -741,7 +920,7 @@ zipWith4 f (unstream s1) (unstream s2) (unstream s3) (unstream s4) = S.toList (S.zipWith4 f s1 s2 s3 s4) #-} -{-# INLINEABLE [1] zipWith4 #-} +{-# INLINEABLE [0] zipWith4 #-} zipWith4 f α β γ δ = S.toList $ S.zipWith4 f (stream α) @@ -757,7 +936,7 @@ 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 #-} +{-# INLINEABLE [0] zipWith5 #-} zipWith5 f α β γ δ ε = S.toList $ S.zipWith5 f (stream α) @@ -774,7 +953,7 @@ 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 #-} +{-# INLINEABLE [0] zipWith6 #-} zipWith6 f α β γ δ ε ζ = S.toList $ S.zipWith6 f (stream α) @@ -788,14 +967,14 @@ -- 'Bitstream' of first components and a 'Bitstream' of second -- components. unzip ∷ Bitstream α ⇒ [(Bool, Bool)] → (α, α) -{-# INLINEABLE [1] unzip #-} +{-# INLINEABLE 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 #-} +{-# INLINEABLE unzip3 #-} unzip3 xs = ( unstream $ S.map (\(α, _, _) → α) $ S.fromList xs , unstream $ S.map (\(_, β, _) → β) $ S.fromList xs , unstream $ S.map (\(_, _, γ) → γ) $ S.fromList xs ) @@ -803,7 +982,7 @@ -- | 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 #-} +{-# INLINEABLE unzip4 #-} unzip4 xs = ( unstream $ S.map (\(α, _, _, _) → α) $ S.fromList xs , unstream $ S.map (\(_, β, _, _) → β) $ S.fromList xs , unstream $ S.map (\(_, _, γ, _) → γ) $ S.fromList xs @@ -812,7 +991,7 @@ -- | 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 #-} +{-# INLINEABLE unzip5 #-} unzip5 xs = ( unstream $ S.map (\(α, _, _, _, _) → α) $ S.fromList xs , unstream $ S.map (\(_, β, _, _, _) → β) $ S.fromList xs , unstream $ S.map (\(_, _, γ, _, _) → γ) $ S.fromList xs @@ -822,62 +1001,10 @@ -- | 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 #-} +{-# INLINEABLE 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 --- a/Data/Bitstream/Internal.hs +++ b/Data/Bitstream/Internal.hs @@ -4,24 +4,31 @@ #-} module Data.Bitstream.Internal ( packPackets + + , lePacketsFromNBits + , bePacketsFromNBits + + , lePacketsToBits + , bePacketsToBits ) where +import Data.Bits 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 hiding (length, null) import Prelude.Unicode packPackets ∷ (Bitstream (Packet d), Monad m) ⇒ Stream m Bool → Stream m (Packet d) -{-# INLINE packPackets #-} +{-# INLINEABLE 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) + Exact n → Exact ((n+7) `div` 8) + Max n → Max ((n+7) `div` 8) Unknown → Unknown {-# INLINE step' #-} step' (p, Just s) @@ -36,3 +43,84 @@ | otherwise → return $ Yield p ((⊥) , Nothing) step' (_, Nothing) = return Done + +nOctets ∷ Integral n ⇒ n → Int +{-# INLINE nOctets #-} +nOctets nBits + = (fromIntegral nBits + 7) `div` 8 + +lePacketsFromNBits ∷ ( Integral n + , Integral β + , Bits β + , Monad m + ) + ⇒ n + → β + → Stream m (Packet Left) +{-# INLINEABLE lePacketsFromNBits #-} +lePacketsFromNBits n0 β0 = Stream step (n0, β0) (Exact (nOctets n0)) + where + {-# INLINE step #-} + step (n, β) + | n > 0 + = let !n' = min 8 n + !n'' = n - n' + !p = fromNBits n' β + !β' = β `shiftR` 8 + in + return $ Yield p (n'', β') + | otherwise + = return Done + +bePacketsFromNBits ∷ ( Integral n + , Integral β + , Bits β + , Monad m + ) + ⇒ n + → β + → Stream m (Packet Right) +{-# INLINEABLE bePacketsFromNBits #-} +bePacketsFromNBits n0 β = Stream step (n0, nOctets n0 ⋅ 8) (Exact (nOctets n0)) + where + {-# INLINE step #-} + step (n, r) + | n > 0 + = let !r' = r - 8 + !n' = n - fromIntegral r' + !n'' = n - n' + !p = fromNBits n' (β `shiftR` r') + in + return $ Yield p (n'', r') + | otherwise + = return Done + +lePacketsToBits ∷ (Monad m, Bits β) ⇒ Stream m (Packet Left) → m β +{-# INLINEABLE lePacketsToBits #-} +lePacketsToBits (Stream step s0 _) = go (s0, 0, 0) + where + {-# INLINE go #-} + go (s, o, n) + = do r ← step s + case r of + Yield p s' → let !n' = (toBits p `shiftL` o) .|. n + !o' = o + length p + in + go (s', o', n') + Skip s' → go (s', o, n) + Done → return n + +bePacketsToBits ∷ (Monad m, Bits β) ⇒ Stream m (Packet Right) → m β +{-# INLINEABLE bePacketsToBits #-} +bePacketsToBits (Stream step s0 _) = go (s0, 0) + where + {-# INLINE go #-} + go (s, n) + = do r ← step s + case r of + Yield p s' → let !o = length p + !n' = (n `shiftL` o) .|. toBits p + in + go (s', n') + Skip s' → go (s', n) + Done → return n diff --git a/Data/Bitstream/Lazy.hs b/Data/Bitstream/Lazy.hs --- a/Data/Bitstream/Lazy.hs +++ b/Data/Bitstream/Lazy.hs @@ -1,6 +1,7 @@ {-# LANGUAGE BangPatterns , FlexibleContexts + , FlexibleInstances , ScopedTypeVariables , UndecidableInstances , UnicodeSyntax @@ -16,7 +17,7 @@ -- 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 + ( -- * Data types Bitstream , Left , Right @@ -34,6 +35,11 @@ , fromByteString , toByteString + -- ** Converting from\/to 'Bits'' + , fromBits + , fromNBits + , toBits + -- ** Converting from\/to 'S.Stream's , stream , unstream @@ -75,7 +81,7 @@ , any , all - -- * Building lists + -- * Building 'Bitstream's -- ** Scans , scanl , scanl1 @@ -205,7 +211,7 @@ , " ]" ] -instance G.Bitstream (Packet d) ⇒ Eq (Bitstream d) where +instance G.Bitstream (Bitstream d) ⇒ Eq (Bitstream d) where {-# INLINE (==) #-} x == y = stream x ≡ stream y @@ -220,7 +226,7 @@ -- , 'compare' z y -- 'LT' -- ] -- @ -instance G.Bitstream (Packet d) ⇒ Ord (Bitstream d) where +instance G.Bitstream (Bitstream d) ⇒ Ord (Bitstream d) where {-# INLINE compare #-} x `compare` y = stream x `compare` stream y @@ -231,142 +237,319 @@ -- 'mappend' = 'append' -- 'mconcat' = 'concat' -- @ -instance G.Bitstream (Packet d) ⇒ Monoid (Bitstream d) where +instance G.Bitstream (Bitstream 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 +instance G.Bitstream (Bitstream Left) where + {-# INLINE basicStream #-} + basicStream = lazyStream - {-# INLINE [0] unstream #-} - unstream - = {-# CORE "Lazy Bitstream unstream" #-} - unId ∘ unstreamChunks ∘ packChunks ∘ packPackets + {-# INLINE basicUnstream #-} + basicUnstream = lazyUnstream - {-# INLINE [2] cons #-} - cons b = Chunk (singleton b) + {-# INLINE basicCons #-} + basicCons = lazyCons - {-# 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) + {-# INLINE basicCons' #-} + basicCons' = lazyCons' - {-# 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 basicSnoc #-} + basicSnoc = lazySnoc - {-# INLINE [2] append #-} - append Empty ch = ch - append (Chunk x xs) ch = Chunk x (append xs ch) + {-# INLINE basicAppend #-} + basicAppend = lazyAppend - {-# INLINEABLE [2] tail #-} - tail Empty = emptyStream - tail (Chunk x xs) = case tail x of + {-# INLINE basicTail #-} + basicTail = lazyTail + + {-# INLINE basicInit #-} + basicInit = lazyInit + + {-# INLINE basicMap #-} + basicMap = lazyMap + + {-# INLINE basicReverse #-} + basicReverse = lazyReverse + + {-# INLINE basicConcat #-} + basicConcat = lazyConcat + + {-# INLINE basicScanl #-} + basicScanl = lazyScanl + + {-# INLINE basicTake #-} + basicTake = lazyTake + + {-# INLINE basicDrop #-} + basicDrop = lazyDrop + + {-# INLINE basicTakeWhile #-} + basicTakeWhile = lazyTakeWhile + + {-# INLINE basicDropWhile #-} + basicDropWhile = lazyDropWhile + + {-# INLINE basicFilter #-} + basicFilter = lazyFilter + + {-# INLINE basicFromNBits #-} + basicFromNBits + = ((unId ∘ unstreamChunks ∘ packChunks) ∘) ∘ lePacketsFromNBits + + {-# INLINE basicToBits #-} + basicToBits = unId ∘ lePacketsToBits ∘ unpackChunks ∘ streamChunks + +instance G.Bitstream (Bitstream Right) where + {-# INLINE basicStream #-} + basicStream = lazyStream + + {-# INLINE basicUnstream #-} + basicUnstream = lazyUnstream + + {-# INLINE basicCons #-} + basicCons = lazyCons + + {-# INLINE basicCons' #-} + basicCons' = lazyCons' + + {-# INLINE basicSnoc #-} + basicSnoc = lazySnoc + + {-# INLINE basicAppend #-} + basicAppend = lazyAppend + + {-# INLINE basicTail #-} + basicTail = lazyTail + + {-# INLINE basicInit #-} + basicInit = lazyInit + + {-# INLINE basicMap #-} + basicMap = lazyMap + + {-# INLINE basicReverse #-} + basicReverse = lazyReverse + + {-# INLINE basicConcat #-} + basicConcat = lazyConcat + + {-# INLINE basicScanl #-} + basicScanl = lazyScanl + + {-# INLINE basicTake #-} + basicTake = lazyTake + + {-# INLINE basicDrop #-} + basicDrop = lazyDrop + + {-# INLINE basicTakeWhile #-} + basicTakeWhile = lazyTakeWhile + + {-# INLINE basicDropWhile #-} + basicDropWhile = lazyDropWhile + + {-# INLINE basicFilter #-} + basicFilter = lazyFilter + + {-# INLINE basicFromNBits #-} + basicFromNBits + = ((unId ∘ unstreamChunks ∘ packChunks) ∘) ∘ bePacketsFromNBits + + {-# INLINE basicToBits #-} + basicToBits = unId ∘ bePacketsToBits ∘ unpackChunks ∘ streamChunks + +lazyStream ∷ G.Bitstream (SB.Bitstream d) ⇒ Bitstream d → S.Stream Bool +{-# INLINE lazyStream #-} +lazyStream + = {-# CORE "Lazy Bitstream stream" #-} + S.concatMap stream ∘ streamChunks + +lazyUnstream ∷ ( G.Bitstream (SB.Bitstream d) + , G.Bitstream (Packet d) + ) + ⇒ S.Stream Bool + → Bitstream d +{-# INLINE lazyUnstream #-} +lazyUnstream + = {-# CORE "Lazy Bitstream unstream" #-} + unId ∘ unstreamChunks ∘ packChunks ∘ packPackets + +lazyCons ∷ G.Bitstream (SB.Bitstream d) ⇒ Bool → Bitstream d → Bitstream d +{-# INLINE lazyCons #-} +lazyCons = Chunk ∘ singleton + +lazyCons' ∷ G.Bitstream (SB.Bitstream d) ⇒ Bool → Bitstream d → Bitstream d +{-# INLINEABLE lazyCons' #-} +lazyCons' b Empty + = Chunk (SB.singleton b) Empty +lazyCons' b (Chunk x xs) + | length x < (chunkBits ∷ Int) + = Chunk (b `cons` x) xs + | otherwise + = Chunk (singleton b) (Chunk x xs) + +lazySnoc ∷ ( G.Bitstream (SB.Bitstream d) + , G.Bitstream (Bitstream d) + ) + ⇒ Bitstream d + → Bool + → Bitstream d +{-# INLINEABLE lazySnoc #-} +lazySnoc Empty b + = Chunk (SB.singleton b) Empty +lazySnoc (Chunk x Empty) b + | length x < (chunkBits ∷ Int) + = Chunk (x `snoc` b) Empty + | otherwise + = Chunk x (Chunk (singleton b) Empty) +lazySnoc (Chunk x xs) b + = Chunk x (xs `snoc` b) + +lazyAppend ∷ G.Bitstream (Bitstream d) ⇒ Bitstream d → Bitstream d → Bitstream d +{-# INLINE lazyAppend #-} +lazyAppend Empty ch = ch +lazyAppend (Chunk x xs) ch = Chunk x (append xs ch) + +lazyTail ∷ G.Bitstream (SB.Bitstream d) ⇒ Bitstream d → Bitstream d +{-# INLINEABLE lazyTail #-} +lazyTail Empty = emptyStream +lazyTail (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 +lazyInit ∷ ( G.Bitstream (SB.Bitstream d) + , G.Bitstream (Bitstream d) + ) + ⇒ Bitstream d + → Bitstream d +{-# INLINEABLE lazyInit #-} +lazyInit Empty = emptyStream +lazyInit (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) +lazyInit (Chunk x xs ) = Chunk x (init 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) +lazyMap ∷ ( G.Bitstream (SB.Bitstream d) + , G.Bitstream (Bitstream d) + ) + ⇒ (Bool → Bool) + → Bitstream d + → Bitstream d +{-# INLINE lazyMap #-} +lazyMap _ Empty = Empty +lazyMap f (Chunk x xs) = Chunk (map f x) (map f xs) - {-# 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') +lazyReverse ∷ G.Bitstream (SB.Bitstream d) ⇒ Bitstream d → Bitstream d +{-# INLINEABLE lazyReverse #-} +lazyReverse ch0 = go ch0 Empty + where + {-# INLINE go #-} + go Empty ch = ch + go (Chunk x xs) ch = go xs (Chunk (reverse x) ch) - {-# INLINE [2] concat #-} - concat = fromChunks ∘ L.concatMap toChunks +lazyConcat ∷ G.Bitstream (SB.Bitstream d) ⇒ [Bitstream d] → Bitstream d +{-# INLINE lazyConcat #-} +lazyConcat = 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 +lazyScanl ∷ ( G.Bitstream (SB.Bitstream d) + , G.Bitstream (Bitstream d) + ) + ⇒ (Bool → Bool → Bool) + → Bool + → Bitstream d + → Bitstream d +{-# INLINEABLE lazyScanl #-} +lazyScanl 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') - {-# 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 +lazyTake ∷ ( Integral n + , G.Bitstream (SB.Bitstream d) + , G.Bitstream (Bitstream d) + ) + ⇒ n + → Bitstream d + → Bitstream d +{-# INLINEABLE lazyTake #-} +lazyTake _ Empty = Empty +lazyTake 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 +lazyDrop ∷ ( Integral n + , G.Bitstream (SB.Bitstream d) + , G.Bitstream (Bitstream d) + ) + ⇒ n + → Bitstream d + → Bitstream d +{-# INLINEABLE lazyDrop #-} +lazyDrop _ Empty = Empty +lazyDrop 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 +lazyTakeWhile ∷ ( G.Bitstream (SB.Bitstream d) + , G.Bitstream (Bitstream d) + ) + ⇒ (Bool → Bool) + → Bitstream d + → Bitstream d +{-# INLINEABLE lazyTakeWhile #-} +lazyTakeWhile _ Empty = Empty +lazyTakeWhile 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 +lazyDropWhile ∷ ( G.Bitstream (SB.Bitstream d) + , G.Bitstream (Bitstream d) + ) + ⇒ (Bool → Bool) + → Bitstream d + → Bitstream d +{-# INLINEABLE lazyDropWhile #-} +lazyDropWhile _ Empty = Empty +lazyDropWhile 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 +lazyFilter ∷ ( G.Bitstream (SB.Bitstream d) + , G.Bitstream (Bitstream d) + ) + ⇒ (Bool → Bool) + → Bitstream d + → Bitstream d +{-# INLINEABLE lazyFilter #-} +lazyFilter _ Empty = Empty +lazyFilter 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). +lazyHead ∷ G.Bitstream (SB.Bitstream d) ⇒ Bitstream d → Bool +{-# RULES "head → lazyHead" [1] + ∀(v ∷ G.Bitstream (SB.Bitstream 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). +lazyLast ∷ G.Bitstream (SB.Bitstream d) ⇒ Bitstream d → Bool +{-# RULES "last → lazyLast" [1] + ∀(v ∷ G.Bitstream (SB.Bitstream d) ⇒ Bitstream d). last v = lazyLast v #-} {-# INLINE lazyLast #-} lazyLast Empty = emptyStream @@ -374,14 +557,14 @@ lazyLast (Chunk _ xs ) = lazyLast xs lazyNull ∷ Bitstream d → Bool -{-# RULES "null → lazyNull" [2] null = lazyNull #-} +{-# RULES "null → lazyNull" [1] 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). +lazyLength ∷ (G.Bitstream (SB.Bitstream d), Num n) ⇒ Bitstream d → n +{-# RULES "length → lazyLength" [1] + ∀(v ∷ G.Bitstream (SB.Bitstream d) ⇒ Bitstream d). length v = lazyLength v #-} {-# INLINE lazyLength #-} lazyLength = go 0 @@ -390,9 +573,9 @@ 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). +lazyAnd ∷ G.Bitstream (SB.Bitstream d) ⇒ Bitstream d → Bool +{-# RULES "and → lazyAnd" [1] + ∀(v ∷ G.Bitstream (SB.Bitstream d) ⇒ Bitstream d). and v = lazyAnd v #-} {-# INLINEABLE lazyAnd #-} lazyAnd Empty = False @@ -400,9 +583,9 @@ | 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). +lazyOr ∷ G.Bitstream (SB.Bitstream d) ⇒ Bitstream d → Bool +{-# RULES "or → lazyOr" [1] + ∀(v ∷ G.Bitstream (SB.Bitstream d) ⇒ Bitstream d). or v = lazyOr v #-} {-# INLINEABLE lazyOr #-} lazyOr Empty = True @@ -410,9 +593,14 @@ | 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. +lazyIndex ∷ ( G.Bitstream (SB.Bitstream d) + , Integral n + ) + ⇒ Bitstream d + → n + → Bool +{-# RULES "(!!) → lazyIndex" [1] + ∀(v ∷ G.Bitstream (SB.Bitstream d) ⇒ Bitstream d) n. v !! n = lazyIndex v n #-} {-# INLINEABLE lazyIndex #-} lazyIndex ch0 i0 @@ -435,7 +623,7 @@ -- | /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 +fromChunks ∷ G.Bitstream (SB.Bitstream d) ⇒ [SB.Bitstream d] → Bitstream d {-# INLINE fromChunks #-} fromChunks [] = Empty fromChunks (x:xs) @@ -450,7 +638,7 @@ 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 +fromByteString ∷ G.Bitstream (SB.Bitstream d) ⇒ LS.ByteString → Bitstream d {-# INLINE fromByteString #-} fromByteString = fromChunks ∘ L.map SB.fromByteString ∘ LS.toChunks @@ -458,22 +646,32 @@ -- 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 +toByteString ∷ ( G.Bitstream (SB.Bitstream d) + , 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 ∷ ( G.Bitstream (SB.Bitstream d) + , Monad m + ) + ⇒ Bitstream d + → Stream m (SB.Bitstream d) +{-# NOINLINE 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) +unstreamChunks ∷ ( G.Bitstream (SB.Bitstream d) + , Monad m + ) ⇒ Stream m (SB.Bitstream d) → m (Bitstream d) -{-# INLINE [0] unstreamChunks #-} +{-# NOINLINE unstreamChunks #-} unstreamChunks (Stream step s0 _) = go s0 where {-# INLINE go #-} @@ -495,26 +693,21 @@ #-} -- Awful implementation to gain speed... -packChunks ∷ ∀m d. Monad m +packChunks ∷ ∀d m. (G.Bitstream (Packet d), Monad m) ⇒ Stream m (Packet d) → Stream m (SB.Bitstream d) -{-# INLINE packChunks #-} +{-# INLINEABLE packChunks #-} packChunks (Stream step s0 sz) - = Stream step' (emptyChunk, 0, Just s0) sz' + = Stream step' (emptyChunk, 0, 0, Just s0) sz' where emptyChunk ∷ New.New SV.Vector (Packet d) {-# INLINE emptyChunk #-} emptyChunk - = New.create (MVector.new chunkSize) + = New.create (MVector.unsafeNew 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 + singletonChunk ∷ Packet d → New.New SV.Vector (Packet d) + {-# INLINE singletonChunk #-} + singletonChunk = writePacket emptyChunk 0 writePacket ∷ New.New SV.Vector (Packet d) → Int @@ -524,33 +717,48 @@ writePacket ch len p = New.modify (\mv → MVector.write mv len p) ch + newChunk ∷ G.Bitstream (Packet d) + ⇒ New.New SV.Vector (Packet d) + → Int + → Int + → SB.Bitstream d + {-# INLINE newChunk #-} + newChunk ch cLen bLen + = SB.unsafeFromPackets bLen + $ GV.new + $ New.apply (MVector.take cLen) 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) + 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) + step' (ch, cLen, bLen, Just s) = do r ← step s case r of Yield p s' - | len ≡ chunkSize - → return $ Yield (newChunk ch len) - (emptyChunk, 0, Just s') + | cLen ≡ chunkSize + → return $ Yield (newChunk ch cLen bLen) + (singletonChunk p, 1, length p, Just s') | otherwise - → return $ Skip (writePacket ch len p, len+1, Just s') - Skip s' → return $ Skip (ch , len , Just s') + → return $ Skip (writePacket ch cLen p, cLen+1, bLen + length p, Just s') + Skip s' → return $ Skip (ch , cLen , bLen , Just s') Done - | len ≡ 0 + | cLen ≡ 0 → return Done | otherwise - → return $ Yield (newChunk ch len) - ((⊥), (⊥), Nothing) - step' (_, _, Nothing) + → return $ Yield (newChunk ch cLen bLen) + ((⊥), (⊥), (⊥), Nothing) + step' (_, _, _, Nothing) = return Done +unpackChunks ∷ S.Stream (SB.Bitstream d) → S.Stream (Packet d) +{-# INLINE unpackChunks #-} +unpackChunks = S.concatMap SB.streamPackets + -- | /O(n)/ Convert a @'Bitstream' 'Left'@ into a @'Bitstream' -- 'Right'@. Bit directions only affect octet-based operations such as -- 'toByteString'. @@ -600,25 +808,30 @@ repeat b = xs where xs = Chunk x xs - x = replicate (chunkBits ∷ Int) b + x = SB.fromPackets (SV.replicate chunkSize p) + p = pack (L.replicate 8 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 +cycle ∷ G.Bitstream (Bitstream 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) +getContents ∷ G.Bitstream (SB.Bitstream 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 () +putBits ∷ ( G.Bitstream (SB.Bitstream d) + , G.Bitstream (Packet d) + ) + ⇒ Bitstream d + → IO () {-# INLINE putBits #-} putBits = LS.putStr ∘ toByteString @@ -626,7 +839,11 @@ -- -> '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 () +interact ∷ ( G.Bitstream (SB.Bitstream d) + , G.Bitstream (Packet d) + ) + ⇒ (Bitstream d → Bitstream d) + → IO () {-# INLINE interact #-} interact = LS.interact ∘ lift' where @@ -634,17 +851,27 @@ lift' f = toByteString ∘ f ∘ fromByteString -- | /O(n)/ Read an entire file lazily into a 'Bitstream'. -readFile ∷ G.Bitstream (Packet d) ⇒ FilePath → IO (Bitstream d) +readFile ∷ G.Bitstream (SB.Bitstream 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 () +writeFile ∷ ( G.Bitstream (SB.Bitstream d) + , 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 () +appendFile ∷ ( G.Bitstream (SB.Bitstream d) + , G.Bitstream (Packet d) + ) + ⇒ FilePath + → Bitstream d + → IO () {-# INLINE appendFile #-} appendFile = (∘ toByteString) ∘ LS.appendFile @@ -653,7 +880,7 @@ -- size. -- -- Once EOF is encountered, the 'Handle' is closed. -hGetContents ∷ G.Bitstream (Packet d) ⇒ Handle → IO (Bitstream d) +hGetContents ∷ G.Bitstream (SB.Bitstream d) ⇒ Handle → IO (Bitstream d) {-# INLINE hGetContents #-} hGetContents = fmap fromByteString ∘ LS.hGetContents @@ -667,17 +894,27 @@ -- 'hGet' will behave as if EOF was reached. -- {-# INLINE hGet #-} -hGet ∷ G.Bitstream (Packet d) ⇒ Handle → Int → IO (Bitstream d) +hGet ∷ G.Bitstream (SB.Bitstream 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 ∷ ( G.Bitstream (SB.Bitstream d) + , 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 () +hPut ∷ ( G.Bitstream (SB.Bitstream d) + , 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 --- a/Data/Bitstream/Packet.hs +++ b/Data/Bitstream/Packet.hs @@ -3,7 +3,6 @@ , EmptyDataDecls , FlexibleContexts , FlexibleInstances - , RankNTypes , UnicodeSyntax #-} -- | For internal use only. @@ -45,6 +44,8 @@ -- -- * 10010100 => [False, False, True , False, True, False, False, True] -- +-- 'Bits' operations (like 'toBits') treat a 'Left' bitstream as a +-- little-endian integer. data Left -- | 'Right' bitstreams interpret an octet as a vector of bits whose @@ -54,6 +55,8 @@ -- -- * 10010100 => [True, False, False, True, False, True , False, False] -- +-- 'Bits' operations (like 'toBits') treat a 'Right' bitstream as a +-- big-endian integer. data Right -- | 'Packet's are strict 'Bitstream's having at most 8 bits. @@ -120,17 +123,18 @@ (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) + {-# INLINE basicStream #-} + basicStream (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) + {-# INLINE basicUnstream #-} + basicUnstream (Stream step s0 sz) = {-# CORE "Packet Left unstream" #-} case upperBound sz of Just n @@ -158,31 +162,31 @@ Skip s' → safeConsume s' i o Done → return $! Packet i o - {-# INLINE [2] cons #-} - cons b p + {-# INLINE basicCons #-} + basicCons b p | full p = packetOverflow | otherwise = b `unsafeConsL` p - {-# INLINE [2] snoc #-} - snoc p b + {-# INLINE basicSnoc #-} + basicSnoc p b | full p = packetOverflow | otherwise = p `unsafeSnocL` b - {-# INLINE [2] append #-} - append (Packet nx ox) (Packet ny oy) + {-# INLINE basicAppend #-} + basicAppend (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 basicTail #-} + basicTail (Packet 0 _) = emptyNotAllowed + basicTail (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 basicInit #-} + basicInit (Packet 0 _) = emptyNotAllowed + basicInit (Packet n o) = Packet (n-1) o - {-# INLINE [2] map #-} - map f (Packet n o0) = Packet n (go 0 o0) + {-# INLINE basicMap #-} + basicMap f (Packet n o0) = Packet n (go 0 o0) where {-# INLINE go #-} go i o @@ -190,21 +194,15 @@ | f (o `testBit` i) = go (i+1) (o `setBit` i) | otherwise = go (i+1) (o `clearBit` i) - {-# INLINE [2] reverse #-} - reverse (Packet n o) + {-# INLINE basicReverse #-} + basicReverse (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 basicScanl #-} + basicScanl = scanlPacket - {-# INLINE [2] take #-} - take l (Packet n o) + {-# INLINE basicTake #-} + basicTake l (Packet n o) | l ≤ 0 = (∅) | otherwise = let n' = fromIntegral (min (fromIntegral n) l) @@ -212,8 +210,8 @@ in Packet n' o' - {-# INLINE [2] drop #-} - drop l (Packet n o) + {-# INLINE basicDrop #-} + basicDrop l (Packet n o) | l ≤ 0 = Packet n o | otherwise = let d = fromIntegral (min (fromIntegral n) l) @@ -222,27 +220,43 @@ in Packet n' o' - {-# INLINE [2] takeWhile #-} - takeWhile = takeWhilePacket + {-# INLINE basicTakeWhile #-} + basicTakeWhile = takeWhilePacket - {-# INLINE [2] dropWhile #-} - dropWhile = dropWhilePacket + {-# INLINE basicDropWhile #-} + basicDropWhile = dropWhilePacket - {-# INLINE [1] filter #-} - filter = filterPacket + {-# INLINE basicFilter #-} + basicFilter = filterPacket + {-# INLINEABLE basicFromNBits #-} + basicFromNBits n β + | n < 0 = (∅) + | n > 8 = packetOverflow + | n ≡ 8 = Packet (fromIntegral n) (fromIntegral β) + | otherwise = let n' ∷ Int + n' = fromIntegral n + o ∷ Word8 + o = fromIntegral (β .&. ((1 `shiftL` n') - 1)) + in Packet n' o + + {-# INLINE basicToBits #-} + basicToBits = fromIntegral ∘ toOctet + + instance Bitstream (Packet Right) where - {-# INLINE [0] stream #-} - stream (Packet n o) = {-# CORE "Packet Right stream" #-} - Stream step 0 (Exact n) + {-# INLINE basicStream #-} + basicStream (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) + {-# INLINE basicUnstream #-} + basicUnstream (Stream step s0 sz) = {-# CORE "Packet Right unstream" #-} case upperBound sz of Just n @@ -270,31 +284,31 @@ Skip s' → safeConsume s' i o Done → return $! Packet i o - {-# INLINE [2] cons #-} - cons b p + {-# INLINE basicCons #-} + basicCons b p | full p = packetOverflow | otherwise = b `unsafeConsR` p - {-# INLINE [2] snoc #-} - snoc p b + {-# INLINE basicSnoc #-} + basicSnoc p b | full p = packetOverflow | otherwise = p `unsafeSnocR` b - {-# INLINE [2] append #-} - append (Packet nx ox) (Packet ny oy) + {-# INLINE basicAppend #-} + basicAppend (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 basicTail #-} + basicTail (Packet 0 _) = emptyNotAllowed + basicTail (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 basicInit #-} + basicInit (Packet 0 _) = emptyNotAllowed + basicInit (Packet n o) = Packet (n-1) o - {-# INLINE [2] map #-} - map f (Packet n o0) = Packet n (go 0 o0) + {-# INLINE basicMap #-} + basicMap f (Packet n o0) = Packet n (go 0 o0) where {-# INLINE go #-} go i o @@ -302,21 +316,15 @@ | 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) + {-# INLINE basicReverse #-} + basicReverse (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 basicScanl #-} + basicScanl = scanlPacket - {-# INLINE [2] take #-} - take l (Packet n o) + {-# INLINE basicTake #-} + basicTake l (Packet n o) | l ≤ 0 = (∅) | otherwise = let n' = fromIntegral (min (fromIntegral n) l) @@ -324,8 +332,8 @@ in Packet n' o' - {-# INLINE [2] drop #-} - drop l (Packet n o) + {-# INLINE basicDrop #-} + basicDrop l (Packet n o) | l ≤ 0 = Packet n o | otherwise = let d = fromIntegral (min (fromIntegral n) l) @@ -334,58 +342,76 @@ in Packet n' o' - {-# INLINE [2] takeWhile #-} - takeWhile = takeWhilePacket + {-# INLINE basicTakeWhile #-} + basicTakeWhile = takeWhilePacket - {-# INLINE [2] dropWhile #-} - dropWhile = dropWhilePacket + {-# INLINE basicDropWhile #-} + basicDropWhile = dropWhilePacket - {-# INLINE [1] filter #-} - filter = filterPacket + {-# INLINE basicFilter #-} + basicFilter = filterPacket + {-# INLINEABLE basicFromNBits #-} + basicFromNBits n β + | n < 0 = (∅) + | n > 8 = packetOverflow + | n ≡ 8 = Packet (fromIntegral n) (fromIntegral β) + | otherwise = let n' ∷ Int + n' = fromIntegral n + o ∷ Word8 + o = fromIntegral ( (β .&. ((1 `shiftL` n') - 1)) + `shiftL` + (8-n') + ) + in Packet n' o + + {-# INLINE basicToBits #-} + basicToBits (Packet n o) + = fromIntegral (o `shiftR` (8-n)) + packetHeadL ∷ Packet Left → Bool -{-# RULES "head → packetHeadL" [2] head = packetHeadL #-} +{-# RULES "head → packetHeadL" [1] head = packetHeadL #-} {-# INLINE packetHeadL #-} packetHeadL (Packet 0 _) = emptyNotAllowed packetHeadL (Packet _ o) = o `testBit` 0 packetHeadR ∷ Packet Right → Bool -{-# RULES "head → packetHeadR" [2] head = packetHeadR #-} +{-# RULES "head → packetHeadR" [1] head = packetHeadR #-} {-# INLINE packetHeadR #-} packetHeadR (Packet 0 _) = emptyNotAllowed packetHeadR (Packet _ o) = o `testBit` 7 packetLastL ∷ Packet Left → Bool -{-# RULES "last → packetLastL" [2] last = packetLastL #-} +{-# RULES "last → packetLastL" [1] 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 #-} +{-# RULES "head → packetLastR" [1] 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 #-} +{-# RULES "and → packetAndL" [1] and = packetAndL #-} {-# INLINE packetAndL #-} packetAndL (Packet n o) = (0xFF `shiftR` (8-n)) ≡ o packetAndR ∷ Packet Right → Bool -{-# RULES "and → packetAndR" [2] and = packetAndR #-} +{-# RULES "and → packetAndR" [1] and = packetAndR #-} {-# INLINE packetAndR #-} packetAndR (Packet n o) = (0xFF `shiftL` (8-n)) ≡ o packetIndexL ∷ Integral n ⇒ Packet Left → n → Bool -{-# RULES "(!!) → packetIndexL" [2] (!!) = packetIndexL #-} +{-# RULES "(!!) → packetIndexL" [1] (!!) = 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 #-} +{-# RULES "(!!) → packetIndexR" [1] (!!) = packetIndexR #-} {-# INLINE packetIndexR #-} packetIndexR p i | i < 0 ∨ i ≥ length p = indexOutOfRange i @@ -402,18 +428,18 @@ = o `testBit` (7 - fromIntegral i) packetNull ∷ Packet d → Bool -{-# RULES "null → packetNull" [2] null = packetNull #-} +{-# RULES "null → packetNull" [1] null = packetNull #-} {-# INLINE packetNull #-} packetNull (Packet 0 _) = True packetNull _ = False packetLength ∷ Num n ⇒ Packet d → n -{-# RULES "length → packetLength" [2] length = packetLength #-} +{-# RULES "length → packetLength" [1] length = packetLength #-} {-# INLINE packetLength #-} packetLength (Packet n _) = fromIntegral n packetOr ∷ Packet d → Bool -{-# RULES "or → packetOr" [2] or = packetOr #-} +{-# RULES "or → packetOr" [1] or = packetOr #-} {-# INLINE packetOr #-} packetOr (Packet _ o) = o ≢ 0 diff --git a/bitstream.cabal b/bitstream.cabal --- a/bitstream.cabal +++ b/bitstream.cabal @@ -6,23 +6,21 @@ 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 +Version: 0.2 License: PublicDomain License-File: COPYING Author: PHO Maintainer: PHO Stability: experimental Homepage: http://cielonegro.org/Bitstream.html +Bug-Reports: http://static.cielonegro.org/ditz/bitstream/ Category: Data Tested-With: GHC == 7.0.1 Cabal-Version: >= 1.10 Build-Type: Simple Extra-Source-Files: COPYING + ChangeLog Source-Repository head Type: git