{-# LANGUAGE ForeignFunctionInterface #-}
-- | Buffer builder to assemble Bgzf blocks.  The idea is to serialize
-- stuff (BAM and BCF) into a buffer, then bgzf chunks from the buffer.
-- We use a large buffer, and we always make sure there is plenty of
-- space in it (to avoid redundant checks).

module Bio.Streaming.Bgzf (
    bgunzip,
    getBgzfHdr,
    BB(..),
    newBuffer,
    fillBuffer,
    expandBuffer,
    encodeBgzf,
    BgzfTokens(..),
    BclArgs(..),
    BclSpecialType(..),
    loop_dec_int,
    loop_bcl_special,
    CompressionError(..),
    DecompressionError(..)
                            ) where

import Bio.Prelude
import Bio.Streaming
import Foreign.C.Types                     ( CInt(..) )
import Foreign.Marshal.Utils               ( copyBytes, fillBytes, with )

import qualified Bio.Streaming.Bytes        as S
import qualified Data.ByteString            as B
import qualified Data.ByteString.Internal   as B
import qualified Data.ByteString.Unsafe     as B
import qualified Data.Vector.Storable       as V

{-| Decompresses a bgzip stream.  Individual chunks are decompressed in
    parallel.  Leftovers are discarded (some compressed HETFA files
    appear to have junk at the end). -}

bgunzip :: MonadIO m => ByteStream m r -> ByteStream m r
bgunzip :: ByteStream m r -> ByteStream m r
bgunzip s :: ByteStream m r
s = do
    Int
np <- IO Int -> ByteStream m Int
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Int -> ByteStream m Int) -> IO Int -> ByteStream m Int
forall a b. (a -> b) -> a -> b
$ IO Int
getNumCapabilities
    Stream (Of Bytes) m r -> ByteStream m r
forall (m :: * -> *) r.
Monad m =>
Stream (Of Bytes) m r -> ByteStream m r
S.fromChunks (Stream (Of Bytes) m r -> ByteStream m r)
-> Stream (Of Bytes) m r -> ByteStream m r
forall a b. (a -> b) -> a -> b
$ Int -> Stream (Of (IO Bytes)) m r -> Stream (Of Bytes) m r
forall (m :: * -> *) a b.
MonadIO m =>
Int -> Stream (Of (IO a)) m b -> Stream (Of a) m b
psequence (2Int -> Int -> Int
forall a. Num a => a -> a -> a
*Int
np) (Stream (Of (IO Bytes)) m r -> Stream (Of Bytes) m r)
-> Stream (Of (IO Bytes)) m r -> Stream (Of Bytes) m r
forall a b. (a -> b) -> a -> b
$ m (Maybe Int, Bytes, ByteStream m r)
-> Stream (Of (IO Bytes)) m (Maybe Int, Bytes, ByteStream m r)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ByteStream m r -> m (Maybe Int, Bytes, ByteStream m r)
forall (m :: * -> *) r.
Monad m =>
ByteStream m r -> m (Maybe Int, Bytes, ByteStream m r)
getBgzfHdr ByteStream m r
s) Stream (Of (IO Bytes)) m (Maybe Int, Bytes, ByteStream m r)
-> ((Maybe Int, Bytes, ByteStream m r)
    -> Stream (Of (IO Bytes)) m r)
-> Stream (Of (IO Bytes)) m r
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Maybe Int, Bytes, ByteStream m r) -> Stream (Of (IO Bytes)) m r
forall (m :: * -> *) r.
Monad m =>
(Maybe Int, Bytes, ByteStream m r) -> Stream (Of (IO Bytes)) m r
go
  where
    go :: (Maybe Int, Bytes, ByteStream m r) -> Stream (Of (IO Bytes)) m r
go (Nothing,    _hdr :: Bytes
_hdr, s1 :: ByteStream m r
s1) = m r -> Stream (Of (IO Bytes)) m r
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ByteStream m r -> m r
forall (m :: * -> *) r. Monad m => ByteStream m r -> m r
S.effects ByteStream m r
s1)
    go (Just bsize :: Int
bsize, _hdr :: Bytes
_hdr, s1 :: ByteStream m r
s1) = do
            blk :: Bytes
blk :> s2 :: ByteStream m r
s2 <- m (Of Bytes (ByteStream m r))
-> Stream (Of (IO Bytes)) m (Of Bytes (ByteStream m r))
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (Of Bytes (ByteStream m r))
 -> Stream (Of (IO Bytes)) m (Of Bytes (ByteStream m r)))
-> m (Of Bytes (ByteStream m r))
-> Stream (Of (IO Bytes)) m (Of Bytes (ByteStream m r))
forall a b. (a -> b) -> a -> b
$ Int -> ByteStream m r -> m (Of Bytes (ByteStream m r))
forall (m :: * -> *) r.
Monad m =>
Int -> ByteStream m r -> m (Of Bytes (ByteStream m r))
S.splitAt' Int
bsize ByteStream m r
s1
            Of (IO Bytes) (Stream (Of (IO Bytes)) m r)
-> Stream (Of (IO Bytes)) m r
forall (m :: * -> *) (f :: * -> *) r.
(Monad m, Functor f) =>
f (Stream f m r) -> Stream f m r
wrap (Bytes -> IO Bytes
decompressChunk Bytes
blk IO Bytes
-> Stream (Of (IO Bytes)) m r
-> Of (IO Bytes) (Stream (Of (IO Bytes)) m r)
forall a b. a -> b -> Of a b
:> (m (Maybe Int, Bytes, ByteStream m r)
-> Stream (Of (IO Bytes)) m (Maybe Int, Bytes, ByteStream m r)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ByteStream m r -> m (Maybe Int, Bytes, ByteStream m r)
forall (m :: * -> *) r.
Monad m =>
ByteStream m r -> m (Maybe Int, Bytes, ByteStream m r)
getBgzfHdr ByteStream m r
s2) Stream (Of (IO Bytes)) m (Maybe Int, Bytes, ByteStream m r)
-> ((Maybe Int, Bytes, ByteStream m r)
    -> Stream (Of (IO Bytes)) m r)
-> Stream (Of (IO Bytes)) m r
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Maybe Int, Bytes, ByteStream m r) -> Stream (Of (IO Bytes)) m r
go))
{-# INLINABLE bgunzip #-}

getBgzfHdr :: Monad m => ByteStream m r -> m (Maybe Int, B.ByteString, ByteStream m r)
getBgzfHdr :: ByteStream m r -> m (Maybe Int, Bytes, ByteStream m r)
getBgzfHdr s0 :: ByteStream m r
s0 = do
        hdr :: Bytes
hdr :> s1 :: ByteStream m r
s1 <- Int -> ByteStream m r -> m (Of Bytes (ByteStream m r))
forall (m :: * -> *) r.
Monad m =>
Int -> ByteStream m r -> m (Of Bytes (ByteStream m r))
S.splitAt' 18 ByteStream m r
s0
        if [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or [ Bytes -> Int
B.length Bytes
hdr Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< 18
              , Bytes -> Int -> Word8
B.index Bytes
hdr 0 Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
/= 139
              , Bytes -> Int -> Word8
B.index Bytes
hdr 1 Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
/= 31
              , Bytes -> Int -> Word8
B.index Bytes
hdr 3 Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.&. 4 Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
/= 4
              , Bytes -> Int -> Word8
B.index Bytes
hdr 10 Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
/= 6
              , Bytes -> Int -> Word8
B.index Bytes
hdr 11 Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
/= 0
              , Bytes -> Int -> Word8
B.index Bytes
hdr 12 Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
/= 66
              , Bytes -> Int -> Word8
B.index Bytes
hdr 13 Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
/= 67 ]
          then (Maybe Int, Bytes, ByteStream m r)
-> m (Maybe Int, Bytes, ByteStream m r)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Int
forall a. Maybe a
Nothing, Bytes
hdr, ByteStream m r
s1)
          else do
            let bsize :: Int
bsize = Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Bytes -> Int -> Word8
B.index Bytes
hdr 16) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Bytes -> Int -> Word8
B.index Bytes
hdr 17) Int -> Int -> Int
forall a. Bits a => a -> Int -> a
`shiftL` 8 Int -> Int -> Int
forall a. Num a => a -> a -> a
- 16
            (Maybe Int, Bytes, ByteStream m r)
-> m (Maybe Int, Bytes, ByteStream m r)
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> Maybe Int
forall a. a -> Maybe a
Just Int
bsize, Bytes
hdr, ByteStream m r
s1)
{-# INLINE getBgzfHdr #-}

-- | We manage a large buffer (multiple megabytes), of which we fill an
-- initial portion.  We remember the size, the used part, and two marks
-- where we later fill in sizes for the length prefixed BAM or BCF
-- records.  We move the buffer down when we yield a piece downstream,
-- and when we run out of space, we simply move to a new buffer.
-- Garbage collection should take care of the rest.  Unused 'mark' must
-- be set to (maxBound::Int) so it doesn't interfere with flushing.

data BB = BB { BB -> ForeignPtr Word8
buffer :: {-# UNPACK #-} !(ForeignPtr Word8)
             , BB -> Int
size   :: {-# UNPACK #-} !Int            -- total size of buffer
             , BB -> Int
off    :: {-# UNPACK #-} !Int            -- offset of active portion
             , BB -> Int
used   :: {-# UNPACK #-} !Int            -- used portion (inactive & active)
             , BB -> Int
mark   :: {-# UNPACK #-} !Int            -- offset of mark
             , BB -> Int
mark2  :: {-# UNPACK #-} !Int }          -- offset of mark2

-- | Things we are able to encode.  Taking inspiration from
-- binary-serialise-cbor, we define these as a lazy list-like thing and
-- consume it in a interpreter.

data BgzfTokens = TkWord32   {-# UNPACK #-} !Word32       BgzfTokens -- a 4-byte int
                | TkWord16   {-# UNPACK #-} !Word16       BgzfTokens -- a 2-byte int
                | TkWord8    {-# UNPACK #-} !Word8        BgzfTokens -- a byte
                | TkFloat    {-# UNPACK #-} !Float        BgzfTokens -- a float
                | TkDouble   {-# UNPACK #-} !Double       BgzfTokens -- a double
                | TkString   {-# UNPACK #-} !B.ByteString BgzfTokens -- a raw string
                | TkDecimal  {-# UNPACK #-} !Int          BgzfTokens -- roughly ':%d'

                | TkMemFill {-# UNPACK #-} !Int {-# UNPACK #-} !Word8   BgzfTokens
                | TkMemCopy {-# UNPACK #-} !(V.Vector Word8)            BgzfTokens

                | TkSetMark                               BgzfTokens -- sets the first mark
                | TkEndRecord                             BgzfTokens -- completes a BAM record
                | TkEndRecordPart1                        BgzfTokens -- completes part 1 of a BCF record
                | TkEndRecordPart2                        BgzfTokens -- completes part 2 of a BCF record
                | TkEnd                                              -- nothing more, for now

                | TkBclSpecial !BclArgs                   BgzfTokens
                | TkLowLevel {-# UNPACK #-} !Int (BB -> IO BB) BgzfTokens

data BclSpecialType = BclNucsBin  | BclNucsAsc  | BclNucsAscRev  | BclNucsWide
                    | BclQualsBin | BclQualsAsc | BclQualsAscRev

data BclArgs = BclArgs BclSpecialType
                       {-# UNPACK #-} !(V.Vector Word8)   -- bcl matrix
                       {-# UNPACK #-} !Int                -- stride
                       {-# UNPACK #-} !Int                -- first cycle
                       {-# UNPACK #-} !Int                -- last cycle
                       {-# UNPACK #-} !Int                -- cluster index

-- | Creates a buffer.
newBuffer :: Int -> IO BB
newBuffer :: Int -> IO BB
newBuffer sz :: Int
sz = Int -> IO (ForeignPtr Word8)
forall a. Int -> IO (ForeignPtr a)
mallocForeignPtrBytes Int
sz IO (ForeignPtr Word8) -> (ForeignPtr Word8 -> IO BB) -> IO BB
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ar :: ForeignPtr Word8
ar -> BB -> IO BB
forall (m :: * -> *) a. Monad m => a -> m a
return (BB -> IO BB) -> BB -> IO BB
forall a b. (a -> b) -> a -> b
$ ForeignPtr Word8 -> Int -> Int -> Int -> Int -> Int -> BB
BB ForeignPtr Word8
ar Int
sz 0 0 Int
forall a. Bounded a => a
maxBound Int
forall a. Bounded a => a
maxBound

-- | Creates a new buffer, copying the active content from an old one,
-- with higher capacity.  The size of the new buffer is twice the free
-- space in the old buffer, but at least @minsz@.
expandBuffer :: Int -> BB -> IO BB
expandBuffer :: Int -> BB -> IO BB
expandBuffer minsz :: Int
minsz b :: BB
b = do
    let sz' :: Int
sz' = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max (2 Int -> Int -> Int
forall a. Num a => a -> a -> a
* (BB -> Int
size BB
b Int -> Int -> Int
forall a. Num a => a -> a -> a
- BB -> Int
used BB
b)) Int
minsz
    ForeignPtr Word8
arr1 <- Int -> IO (ForeignPtr Word8)
forall a. Int -> IO (ForeignPtr a)
mallocForeignPtrBytes Int
sz'
    ForeignPtr Word8 -> (Ptr Word8 -> IO ()) -> IO ()
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr Word8
arr1 ((Ptr Word8 -> IO ()) -> IO ()) -> (Ptr Word8 -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \d :: Ptr Word8
d ->
        ForeignPtr Word8 -> (Ptr Word8 -> IO ()) -> IO ()
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr (BB -> ForeignPtr Word8
buffer BB
b) ((Ptr Word8 -> IO ()) -> IO ()) -> (Ptr Word8 -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \s :: Ptr Word8
s ->
             Ptr Word8 -> Ptr Word8 -> Int -> IO ()
forall a. Ptr a -> Ptr a -> Int -> IO ()
copyBytes Ptr Word8
d (Ptr Word8 -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
plusPtr Ptr Word8
s (BB -> Int
off BB
b)) (BB -> Int
used BB
b Int -> Int -> Int
forall a. Num a => a -> a -> a
- BB -> Int
off BB
b)
    BB -> IO BB
forall (m :: * -> *) a. Monad m => a -> m a
return $WBB :: ForeignPtr Word8 -> Int -> Int -> Int -> Int -> Int -> BB
BB{ buffer :: ForeignPtr Word8
buffer = ForeignPtr Word8
arr1
             , size :: Int
size   = Int
sz'
             , off :: Int
off    = 0
             , used :: Int
used   = BB -> Int
used BB
b Int -> Int -> Int
forall a. Num a => a -> a -> a
- BB -> Int
off BB
b
             , mark :: Int
mark   = if BB -> Int
mark  BB
b Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
forall a. Bounded a => a
maxBound then Int
forall a. Bounded a => a
maxBound else BB -> Int
mark  BB
b Int -> Int -> Int
forall a. Num a => a -> a -> a
- BB -> Int
off BB
b
             , mark2 :: Int
mark2  = if BB -> Int
mark2 BB
b Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
forall a. Bounded a => a
maxBound then Int
forall a. Bounded a => a
maxBound else BB -> Int
mark2 BB
b Int -> Int -> Int
forall a. Num a => a -> a -> a
- BB -> Int
off BB
b }

data CompressionError = CompressionError !CInt deriving (Typeable,Int -> CompressionError -> ShowS
[CompressionError] -> ShowS
CompressionError -> String
(Int -> CompressionError -> ShowS)
-> (CompressionError -> String)
-> ([CompressionError] -> ShowS)
-> Show CompressionError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [CompressionError] -> ShowS
$cshowList :: [CompressionError] -> ShowS
show :: CompressionError -> String
$cshow :: CompressionError -> String
showsPrec :: Int -> CompressionError -> ShowS
$cshowsPrec :: Int -> CompressionError -> ShowS
Show)
instance Exception CompressionError where
    displayException :: CompressionError -> String
displayException (CompressionError rc :: CInt
rc) = "compress_chunk failed: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ CInt -> String
forall a. Show a => a -> String
show CInt
rc

data DecompressionError = DecompressionError !CInt deriving (Typeable,Int -> DecompressionError -> ShowS
[DecompressionError] -> ShowS
DecompressionError -> String
(Int -> DecompressionError -> ShowS)
-> (DecompressionError -> String)
-> ([DecompressionError] -> ShowS)
-> Show DecompressionError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [DecompressionError] -> ShowS
$cshowList :: [DecompressionError] -> ShowS
show :: DecompressionError -> String
$cshow :: DecompressionError -> String
showsPrec :: Int -> DecompressionError -> ShowS
$cshowsPrec :: Int -> DecompressionError -> ShowS
Show)
instance Exception DecompressionError where
    displayException :: DecompressionError -> String
displayException (DecompressionError rc :: CInt
rc) = "decompress_chunk failed: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ CInt -> String
forall a. Show a => a -> String
show CInt
rc

compressChunk :: Int -> ForeignPtr Word8 -> Int -> Int -> IO B.ByteString
compressChunk :: Int -> ForeignPtr Word8 -> Int -> Int -> IO Bytes
compressChunk lv :: Int
lv fptr :: ForeignPtr Word8
fptr off :: Int
off slen :: Int
slen =
    ForeignPtr Word8 -> (Ptr Word8 -> IO Bytes) -> IO Bytes
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr Word8
fptr                 ((Ptr Word8 -> IO Bytes) -> IO Bytes)
-> (Ptr Word8 -> IO Bytes) -> IO Bytes
forall a b. (a -> b) -> a -> b
$ \ptr :: Ptr Word8
ptr ->
    Int -> (Ptr Word8 -> IO Int) -> IO Bytes
B.createAndTrim 65536               ((Ptr Word8 -> IO Int) -> IO Bytes)
-> (Ptr Word8 -> IO Int) -> IO Bytes
forall a b. (a -> b) -> a -> b
$ \buf :: Ptr Word8
buf ->
    CInt -> (Ptr CInt -> IO Int) -> IO Int
forall a b. Storable a => a -> (Ptr a -> IO b) -> IO b
with 65536                          ((Ptr CInt -> IO Int) -> IO Int) -> (Ptr CInt -> IO Int) -> IO Int
forall a b. (a -> b) -> a -> b
$ \p_len :: Ptr CInt
p_len -> do
        CInt
rc <- Ptr Word8 -> Ptr CInt -> Ptr Word8 -> CInt -> CInt -> IO CInt
compress_chunk Ptr Word8
buf Ptr CInt
p_len (Ptr Word8 -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
plusPtr Ptr Word8
ptr Int
off) (Int -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
slen) (Int -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
lv)
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (CInt
rc CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
/= 0 Bool -> Bool -> Bool
&& CInt
rc CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
/= 1) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ CompressionError -> IO ()
forall e a. Exception e => e -> IO a
throwIO (CompressionError -> IO ()) -> CompressionError -> IO ()
forall a b. (a -> b) -> a -> b
$ CInt -> CompressionError
CompressionError CInt
rc
        CInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (CInt -> Int) -> IO CInt -> IO Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ptr CInt -> IO CInt
forall a. Storable a => Ptr a -> IO a
peek Ptr CInt
p_len

decompressChunk :: B.ByteString -> IO B.ByteString
decompressChunk :: Bytes -> IO Bytes
decompressChunk ck :: Bytes
ck =
    Bytes -> (CString -> IO Bytes) -> IO Bytes
forall a. Bytes -> (CString -> IO a) -> IO a
B.unsafeUseAsCString Bytes
ck                         ((CString -> IO Bytes) -> IO Bytes)
-> (CString -> IO Bytes) -> IO Bytes
forall a b. (a -> b) -> a -> b
$ \psrc :: CString
psrc ->
    CString -> Int -> IO Word32
forall a b. Storable a => Ptr b -> Int -> IO a
peekByteOff CString
psrc (Bytes -> Int
B.length Bytes
ck Int -> Int -> Int
forall a. Num a => a -> a -> a
- 4)            IO Word32 -> (Word32 -> IO Bytes) -> IO Bytes
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \dlen :: Word32
dlen ->
    Int -> (Ptr Word8 -> IO ()) -> IO Bytes
B.create (Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32
dlen::Word32))          ((Ptr Word8 -> IO ()) -> IO Bytes)
-> (Ptr Word8 -> IO ()) -> IO Bytes
forall a b. (a -> b) -> a -> b
$ \pdest :: Ptr Word8
pdest -> do
        CInt
rc <- Ptr Word8 -> CInt -> Ptr Word8 -> CInt -> IO CInt
decompress_chunk Ptr Word8
pdest (Word32 -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
dlen) (CString -> Ptr Word8
forall a b. Ptr a -> Ptr b
castPtr CString
psrc) (Int -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> CInt) -> Int -> CInt
forall a b. (a -> b) -> a -> b
$ Bytes -> Int
B.length Bytes
ck)
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (CInt
rc CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
/= 0) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ DecompressionError -> IO ()
forall e a. Exception e => e -> IO a
throwIO (DecompressionError -> IO ()) -> DecompressionError -> IO ()
forall a b. (a -> b) -> a -> b
$ CInt -> DecompressionError
DecompressionError CInt
rc


-- | Expand a chain of tokens into a buffer, sending finished pieces
-- downstream as soon as possible.
encodeBgzf :: MonadIO m => Int -> Stream (Of (Endo BgzfTokens)) m b -> S.ByteStream m b
encodeBgzf :: Int -> Stream (Of (Endo BgzfTokens)) m b -> ByteStream m b
encodeBgzf lv :: Int
lv str :: Stream (Of (Endo BgzfTokens)) m b
str = do
    Int
np <- IO Int -> ByteStream m Int
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Int -> ByteStream m Int) -> IO Int -> ByteStream m Int
forall a b. (a -> b) -> a -> b
$ IO Int
getNumCapabilities
    BB
bb <- IO BB -> ByteStream m BB
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO BB -> ByteStream m BB) -> IO BB -> ByteStream m BB
forall a b. (a -> b) -> a -> b
$ Int -> IO BB
newBuffer (1024Int -> Int -> Int
forall a. Num a => a -> a -> a
*1024)
    Stream (Of Bytes) m b -> ByteStream m b
forall (m :: * -> *) r.
Monad m =>
Stream (Of Bytes) m r -> ByteStream m r
S.fromChunks (Stream (Of Bytes) m b -> ByteStream m b)
-> Stream (Of Bytes) m b -> ByteStream m b
forall a b. (a -> b) -> a -> b
$ Int -> Stream (Of (IO Bytes)) m b -> Stream (Of Bytes) m b
forall (m :: * -> *) a b.
MonadIO m =>
Int -> Stream (Of (IO a)) m b -> Stream (Of a) m b
psequence (2Int -> Int -> Int
forall a. Num a => a -> a -> a
*Int
np) (Stream (Of (IO Bytes)) m b -> Stream (Of Bytes) m b)
-> Stream (Of (IO Bytes)) m b -> Stream (Of Bytes) m b
forall a b. (a -> b) -> a -> b
$ m (Either
     b (Of (Endo BgzfTokens) (Stream (Of (Endo BgzfTokens)) m b)))
-> Stream
     (Of (IO Bytes))
     m
     (Either
        b (Of (Endo BgzfTokens) (Stream (Of (Endo BgzfTokens)) m b)))
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Stream (Of (Endo BgzfTokens)) m b
-> m (Either
        b (Of (Endo BgzfTokens) (Stream (Of (Endo BgzfTokens)) m b)))
forall (m :: * -> *) (f :: * -> *) r.
Monad m =>
Stream f m r -> m (Either r (f (Stream f m r)))
inspect Stream (Of (Endo BgzfTokens)) m b
str) Stream
  (Of (IO Bytes))
  m
  (Either
     b (Of (Endo BgzfTokens) (Stream (Of (Endo BgzfTokens)) m b)))
-> (Either
      b (Of (Endo BgzfTokens) (Stream (Of (Endo BgzfTokens)) m b))
    -> Stream (Of (IO Bytes)) m b)
-> Stream (Of (IO Bytes)) m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= BB
-> Either
     b (Of (Endo BgzfTokens) (Stream (Of (Endo BgzfTokens)) m b))
-> Stream (Of (IO Bytes)) m b
forall (m :: * -> *) b.
MonadIO m =>
BB
-> Either
     b (Of (Endo BgzfTokens) (Stream (Of (Endo BgzfTokens)) m b))
-> Stream (Of (IO Bytes)) m b
go BB
bb
  where
    go :: MonadIO m
       => BB
       -> Either b (Of (Endo BgzfTokens) (Stream (Of (Endo BgzfTokens)) m b))
       -> Stream (Of (IO Bytes)) m b
    go :: BB
-> Either
     b (Of (Endo BgzfTokens) (Stream (Of (Endo BgzfTokens)) m b))
-> Stream (Of (IO Bytes)) m b
go bb0 :: BB
bb0 (Left r :: b
r) = BB -> b -> Stream (Of (IO Bytes)) m b
forall (m :: * -> *) r.
Monad m =>
BB -> r -> Stream (Of (IO Bytes)) m r
final_flush BB
bb0 b
r
    go bb0 :: BB
bb0 (Right (f :: Endo BgzfTokens
f :> s :: Stream (Of (Endo BgzfTokens)) m b
s))
        -- initially, we make sure we have reasonable space.  this may not be enough.
        | BB -> Int
size BB
bb0 Int -> Int -> Int
forall a. Num a => a -> a -> a
- BB -> Int
used BB
bb0 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< 1024 = IO BB -> Stream (Of (IO Bytes)) m BB
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Int -> BB -> IO BB
expandBuffer (1024Int -> Int -> Int
forall a. Num a => a -> a -> a
*1024) BB
bb0) Stream (Of (IO Bytes)) m BB
-> (BB -> Stream (Of (IO Bytes)) m b) -> Stream (Of (IO Bytes)) m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \bb' :: BB
bb' -> BB
-> BgzfTokens
-> Stream (Of (Endo BgzfTokens)) m b
-> Stream (Of (IO Bytes)) m b
forall (m :: * -> *) r.
MonadIO m =>
BB
-> BgzfTokens
-> Stream (Of (Endo BgzfTokens)) m r
-> Stream (Of (IO Bytes)) m r
go' BB
bb' (Endo BgzfTokens -> BgzfTokens -> BgzfTokens
forall a. Endo a -> a -> a
appEndo Endo BgzfTokens
f BgzfTokens
TkEnd) Stream (Of (Endo BgzfTokens)) m b
s
        | Bool
otherwise                  =                                                   BB
-> BgzfTokens
-> Stream (Of (Endo BgzfTokens)) m b
-> Stream (Of (IO Bytes)) m b
forall (m :: * -> *) r.
MonadIO m =>
BB
-> BgzfTokens
-> Stream (Of (Endo BgzfTokens)) m r
-> Stream (Of (IO Bytes)) m r
go' BB
bb0 (Endo BgzfTokens -> BgzfTokens -> BgzfTokens
forall a. Endo a -> a -> a
appEndo Endo BgzfTokens
f BgzfTokens
TkEnd) Stream (Of (Endo BgzfTokens)) m b
s

    go' :: BB
-> BgzfTokens
-> Stream (Of (Endo BgzfTokens)) m r
-> Stream (Of (IO Bytes)) m r
go' bb0 :: BB
bb0 tk :: BgzfTokens
tk s :: Stream (Of (Endo BgzfTokens)) m r
s = IO (BB, BgzfTokens) -> Stream (Of (IO Bytes)) m (BB, BgzfTokens)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (BB -> BgzfTokens -> IO (BB, BgzfTokens)
fillBuffer BB
bb0 BgzfTokens
tk) Stream (Of (IO Bytes)) m (BB, BgzfTokens)
-> ((BB, BgzfTokens) -> Stream (Of (IO Bytes)) m r)
-> Stream (Of (IO Bytes)) m r
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \(bb' :: BB
bb',tk' :: BgzfTokens
tk') -> BgzfTokens
-> BB
-> Stream (Of (Endo BgzfTokens)) m r
-> Stream (Of (IO Bytes)) m r
flush_blocks BgzfTokens
tk' BB
bb' Stream (Of (Endo BgzfTokens)) m r
s

    -- We can flush anything that is between 'off' and the lower of 'mark'
    -- and 'used'.  When done, we bump 'off'.
    flush_blocks :: BgzfTokens
-> BB
-> Stream (Of (Endo BgzfTokens)) m r
-> Stream (Of (IO Bytes)) m r
flush_blocks tk :: BgzfTokens
tk bb :: BB
bb s :: Stream (Of (Endo BgzfTokens)) m r
s
        | Int -> Int -> Int
forall a. Ord a => a -> a -> a
min (BB -> Int
mark BB
bb) (BB -> Int
used BB
bb) Int -> Int -> Int
forall a. Num a => a -> a -> a
- BB -> Int
off BB
bb Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
maxBlockSize =
            case BgzfTokens
tk of TkEnd -> m (Either
     r (Of (Endo BgzfTokens) (Stream (Of (Endo BgzfTokens)) m r)))
-> Stream
     (Of (IO Bytes))
     m
     (Either
        r (Of (Endo BgzfTokens) (Stream (Of (Endo BgzfTokens)) m r)))
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Stream (Of (Endo BgzfTokens)) m r
-> m (Either
        r (Of (Endo BgzfTokens) (Stream (Of (Endo BgzfTokens)) m r)))
forall (m :: * -> *) (f :: * -> *) r.
Monad m =>
Stream f m r -> m (Either r (f (Stream f m r)))
inspect Stream (Of (Endo BgzfTokens)) m r
s) Stream
  (Of (IO Bytes))
  m
  (Either
     r (Of (Endo BgzfTokens) (Stream (Of (Endo BgzfTokens)) m r)))
-> (Either
      r (Of (Endo BgzfTokens) (Stream (Of (Endo BgzfTokens)) m r))
    -> Stream (Of (IO Bytes)) m r)
-> Stream (Of (IO Bytes)) m r
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= BB
-> Either
     r (Of (Endo BgzfTokens) (Stream (Of (Endo BgzfTokens)) m r))
-> Stream (Of (IO Bytes)) m r
forall (m :: * -> *) b.
MonadIO m =>
BB
-> Either
     b (Of (Endo BgzfTokens) (Stream (Of (Endo BgzfTokens)) m b))
-> Stream (Of (IO Bytes)) m b
go BB
bb
                       _     -> -- we arrive here because we ran out of buffer space, so we expand it.
                                IO BB -> Stream (Of (IO Bytes)) m BB
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Int -> BB -> IO BB
expandBuffer (1024Int -> Int -> Int
forall a. Num a => a -> a -> a
*1024) BB
bb) Stream (Of (IO Bytes)) m BB
-> (BB -> Stream (Of (IO Bytes)) m r) -> Stream (Of (IO Bytes)) m r
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \bb' :: BB
bb' -> BB
-> BgzfTokens
-> Stream (Of (Endo BgzfTokens)) m r
-> Stream (Of (IO Bytes)) m r
go' BB
bb' BgzfTokens
tk Stream (Of (Endo BgzfTokens)) m r
s
        | Bool
otherwise =
            Of (IO Bytes) (Stream (Of (IO Bytes)) m r)
-> Stream (Of (IO Bytes)) m r
forall (m :: * -> *) (f :: * -> *) r.
(Monad m, Functor f) =>
f (Stream f m r) -> Stream f m r
wrap (Of (IO Bytes) (Stream (Of (IO Bytes)) m r)
 -> Stream (Of (IO Bytes)) m r)
-> Of (IO Bytes) (Stream (Of (IO Bytes)) m r)
-> Stream (Of (IO Bytes)) m r
forall a b. (a -> b) -> a -> b
$  Int -> ForeignPtr Word8 -> Int -> Int -> IO Bytes
compressChunk Int
lv (BB -> ForeignPtr Word8
buffer BB
bb) (BB -> Int
off BB
bb) Int
maxBlockSize
                 IO Bytes
-> Stream (Of (IO Bytes)) m r
-> Of (IO Bytes) (Stream (Of (IO Bytes)) m r)
forall a b. a -> b -> Of a b
:> BgzfTokens
-> BB
-> Stream (Of (Endo BgzfTokens)) m r
-> Stream (Of (IO Bytes)) m r
flush_blocks BgzfTokens
tk BB
bb { off :: Int
off = BB -> Int
off BB
bb Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
maxBlockSize } Stream (Of (Endo BgzfTokens)) m r
s

    final_flush :: BB -> r -> Stream (Of (IO Bytes)) m r
final_flush bb :: BB
bb r :: r
r
        | BB -> Int
used BB
bb Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> BB -> Int
off BB
bb =
            Of (IO Bytes) (Stream (Of (IO Bytes)) m r)
-> Stream (Of (IO Bytes)) m r
forall (m :: * -> *) (f :: * -> *) r.
(Monad m, Functor f) =>
f (Stream f m r) -> Stream f m r
wrap (Of (IO Bytes) (Stream (Of (IO Bytes)) m r)
 -> Stream (Of (IO Bytes)) m r)
-> Of (IO Bytes) (Stream (Of (IO Bytes)) m r)
-> Stream (Of (IO Bytes)) m r
forall a b. (a -> b) -> a -> b
$  Int -> ForeignPtr Word8 -> Int -> Int -> IO Bytes
compressChunk Int
lv (BB -> ForeignPtr Word8
buffer BB
bb) (BB -> Int
off BB
bb) (BB -> Int
used BB
bb Int -> Int -> Int
forall a. Num a => a -> a -> a
- BB -> Int
off BB
bb)
                 IO Bytes
-> Stream (Of (IO Bytes)) m r
-> Of (IO Bytes) (Stream (Of (IO Bytes)) m r)
forall a b. a -> b -> Of a b
:> Of (IO Bytes) (Stream (Of (IO Bytes)) m r)
-> Stream (Of (IO Bytes)) m r
forall (m :: * -> *) (f :: * -> *) r.
(Monad m, Functor f) =>
f (Stream f m r) -> Stream f m r
wrap (Bytes -> IO Bytes
forall (m :: * -> *) a. Monad m => a -> m a
return Bytes
bgzfEofMarker IO Bytes
-> Stream (Of (IO Bytes)) m r
-> Of (IO Bytes) (Stream (Of (IO Bytes)) m r)
forall a b. a -> b -> Of a b
:> r -> Stream (Of (IO Bytes)) m r
forall (f :: * -> *) a. Applicative f => a -> f a
pure r
r)
        | Bool
otherwise =
            Of (IO Bytes) (Stream (Of (IO Bytes)) m r)
-> Stream (Of (IO Bytes)) m r
forall (m :: * -> *) (f :: * -> *) r.
(Monad m, Functor f) =>
f (Stream f m r) -> Stream f m r
wrap (Bytes -> IO Bytes
forall (m :: * -> *) a. Monad m => a -> m a
return Bytes
bgzfEofMarker IO Bytes
-> Stream (Of (IO Bytes)) m r
-> Of (IO Bytes) (Stream (Of (IO Bytes)) m r)
forall a b. a -> b -> Of a b
:> r -> Stream (Of (IO Bytes)) m r
forall (f :: * -> *) a. Applicative f => a -> f a
pure r
r)

    -- maximum block size for Bgzf: 64k with some room for
    -- headers and uncompressible stuff
    maxBlockSize :: Int
maxBlockSize = 65478


fillBuffer :: BB -> BgzfTokens -> IO (BB, BgzfTokens)
fillBuffer :: BB -> BgzfTokens -> IO (BB, BgzfTokens)
fillBuffer bb0 :: BB
bb0 tk :: BgzfTokens
tk = ForeignPtr Word8
-> (Ptr Word8 -> IO (BB, BgzfTokens)) -> IO (BB, BgzfTokens)
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr (BB -> ForeignPtr Word8
buffer BB
bb0) (\p :: Ptr Word8
p -> Ptr Word8 -> BB -> BgzfTokens -> IO (BB, BgzfTokens)
forall a. Ptr a -> BB -> BgzfTokens -> IO (BB, BgzfTokens)
go_slowish Ptr Word8
p BB
bb0 BgzfTokens
tk)
  where
    go_slowish :: Ptr a -> BB -> BgzfTokens -> IO (BB, BgzfTokens)
go_slowish p :: Ptr a
p bb :: BB
bb = Ptr a -> BB -> Int -> BgzfTokens -> IO (BB, BgzfTokens)
go_fast Ptr a
p BB
bb (BB -> Int
used BB
bb)

    go_fast :: Ptr a -> BB -> Int -> BgzfTokens -> IO (BB, BgzfTokens)
go_fast p :: Ptr a
p bb :: BB
bb use :: Int
use tk1 :: BgzfTokens
tk1 = case BgzfTokens
tk1 of
        -- no space?  not our job.
        _ | BB -> Int
size BB
bb Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
use Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< 1024 -> (BB, BgzfTokens) -> IO (BB, BgzfTokens)
forall (m :: * -> *) a. Monad m => a -> m a
return (BB
bb { used :: Int
used = Int
use },BgzfTokens
tk1)

        -- the actual end.
        TkEnd                    -> (BB, BgzfTokens) -> IO (BB, BgzfTokens)
forall (m :: * -> *) a. Monad m => a -> m a
return (BB
bb { used :: Int
used = Int
use },BgzfTokens
tk1)

        -- I'm cheating.  This stuff works only if the platform allows
        -- unaligned accesses, is little-endian and uses IEEE floats.
        -- It's true on i386 and ix86_64.
        TkWord32   x :: Word32
x tk' :: BgzfTokens
tk' -> do Ptr a -> Int -> Word32 -> IO ()
forall a b. Storable a => Ptr b -> Int -> a -> IO ()
pokeByteOff Ptr a
p Int
use Word32
x
                               Ptr a -> BB -> Int -> BgzfTokens -> IO (BB, BgzfTokens)
go_fast Ptr a
p BB
bb (Int
use Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 4) BgzfTokens
tk'

        TkWord16   x :: Word16
x tk' :: BgzfTokens
tk' -> do Ptr a -> Int -> Word16 -> IO ()
forall a b. Storable a => Ptr b -> Int -> a -> IO ()
pokeByteOff Ptr a
p Int
use Word16
x
                               Ptr a -> BB -> Int -> BgzfTokens -> IO (BB, BgzfTokens)
go_fast Ptr a
p BB
bb (Int
use Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 2) BgzfTokens
tk'

        TkWord8    x :: Word8
x tk' :: BgzfTokens
tk' -> do Ptr a -> Int -> Word8 -> IO ()
forall a b. Storable a => Ptr b -> Int -> a -> IO ()
pokeByteOff Ptr a
p Int
use Word8
x
                               Ptr a -> BB -> Int -> BgzfTokens -> IO (BB, BgzfTokens)
go_fast Ptr a
p BB
bb (Int
use Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1) BgzfTokens
tk'

        TkFloat    x :: Float
x tk' :: BgzfTokens
tk' -> do Ptr a -> Int -> Float -> IO ()
forall a b. Storable a => Ptr b -> Int -> a -> IO ()
pokeByteOff Ptr a
p Int
use Float
x
                               Ptr a -> BB -> Int -> BgzfTokens -> IO (BB, BgzfTokens)
go_fast Ptr a
p BB
bb (Int
use Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 4) BgzfTokens
tk'

        TkDouble   x :: Double
x tk' :: BgzfTokens
tk' -> do Ptr a -> Int -> Double -> IO ()
forall a b. Storable a => Ptr b -> Int -> a -> IO ()
pokeByteOff Ptr a
p Int
use Double
x
                               Ptr a -> BB -> Int -> BgzfTokens -> IO (BB, BgzfTokens)
go_fast Ptr a
p BB
bb (Int
use Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 8) BgzfTokens
tk'

        -- The next three may be too big to handle.  By returning with
        -- unfinished business, we will get progressively bigger buffers
        -- and eventually handle it just fine.
        TkString   s :: Bytes
s tk' :: BgzfTokens
tk'
            | Bytes -> Int
B.length Bytes
s Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> BB -> Int
size BB
bb Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
use -> (BB, BgzfTokens) -> IO (BB, BgzfTokens)
forall (m :: * -> *) a. Monad m => a -> m a
return (BB
bb { used :: Int
used = Int
use },BgzfTokens
tk1)

            | Bool
otherwise  -> do let ln :: Int
ln = Bytes -> Int
B.length Bytes
s
                               Bytes -> (CString -> IO ()) -> IO ()
forall a. Bytes -> (CString -> IO a) -> IO a
B.unsafeUseAsCString Bytes
s ((CString -> IO ()) -> IO ()) -> (CString -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \q :: CString
q ->
                                    CString -> CString -> Int -> IO ()
forall a. Ptr a -> Ptr a -> Int -> IO ()
copyBytes (Ptr a
p Ptr a -> Int -> CString
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
use) CString
q Int
ln
                               Ptr a -> BB -> Int -> BgzfTokens -> IO (BB, BgzfTokens)
go_fast Ptr a
p BB
bb (Int
use Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
ln) BgzfTokens
tk'

        TkMemFill ln :: Int
ln c :: Word8
c tk' :: BgzfTokens
tk'
            | Int
ln Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> BB -> Int
size BB
bb Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
use -> (BB, BgzfTokens) -> IO (BB, BgzfTokens)
forall (m :: * -> *) a. Monad m => a -> m a
return (BB
bb { used :: Int
used = Int
use },BgzfTokens
tk1)

            | Bool
otherwise  -> do Ptr Any -> Word8 -> Int -> IO ()
forall a. Ptr a -> Word8 -> Int -> IO ()
fillBytes (Ptr a
p Ptr a -> Int -> Ptr Any
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
use) Word8
c Int
ln
                               Ptr a -> BB -> Int -> BgzfTokens -> IO (BB, BgzfTokens)
go_fast Ptr a
p BB
bb (Int
use Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
ln) BgzfTokens
tk'

        TkMemCopy v :: Vector Word8
v tk' :: BgzfTokens
tk'
            | Vector Word8 -> Int
forall a. Storable a => Vector a -> Int
V.length Vector Word8
v Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> BB -> Int
size BB
bb Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
use -> (BB, BgzfTokens) -> IO (BB, BgzfTokens)
forall (m :: * -> *) a. Monad m => a -> m a
return (BB
bb { used :: Int
used = Int
use },BgzfTokens
tk1)

            | Bool
otherwise  -> do let ln :: Int
ln = Vector Word8 -> Int
forall a. Storable a => Vector a -> Int
V.length Vector Word8
v
                               Vector Word8 -> (Ptr Word8 -> IO ()) -> IO ()
forall a b. Storable a => Vector a -> (Ptr a -> IO b) -> IO b
V.unsafeWith Vector Word8
v ((Ptr Word8 -> IO ()) -> IO ()) -> (Ptr Word8 -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \q :: Ptr Word8
q ->
                                    Ptr Word8 -> Ptr Word8 -> Int -> IO ()
forall a. Ptr a -> Ptr a -> Int -> IO ()
copyBytes (Ptr a
p Ptr a -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
use) Ptr Word8
q Int
ln
                               Ptr a -> BB -> Int -> BgzfTokens -> IO (BB, BgzfTokens)
go_fast Ptr a
p BB
bb (Int
use Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
ln) BgzfTokens
tk'


        TkDecimal  x :: Int
x tk' :: BgzfTokens
tk' -> do CInt
ln <- Ptr Word8 -> CInt -> IO CInt
int_loop (Ptr a
p Ptr a -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
use) (Int -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
x)
                               Ptr a -> BB -> Int -> BgzfTokens -> IO (BB, BgzfTokens)
go_fast Ptr a
p BB
bb (Int
use Int -> Int -> Int
forall a. Num a => a -> a -> a
+ CInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral CInt
ln) BgzfTokens
tk'

        TkSetMark        tk' :: BgzfTokens
tk' ->    Ptr a -> BB -> BgzfTokens -> IO (BB, BgzfTokens)
go_slowish Ptr a
p BB
bb { used :: Int
used = Int
use Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 4, mark :: Int
mark = Int
use } BgzfTokens
tk'

        TkEndRecord      tk' :: BgzfTokens
tk' -> do let !l :: Int
l = Int
use Int -> Int -> Int
forall a. Num a => a -> a -> a
- BB -> Int
mark BB
bb Int -> Int -> Int
forall a. Num a => a -> a -> a
- 4
                                   Ptr a -> Int -> Word32 -> IO ()
forall a b. Storable a => Ptr b -> Int -> a -> IO ()
pokeByteOff Ptr a
p (BB -> Int
mark BB
bb) (Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
l :: Word32)
                                   Ptr a -> BB -> BgzfTokens -> IO (BB, BgzfTokens)
go_slowish Ptr a
p BB
bb { used :: Int
used = Int
use, mark :: Int
mark = Int
forall a. Bounded a => a
maxBound } BgzfTokens
tk'

        TkEndRecordPart1 tk' :: BgzfTokens
tk' -> do let !l :: Int
l = Int
use Int -> Int -> Int
forall a. Num a => a -> a -> a
- BB -> Int
mark BB
bb Int -> Int -> Int
forall a. Num a => a -> a -> a
- 4
                                   Ptr a -> Int -> Word32 -> IO ()
forall a b. Storable a => Ptr b -> Int -> a -> IO ()
pokeByteOff Ptr a
p (BB -> Int
mark BB
bb Int -> Int -> Int
forall a. Num a => a -> a -> a
- 4) (Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
l :: Word32)
                                   Ptr a -> BB -> BgzfTokens -> IO (BB, BgzfTokens)
go_slowish Ptr a
p BB
bb { used :: Int
used = Int
use, mark2 :: Int
mark2 = Int
use } BgzfTokens
tk'

        TkEndRecordPart2 tk' :: BgzfTokens
tk' -> do let !l :: Int
l = Int
use Int -> Int -> Int
forall a. Num a => a -> a -> a
- BB -> Int
mark2 BB
bb
                                   Ptr a -> Int -> Word32 -> IO ()
forall a b. Storable a => Ptr b -> Int -> a -> IO ()
pokeByteOff Ptr a
p (BB -> Int
mark BB
bb) (Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
l :: Word32)
                                   Ptr a -> BB -> BgzfTokens -> IO (BB, BgzfTokens)
go_slowish Ptr a
p BB
bb { used :: Int
used = Int
use, mark :: Int
mark = Int
forall a. Bounded a => a
maxBound } BgzfTokens
tk'

        TkBclSpecial special_args :: BclArgs
special_args tk' :: BgzfTokens
tk' -> do
            Int
l <- Ptr Word8 -> BclArgs -> IO Int
loop_bcl_special (Ptr a
p Ptr a -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
use) BclArgs
special_args
            Ptr a -> BB -> Int -> BgzfTokens -> IO (BB, BgzfTokens)
go_fast Ptr a
p BB
bb (Int
use Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
l) BgzfTokens
tk'

        TkLowLevel minsize :: Int
minsize proc :: BB -> IO BB
proc tk' :: BgzfTokens
tk'
            | BB -> Int
size BB
bb Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
use Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
minsize -> (BB, BgzfTokens) -> IO (BB, BgzfTokens)
forall (m :: * -> *) a. Monad m => a -> m a
return (BB
bb { used :: Int
used = Int
use },BgzfTokens
tk1)
            | Bool
otherwise               -> do BB
bb' <- BB -> IO BB
proc BB
bb { used :: Int
used = Int
use }
                                            Ptr a -> BB -> BgzfTokens -> IO (BB, BgzfTokens)
go_slowish Ptr a
p BB
bb' BgzfTokens
tk'

-- | The EOF marker for BGZF files.
-- This is just an empty string compressed as BGZF.  Appended to BAM
-- files to indicate their end.
bgzfEofMarker :: Bytes
bgzfEofMarker :: Bytes
bgzfEofMarker = "\x1f\x8b\x8\x4\0\0\0\0\0\xff\x6\0\x42\x43\x2\0\x1b\0\x3\0\0\0\0\0\0\0\0\0"

loop_dec_int :: Ptr Word8 -> Int -> IO Int
loop_dec_int :: Ptr Word8 -> Int -> IO Int
loop_dec_int p :: Ptr Word8
p i :: Int
i = CInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (CInt -> Int) -> IO CInt -> IO Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ptr Word8 -> CInt -> IO CInt
int_loop Ptr Word8
p (Int -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
i)

loop_bcl_special :: Ptr Word8 -> BclArgs -> IO Int
loop_bcl_special :: Ptr Word8 -> BclArgs -> IO Int
loop_bcl_special p :: Ptr Word8
p (BclArgs tp :: BclSpecialType
tp vec :: Vector Word8
vec stride :: Int
stride u :: Int
u v :: Int
v i :: Int
i) =

    Vector Word8 -> (Ptr Word8 -> IO Int) -> IO Int
forall a b. Storable a => Vector a -> (Ptr a -> IO b) -> IO b
V.unsafeWith Vector Word8
vec ((Ptr Word8 -> IO Int) -> IO Int)
-> (Ptr Word8 -> IO Int) -> IO Int
forall a b. (a -> b) -> a -> b
$ \q :: Ptr Word8
q -> case BclSpecialType
tp of
        BclNucsBin -> do
            Ptr Word8 -> CInt -> Ptr Word8 -> CInt -> CInt -> IO ()
nuc_loop Ptr Word8
p (Int -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
stride) (Ptr Word8 -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
plusPtr Ptr Word8
q Int
i) (Int -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
u) (Int -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
v)
            Int -> IO Int
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> IO Int) -> Int -> IO Int
forall a b. (a -> b) -> a -> b
$ (Int
v Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
u Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 2) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` 2

        BclNucsWide -> do
            Ptr Word8 -> CInt -> Ptr Word8 -> CInt -> CInt -> IO ()
nuc_loop_wide Ptr Word8
p (Int -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
stride) (Ptr Word8 -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
plusPtr Ptr Word8
q Int
i) (Int -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
u) (Int -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
v)
            Int -> IO Int
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> IO Int) -> Int -> IO Int
forall a b. (a -> b) -> a -> b
$ Int
v Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
u Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1

        BclNucsAsc -> do
            Ptr Word8 -> CInt -> Ptr Word8 -> CInt -> CInt -> IO ()
nuc_loop_asc Ptr Word8
p (Int -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
stride) (Ptr Word8 -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
plusPtr Ptr Word8
q Int
i) (Int -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
u) (Int -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
v)
            Int -> IO Int
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> IO Int) -> Int -> IO Int
forall a b. (a -> b) -> a -> b
$ Int
v Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
u Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1

        BclNucsAscRev -> do
            Ptr Word8 -> CInt -> Ptr Word8 -> CInt -> CInt -> IO ()
nuc_loop_asc_rev Ptr Word8
p (Int -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
stride) (Ptr Word8 -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
plusPtr Ptr Word8
q Int
i) (Int -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
u) (Int -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
v)
            Int -> IO Int
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> IO Int) -> Int -> IO Int
forall a b. (a -> b) -> a -> b
$ Int
v Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
u Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1

        BclQualsBin -> do
            Ptr Word8 -> CInt -> Ptr Word8 -> CInt -> CInt -> IO ()
qual_loop Ptr Word8
p (Int -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
stride) (Ptr Word8 -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
plusPtr Ptr Word8
q Int
i) (Int -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
u) (Int -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
v)
            Int -> IO Int
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> IO Int) -> Int -> IO Int
forall a b. (a -> b) -> a -> b
$ Int
v Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
u Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1

        BclQualsAsc -> do
            Ptr Word8 -> CInt -> Ptr Word8 -> CInt -> CInt -> IO ()
qual_loop_asc Ptr Word8
p (Int -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
stride) (Ptr Word8 -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
plusPtr Ptr Word8
q Int
i) (Int -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
u) (Int -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
v)
            Int -> IO Int
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> IO Int) -> Int -> IO Int
forall a b. (a -> b) -> a -> b
$ Int
v Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
u Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1

        BclQualsAscRev -> do
            Ptr Word8 -> CInt -> Ptr Word8 -> CInt -> CInt -> IO ()
qual_loop_asc_rev Ptr Word8
p (Int -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
stride) (Ptr Word8 -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
plusPtr Ptr Word8
q Int
i) (Int -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
u) (Int -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
v)
            Int -> IO Int
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> IO Int) -> Int -> IO Int
forall a b. (a -> b) -> a -> b
$ Int
v Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
u Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1

foreign import ccall unsafe "nuc_loop"
    nuc_loop :: Ptr Word8 -> CInt -> Ptr Word8 -> CInt -> CInt -> IO ()

foreign import ccall unsafe "nuc_loop_wide"
    nuc_loop_wide :: Ptr Word8 -> CInt -> Ptr Word8 -> CInt -> CInt -> IO ()

foreign import ccall unsafe "nuc_loop_asc"
    nuc_loop_asc :: Ptr Word8 -> CInt -> Ptr Word8 -> CInt -> CInt -> IO ()

foreign import ccall unsafe "nuc_loop_asc_rev"
    nuc_loop_asc_rev :: Ptr Word8 -> CInt -> Ptr Word8 -> CInt -> CInt -> IO ()

foreign import ccall unsafe "qual_loop"
    qual_loop :: Ptr Word8 -> CInt -> Ptr Word8 -> CInt -> CInt -> IO ()

foreign import ccall unsafe "qual_loop_asc"
    qual_loop_asc :: Ptr Word8 -> CInt -> Ptr Word8 -> CInt -> CInt -> IO ()

foreign import ccall unsafe "qual_loop_asc_rev"
    qual_loop_asc_rev :: Ptr Word8 -> CInt -> Ptr Word8 -> CInt -> CInt -> IO ()

foreign import ccall unsafe "int_loop"
    int_loop :: Ptr Word8 -> CInt -> IO CInt

foreign import ccall unsafe "compress_chunk"
    compress_chunk :: Ptr Word8 -> Ptr CInt -> Ptr Word8 -> CInt -> CInt -> IO CInt

foreign import ccall unsafe "decompress_chunk"
    decompress_chunk :: Ptr Word8 -> CInt -> Ptr Word8 -> CInt -> IO CInt