biohazard 1.1.1 → 2.0

raw patch · 74 files changed

+7685/−9935 lines, 74 filesdep +bifunctorsdep +directorydep +streamingdep −asyncdep −vector-th-unboxPVP ok

version bump matches the API change (PVP)

Dependencies added: bifunctors, directory, streaming

Dependencies removed: async, vector-th-unbox

API changes (from Hackage documentation)

Files

• Bio/Adna.hs +655/−0
• Bio/Align.hs +85/−0
• Bio/Bam.hs +24/−0
• Bio/Bam/Evan.hs +100/−0
• Bio/Bam/Fastq.hs +121/−0
• Bio/Bam/Filter.hs +121/−0
• Bio/Bam/Header.hs +570/−0
• Bio/Bam/Index.hs +384/−0
• Bio/Bam/Pileup.hs +475/−0
• Bio/Bam/Reader.hs +261/−0
• Bio/Bam/Rec.hs +378/−0
• Bio/Bam/Regions.hs +53/−0
• Bio/Bam/Rmdup.hs +691/−0
• Bio/Bam/Trim.hs +442/−0
• Bio/Bam/Writer.hs +247/−0
• Bio/Base.hs +339/−0
• Bio/Prelude.hs +65/−0
• Bio/Streaming.hs +195/−0
• Bio/Streaming/Bgzf.hs +331/−0
• Bio/Streaming/Bytes.hs +780/−0
• Bio/Streaming/Furrow.hs +45/−0
• Bio/Streaming/Parse.hs +140/−0
• Bio/Streaming/Vector.hs +35/−0
• Bio/TwoBit.hs +296/−0
• Bio/Util/MMap.hs +28/−0
• Bio/Util/Nub.hs +16/−0
• Bio/Util/Numeric.hs +213/−0
• Bio/Util/Storable.hs +97/−0
• Bio/Util/Text.hs +51/−0
• CHANGELOG.md +7/−0
• biohazard.cabal +29/−25
• cbits/loops.c +113/−0
• cbits/mmap.c +10/−0
• cbits/myers_align.c +102/−0
• cbits/myers_align.h +76/−0
• cbits/trim.c +46/−0
• cbits/zlib.c +64/−0
• src/Bio/Adna.hs +0/−661
• src/Bio/Align.hs +0/−85
• src/Bio/Bam.hs +0/−24
• src/Bio/Bam/Evan.hs +0/−97
• src/Bio/Bam/Fastq.hs +0/−113
• src/Bio/Bam/Filter.hs +0/−127
• src/Bio/Bam/Header.hs +0/−397
• src/Bio/Bam/Index.hs +0/−334
• src/Bio/Bam/Pileup.hs +0/−469
• src/Bio/Bam/Reader.hs +0/−295
• src/Bio/Bam/Rec.hs +0/−391
• src/Bio/Bam/Regions.hs +0/−45
• src/Bio/Bam/Rmdup.hs +0/−688
• src/Bio/Bam/Trim.hs +0/−441
• src/Bio/Bam/Writer.hs +0/−218
• src/Bio/Base.hs +0/−369
• src/Bio/Iteratee.hs +0/−318
• src/Bio/Iteratee/Base.hs +0/−242
• src/Bio/Iteratee/Bgzf.hsc +0/−491
• src/Bio/Iteratee/Builder.hs +0/−262
• src/Bio/Iteratee/Bytes.hs +0/−269
• src/Bio/Iteratee/Exception.hs +0/−212
• src/Bio/Iteratee/IO.hs +0/−91
• src/Bio/Iteratee/Iteratee.hs +0/−601
• src/Bio/Iteratee/List.hs +0/−810
• src/Bio/Iteratee/ZLib.hsc +0/−741
• src/Bio/Prelude.hs +0/−117
• src/Bio/TwoBit.hs +0/−296
• src/Bio/Util/MMap.hs +0/−26
• src/Bio/Util/Numeric.hs +0/−213
• src/Bio/Util/Storable.hs +0/−97
• src/Bio/Util/Zlib.hs +0/−23
• src/cbits/loops.c +0/−113
• src/cbits/mmap.c +0/−10
• src/cbits/myers_align.c +0/−102
• src/cbits/myers_align.h +0/−76
• src/cbits/trim.c +0/−46

@@ -0,0 +1,655 @@+-- | Things specific to ancient DNA, e.g. damage models.+--+-- For aDNA, we need a substitution probability.  We have three options:+-- use an empirically determined PSSM, use an arithmetically defined+-- PSSM based on the /Johnson/ model, use a context sensitive PSSM based+-- on the /Johnson/ model and an alignment.  Using /Dindel/, actual+-- substitutions relative to a called haplotype would be taken into+-- account.  Since we're not going to do that, taking alignments into+-- account is difficult, somewhat approximate, and therefore not worth+-- the hassle.++module Bio.Adna (+    DmgStats(..),+    CompositionStats,+    SubstitutionStats,+    addFragType,+    damagePatternsIter,+    damagePatternsIterMD,+    damagePatternsIter2Bit,+    alnFromMd,++    DamageParameters(..),+    NewDamageParameters(..),+    GenDamageParameters(..),+    DamageModel,+    bang, nudge,+    Alignment(..),+    FragType(..),+    Subst(..),++    NPair,+    npair,+    fst_np,+    snd_np,++    noDamage,+    univDamage,+    empDamage,+    Mat44D(..),+    MMat44D(..),+    scalarMat,+    complMat,+    freezeMats,++    bwa_cal_maxdiff+  ) where++import Bio.Bam+import Bio.Prelude+import Bio.TwoBit++import qualified Data.Vector                    as V+import qualified Data.Vector.Generic            as G+import qualified Data.Vector.Storable           as VS+import qualified Data.Vector.Unboxed            as U+import qualified Data.Vector.Unboxed.Mutable    as UM+import qualified Streaming.Prelude              as Q++-- | We represent substitution matrices by the type 'Mat44D'.  Internally,+-- this is a vector of packed vectors.  Conveniently, each of the packed+-- vectors represents all transitions /into/ the given nucleotide.++newtype Mat44D = Mat44D (U.Vector Double) deriving (Show, Generic)+newtype MMat44D = MMat44D (UM.IOVector Double)++-- | A 'DamageModel' is a function that gives substitution matrices for+-- each position in a read.  The 'DamageModel' can depend on whether the+-- alignment is reversed, the length of the read and the position.  (In+-- practice, we should probably memoize precomputed damage models+-- somehow.)++type DamageModel = Bool -> Int -> Int -> Mat44D+data Subst = Nucleotide :-> Nucleotide deriving (Eq, Ord, Ix, Show)++infix 9 :->+infix 8 `bang`++-- | Convenience function to access a substitution matrix that has a+-- mnemonic reading.+{-# INLINE bang #-}+bang :: Mat44D -> Subst -> Double+bang (Mat44D v) (N x :-> N y)+    | U.length v == 16 = v U.! (fromIntegral x + 4 * fromIntegral y)+    | otherwise = error $ "Huh? " ++ show (U.length v)++{-# INLINE nudge #-}+nudge :: MMat44D -> Subst -> Double -> IO ()+nudge (MMat44D v) (N x :-> N y) a = UM.read v i >>= UM.write v i . (+) a+  where i = fromIntegral x + 4 * fromIntegral y++scalarMat :: Double -> Mat44D+scalarMat s = Mat44D $ U.fromListN 16 [ s, 0, 0, 0+                                      , 0, s, 0, 0+                                      , 0, 0, s, 0+                                      , 0, 0, 0, s ]+complMat :: Mat44D -> Mat44D+complMat v = Mat44D $ U.fromListN 16 [ v `bang` compl x :-> compl y+                                     | y <- range (nucA, nucT)+                                     , x <- range (nucA, nucT) ]++-- | Adds the two matrices of a mutable substitution model (one for each+-- strand) appropriately, normalizes the result (to make probabilities+-- from pseudo-counts), and freezes that into one immutable matrix.  We+-- add a single count everywhere to avoid getting NaN from bizarre data.+freezeMats :: MMat44D -> MMat44D -> IO Mat44D+freezeMats (MMat44D vv) (MMat44D ww) = do+    v <-            Mat44D <$> U.freeze vv+    w <- complMat . Mat44D <$> U.freeze ww++    let sums = U.generate 4 $ \x0 ->+                    let x = N $ fromIntegral x0+                    in sum [ v `bang` x :-> z + w `bang` x :-> z+                           | z <- range (nucA, nucT) ] + 4++    return . Mat44D $ U.fromListN 16+            [ (v `bang` x :-> y + w `bang` x :-> y + 1) / s+            | y <- range (nucA, nucT)+            , x <- range (nucA, nucT)+            , let s = sums U.! fromIntegral (unN x) ]+++-- | 'DamageModel' for undamaged DNA.  The likelihoods follow directly+-- from the quality score.  This needs elaboration to see what to do+-- with amibiguity codes (even though those haven't actually been+-- observed in the wild).+noDamage :: DamageModel+noDamage _ _ _ = one where !one = scalarMat 1+++-- | Parameters for the universal damage model.+--+-- We assume the correct model is either no damage, or single strand+-- damage, or double strand damage.  Each of them comes with a+-- probability.  It turns out that blending them into one is simply+-- accomplished by multiplying these probabilities onto the deamination+-- probabilities.+--+-- For single stranded library prep, only one kind of damage occurs (C+-- frequency ('ssd_sigma') in single stranded parts, and the overhang+-- length is distributed exponentially with parameter 'ssd_lambda' at+-- the 5' end and 'ssd_kappa' at the 3' end.  (Without UDG treatment,+-- those will be equal.  With UDG, those are much smaller and in fact+-- don't literally represent overhangs.)+--+-- For double stranded library prep, we get C->T damage at the 5' end+-- and G->A at the 3' end with rate 'dsd_sigma' and both in the interior+-- with rate 'dsd_delta'.  Everything is symmetric, and therefore the+-- orientation of the aligned read doesn't matter either.  Both+-- overhangs follow a distribution with parameter 'dsd_lambda'.++data DamageParameters float = DP { ssd_sigma  :: !float         -- deamination rate in ss DNA, SS model+                                 , ssd_delta  :: !float         -- deamination rate in ds DNA, SS model+                                 , ssd_lambda :: !float         -- param for geom. distribution, 5' end, SS model+                                 , ssd_kappa  :: !float         -- param for geom. distribution, 3' end, SS model+                                 , dsd_sigma  :: !float         -- deamination rate in ss DNA, DS model+                                 , dsd_delta  :: !float         -- deamination rate in ds DNA, DS model+                                 , dsd_lambda :: !float }       -- param for geom. distribution, DS model+  deriving (Read, Show, Generic)++data NewDamageParameters vec float = NDP { dp_gc_frac :: !float+                                         , dp_mu      :: !float+                                         , dp_nu      :: !float+                                         , dp_alpha5  :: !(vec float)+                                         , dp_beta5   :: !(vec float)+                                         , dp_alpha   :: !float+                                         , dp_beta    :: !float+                                         , dp_alpha3  :: !(vec float)+                                         , dp_beta3   :: !(vec float) }+  deriving (Read, Show, Generic)++data GenDamageParameters vec float+    = UnknownDamage+    | OldDamage (DamageParameters float)+    | NewDamage (NewDamageParameters vec float)+  deriving (Show, Generic, Read)++++-- | Generic substitution matrix, has C->T and G->A deamination as+-- parameters.  Setting 'p' or 'q' to 0 as appropriate makes this apply+-- to the single stranded or undamaged case.++{-# INLINE genSubstMat #-}+genSubstMat :: Double -> Double -> Mat44D+genSubstMat p q = Mat44D $ U.fromListN 16 [ 1,  0,   q,  0+                                          , 0, 1-p,  0,  0+                                          , 0,  0,  1-q, 0+                                          , 0,  p,   0,  1 ]++univDamage :: DamageParameters Double -> DamageModel+univDamage DP{..} r l i = genSubstMat (p1+p2) (q1+q2)+    where+        (p1, q1) = if r then let lam5 = ssd_lambda ^ (l-i)+                                 lam3 = ssd_kappa ^ (1+i)+                                 lam  = lam3 + lam5 - lam3 * lam5+                                 p    = ssd_sigma * lam + ssd_delta * (1-lam)+                             in (0,p)+                        else let lam5 = ssd_lambda ^ (1+i)+                                 lam3 = ssd_kappa ^ (l-i)+                                 lam  = lam3 + lam5 - lam3 * lam5+                                 p    = ssd_sigma * lam + ssd_delta * (1-lam)+                             in (p,0)++        p2      = dsd_sigma * lam5_ds + dsd_delta * (1-lam5_ds)+        q2      = dsd_sigma * lam3_ds + dsd_delta * (1-lam3_ds)+        lam5_ds = dsd_lambda ^ (1+i)+        lam3_ds = dsd_lambda ^ (l-i)++empDamage :: NewDamageParameters U.Vector Double -> DamageModel+empDamage NDP{..} =+    \r l i -> if i+i < l then+                if r then fromMaybe middleRev (rev5 V.!? i)+                     else fromMaybe middle    (fwd5 V.!? i)+              else+                if r then fromMaybe middleRev (rev3 V.!? (l-i-1))+                     else fromMaybe middle    (fwd3 V.!? (l-i-1))+  where+    !middle    = genSubstMat' dp_alpha dp_beta+    !middleRev = genSubstMat' dp_beta dp_alpha++    !fwd5 = V.zipWith genSubstMat' (G.convert dp_alpha5) (G.convert dp_beta5)+    !fwd3 = V.zipWith genSubstMat' (G.convert dp_alpha3) (G.convert dp_beta3)++    !rev5 = V.zipWith genSubstMat' (G.convert dp_beta5) (G.convert dp_alpha5)+    !rev3 = V.zipWith genSubstMat' (G.convert dp_beta3) (G.convert dp_alpha3)++    genSubstMat' a b = genSubstMat (recip $ 1 + exp (-a)) (recip $ 1 + exp (-b))+++-- | Collected \"traditional\" statistics:+--+-- * Base composition near 5' end and near 3' end.  Each consists of+--   five vectors of counts of A,C,G,T, and everything else.+--   'basecompo5' begins with 'context' bases to the left of the 5' end,+--   'basecompo3' ends with 'context' bases to the right of the 3' end.+--+-- * Substitutions.  Counted from the reconstructed alignment, once+--   around the 5' end and once around the 3' end.  For a total of 2*4*4+--   different substitutions.  Positions where the query has a gap are+--   skipped.+--+-- * Substitutions at CpG motifs.  Also counted from the reconstructed+--   alignment, and a CpG site is simply the sequence CG in the+--   reference.  Gaps may confuse that definition, so that CpHpG still+--   counts as CpG, because the H is gapped.  That might actually+--   be desirable.+--+-- * Conditional substitutions.  The 5' and 3' ends count as damaged if+--   the very last position has a C-to-T substitution.  With that in+--   mind, 'substs5d5', 'substs5d3', 'substs5dd' are like 'substs5', but+--   counting only reads where the 5' end is damaged, where the 3' end+--   is damaged, and where both ends are damaged, respectively.++data DmgStats = DmgStats {+    basecompo5 :: CompositionStats,+    basecompo3 :: CompositionStats,+    substs5    :: SubstitutionStats,+    substs3    :: SubstitutionStats,+    substs5d5  :: SubstitutionStats,+    substs3d5  :: SubstitutionStats,+    substs5d3  :: SubstitutionStats,+    substs3d3  :: SubstitutionStats,+    substs5dd  :: SubstitutionStats,+    substs3dd  :: SubstitutionStats,+    substs5cpg :: SubstitutionStats,+    substs3cpg :: SubstitutionStats }+  deriving Show++type CompositionStats  = [( Maybe Nucleotide, U.Vector Int )]+type SubstitutionStats = [( Subst, U.Vector Int )]+++data FragType = Complete | Leading | Trailing deriving (Show, Eq)++-- | Compact storage of a pair of ambiguous 'Nucleotides'.  Used to+-- represent alignments in a way that is accessible even to assembly+-- code.  The first and sencond field are stored in the low and high+-- nybble, respectively.  See 'fst_np', 'snd_np', 'npair'.+newtype NPair = NPair Word8 deriving (Eq, Ord)++npair :: Nucleotides -> Nucleotides -> NPair+npair (Ns r) (Ns q) = NPair $ shiftL q 4 .|. r .&. 0xF++fst_np, snd_np :: NPair -> Nucleotides+fst_np (NPair w) = Ns (w .&. 0xF)+snd_np (NPair w) = Ns (shiftR w 4)++instance Storable NPair where+    sizeOf    _ = 1+    alignment _ = 1+    peek p = NPair <$> peek (castPtr p :: Ptr Word8)+    poke p (NPair v) = poke (castPtr p :: Ptr Word8) v++instance Show NPair where+    showsPrec _ p = shows (fst_np p) . (:) '/' . shows (snd_np p)++-- | Alignment record.  The reference sequence is filled with Ns if+-- missing.+data Alignment = ALN+    { a_sequence :: !(VS.Vector NPair)      -- the alignment proper+    , a_fragment_type :: !FragType }        -- was the adapter trimmed?++addFragType :: Monad m => BamMeta -> Stream (Of BamRaw) m b -> Stream (Of (BamRaw,FragType)) m b+addFragType meta = Q.map $ \br -> (br, case unpackBam br of+    b | isFirstMate  b && isPaired     b -> Leading+      | isSecondMate b && isPaired     b -> Trailing+      | not sane                         -> Complete     -- leeHom fscked it up+      | isFirstMate  b || isSecondMate b -> Complete     -- old style flagging+      | isTrimmed    b || isMerged     b -> Complete     -- new style flagging+      | otherwise                        -> Leading)+  where+    sane = null [ () | ("PG",line) <- meta_other_shit meta+                     , ("PN","mergeTrimReadsBAM") <- line ]++-- | Stream transformer that computes some statistics from plain BAM+-- (no MD field needed) and a 2bit file.  The 'Alignment' is also+-- reconstructed and passed downstream.  The final value of the source+-- stream ends up in the 'stats_more' field of the result.+--+-- * Get the reference sequence including both contexts once.  If this+--   includes invalid sequence (negative coordinate), pad suitably.+-- * Accumulate counts for the valid parts around 5' and 3' ends as+--   appropriate from flags and config.+-- * Combine the part that was aligned to (so no context) with the read+--   to reconstruct the alignment.+--+-- Arguments are the table of reference names, the 2bit file with the+-- reference, the amount of context outside the alignment desired, and+-- the amount of context inside desired.+--+-- For 'Complete' fragments, we cut the read in the middle, so the 5'+-- and 3' plots stay clean from each other's influence.  'Leading' and+-- 'Trailing' fragments count completely towards the appropriate end.++damagePatternsIter2Bit :: MonadIO m+                       => Refs -> TwoBitFile -> Int -> Int+                       -> Stream (Of (BamRaw,FragType)) m x+                       -> Stream (Of Alignment) m DmgStats+damagePatternsIter2Bit refs tbf ctx rng =+    damagePatternsIter ctx rng .+    Q.mapMaybe (\(br,ft) -> do+        let b@BamRec{..} = unpackBam br+        guard (not $ isUnmapped b)+        let ref_nm = sq_name $ getRef refs b_rname+            ref    = getFragment tbf ref_nm (b_pos - ctx) (alignedLength b_cigar + 2*ctx)+            pps    = aln_from_ref (U.drop ctx ref) b_seq b_cigar+        return (b, ft, ref, pps))++-- | Stream transformer that computes some statistics from plain BAM+-- with a valid MD field.  The 'Alignment' is also reconstructed and+-- passed downstream.  The final value of the source stream becomes+-- the 'stats_more' field of the result.+--+-- * Reconstruct the alignment from CIGAR, SEQ, and MD.+-- * Filter the alignment to get the reference sequence, accumulate it.+-- * Accumulate everything over the alignment.+--+-- The argument is the amount of context inside desired.+--+-- For 'Complete' fragments, we cut the read in the middle, so the 5'+-- and 3' plots stay clean from each other's influence.  'Leading' and+-- 'Trailing' fragments count completely towards the appropriate end.++damagePatternsIterMD :: MonadIO m+                     => Int+                     -> Stream (Of (BamRaw,FragType)) m x+                     -> Stream (Of Alignment) m DmgStats+damagePatternsIterMD rng =+    damagePatternsIter 0 rng .+    Q.mapMaybe (\(br,ft) -> do+        let b@BamRec{..} = unpackBam br+        guard (not $ isUnmapped b)+        md <- getMd b+        let pps = alnFromMd b_seq b_cigar md+            ref = U.convert $ VS.map fromN $ VS.filter ((/=) gap) $ VS.map fst_np pps+        return (b, ft, ref, pps))+  where+    fromN ns | ns == nucsA = 2+             | ns == nucsC = 1+             | ns == nucsG = 3+             | ns == nucsT = 0+             | otherwise   = 4++-- | Common logic for statistics. The function 'get_ref_and_aln'+-- reconstructs reference sequence and alignment from a Bam record.  It+-- is expected to construct the alignment with respect to the forwards+-- strand of the reference; we reverse-complement it if necessary.+damagePatternsIter :: MonadIO m+                   => Int -> Int+                   -> Stream (Of (BamRec, FragType, U.Vector Word8, VS.Vector NPair)) m x+                   -> Stream (Of Alignment) m DmgStats+damagePatternsIter ctx rng stream = do+    let maxwidth = ctx + rng+    acc_bc <- liftIO $ UM.replicate (2 * 5 *    maxwidth) (0::Int)+    acc_st <- liftIO $ UM.replicate (2 * 4 * 4 * 4 * rng) (0::Int)+    acc_cg <- liftIO $ UM.replicate (2 * 2 * 4 *     rng) (0::Int)++    void $ flip Q.mapM (Q.map revcom_both stream) $+             \(BamRec{..}, a_fragment_type, ref, a_sequence) -> liftIO $ do+                  -- basecompositon near 5' end, near 3' end+                  let (width5, width3) = case a_fragment_type of+                                                Leading -> (full_width, 0)+                                                Trailing -> (0, full_width)+                                                Complete -> (half_width, half_width)+                            where full_width = min (U.length ref) $ ctx + min rng (alignedLength b_cigar)+                                  half_width = min (U.length ref) $ ctx + min rng (alignedLength b_cigar `div` 2)+                  mapM_ (\i -> bump (fromIntegral (ref U.!  i                   ) * maxwidth + i) acc_bc) [0 .. width5-1]+                  mapM_ (\i -> bump (fromIntegral (ref U.! (i + U.length ref) +6) * maxwidth + i) acc_bc) [-width3 .. -1]++                  -- For substitutions, decide what damage class we're in:+                  -- 0 - no damage, 1 - damaged 5' end, 2 - damaged 3' end, 3 - both+                  let dmgbase = 2*4*4*rng *+                                ((if VS.null a_sequence || VS.head a_sequence /= npair nucsC nucsT then 1 else 0)+                                +(if VS.null a_sequence || VS.last a_sequence /= npair nucsC nucsT then 2 else 0))++                  -- substitutions near 5' end+                  let len_at_5 = case a_fragment_type of Leading  -> min rng (G.length b_seq)+                                                         Complete -> min rng (G.length b_seq `div` 2)+                                                         Trailing -> 0+                  flip G.imapM_ (VS.take len_at_5 a_sequence) $+                        \i uv -> withPair uv $ \j -> bump (j * rng + i + dmgbase) acc_st++                  -- substitutions at CpG sites near 5' end+                  G.izipWithM_+                      (\i uv wz ->+                          when (fst_np uv == nucsC && fst_np wz == nucsG) $ do+                              withNs (snd_np uv) $ \y -> bump (  y   * rng +  i ) acc_cg+                              withNs (snd_np wz) $ \y -> bump ((y+4) * rng + i+1) acc_cg)+                      (VS.take len_at_5 a_sequence) (VS.drop 1 a_sequence)++                  -- substitutions near 3' end+                  let len_at_3 = case a_fragment_type of Leading  -> 0+                                                         Complete -> min rng (G.length b_seq `div` 2)+                                                         Trailing -> min rng (G.length b_seq)+                  flip G.imapM_ (VS.take len_at_3 (VS.reverse a_sequence)) $+                        \i uv -> withPair uv $ \j -> bump ((17+j) * rng -i -1 + dmgbase) acc_st++                  -- substitutions at CpG sites near 3' end+                  G.izipWithM_+                      (\i wz uv ->+                          when (fst_np uv == nucsC && fst_np wz == nucsG) $ do+                              withNs (snd_np uv) $ \y -> bump ((y+ 9) * rng - i-2) acc_cg+                              withNs (snd_np wz) $ \y -> bump ((y+13) * rng - i-1) acc_cg)+                      (VS.take len_at_3 (VS.reverse a_sequence))+                      (VS.drop 1 (VS.reverse a_sequence))++                  return ALN{..}+++    let nsubsts = 4*4*rng+        mk_substs off = sequence [ (,) (n1 :-> n2) <$> U.unsafeFreeze (UM.slice ((4*i+j)*rng + off*nsubsts) rng acc_st)+                                 | (i,n1) <- zip [0..] [nucA..nucT]+                                 , (j,n2) <- zip [0..] [nucA..nucT] ]++    accs <- liftIO $ DmgStats <$> sequence [ (,) nuc <$> U.unsafeFreeze (UM.slice (i*maxwidth) maxwidth acc_bc)+                                           | (i,nuc) <- zip [2,1,3,0,4] [Just nucA,Just nucC,Just nucG,Just nucT,Nothing] ]+                              <*> sequence [ (,) nuc <$> U.unsafeFreeze (UM.slice (i*maxwidth) maxwidth acc_bc)+                                           | (i,nuc) <- zip [7,6,8,5,9] [Just nucA,Just nucC,Just nucG,Just nucT,Nothing] ]++                              <*> mk_substs 0+                              <*> mk_substs 1+                              <*> mk_substs 2+                              <*> mk_substs 3+                              <*> mk_substs 4+                              <*> mk_substs 5+                              <*> mk_substs 6+                              <*> mk_substs 7++                              <*> sequence [ (,) (n1 :-> n2) <$> U.unsafeFreeze (UM.slice ((i+j)*rng) rng acc_cg)+                                           | (i,n1) <- [(0,nucC), (4,nucG)]+                                           , (j,n2) <- zip [0..] [nucA..nucT] ]++                              <*> sequence [ (,) (n1 :-> n2) <$> U.unsafeFreeze (UM.slice ((i+j)*rng) rng acc_cg)+                                           | (i,n2) <- [(8,nucC), (12,nucG)]+                                           , (j,n1) <- zip [0..] [nucA..nucT] ]++    return $ accs { substs5   = mconcat [ substs5 accs, substs5d5 accs, substs5d3 accs, substs5dd accs ]+                  , substs3   = mconcat [ substs3 accs, substs3d5 accs, substs3d3 accs, substs3dd accs ]+                  , substs5d5 = mconcat [ substs5d5 accs, substs5dd accs]+                  , substs3d5 = mconcat [ substs3d5 accs, substs3dd accs]+                  , substs5d3 = mconcat [ substs5d3 accs, substs5dd accs]+                  , substs3d3 = mconcat [ substs3d3 accs, substs3dd accs] }+  where+    {-# INLINE withPair #-}+    withPair (NPair i) k =+        case pairTab `U.unsafeIndex` fromIntegral i of+            j -> when (j >= 0) (k j)++    !pairTab = U.replicate 256 (-1) U.//+            [ (fromIntegral i, x*4+y) | (u,x) <- zip [nucsA, nucsC, nucsG, nucsT] [0,1,2,3]+                                      , (v,y) <- zip [nucsA, nucsC, nucsG, nucsT] [0,1,2,3]+                                      , let NPair i = npair u v ]+    {-# INLINE bump #-}+    bump i v = UM.unsafeRead v i >>= UM.unsafeWrite v i . succ++    {-# INLINE withNs #-}+    withNs ns k | ns == nucsA = k 0+                | ns == nucsC = k 1+                | ns == nucsG = k 2+                | ns == nucsT = k 3+                | otherwise   = return ()+++instance Monoid DmgStats where+    mappend = (<>)+    mempty = DmgStats { basecompo5 = empty_compo+                      , basecompo3 = empty_compo+                      , substs5    = empty_subst+                      , substs3    = empty_subst+                      , substs5d5  = empty_subst+                      , substs3d5  = empty_subst+                      , substs5d3  = empty_subst+                      , substs3d3  = empty_subst+                      , substs5dd  = empty_subst+                      , substs3dd  = empty_subst+                      , substs5cpg = empty_subst+                      , substs3cpg = empty_subst }+      where+        empty_compo = [ (nuc, U.empty) | nuc <- [Just nucA, Just nucC, Just nucG, Just nucT, Nothing] ]+        empty_subst = [ (n1 :-> n2, U.empty) | n1 <- [nucA..nucT], n2 <- [nucA..nucT] ]++instance Semigroup DmgStats where+    (<>) = merge_dmg_stats++merge_dmg_stats :: DmgStats -> DmgStats -> DmgStats+merge_dmg_stats a b =+    DmgStats { basecompo5 = zipWith s1 (basecompo5 a) (basecompo5 b)+             , basecompo3 = zipWith s1 (basecompo3 a) (basecompo3 b)+             , substs5    = zipWith s2 (substs5    a) (substs5    b)+             , substs3    = zipWith s2 (substs3    a) (substs3    b)+             , substs5d5  = zipWith s2 (substs5d5  a) (substs5d5  b)+             , substs3d5  = zipWith s2 (substs3d5  a) (substs3d5  b)+             , substs5d3  = zipWith s2 (substs5d3  a) (substs5d3  b)+             , substs3d3  = zipWith s2 (substs3d3  a) (substs3d3  b)+             , substs5dd  = zipWith s2 (substs5dd  a) (substs5dd  b)+             , substs3dd  = zipWith s2 (substs3dd  a) (substs3dd  b)+             , substs5cpg = zipWith s2 (substs5cpg a) (substs5cpg b)+             , substs3cpg = zipWith s2 (substs3cpg a) (substs3cpg b) }+      where+        s1 (x, u) (z, v) | x /= z    = error "Mismatch in zip.  This is a bug."+                         | U.null u  = (x, v)+                         | U.null v  = (x, u)+                         | otherwise = (x, U.zipWith (+) u v)++        s2 (x :-> y, u) (z :-> w, v) | x /= z || y /= w = error "Mismatch in zip.  This is a bug."+                                     | U.null u         = (x :-> y, v)+                                     | U.null v         = (x :-> y, u)+                                     | otherwise        = (x :-> y, U.zipWith (+) u v)+++revcom_both :: ( BamRec, FragType, U.Vector Word8, VS.Vector NPair )+            -> ( BamRec, FragType, U.Vector Word8, VS.Vector NPair )+revcom_both (b, ft, ref, pps)+    | isReversed b = ( b, ft, revcom_ref ref, revcom_pairs pps )+    | otherwise    = ( b, ft,            ref,              pps )+  where+    revcom_ref   =  U.reverse .  U.map (\c -> if c > 3 then c else xor c 2)+    revcom_pairs = VS.reverse . VS.map (\p -> npair (compls $ fst_np p) (compls $ snd_np p))+++-- | Reconstructs the alignment from reference, query, and cigar.  Only+-- positions where the query is not gapped are produced.+aln_from_ref :: U.Vector Word8 -> Vector_Nucs_half Nucleotides -> VS.Vector Cigar -> VS.Vector NPair+aln_from_ref ref0 qry0 cig0 = VS.fromList $ step ref0 qry0 cig0+  where+    step ref qry cig1+        | U.null ref || G.null qry || G.null cig1 = []+        | otherwise = case G.unsafeHead cig1 of { op :* n ->+                      case G.unsafeTail cig1 of { cig ->+                      case op of {++        Mat -> zipWith (npair . nn) (G.toList (G.take n ref))+                                    (G.toList (G.take n qry)) ++ step (G.drop n ref) (G.drop n qry) cig ;+        Del ->                                                   step (G.drop n ref)           qry  cig ;+        Ins -> map (npair gap) (G.toList (G.take n qry))      ++ step           ref  (G.drop n qry) cig ;+        SMa -> map (npair gap) (G.toList (G.take n qry))      ++ step           ref  (G.drop n qry) cig ;+        HMa -> replicate n (npair gap nucsN)                  ++ step           ref            qry  cig ;+        Nop ->                                                   step           ref            qry  cig ;+        Pad ->                                                   step           ref            qry  cig }}}++    nn 0 = nucsT+    nn 1 = nucsC+    nn 2 = nucsA+    nn 3 = nucsG+    nn _ = nucsN+++-- | Reconstructs the alignment from query, cigar, and md.  Only+-- positions where the query is not gapped are produced.+alnFromMd :: Vector_Nucs_half Nucleotides -> VS.Vector Cigar -> [MdOp] -> VS.Vector NPair+alnFromMd qry0 cig0 md0 = VS.fromList $ step qry0 cig0 md0+  where+    step qry cig1 md+        | G.null qry || G.null cig1 || null md = []+        | otherwise = case G.unsafeHead cig1 of op :* n -> step' qry op n (G.unsafeTail cig1) md++    step' qry  _ 0 cig             md  = step  qry      cig md+    step' qry op n cig (MdNum  0 : md) = step' qry op n cig md+    step' qry op n cig (MdDel [] : md) = step' qry op n cig md++    step' qry Mat n cig (MdNum m : md)+            | n <  m =    map twin (G.toList (G.take n qry)) ++ step  (G.drop n qry)           cig (MdNum (m-n) : md)+            | n >  m =    map twin (G.toList (G.take m qry)) ++ step' (G.drop m qry) Mat (n-m) cig                md+            | n == m =    map twin (G.toList (G.take n qry)) ++ step  (G.drop n qry)           cig                md+    step' qry Mat n cig (MdRep c : md) = npair c (G.head qry) : step' (G.tail   qry) Mat (n-1) cig                md+    step'   _ Mat _   _          _     = []++    step' qry Del n cig (MdDel (_:ss) : md) = step' qry Del (n-1) cig (MdDel ss : md)+    step'   _ Del _   _               _     = []++    step' qry Ins n cig                 md  = map (npair gap) (G.toList (G.take n qry)) ++ step (G.drop n qry) cig md+    step' qry SMa n cig                 md  = map (npair gap) (G.toList (G.take n qry)) ++ step (G.drop n qry) cig md+    step' qry HMa n cig                 md  =             replicate n (npair gap nucsN) ++ step           qry  cig md+    step' qry Nop _ cig                 md  =                                              step           qry  cig md+    step' qry Pad _ cig                 md  =                                              step           qry  cig md++    twin q = npair q q++-- | Number of mismatches allowed by BWA.+-- @bwa_cal_maxdiff thresh len@ returns the number of mismatches+-- @bwa aln -n $tresh@ would allow in a read of length @len@.  For+-- reference, here is the code from BWA that computes it (we assume @err+-- = 0.02@, just like BWA):+--+-- @+-- int bwa_cal_maxdiff(int l, double err, double thres)+--   {+--      double elambda = exp(-l * err);+--      double sum, y = 1.0;+--      int k, x = 1;+--      for (k = 1, sum = elambda; k < 1000; ++k) {+--          y *= l * err;+--          x *= k;+--          sum += elambda * y / x;+--          if (1.0 - sum < thres) return k;+--      }+--      return 2;+--   }+-- @++bwa_cal_maxdiff :: Double -> Int -> Int+bwa_cal_maxdiff thresh len = k_fin-1+  where+    (k_fin, _, _, _) = head $ dropWhile bad $ iterate step (1,elambda,1,1)++    err = 0.02+    elambda = exp . negate $ fromIntegral len * err++    step (k, s, x, y) = (k+1, s', x', y')+      where y' = y * fromIntegral len * err+            x' = x * fromIntegral k+            s' = s + elambda * y' / x'++    bad (_, s, _, _) = 1-s >= thresh+

@@ -0,0 +1,85 @@+module Bio.Align (+    Mode(..),+    myersAlign,+    showAligned+                 ) where++import Bio.Prelude       hiding ( lefts, rights )+import Foreign.C.String         ( CString )+import Foreign.C.Types          ( CInt(..) )+import Foreign.Marshal.Alloc    ( allocaBytes )++import qualified Data.ByteString.Char8      as S+import qualified Data.ByteString.Unsafe     as S+import qualified Data.ByteString.Lazy.Char8 as L++foreign import ccall unsafe "myers_align.h myers_diff" myers_diff ::+        CString -> CInt ->              -- sequence A and length A+        CInt ->                         -- mode (an enum)+        CString -> CInt ->              -- sequence B and length B+        CInt ->                         -- max distance+        CString ->                      -- backtracing space A+        CString ->                      -- backtracing space B+        IO CInt                         -- returns distance++-- | Mode argument for 'myersAlign', determines where free gaps are+-- allowed.+data Mode = Globally  -- ^ align globally, without gaps at either end+          | HasPrefix -- ^ align so that the second sequence is a prefix of the first+          | IsPrefix  -- ^ align so that the first sequence is a prefix of the second+    deriving Enum++-- | Align two strings.  @myersAlign maxd seqA mode seqB@ tries to align+-- @seqA@ to @seqB@, which will work as long as no more than @maxd@ gaps+-- or mismatches are incurred.  The @mode@ argument determines if either+-- of the sequences is allowed to have an overhanging tail.+--+-- The result is the triple of the actual distance (gaps + mismatches)+-- and the two padded sequences.  These sequences are the original+-- sequences with dashes inserted for gaps.+--+-- The algorithm is the O(nd) algorithm by Myers, implemented in C.  A+-- gap and a mismatch score the same.  The strings are supposed to code+-- for DNA, the code understands IUPAC-IUB ambiguity codes.  Two+-- characters match iff there is at least one nucleotide both can code+-- for.  Note that N is a wildcard, while X matches nothing.++myersAlign :: Int -> Bytes -> Mode -> Bytes -> (Int, Bytes, Bytes)+myersAlign maxd seqA mode seqB =+    unsafePerformIO                                 $+    S.unsafeUseAsCStringLen seqA                    $ \(seq_a, len_a) ->+    S.unsafeUseAsCStringLen seqB                    $ \(seq_b, len_b) ->++    -- size of output buffers derives from this:+    -- char *out_a = bt_a + len_a + maxd +2 ;+    -- char *out_b = bt_b + len_b + maxd +2 ;+    allocaBytes (len_a + maxd + 2)                  $ \bt_a ->+    allocaBytes (len_b + maxd + 2)                  $ \bt_b ->++    myers_diff seq_a (fromIntegral len_a)+               (fromIntegral $ fromEnum mode)+               seq_b (fromIntegral len_b)+               (fromIntegral maxd) bt_a bt_b      >>= \dist ->+    if dist < 0+      then return (maxBound, S.empty, S.empty)+      else (,,) (fromIntegral dist) <$>+           S.packCString bt_a <*>+           S.packCString bt_b+++-- | Nicely print an alignment.  An alignment is simply a list of+-- strings with inserted gaps to make them align.  We split them into+-- manageable chunks, stack them vertically and add a line showing+-- asterisks in every column where all aligned strings agree.  The+-- result is /almost/ the Clustal format.+showAligned :: Int -> [Bytes] -> [L.ByteString]+showAligned w ss | all S.null ss = []+                 | otherwise = map (L.fromChunks . (:[])) lefts +++                               L.pack agreement :+                               L.empty :+                               showAligned w rights+  where+    (lefts, rights) = unzip $ map (S.splitAt w) ss+    agreement = map star $ S.transpose lefts+    star str = if S.null str || S.all (== S.head str) str then '*' else ' '+

@@ -0,0 +1,24 @@+-- | Umbrella module for most of what's under 'Bio.Bam'.++module Bio.Bam (+    module Bio.Bam.Fastq,+    module Bio.Bam.Filter,+    module Bio.Bam.Header,+    module Bio.Bam.Index,+    module Bio.Bam.Reader,+    module Bio.Bam.Rec,+    module Bio.Bam.Trim,+    module Bio.Bam.Writer,+    module Bio.Streaming+               ) where++import Bio.Bam.Fastq+import Bio.Bam.Filter+import Bio.Bam.Header+import Bio.Bam.Index+import Bio.Bam.Reader+import Bio.Bam.Rec+import Bio.Bam.Trim+import Bio.Bam.Writer+import Bio.Streaming+

@@ -0,0 +1,100 @@+-- | This module contains stuff relating to conventions local to MPI+-- EVAN.  The code is needed regularly, but it can be harmful when+-- applied to BAM files that follow different conventions.  Most+-- importantly, no program should call these functions by default.++module Bio.Bam.Evan+    ( fixupFlagAbuse+    , fixupBwaFlags+    , removeWarts+    ) where++import Bio.Bam.Header+import Bio.Bam.Rec+import Bio.Prelude++import qualified Data.ByteString.Char8 as S++-- | Fixes abuse of flags valued 0x800 and 0x1000.  We used them for+-- low quality and low complexity, but they have since been redefined.+-- If set, we clear them and store them into the ZQ field.  Also fixes+-- abuse of the combination of the paired, 1st mate and 2nd mate flags+-- used to indicate merging or trimming.  These are canonicalized and+-- stored into the FF field.  This function is unsafe on BAM files of+-- unclear origin!+fixupFlagAbuse :: BamRec -> BamRec+fixupFlagAbuse b =+    (if b_flag b .&. flag_low_quality /= 0 then setQualFlag 'Q' else id) $          -- low qual, new convention+    (if b_flag b .&. flag_low_complexity /= 0 then setQualFlag 'C' else id) $       -- low complexity, new convention+    b { b_flag = cleaned_flags, b_exts = cleaned_exts }+  where+        -- removes old flag abuse+        flags' = b_flag b .&. complement (flag_low_quality .|. flag_low_complexity)+        cleaned_flags | flags' .&. flagPaired == 0 = flags' .&. complement (flagFirstMate .|. flagSecondMate)+                      | otherwise                  = flags'++        flag_low_quality    =  0x800+        flag_low_complexity = 0x1000++        -- merged & trimmed from old flag abuse+        is_merged  = flags' .&. (flagPaired .|. flagFirstMate .|. flagSecondMate) == flagFirstMate .|. flagSecondMate+        is_trimmed = flags' .&. (flagPaired .|. flagFirstMate .|. flagSecondMate) == flagSecondMate+        newflags = (if is_merged then eflagMerged else 0) .|. (if is_trimmed then eflagTrimmed else 0)++        -- Extended flags, renamed to avoid collision with BWA.  Goes like this:  if FF is there, use+        -- it.  Else check if XF is there __and is numeric__.  If so, use it, remove it, and set FF+        -- instead.  Else use 0 and leave it alone.  Note that this resolves the collision with BWA,+        -- since BWA puts a character there, not an int.+        cleaned_exts = case (lookup "FF" (b_exts b), lookup "XF" (b_exts b)) of+                ( Just (Int i), _ ) -> updateE "FF" (Int (i .|. newflags))                (b_exts b)+                ( _, Just (Int i) ) -> updateE "FF" (Int (i .|. newflags)) $ deleteE "XF" (b_exts b)+                _ | newflags /= 0   -> updateE "FF" (Int        newflags )                (b_exts b)+                  | otherwise       ->                                                     b_exts b+++-- | Fixes typical inconsistencies produced by Bwa: sometimes, 'mate unmapped' should be set, and we+-- can see it, because we match the mate's coordinates.  Sometimes 'properly paired' should not be+-- set, because one mate is unmapped.  This function is generally safe, but needs to be called only+-- on the output of affected (older?) versions of Bwa.+fixupBwaFlags :: BamRec -> BamRec+fixupBwaFlags b = b { b_flag = fixPP $ b_flag b .|. if mu then flagMateUnmapped else 0 }+  where+        -- Set "mate unmapped" if self coordinates and mate coordinates are equal, but self is+        -- paired and mapped.  (BWA forgets this flag for invalid mate alignments)+        mu = and [ isPaired b, not (isUnmapped b)+                 , isReversed b == isMateReversed b+                 , b_rname b == b_mrnm b, b_pos b == b_mpos b ]++        -- If either mate is unmapped, remove "properly paired".+        fixPP f | f .&. (flagUnmapped .|. flagMateUnmapped) == 0 = f+                | otherwise = f .&. complement flagProperlyPaired+++-- | Removes syntactic warts from old read names or the read names used+-- in FastQ files.+removeWarts :: BamRec -> BamRec+removeWarts br = br { b_qname = name, b_flag = flags, b_exts = tags }+  where+    (name, flags, tags) = checkFR $ checkC $ checkSharp (b_qname br, b_flag br, b_exts br)++    checkFR (n,f,t) | "F_" `S.isPrefixOf` n = checkC (S.drop 2 n, f .|. flagFirstMate  .|. flagPaired, t)+                    | "R_" `S.isPrefixOf` n = checkC (S.drop 2 n, f .|. flagSecondMate .|. flagPaired, t)+                    | "M_" `S.isPrefixOf` n = checkC (S.drop 2 n, f,   insertE "FF" (Int  eflagMerged) t)+                    | "T_" `S.isPrefixOf` n = checkC (S.drop 2 n, f,   insertE "FF" (Int eflagTrimmed) t)+                    | "/1" `S.isSuffixOf` n =        ( rdrop 2 n, f .|. flagFirstMate  .|. flagPaired, t)+                    | "/2" `S.isSuffixOf` n =        ( rdrop 2 n, f .|. flagSecondMate .|. flagPaired, t)+                    | otherwise             =        (         n, f,                                   t)++    checkC (n,f,t) | "C_" `S.isPrefixOf` n  = (S.drop 2 n, f, insertE "XP" (Int (-1)) t)+                   | otherwise              = (         n, f,                         t)++    rdrop n s = S.take (S.length s - n) s++    checkSharp (n,f,t) = case S.split '#' n of [n',ts] -> (n', f, insertTags ts t)+                                               _       -> ( n, f,               t)++    insertTags ts t | S.null y  = insertE "XI" (Text ts) t+                    | otherwise = insertE "XI" (Text  x) $ insertE "XJ" (Text $ S.tail y) t+        where (x,y) = S.break (== ',') ts++

@@ -0,0 +1,121 @@+-- | Parser for @FastA/FastQ@, 'ByteStream' style, based on+-- "Data.Attoparsec", and written such that it is compatible with module+-- "Bio.Bam".  This gives import of @FastA/FastQ@ while respecting some+-- local (to MPI EVAN) conventions.++module Bio.Bam.Fastq ( parseFastq, parseFastqWith, parseFastqCassava ) where++import Bio.Bam.Header+import Bio.Bam.Rec+import Bio.Prelude hiding ( isSpace )+import Bio.Streaming+import Bio.Streaming.Parse ( parse, atto )+import Data.Attoparsec.ByteString.Char8+        ( char, skipSpace, satisfy, inClass, skipWhile, takeTill+        , scan, isSpace, isSpace_w8, (<?>) )++import qualified Data.Attoparsec.ByteString.Char8   as P+import qualified Data.ByteString                    as B+import qualified Data.ByteString.Char8              as C+import qualified Data.Vector.Generic                as V+import qualified Streaming.Prelude                  as Q+import qualified Bio.Streaming.Bytes                as S++-- | Reader for DNA (not protein) sequences in FastA and FastQ.  We read+-- everything vaguely looking like FastA or FastQ, then shoehorn it into+-- a BAM record.  We strive to extract information following more or+-- less established conventions from the header, but don't aim for+-- completeness.  The recognized syntactical warts are converted into+-- appropriate flags and removed.  Only the canonical variant of FastQ+-- is supported (qualities stored as raw bytes with offset 33).+--+-- Supported additional conventions:+--+-- * A name suffix of @/1@ or @/2@ is turned into the first mate or second+--   mate flag and the read is flagged as paired.+--+-- * Same for name prefixes of @F_@ or @R_@, respectively.+--+-- * A name prefix of @M_@ flags the sequence as unpaired and merged+--+-- * A name prefix of @T_@ flags the sequence as unpaired and trimmed+--+-- * A name prefix of @C_@, optionally before or after any of the other+--   prefixes, is turned into the extra flag @XP:i:-1@ (result of+--   duplicate removal with unknown duplicate count).+--+-- * A collection of tags separated from the name by an octothorpe is+--   removed and put into the fields @XI@ and @XJ@ as text.+--+-- Everything before the first sequence header is ignored.  Headers can+-- start with @\>@ or @\@@, we treat both equally.  The first word of+-- the header becomes the read name, the remainder of the header is+-- ignored.  The sequence can be split across multiple lines;+-- whitespace, dashes and dots are ignored, IUPAC-IUB ambiguity codes+-- are accepted as bases, anything else causes an error.  The sequence+-- ends at a line that is either a header or starts with @\+@, in the+-- latter case, that line is ignored and must be followed by quality+-- scores.  There must be exactly as many Q-scores as there are bases,+-- followed immediately by a header or end-of-file.  Whitespace is+-- ignored.++parseFastq :: Monad m => ByteStream m r -> Stream (Of BamRec) m (Either SomeException r)+parseFastq = parseFastqWith (const id)++-- | Like 'parseFastq', but also+--+-- * If the first word of the description has at least four colon+--   separated subfields, the first is used to flag first/second mate,+--   the second is the \"QC failed\" flag, and the fourth is the index+--   sequence.++parseFastqCassava :: Monad m => ByteStream m r -> Stream (Of BamRec) m (Either SomeException r)+parseFastqCassava = parseFastqWith (pdesc . C.split ':' . C.takeWhile (' ' /=))+  where+    pdesc (num:flg:_:idx:_) br = br { b_flag = sum [ if num == "1" then flagFirstMate .|. flagPaired else 0+                                                   , if num == "2" then flagSecondMate .|. flagPaired else 0+                                                   , if flg == "Y" then flagFailsQC else 0+                                                   , b_flag br .&. complement (flagFailsQC .|. flagSecondMate .|. flagPaired) ]+                                    , b_exts = if C.all (`C.elem` "ACGTN") idx then insertE "XI" (Text idx) (b_exts br) else b_exts br }+    pdesc _ br = br++-- | Same as 'parseFastq', but a custom function can be applied to the+-- description string (the part of the header after the sequence name),+-- which can modify the parsed record.  Note that the quality field can+-- end up empty.++parseFastqWith :: Monad m => (Bytes -> BamRec -> BamRec) -> ByteStream m r -> Stream (Of BamRec) m (Either SomeException r)+parseFastqWith descr = Q.unfoldr (liftM twiddle . parse (const $ atto pRec)) . skipJunk+  where+    twiddle        (Left  e)  = Left (Left  e)+    twiddle (Right (Left  r)) = Left (Right r)+    twiddle (Right (Right a)) = Right a++    isCBase   = inClass "ACGTUBDHVSWMKRYNacgtubdhvswmkryn"+    canSkip c = isSpace c || c == '.' || c == '-'+    isHdr   c = c == '@' || c == '>'++    pRec   = (satisfy isHdr <?> "start marker") *> (makeRecord <$> pName <*> (descr <$> P.takeWhile ('\n' /=)) <*> (pSeq >>= pQual))+    pName  = takeTill isSpace <* skipWhile (\c -> c /= '\n' && isSpace c)  <?> "read name"+    pSeq   =     (:) <$> satisfy isCBase <*> pSeq+             <|> satisfy canSkip *> pSeq+             <|> pure []                                                   <?> "sequence"++    pQual sq = (,) sq <$> (char '+' *> skipWhile ('\n' /=) *> pQual' (length sq) <* skipSpace <|> return C.empty)  <?> "qualities"+    pQual' n = B.filter (not . isSpace_w8) <$> scan n step+    step 0 _ = Nothing+    step i c | isSpace c = Just i+             | otherwise = Just (i-1)++skipJunk :: Monad m => ByteStream m r -> ByteStream m r+skipJunk = lift . S.nextByte >=> check+  where+    check (Right (c,s)) | bad c     = skipJunk . S.drop 1 . S.dropWhile (c2w '\n' /=) $ s+                        | otherwise = S.cons c s+    check (Left r)                  = pure r+    bad c = c /= c2w '>' && c /= c2w '@'++makeRecord :: Bytes -> (BamRec->BamRec) -> (String, Bytes) -> BamRec+makeRecord name extra (sq,qual) = extra $ nullBamRec+        { b_qname = name, b_seq = V.fromList $ read sq, b_qual = V.fromList $ map (Q . subtract 33) $ B.unpack qual }+

@@ -0,0 +1,121 @@+-- | Quality filters adapted from prehistoric pipeline.++module Bio.Bam.Filter (+    filterPairs, QualFilter,+    complexSimple, complexEntropy,+    qualityAverage, qualityMinimum,+    qualityFromOldIllumina, qualityFromNewIllumina+                      ) where++import Bio.Bam.Header+import Bio.Bam.Rec+import Bio.Prelude+import Bio.Streaming++import qualified Data.Vector.Generic as V++-- | A filter/transformation applied to pairs of reads.  We supply a+-- predicate to be applied to single reads and one to be applied to+-- pairs, the latter can get incomplete pairs, too, if mates have been+-- separated or filtered asymmetrically.  This fails spectacularly if+-- the input isn't grouped by name.++filterPairs :: Monad m => (BamRec -> [BamRec])+                       -> (Maybe BamRec -> Maybe BamRec -> [BamRec])+                       -> Stream (Of BamRec) m r -> Stream (Of BamRec) m r+filterPairs ps pp = step+  where+    step = lift . inspect >=> either pure step'+    step' (b :> s)+        | isPaired b = lift (inspect s) >>= step'' b+        | otherwise  = each (ps b) >> step s++    step'' b (Left r) = each (pp (Just b) Nothing) >> pure r++    step'' b (Right (c :> s))+        | b_rname b /= b_rname c || not (isPaired c) =+                let b' = if isSecondMate b then pp Nothing (Just b) else pp (Just b) Nothing+                in each b' >> step' (c :> s)++        | isFirstMate c && isSecondMate b = step''' c b s+        | otherwise                       = step''' b c s++    step''' b c s = each (pp (Just b) (Just c)) >> step s+++-- | A quality filter is simply a transformation on @BamRec@s.  By+-- convention, quality filters should set @flagFailsQC@, a further step+-- can then remove the failed reads.  Filtering of individual reads+-- tends to result in mate pairs with inconsistent flags, which in turn+-- will result in lone mates and all sort of troubles with programs that+-- expect non-broken BAM files.  It is therefore recommended to use+-- @pairFilter@ with suitable predicates to do the post processing.++type QualFilter = BamRec -> BamRec++{-# INLINE count #-}+count :: (V.Vector v a, Eq a) => a -> v a -> Int+count x = V.foldl' (\acc y -> if x == y then acc+1 else acc) 0++-- | Simple complexity filter aka "Nancy Filter".  A read is considered+-- not-sufficiently-complex if the most common base accounts for greater+-- than the @cutoff@ fraction of all non-N bases.+{-# INLINE complexSimple #-}+complexSimple :: Double -> QualFilter+complexSimple r b = if p then b else b'+  where+    b' = setQualFlag 'C' $ b { b_flag = b_flag b .|. flagFailsQC }+    p  = let counts = [ count x $ b_seq b | x <- properBases ]+             lim = floor $ r * fromIntegral (sum counts)+         in all (<= lim) counts++-- | Filter on order zero empirical entropy.  Entropy per base must be+-- greater than cutoff.+{-# INLINE complexEntropy #-}+complexEntropy :: Double -> QualFilter+complexEntropy r b = if p then b else b'+  where+    b' = setQualFlag 'C' $ b { b_flag = b_flag b .|. flagFailsQC }+    p = ent >= r * total++    counts = [ count x $ b_seq b | x <- properBases ]+    total = fromIntegral $ V.length $ b_seq b+    ent   = sum [ fromIntegral c * log (total / fromIntegral c) | c <- counts, c /= 0 ] / log 2++-- | Filter on average quality.  Reads without quality string pass.+{-# INLINE qualityAverage #-}+qualityAverage :: Int -> QualFilter+qualityAverage q b = if p then b else b'+  where+    b' = setQualFlag 'Q' $ b { b_flag = b_flag b .|. flagFailsQC }+    p  = let total = V.foldl' (\a x -> a + fromIntegral (unQ x)) 0 $ b_qual b+         in total >= q * V.length (b_qual b)++-- | Filter on minimum quality.  In @qualityMinimum n q@, a read passes+-- if it has no more than @n@ bases with quality less than @q@.  Reads+-- without quality string pass.+{-# INLINE qualityMinimum #-}+qualityMinimum :: Int -> Qual -> QualFilter+qualityMinimum n (Q q) b = if p then b else b'+  where+    b' = setQualFlag 'Q' $ b { b_flag = b_flag b .|. flagFailsQC }+    p  = V.length (V.filter (< Q q) (b_qual b)) <= n+++-- | Convert quality scores from old Illumina scale (different formula+-- and offset 64 in FastQ).+qualityFromOldIllumina :: BamRec -> BamRec+qualityFromOldIllumina b = b { b_qual = V.map conv $ b_qual b }+  where+    conv (Q s) = let s' :: Double+                     s' = exp $ log 10 * (fromIntegral s - 31) / (-10)+                     p  = s' / (1+s')+                     q  = - 10 * log p / log 10+                 in Q (round q)++-- | Convert quality scores from new Illumina scale (standard formula+-- but offset 64 in FastQ).+qualityFromNewIllumina :: BamRec -> BamRec+qualityFromNewIllumina b = b { b_qual = V.map (Q . subtract 31 . unQ) $ b_qual b }++

@@ -0,0 +1,570 @@+{-# LANGUAGE UndecidableInstances #-}+module Bio.Bam.Header (+        BamMeta(..),+        parseBamMeta,+        showBamMeta,+        addPG,++        BamKey(..),+        BamHeader(..),+        BamSQ(..),+        BamSorting(..),+        BamOtherShit,++        Refseq(..),+        invalidRefseq,+        isValidRefseq,+        invalidPos,+        isValidPos,+        unknownMapq,+        isKnownMapq,++        Refs(..),+        getRef,++        compareNames,++        flagPaired,+        flagProperlyPaired,+        flagUnmapped,+        flagMateUnmapped,+        flagReversed,+        flagMateReversed,+        flagFirstMate,+        flagSecondMate,+        flagAuxillary,+        flagSecondary,+        flagFailsQC,+        flagDuplicate,+        flagSupplementary,+        eflagTrimmed,+        eflagMerged,+        eflagAlternative,+        eflagExactIndex,++        distinctBin,++        MdOp(..),+        readMd,+        showMd+    ) where++import Bio.Prelude           hiding ( uncons )+import Bio.Util.Nub+import Control.Monad.Trans.RWS+import Data.ByteString              ( uncons )+import Data.ByteString.Builder      ( Builder, byteString, char7, intDec, word16LE )++import qualified Data.Attoparsec.ByteString.Char8   as P+import qualified Data.ByteString.Char8              as S+import qualified Data.HashMap.Strict                as H+import qualified Data.Vector                        as V++data BamMeta = BamMeta {+        meta_hdr :: !BamHeader,+        meta_refs :: !Refs,+        meta_pgs :: [Fix BamPG],+        meta_other_shit :: [(BamKey, BamOtherShit)],+        meta_comment :: [Bytes]+    } deriving ( Show, Generic )++-- | Exactly two characters, for the \"named\" fields in bam.+newtype BamKey = BamKey Word16+    deriving ( Eq, Ord, Hashable, Generic )++instance IsString BamKey where+    {-# INLINE fromString #-}+    fromString [a,b]+        | ord a < 256 && ord b < 256+            = BamKey . fromIntegral $ ord a .|. shiftL (ord b) 8++    fromString s+            = error $ "Not a legal BAM key: " ++ show s++instance Show BamKey where+    show (BamKey a) = [ chr (fromIntegral a .&. 0xff), chr (shiftR (fromIntegral a) 8 .&. 0xff) ]++-- | Adds a new program line to a header.  The new entry is+-- (arbitrarily) prepended to the first existing chain, or forms a new+-- singleton chain if none exists.++addPG :: Maybe Version -> IO (BamMeta -> BamMeta)+addPG vn = do+    args <- getArgs+    pn   <- getProgName++    let more = ("PN", S.pack pn) :+               ("CL", S.pack $ unwords args) :+               maybe [] (\v -> [("VN",S.pack (showVersion v))]) vn++    return $ \bm -> case meta_pgs bm of+        [    ] -> bm { meta_pgs = Fix (BamPG (S.pack pn)  Nothing  more) : [ ] }+        pg:pgs -> bm { meta_pgs = Fix (BamPG (S.pack pn) (Just pg) more) : pgs }+++instance Semigroup BamMeta where (<>)    = combineBamMeta+instance Monoid    BamMeta where mempty  = BamMeta mempty mempty mempty [] []+                                 mappend = (<>)++{- | Combines two bam headers into one.++The overarching goal is to combine headers in such a way that no+information is lost, but redundant information is removed.  In+particular, we sometimes \"merge\" headers with the same references, at+other times we \"meld\" headers with entirely different references.  In+the former case, we must concatenate the reference lists, in the latter+case we want to keep it as is.++* If both headers have a version number, the result is the smaller of+  the two.++* The resulting sort order is the most specific one compatible with both+  input sort orders.  The stupid 'Unknown' state is compatible with+  everything.++* Reference sequences are appended and run through 'nub'.  The numbering+  of reference may thus change, which has to be dealt with in an+  appropriate way, see 'concatInputs', 'mergeInputsOn', and \"bam-meld\"+  for details.  (It is also possible that different sequences are left+  with the same name.  We cannot solve this right here, and there is no+  reliable way to do it in general.)++* Comments are appended and run through 'nub'.  This should work in+  most case, and if it doesn't, someone needs to \"samtools reheader\"+  the file anyway.++* Program chains are just collected, but when formatting, they are+  (effectively) run through 'nub' and are potentially assigned new+  unique identifiers.+-}+combineBamMeta :: BamMeta -> BamMeta -> BamMeta+combineBamMeta a b = BamMeta+    { meta_hdr        = meta_hdr a <> meta_hdr b+    , meta_refs       = meta_refs a `mappend` meta_refs b+    , meta_pgs        = meta_pgs a <> meta_pgs b+    , meta_other_shit = nubHash $ meta_other_shit a ++ meta_other_shit b+    , meta_comment    = nubHash $ meta_comment a ++ meta_comment b }++data BamHeader = BamHeader {+        hdr_version :: (Int, Int),+        hdr_sorting :: BamSorting,+        hdr_other_shit :: BamOtherShit+    } deriving (Show, Eq)++instance Monoid BamHeader where+    mempty = BamHeader (1,0) Unknown []+    mappend = (<>)++instance Semigroup BamHeader where+    a <> b = BamHeader { hdr_version    = max (hdr_version a) (hdr_version b)+                       , hdr_sorting    = hdr_sorting a <> hdr_sorting b+                       , hdr_other_shit = nubHashBy fst $ hdr_other_shit a ++ hdr_other_shit b }++data BamSQ = BamSQ {+        sq_name :: Bytes,+        sq_length :: Int,+        sq_other_shit :: BamOtherShit+    } deriving (Show, Eq, Generic)++instance Hashable BamSQ++bad_seq :: BamSQ+bad_seq = BamSQ (error "no SN field") (error "no LN field") []++data BamPG pp = BamPG {+        pg_pref_name :: Bytes,+        pg_prev_pg :: Maybe pp,+        pg_other_shit :: BamOtherShit+    } deriving (Show, Eq, Generic1)++newtype Fix f = Fix (f (Fix f))++instance Eq (f (Fix f)) => Eq (Fix f) where+    Fix f == Fix g  =  f == g++instance Show (f (Fix f)) => Show (Fix f) where+    showsPrec p (Fix f) = showsPrec p f++instance Hashable1 f => Hashable (Fix f) where+    hashWithSalt salt (Fix f) = liftHashWithSalt hashWithSalt salt f++instance Hashable1 BamPG++bad_pg :: BamPG pp+bad_pg = BamPG (error "no ID field") Nothing []+++-- | Possible sorting orders from bam header.  Thanks to samtools, which+-- doesn't declare sorted files properly, we have to have the stupid+-- 'Unknown' state, too.+data BamSorting = Unknown       -- ^ undeclared sort order+                | Unsorted      -- ^ definitely not sorted+                | Grouped       -- ^ grouped by query name+                | Queryname     -- ^ sorted by query name+                | Coordinate    -- ^ sorted by coordinate+    deriving (Show, Eq)++instance Semigroup BamSorting where+    Unknown    <>          b  =  b+    a          <>    Unknown  =  a+    Grouped    <>    Grouped  =  Grouped+    Grouped    <>  Queryname  =  Grouped+    Queryname  <>    Grouped  =  Grouped+    Queryname  <>  Queryname  =  Queryname+    Coordinate <> Coordinate  =  Coordinate+    _          <>          _  =  Unsorted+++type BamOtherShit = [(BamKey, Bytes)]++parseBamMeta :: P.Parser BamMeta+parseBamMeta = fixupMeta . foldl' (flip ($)) emptyHeader+               <$> many (parseBamMetaLine <* P.skipWhile (=='\t') <* P.char '\n')++-- Bam header in the process of being parsed.  Better suited for+-- collecting lines than 'BamMeta'.+data PreBamMeta = PreBamMeta {+        pmeta_hdr        :: BamHeader,+        pmeta_refs       :: [BamSQ],+        pmeta_pgs        :: HashMap Bytes (BamPG Bytes),+        pmeta_other_shit :: [(BamKey, BamOtherShit)],+        pmeta_comment    :: [Bytes] }++emptyHeader :: PreBamMeta+emptyHeader = PreBamMeta mempty [] H.empty [] []+++-- | Fixes a bam header after parsing.  It turns accumulated lists in to+-- vectors, and it handles the program lines.  Program lines come in as+-- an arbitrary graph.  It chould be a linear chain, but this+-- isn't guaranteed in practice.  We decompose the graph into chains by+-- tracing from nodes with no predecessor, or from an arbitrary node if+-- all nodes have predecessors.  Tracing stops once it would form a+-- cycle.+fixupMeta :: PreBamMeta -> BamMeta+fixupMeta PreBamMeta{..} = BamMeta+    { meta_hdr        = pmeta_hdr+    , meta_refs       = Refs . V.fromList . reverse $ pmeta_refs+    , meta_pgs        = snd $ evalRWS trace_pgs () pmeta_pgs+    , meta_other_shit = reverse pmeta_other_shit+    , meta_comment    = reverse pmeta_comment  }+  where+    -- keep tracing from roots until no nodes are left+    trace_pgs :: RWS () [Fix BamPG] (HashMap Bytes (BamPG Bytes)) ()+    trace_pgs = do+        gg <- get+        case foldl' (flip H.delete) gg+                    [ pp | p <- H.elems gg+                         , pp <- maybe [] pure (pg_prev_pg p) ] of+          orphans+            -- the empty graph has no roots:+            | H.null gg      -> return ()+            -- an arbitrary node is picked as root:+            | H.null orphans -> trace_pg H.empty (head $ H.keys gg) >> trace_pgs+            -- nodes without parents are roots:+            | otherwise      -> mapM_ (trace_pg H.empty) (H.keys orphans) >> trace_pgs++    -- Trace one PG line.  Do not trace into nodes in the 'closed' set,+    -- remove reached nodes from the 'open' set (the state) and add them+    -- to the 'closed' set.+    trace_pg :: HashMap Bytes () -> Bytes -> RWS () [Fix BamPG] (HashMap Bytes x) (Maybe (Fix BamPG))+    trace_pg closed name =+        case H.lookup name pmeta_pgs of+            _ | H.member name closed -> return Nothing+            Nothing                  -> return Nothing+            Just pg -> do+                modify $ H.delete name+                pp <- mapM (trace_pg (H.insert name () closed)) (pg_prev_pg pg)+                let self = Fix $ pg { pg_prev_pg = join pp }+                tell [ self ]+                return $ Just self+++parseBamMetaLine :: P.Parser (PreBamMeta -> PreBamMeta)+parseBamMetaLine = P.char '@' >> P.choice [hdLine, sqLine, pgLine, coLine, otherLine]+  where+    hdLine = P.string "HD\t" >>+             (\fns meta -> meta { pmeta_hdr = foldr ($) (pmeta_hdr meta) fns })+               <$> P.sepBy1 (P.choice [hdvn, hdso, hdother]) tabs++    sqLine = P.string "SQ\t" >>+             (\fns meta -> meta { pmeta_refs = foldr ($) bad_seq fns : pmeta_refs meta })+               <$> P.sepBy1 (P.choice [sqnm, sqln, sqother]) tabs++    pgLine = P.string "PG\t" >>+             (\fns meta -> let pg = foldr ($) bad_pg fns+                           in meta { pmeta_pgs = H.insert (pg_pref_name pg) pg (pmeta_pgs meta) })+               <$> P.sepBy1 (P.choice [pgid, pgpp, pgother]) tabs++    hdvn = P.string "VN:" >>+           (\a b hdr -> hdr { hdr_version = (a,b) })+             <$> P.decimal <*> ((P.char '.' <|> P.char ':') >> P.decimal)++    hdso = P.string "SO:" >>+           (\s hdr -> hdr { hdr_sorting = s })+             <$> P.choice [ Grouped     <$ P.string "grouped"+                          , Queryname   <$ P.string "queryname"+                          , Coordinate  <$ P.string "coordinate"+                          , Unsorted    <$ P.string "unsorted"+                          , Unknown     <$ P.skipWhile (\c -> c/='\t' && c/='\n') ]++    sqnm = P.string "SN:" >> (\s sq -> sq { sq_name = s }) <$> pall+    sqln = P.string "LN:" >> (\i sq -> sq { sq_length = i }) <$> P.decimal++    pgid = P.string "ID:" >> (\s pg -> pg { pg_pref_name =      s }) <$> pall+    pgpp = P.string "PP:" >> (\s pg -> pg { pg_prev_pg   = Just s }) <$> pall++    hdother = (\t hdr -> hdr { hdr_other_shit = t : hdr_other_shit hdr }) <$> tagother+    sqother = (\t sq  -> sq  { sq_other_shit  = t : sq_other_shit  sq  }) <$> tagother+    pgother = (\t p   -> p   { pg_other_shit  = t : pg_other_shit  p   }) <$> tagother++    coLine = P.string "CO\t" >>+             (\s meta -> s `seq` meta { pmeta_comment = s : pmeta_comment meta })+               <$> P.takeWhile (/= 'n')++    otherLine = (\k ts meta -> meta { pmeta_other_shit = (k,ts) : pmeta_other_shit meta })+                  <$> bamkey <*> (tabs >> P.sepBy1 tagother tabs)++    tagother :: P.Parser (BamKey,Bytes)+    tagother = (,) <$> bamkey <*> (P.char ':' >> pall)++    tabs = P.char '\t' >> P.skipWhile (== '\t')++    pall :: P.Parser Bytes+    pall = P.takeWhile (\c -> c/='\t' && c/='\n')++    bamkey :: P.Parser BamKey+    bamkey = (\a b -> fromString [a,b]) <$> P.anyChar <*> P.anyChar+++-- | Creates the textual form of Bam meta data.+--+-- Formatting is straight forward, only program lines are a bit+-- involved.  Our multiple chains may lead to common nodes, and we do+-- not want to print multiple identical lines.  At the same time, we may+-- need to print multiple different lines that carry the same id.  The+-- solution is to memoize printed lines, and to reuse their identity if+-- an identical line is needed.  When printing a line, it gets its+-- preferred identifier, but if it's already taken, a new identifier is+-- made up by first removing any trailing number and then by appending+-- numeric suffixes.++showBamMeta :: BamMeta -> Builder+showBamMeta (BamMeta h (Refs ss) pgs os cs) =+    show_bam_meta_hdr h <>+    foldMap show_bam_meta_seq ss <>+    show_bam_pgs <>+    foldMap show_bam_meta_other os <>+    foldMap show_bam_meta_comment cs+  where+    show_bam_meta_hdr (BamHeader (major,minor) so os') =+        "@HD\tVN:" <>+        intDec major <> char7 '.' <> intDec minor <>+        byteString (case so of Unsorted    -> "\tSO:unsorted"+                               Grouped     -> "\tSO:grouped"+                               Queryname   -> "\tSO:queryname"+                               Coordinate  -> "\tSO:coordinate"+                               Unknown     -> mempty) <>+        show_bam_others os'++    show_bam_meta_seq (BamSQ nm ln ts) =+        byteString "@SQ\tSN:" <> byteString nm <>+        byteString "\tLN:" <> intDec ln <> show_bam_others ts++    show_bam_meta_comment cm = byteString "@CO\t" <> byteString cm <> char7 '\n'++    show_bam_meta_other (BamKey k,ts) =+        char7 '@' <> word16LE k <> show_bam_others ts++    show_bam_others ts =+        foldMap show_bam_other ts <> char7 '\n'++    show_bam_other (BamKey k,v) =+        char7 '\t' <> word16LE k <> char7 ':' <> byteString v++    show_bam_pgs = snd $ evalRWS (mapM_ show_bam_pg pgs) () (H.empty, H.empty)++    show_bam_pg p@(Fix (BamPG pn pp po)) = do+        ppid <- case pp of Nothing -> return Nothing+                           Just p' -> Just <$> show_bam_pg p'++        gets (H.lookup p . fst) >>= \case+            Just pid -> return pid+            Nothing  -> do+                -- preferred name without a trailing dash-and-number+                let pn' = case dropWhile isDigit . reverse $ S.unpack pn of+                            '-':xs -> reverse xs+                            _      -> S.unpack pn++                -- find unused preferable PG:ID:  try prefered name,+                -- preferred name without number, preferred name+                -- without number and increasing numbers attached+                pid <- gets $ \(_,hs) ->+                            head . filter (not . flip H.member hs) $+                            pn : S.pack pn' : [ S.pack $ pn' ++ '-' : (show i) | i <- [2::Int ..] ]++                modify . first $ H.insert p pid+                modify . second $ H.insert pid ()++                tell $ byteString "@PG\tID:" <> byteString pid <>+                       maybe mempty (\x -> byteString "\tPP:" <> byteString x) ppid <>+                       show_bam_others po+                return pid+++-- | Reference sequence in Bam+-- Bam enumerates the reference sequences and then sorts by index.  We+-- need to track that index if we want to reproduce the sorting order.+newtype Refseq = Refseq { unRefseq :: Word32 } deriving (Eq, Ord, Ix, Bounded)++instance Show Refseq where+    showsPrec p (Refseq r) = showsPrec p r++instance Enum Refseq where+    succ = Refseq . succ . unRefseq+    pred = Refseq . pred . unRefseq+    toEnum = Refseq . fromIntegral+    fromEnum = fromIntegral . unRefseq+    enumFrom = map Refseq . enumFrom . unRefseq+    enumFromThen (Refseq a) (Refseq b) = map Refseq $ enumFromThen a b+    enumFromTo (Refseq a) (Refseq b) = map Refseq $ enumFromTo a b+    enumFromThenTo (Refseq a) (Refseq b) (Refseq c) = map Refseq $ enumFromThenTo a b c+++-- | Tests whether a reference sequence is valid.+-- Returns true unless the the argument equals @invalidRefseq@.+isValidRefseq :: Refseq -> Bool+isValidRefseq = (/=) invalidRefseq++-- | The invalid Refseq.+-- Bam uses this value to encode a missing reference sequence.+invalidRefseq :: Refseq+invalidRefseq = Refseq 0xffffffff++-- | The invalid position.+-- Bam uses this value to encode a missing position.+{-# INLINE invalidPos #-}+invalidPos :: Int+invalidPos = -1++-- | Tests whether a position is valid.+-- Returns true unless the the argument equals @invalidPos@.+{-# INLINE isValidPos #-}+isValidPos :: Int -> Bool+isValidPos = (/=) invalidPos++{-# INLINE unknownMapq #-}+unknownMapq :: Int+unknownMapq = 255++isKnownMapq :: Int -> Bool+isKnownMapq = (/=) unknownMapq++-- | A list of reference sequences.+newtype Refs = Refs { unRefs :: V.Vector BamSQ } deriving Show++instance Monoid Refs where+    mempty = Refs V.empty+    mappend = (<>)++instance Semigroup Refs where+    Refs a <> Refs b = Refs . V.fromList . nubHash $ V.toList a ++ V.toList b++getRef :: Refs -> Refseq -> BamSQ+getRef (Refs refs) (Refseq i) = fromMaybe (BamSQ "*" 0 []) $ refs V.!? fromIntegral i++flagPaired, flagProperlyPaired, flagUnmapped, flagMateUnmapped,+ flagReversed, flagMateReversed, flagFirstMate, flagSecondMate,+ flagAuxillary, flagSecondary, flagFailsQC, flagDuplicate,+ flagSupplementary :: Int++flagPaired         =   0x1+flagProperlyPaired =   0x2+flagUnmapped       =   0x4+flagMateUnmapped   =   0x8+flagReversed       =  0x10+flagMateReversed   =  0x20+flagFirstMate      =  0x40+flagSecondMate     =  0x80+flagAuxillary      = 0x100+flagSecondary      = 0x100+flagFailsQC        = 0x200+flagDuplicate      = 0x400+flagSupplementary  = 0x800++eflagTrimmed, eflagMerged, eflagAlternative, eflagExactIndex :: Int+eflagTrimmed     = 0x1+eflagMerged      = 0x2+eflagAlternative = 0x4+eflagExactIndex  = 0x8+++-- | Compares two sequence names the way samtools does.+-- samtools sorts by \"strnum_cmp\":+--+-- * if both strings start with a digit, parse the initial+--   sequence of digits and compare numerically, if equal,+--   continue behind the numbers+-- * else compare the first characters (possibly NUL), if equal+--   continue behind them+-- * else both strings ended and the shorter one counts as+--   smaller (and that part is stupid)++compareNames :: Bytes -> Bytes -> Ordering+compareNames n m = case (uncons n, uncons m) of+        ( Nothing, Nothing ) -> EQ+        ( Just  _, Nothing ) -> GT+        ( Nothing, Just  _ ) -> LT+        ( Just (c,n'), Just (d,m') )+            | is_digit c || is_digit d+            , Just (u,n'') <- S.readInt n+            , Just (v,m'') <- S.readInt m ->+                case u `compare` v of+                    LT -> LT+                    GT -> GT+                    EQ -> n'' `compareNames` m''+            | otherwise ->+                case c `compare` d of+                    LT -> LT+                    GT -> GT+                    EQ -> n' `compareNames` m'+  where+    is_digit c = c2w '0' <= c && c <= c2w '9'+++data MdOp = MdNum Int | MdRep Nucleotides | MdDel [Nucleotides] deriving Show++readMd :: Bytes -> Maybe [MdOp]+readMd s | S.null s           = return []+         | isDigit (S.head s) = do (n,t) <- S.readInt s+                                   (MdNum n :) <$> readMd t+         | S.head s == '^'    = let (a,b) = S.break isDigit (S.tail s)+                                in (MdDel (map toNucleotides $ S.unpack a) :) <$> readMd b+         | otherwise          = (MdRep (toNucleotides $ S.head s) :) <$> readMd (S.tail s)++-- | Normalizes a series of 'MdOp's and encodes them in the way BAM and+-- SAM expect it.+showMd :: [MdOp] -> Bytes+showMd = S.pack . flip s1 []+  where+    s1 (MdNum  i : MdNum  j : ms) = s1 (MdNum (i+j) : ms)+    s1 (MdNum  0            : ms) = s1 ms+    s1 (MdNum  i            : ms) = shows i . s1 ms++    s1 (MdRep  r            : ms) = shows r . s1 ms++    s1 (MdDel d1 : MdDel d2 : ms) = s1 (MdDel (d1++d2) : ms)+    s1 (MdDel []            : ms) = s1 ms+    s1 (MdDel ns : MdRep  r : ms) = (:) '^' . shows ns . (:) '0' . shows r . s1 ms+    s1 (MdDel ns            : ms) = (:) '^' . shows ns . s1 ms+    s1 [                        ] = id+++-- | Computes the "distinct bin" according to the BAM binning scheme.  If+-- an alignment starts at @pos@ and its CIGAR implies a length of @len@+-- on the reference, then it goes into bin @distinctBin pos len@.+distinctBin :: Int -> Int -> Int+distinctBin beg len = mkbin 14 $ mkbin 17 $ mkbin 20 $ mkbin 23 $ mkbin 26 0+  where end = beg + len - 1+        mkbin n x = if beg `shiftR` n /= end `shiftR` n then x+                    else ((1 `shiftL` (29-n))-1) `div` 7 + (beg `shiftR` n)

@@ -0,0 +1,384 @@+module Bio.Bam.Index (+    BamIndex(..),+    withIndexedBam,+    readBamIndex,+    readBaiIndex,+    readTabix,++    Region(..),+    Subsequence(..),+    streamBamRefseq,+    streamBamRegions,+    streamBamSubseq,+    streamBamUnaligned+) where++import Bio.Bam.Header+import Bio.Bam.Reader+import Bio.Bam.Rec+import Bio.Bam.Regions              ( Region(..), Subsequence(..) )+import Bio.Prelude+import Bio.Streaming+import Bio.Streaming.Bgzf           ( bgunzip )+import System.Directory             ( doesFileExist )++import qualified Bio.Bam.Regions                as R+import qualified Bio.Streaming.Bytes            as S+import qualified Bio.Streaming.Parse            as P+import qualified Data.IntMap.Strict             as M+import qualified Data.ByteString                as B+import qualified Data.Vector                    as V+import qualified Data.Vector.Mutable            as W+import qualified Data.Vector.Unboxed            as U+import qualified Data.Vector.Unboxed.Mutable    as N+import qualified Data.Vector.Algorithms.Intro   as N+import qualified Streaming.Prelude              as Q++-- | Full index, unifying BAI and CSI style.  In both cases, we have the+-- binning scheme, parameters are fixed in BAI, but variable in CSI.+-- Checkpoints are created from the linear index in BAI or from the+-- `loffset' field in CSI.++data BamIndex a = BamIndex {+    -- | Minshift parameter from CSI+    minshift :: {-# UNPACK #-} !Int,++    -- | Depth parameter from CSI+    depth :: {-# UNPACK #-} !Int,++    -- | Best guess at where the unaligned records start+    unaln_off :: {-# UNPACK #-} !Int64,++    -- | Room for stuff (needed for tabix)+    extensions :: a,++    -- | Records for the binning index, where each bin has a list of+    -- segments belonging to it.+    refseq_bins :: {-# UNPACK #-} !(V.Vector Bins),++    -- | Known checkpoints of the form (pos,off) where off is the+    -- virtual offset of the first record crossing pos.+    refseq_ckpoints :: {-# UNPACK #-} !(V.Vector Ckpoints) }++  deriving Show++-- | Mapping from bin number to vector of clusters.+type Bins = IntMap Segments+type Segments = U.Vector (Int64,Int64)+++-- | Checkpoints.  Each checkpoint is a position with the virtual offset+-- where the first alignment crossing the position is found.  In BAI, we+-- get this from the 'ioffset' vector, in CSI we get it from the+-- 'loffset' field:  "Given a region [beg,end), we only need to visit+-- chunks whose end file offset is larger than 'ioffset' of the 16kB+-- window containing 'beg'."  (Sounds like a marginal gain, though.)++type Ckpoints = IntMap Int64+++-- | Decode only those reads that fall into one of several regions.+-- Strategy:  We will scan the file mostly linearly, but only those+-- regions that are actually needed.  We filter the decoded stuff so+-- that it actually overlaps our regions.+--+-- From the binning index, we get a list of segments per requested+-- region.  Using the checkpoints, we prune them:  if we have a+-- checkpoint to the left of the beginning of the interesting region, we+-- can move the start of each segment forward to the checkpoint.  If+-- that makes the segment empty, it can be droppped.+--+-- The resulting segment lists are merged, then traversed.  We seek to+-- the beginning of the earliest segment and start decoding.  Once the+-- virtual file position leaves the segment or the alignment position+-- moves past the end of the requested region, we move to the next.+-- Moving is a seek if it spans a sufficiently large gap or points+-- backwards, else we just keep going.++-- | A 'Segment' has a start and an end offset, and an "end coordinate"+-- from the originating region.+data Segment = Segment {-# UNPACK #-} !Int64 {-# UNPACK #-} !Int64 {-# UNPACK #-} !Int deriving Show++segmentLists :: BamIndex a -> Refseq -> R.Subsequence -> [[Segment]]+segmentLists bi@BamIndex{..} (Refseq ref) (R.Subsequence imap)+        | Just bins <- refseq_bins V.!? fromIntegral ref,+          Just cpts <- refseq_ckpoints V.!? fromIntegral ref+        = [ rgnToSegments bi beg end bins cpts | (beg,end) <- M.toList imap ]+segmentLists _ _ _ = []++-- from region to list of bins, then to list of segments+rgnToSegments :: BamIndex a -> Int -> Int -> Bins -> Ckpoints -> [Segment]+rgnToSegments bi@BamIndex{..} beg end bins cpts =+    [ Segment boff' eoff end+    | bin <- binList bi beg end+    , (boff,eoff) <- maybe [] U.toList $ M.lookup bin bins+    , let boff' = max boff cpt+    , boff' < eoff ]+  where+    !cpt = maybe 0 snd $ M.lookupLE beg cpts++-- list of bins for given range of coordinates, from Heng's horrible code+binList :: BamIndex a -> Int -> Int -> [Int]+binList BamIndex{..} beg end = binlist' 0 (minshift + 3*depth) 0+  where+    binlist' l s t = if l > depth then [] else [b..e] ++ go+      where+        b = t + beg `shiftR` s+        e = t + (end-1) `shiftR` s+        go = binlist' (l+1) (s-3) (t + 1 `shiftL` (3*l))+++-- | Merges two lists of segments.  Lists must be sorted, the merge sort+-- merges overlapping segments into one.+infix 4 ~~+(~~) :: [Segment] -> [Segment] -> [Segment]+Segment a b e : xs ~~ Segment u v f : ys+    |          b < u = Segment a b e : (xs ~~ Segment u v f : ys)     -- no overlap+    | a < u && b < v = Segment a v (max e f) : (xs ~~ ys)             -- some overlap+    |          b < v = Segment u v (max e f) : (xs ~~ ys)             -- contained+    | v < a          = Segment u v f : (xs ~~ Segment a b e : ys)     -- no overlap+    | u < a          = Segment u b (max e f) : (xs ~~ ys)             -- some overlap+    | otherwise      = Segment a b (max e f) : (xs ~~ ys)             -- contained+[] ~~ ys = ys+xs ~~ [] = xs+++data IndexFormatError = IndexFormatError Bytes deriving Typeable++instance Exception IndexFormatError+instance Show IndexFormatError where+    show (IndexFormatError m) = "index signature " ++ show m ++ " not recognized"++{- | Reads any index we can find for a file.++If the file name has a .bai or .csi extension, optionally followed by+.gz, we read it.  Else we look for the index by adding such an extension+and by replacing the extension with these two, and finally try the file+itself.  The first file that exists is used.+-}+readBamIndex :: FilePath -> IO (BamIndex ())+readBamIndex fp1 | any (`isSuffixOf` fp1) exts = streamFile fp1 readBaiIndex+                 | otherwise                   = tryAll exts+  where+    exts = words ".bai .bai.gz .csi .csi.gz"++    fp2 = reverse $ case dropWhile (/='.') f of [] -> f++d ; _:b -> b++d+    (f,d) = break (=='/') $ reverse fp1++    tryAll [    ] = streamFile fp1 readBaiIndex+    tryAll (e:es) = do x1 <- liftIO $ doesFileExist (fp1 ++ e)+                       x2 <- liftIO $ doesFileExist (fp2 ++ e)+                       case () of+                            _ | x1 -> streamFile (fp1 ++ e) readBaiIndex+                              | x2 -> streamFile (fp2 ++ e) readBaiIndex+                            _      -> tryAll es++-- | Reads an index in BAI or CSI format, recognized automatically.  The+-- index can be compressed, even though this isn't standard.+readBaiIndex :: MonadIO m => ByteStream m r -> m (BamIndex ())+readBaiIndex = either (const . liftIO $ throwM P.EofException) (return . fst) <=<+               P.parseIO (const $ P.getString 4 >>= switch) . S.gunzip+  where+    switch "BAI\1" = do nref <- fromIntegral `liftM` P.getWord32+                        getIndexArrays nref 14 5 (const return) getIntervals++    switch "CSI\1" = do minshift <- fromIntegral `liftM` P.getWord32+                        depth <- fromIntegral `liftM` P.getWord32+                        P.getWord32 >>= P.drop . fromIntegral -- aux data+                        nref <- fromIntegral `liftM` P.getWord32+                        getIndexArrays nref minshift depth (addOneCheckpoint minshift depth) return++    switch magic   = throwM $ IndexFormatError magic+++    -- Insert one checkpoint.  If we already have an entry (can happen+    -- if it comes from a different bin), we conservatively take the min+    addOneCheckpoint minshift depth bin cp = do+            loffset <- fromIntegral `liftM` P.getWord64+            let key = llim (fromIntegral bin) (3*depth) minshift+            return $! M.insertWith min key loffset cp++    -- compute left limit of bin+    llim bin dp sf | dp  ==  0 = 0+                   | bin >= ix = (bin - ix) `shiftL` sf+                   | otherwise = llim bin (dp-3) (sf+3)+            where ix = (1 `shiftL` dp - 1) `div` 7++withIndexedBam :: (MonadIO m, MonadMask m) => FilePath -> (BamMeta -> BamIndex () -> Handle -> m r) -> m r+withIndexedBam f k = do+    idx <- liftIO $ readBamIndex f+    bracket (liftIO $ openBinaryFile f ReadMode) (liftIO . hClose) $ \hdl -> do+        (hdr,_) <- decodeBam $ streamHandle hdl+        k hdr idx hdl+++type TabIndex = BamIndex TabMeta++data TabMeta = TabMeta { format :: TabFormat+                       , col_seq :: Int                           -- Column for the sequence name+                       , col_beg :: Int                           -- Column for the start of a region+                       , col_end :: Int                           -- Column for the end of a region+                       , comment_char :: Char+                       , skip_lines :: Int+                       , names :: V.Vector Bytes }+  deriving Show++data TabFormat = Generic | SamFormat | VcfFormat | ZeroBased   deriving Show++-- | Reads a Tabix index.  Note that tabix indices are compressed, this+-- is taken care of automatically.+readTabix :: MonadIO m => ByteStream m r -> m TabIndex+readTabix = either (const . liftIO $ throwM P.EofException) (return . fst) <=<+            P.parseIO (const $ P.getString 4 >>= switch) . S.gunzip+  where+    switch "TBI\1" = do nref <- fromIntegral `liftM` P.getWord32+                        format       <- liftM toFormat     P.getWord32+                        col_seq      <- liftM fromIntegral P.getWord32+                        col_beg      <- liftM fromIntegral P.getWord32+                        col_end      <- liftM fromIntegral P.getWord32+                        comment_char <- liftM (chr . fromIntegral) P.getWord32+                        skip_lines   <- liftM fromIntegral P.getWord32+                        names        <- liftM (V.fromList . B.split 0) . P.getString . fromIntegral =<< P.getWord32++                        ix <- getIndexArrays nref 14 5 (const return) getIntervals+                        fin <- P.isFinished+                        if fin then return $! ix { extensions = TabMeta{..} }+                               else do unaln <- fromIntegral `liftM` P.getWord64+                                       return $! ix { unaln_off = unaln, extensions = TabMeta{..} }++    switch magic   = throwM $ IndexFormatError magic++    toFormat 1 = SamFormat+    toFormat 2 = VcfFormat+    toFormat x = if testBit x 16 then ZeroBased else Generic++-- Read the intervals.  Each one becomes a checkpoint.+getIntervals :: Monad m => (IntMap Int64, Int64) -> P.Parser r m (IntMap Int64, Int64)+getIntervals (cp,mx0) = do+    nintv <- fromIntegral `liftM` P.getWord32+    reduceM 0 nintv (cp,mx0) $ \(!im,!mx) int -> do+        oo <- fromIntegral `liftM` P.getWord64+        return (if oo == 0 then im else M.insert (int * 0x4000) oo im, max mx oo)+++getIndexArrays :: MonadIO m => Int -> Int -> Int+               -> (Word32 -> Ckpoints -> P.Parser r m Ckpoints)+               -> ((Ckpoints, Int64) -> P.Parser r m (Ckpoints, Int64))+               -> P.Parser r m (BamIndex ())+getIndexArrays nref minshift depth addOneCheckpoint addManyCheckpoints+    | nref  < 1 = return $ BamIndex minshift depth 0 () V.empty V.empty+    | otherwise = do+        rbins  <- liftIO $ W.new nref+        rckpts <- liftIO $ W.new nref+        mxR <- reduceM 0 nref 0 $ \mx0 r -> do+                nbins <- P.getWord32+                (!bins,!cpts,!mx1) <- reduceM 0 nbins (M.empty,M.empty,mx0) $ \(!im,!cp,!mx) _ -> do+                        bin <- P.getWord32 -- the "distinct bin"+                        cp' <- addOneCheckpoint bin cp+                        segsarr <- getSegmentArray+                        let !mx' = if U.null segsarr then mx else max mx (snd (U.last segsarr))+                        return (M.insert (fromIntegral bin) segsarr im, cp', mx')+                (!cpts',!mx2) <- addManyCheckpoints (cpts,mx1)+                liftIO $ W.write rbins r bins >> W.write rckpts r cpts'+                return mx2+        liftM2 (BamIndex minshift depth mxR ()) (liftIO $ V.unsafeFreeze rbins) (liftIO $ V.unsafeFreeze rckpts)++-- | Reads the list of segments from an index file and makes sure+-- it is sorted.+getSegmentArray :: MonadIO m => P.Parser r m Segments+getSegmentArray = do+    nsegs <- fromIntegral `liftM` P.getWord32+    segsarr <- liftIO $ N.new nsegs+    loopM 0 nsegs $ \i -> do beg <- fromIntegral `liftM` P.getWord64+                             end <- fromIntegral `liftM` P.getWord64+                             liftIO $ N.write segsarr i (beg,end)+    liftIO $ N.sort segsarr >> U.unsafeFreeze segsarr++{-# INLINE reduceM #-}+reduceM :: (Monad m, Enum ix, Eq ix) => ix -> ix -> a -> (a -> ix -> m a) -> m a+reduceM beg end acc cons = if beg /= end then cons acc beg >>= \n -> reduceM (succ beg) end n cons else return acc++{-# INLINE loopM #-}+loopM :: (Monad m, Enum ix, Eq ix) => ix -> ix -> (ix -> m ()) -> m ()+loopM beg end k = if beg /= end then k beg >> loopM (succ beg) end k else return ()++{-| Seeks to a virtual offset in a BGZF file and streams from there.++If the optional end offset is supplied, streaming stops when it is+reached.  Else, streaming goes on to the end of file.+-}+streamBgzf :: MonadIO m => Handle -> Int64 -> Maybe Int64 -> ByteStream m ()+streamBgzf hdl off eoff =+    S.drop (off .&. 0xffff) . bgunzip $ do+        when (off /= 0) (liftIO $ hSeek hdl AbsoluteSeek $ fromIntegral $ shiftR off 16)+        maybe id S.trim eoff $ streamHandle hdl+{-# INLINE streamBgzf #-}++{- | Streams one reference from a bam file.++Seeks to a given sequence in a Bam file and enumerates only those+records aligning to that reference.  We use the first checkpoint+available for the sequence, which an appropriate index.  Streams the+'BamRaw' records of the correct reference sequence only, and produces an+empty stream if the sequence isn't found.+-}+streamBamRefseq :: MonadIO m => BamIndex b -> Handle -> Refseq -> Stream (Of BamRaw) m ()+streamBamRefseq BamIndex{..} hdl (Refseq r)+    | Just ckpts <- refseq_ckpoints V.!? fromIntegral r+    , Just (voff, _) <- M.minView ckpts+    , voff /= 0 = void $+                  Q.takeWhile ((Refseq r ==) . b_rname . unpackBam) $+                  Q.unfoldr (P.parseIO getBamRaw) $+                  streamBgzf hdl voff Nothing+    | otherwise = pure ()++{- | Reads from a Bam file the part with unaligned reads.++Sort of the dual to 'streamBamRefseq'.  Since the index does not+actually point to the unaligned part at the end, we use a best guess at+where the unaligned stuff might start, then skip over any aligned+records.  Our \"fallback guess\" is to decode from the current position;+this only works if something else already consumed the Bam header.+-}+streamBamUnaligned :: MonadIO m => BamIndex b -> Handle -> Stream (Of BamRaw) m ()+streamBamUnaligned BamIndex{..} hdl =+    Q.filter (not . isValidRefseq . b_rname . unpackBam) $+    Q.unfoldr (P.parseIO getBamRaw) $+    streamBgzf hdl unaln_off Nothing++{- | Streams one 'Segment'.++Takes a 'Handle', a 'Segment' and a 'Stream' coming from that handle.+If skipping ahead in the stream looks cheap enough, that is done.  Else+we seek the handle to the start offset and stream from it.  Either way,+the part of the stream before it crosses either the end offset or the+max position is returned, and the remaining stream after it is returned+in its functorial value so it can be passed to another invocation of+e.g. 'streamBamSegment'.  Note that the stream passed in becomes+unusable.+-}+streamBamSegment :: MonadIO m+                 => Handle -> Segment -> Stream (Of BamRaw) m ()+                 -> Stream (Of BamRaw) m (Stream (Of BamRaw) m ())+streamBamSegment hdl (Segment beg end mpos) =+    lift . Q.uncons >=> \case+        -- don't seek if it's a forwards seek of less than 512k+        Just (br,brs) | near (virt_offset br)+            -> Q.span in_seg $ Q.cons br brs+        _   -> Q.span in_seg $ Q.unfoldr (P.parseIO getBamRaw) $ streamBgzf hdl beg (Just end)+  where+    near    o = beg <= fromIntegral o && beg + 0x800000000 > fromIntegral o+    in_seg br = virt_offset br <= end && b_pos (unpackBam br) <= mpos++streamBamSubseq :: MonadIO m+                => BamIndex b -> Handle -> Refseq -> R.Subsequence -> Stream (Of BamRaw) m ()+                -> Stream (Of BamRaw) m (Stream (Of BamRaw) m ())+streamBamSubseq bi hdl ref subs str = Q.filter olap $ foldM (flip $ streamBamSegment hdl) str segs+  where+    segs = foldr (~~) [] $ segmentLists bi ref subs+    olap br = case unpackBam br of+        BamRec{..} -> b_rname == ref && R.overlaps b_pos (b_pos + alignedLength b_cigar) subs++streamBamRegions :: MonadIO m => BamIndex b -> Handle -> [R.Region] -> Stream (Of BamRaw) m ()+streamBamRegions bi hdl = void . foldM (\s (r,is) -> streamBamSubseq bi hdl r is s) (pure ()) . R.toList . R.fromList+

@@ -0,0 +1,475 @@+{-# LANGUAGE Rank2Types #-}++-- | Pileup, similar to Samtools+--+-- Pileup turns a sorted sequence of reads into a sequence of \"piles\",+-- one for each site where a genetic variant might be called.  We will+-- scan each read's CIGAR line and MD field in concert with the sequence+-- and effective quality.  Effective quality is the lowest available+-- quality score of QUAL, MAPQ, and BQ.  For aDNA calling, a base is+-- represented as four probabilities, derived from a position dependent+-- damage model.++module Bio.Bam.Pileup+    ( PrimChunks(..)+    , PrimBase(..)+    , PosPrimChunks+    , DamagedBase(..)+    , DmgToken(..)+    , dissect+    , CallStats(..)+    , V_Nuc(..)+    , V_Nucs(..)+    , IndelVariant(..)+    , BasePile+    , IndelPile+    , Pile'(..)+    , Pile+    , pileup+    ) where++import Bio.Bam.Header+import Bio.Bam.Rec+import Bio.Prelude+import Bio.Streaming++import qualified Data.ByteString        as B+import qualified Data.Vector.Generic    as V+import qualified Data.Vector.Storable   as U+import qualified Streaming.Prelude      as Q++-- | The primitive pieces for genotype calling:  A position, a base+-- represented as four likelihoods, an inserted sequence, and the+-- length of a deleted sequence.  The logic is that we look at a base+-- followed by some indel, and all those indels are combined into a+-- single insertion and a single deletion.+data PrimChunks = Seek {-# UNPACK #-} !Int PrimBase                   -- ^ skip to position (at start or after N operation)+                | Indel [Nucleotides] [DamagedBase] PrimBase          -- ^ observed deletion and insertion between two bases+                | EndOfRead                                           -- ^ nothing anymore+  deriving Show++data PrimBase = Base { _pb_wait   :: {-# UNPACK #-} !Int              -- ^ number of bases to wait due to a deletion+                     , _pb_base   :: {-# UNPACK #-} !DamagedBase+                     , _pb_mapq   :: {-# UNPACK #-} !Qual             -- ^ map quality+                     , _pb_chunks ::                 PrimChunks }     -- ^ more chunks+  deriving Show++type PosPrimChunks = (Refseq, Int, Bool, PrimChunks)++-- | Represents our knowledge about a certain base, which consists of+-- the base itself (A,C,G,T, encoded as 0..3; no Ns), the quality score+-- (anything that isn't A,C,G,T becomes A with quality 0), and a+-- substitution matrix representing post-mortem but pre-sequencing+-- substitutions.+--+-- Unfortunately, none of this can be rolled into something more simple,+-- because damage and sequencing error behave so differently.+--+-- Damage information is polymorphic.  We might run with a simple+-- version (a matrix) for calling, but we need more (a matrix and a+-- mutable matrix, I think) for estimation.++data DamagedBase = DB { db_call    :: {-# UNPACK #-} !Nucleotide           -- ^ called base+                      , db_qual    :: {-# UNPACK #-} !Qual                 -- ^ quality of called base+                      , db_dmg_tk  :: {-# UNPACK #-} !DmgToken             -- ^ damage information+                      , db_dmg_pos :: {-# UNPACK #-} !Int                  -- ^ damage information+                      , db_ref     :: {-# UNPACK #-} !Nucleotides }        -- ^ reference base from MD field++newtype DmgToken = DmgToken { fromDmgToken :: Int }++instance Show DamagedBase where+    showsPrec _ (DB n q _ _ r)+        | nucToNucs n == r = shows n .                     (:) '@' . shows q+        | otherwise        = shows n . (:) '/' . shows r . (:) '@' . shows q+++-- | Decomposes a BAM record into chunks suitable for piling up.  We+-- pick apart the CIGAR and MD fields, and combine them with sequence+-- and quality as appropriate.  Clipped bases are removed/skipped as+-- needed.  We also apply a substitution matrix to each base, which must+-- be supplied along with the read.+{-# INLINE dissect #-}+dissect :: DmgToken -> BamRaw -> [PosPrimChunks]+dissect dtok br =+    if isUnmapped b || isDuplicate b || not (isValidRefseq b_rname)+    then [] else [(b_rname, b_pos, isReversed b, pchunks)]+  where+    b@BamRec{..} = unpackBam br+    pchunks = firstBase b_pos 0 0 (fromMaybe [] $ getMd b)++    !max_cig = V.length b_cigar+    !max_seq = V.length b_seq+    !baq     = extAsString "BQ" b++    -- This will compute the effective quality.  As far as I can see+    -- from the BAM spec V1.4, the qualities that matter are QUAL, MAPQ,+    -- and BAQ.  If QUAL is invalid, we replace it (arbitrarily) with+    -- 23 (assuming a rather conservative error rate of ~0.5%), BAQ is+    -- added to QUAL, and MAPQ is an upper limit for effective quality.++    get_seq :: Int -> (Nucleotides -> Nucleotides) -> DamagedBase+    get_seq i f = case b_seq `V.unsafeIndex` i of                                -- nucleotide+            n | n == nucsA -> DB nucA qe dtok dmg (f n)+              | n == nucsC -> DB nucC qe dtok dmg (f n)+              | n == nucsG -> DB nucG qe dtok dmg (f n)+              | n == nucsT -> DB nucT qe dtok dmg (f n)+              | otherwise  -> DB nucA (Q 0) dtok dmg (f n)+      where+        !q   = case b_qual `V.unsafeIndex` i of Q 0xff -> Q 30 ; x -> x         -- quality; invalid (0xff) becomes 30+        !q'  | i >= B.length baq = q                                            -- no BAQ available+             | otherwise = Q (unQ q + (B.index baq i - 64))                     -- else correct for BAQ+        !qe  = min q' b_mapq                                                    -- use MAPQ as upper limit+        !dmg = if i+i > max_seq then i-max_seq else i++    -- Look for first base following the read's start or a gap (CIGAR+    -- code N).  Indels are skipped, since these are either bugs in the+    -- aligner or the aligner getting rid of essentially unalignable+    -- bases.+    firstBase :: Int -> Int -> Int -> [MdOp] -> PrimChunks+    firstBase !pos !is !ic mds+        | is >= max_seq || ic >= max_cig = EndOfRead+        | otherwise = case b_cigar `V.unsafeIndex` ic of+            Ins :* cl ->            firstBase  pos (cl+is) (ic+1) mds+            SMa :* cl ->            firstBase  pos (cl+is) (ic+1) mds+            Del :* cl ->            firstBase (pos+cl) is  (ic+1) (drop_del cl mds)+            Nop :* cl ->            firstBase (pos+cl) is  (ic+1) mds+            HMa :*  _ ->            firstBase  pos     is  (ic+1) mds+            Pad :*  _ ->            firstBase  pos     is  (ic+1) mds+            Mat :*  0 ->            firstBase  pos     is  (ic+1) mds+            Mat :*  _ -> Seek pos $ nextBase 0 pos     is   ic 0  mds+      where+        -- We have to treat (MdNum 0), because samtools actually+        -- generates(!) it all over the place and if not handled as a+        -- special case, it looks like an inconsistent MD field.+        drop_del n (MdDel ns : mds')+            | n < length ns = MdDel (drop n ns) : mds'+            | n > length ns = drop_del (n - length ns) mds'+            | otherwise     = mds'+        drop_del n (MdNum 0 : mds') = drop_del n mds'+        drop_del _ mds'     = mds'++    -- Generate likelihoods for the next base.  When this gets called,+    -- we are looking at an M CIGAR operation and all the subindices are+    -- valid.+    -- I don't think we can ever get (MdDel []), but then again, who+    -- knows what crazy shit samtools decides to generate.  There is+    -- little harm in special-casing it.+    nextBase :: Int -> Int -> Int -> Int -> Int -> [MdOp] -> PrimBase+    nextBase !wt !pos !is !ic !io mds = case mds of+        MdNum   0 : mds' -> nextBase wt pos is ic io mds'+        MdDel  [] : mds' -> nextBase wt pos is ic io mds'+        MdNum   1 : mds' -> nextBase' (get_seq is id   ) mds'+        MdNum   n : mds' -> nextBase' (get_seq is id   ) (MdNum (n-1) : mds')+        MdRep ref : mds' -> nextBase' (get_seq is $ const ref  ) mds'+        MdDel   _ : _    -> nextBase' (get_seq is $ const nucsN) mds+        [              ] -> nextBase' (get_seq is $ const nucsN) [ ]+      where+        nextBase' ref mds' = Base wt ref b_mapq $ nextIndel  [] [] (pos+1) (is+1) ic (io+1) mds'++    -- Look for the next indel after a base.  We collect all indels (I+    -- and D codes) into one combined operation.  If we hit N or the+    -- read's end, we drop all of it (indels next to a gap indicate+    -- trouble).  Other stuff is skipped: we could check for stuff that+    -- isn't valid in the middle of a read (H and S), but then what+    -- would we do about it anyway?  Just ignoring it is much easier and+    -- arguably at least as correct.+    nextIndel :: [[DamagedBase]] -> [Nucleotides] -> Int -> Int -> Int -> Int -> [MdOp] -> PrimChunks+    nextIndel ins del !pos !is !ic !io mds+        | is >= max_seq || ic >= max_cig = EndOfRead+        | otherwise = case b_cigar `V.unsafeIndex` ic of+            Ins :* cl ->             nextIndel (isq cl) del   pos (cl+is) (ic+1) 0 mds+            SMa :* cl ->             nextIndel  ins     del   pos (cl+is) (ic+1) 0 mds+            Del :* cl ->             nextIndel ins (del++dsq) (pos+cl) is (ic+1) 0 mds'+                where (dsq,mds') = split_del cl mds+            Pad :*  _ ->             nextIndel  ins     del   pos     is  (ic+1) 0 mds+            HMa :*  _ ->             nextIndel  ins     del   pos     is  (ic+1) 0 mds+            Nop :* cl ->             firstBase               (pos+cl) is  (ic+1)   mds      -- ends up generating a 'Seek'+            Mat :* cl | io == cl  -> nextIndel  ins     del   pos     is  (ic+1) 0 mds+                      | otherwise -> indel del out $ nextBase (length del) pos is ic io mds -- ends up generating a 'Base'+      where+        indel d o k = foldr seq (Indel d o k) o+        out    = concat $ reverse ins+        isq cl = [ get_seq i $ const gap | i <- [is..is+cl-1] ] : ins++        -- We have to treat (MdNum 0), because samtools actually+        -- generates(!) it all over the place and if not handled as a+        -- special case, it looks like an incinsistend MD field.+        split_del n (MdDel ns : mds')+            | n < length ns = (take n ns, MdDel (drop n ns) : mds')+            | n > length ns = let (ns', mds'') = split_del (n - length ns) mds' in (ns++ns', mds'')+            | otherwise     = (ns, mds')+        split_del n (MdNum 0 : mds') = split_del n mds'+        split_del n mds'    = (replicate n nucsN, mds')++-- | Statistics about a genotype call.  Probably only useful for+-- filtering (so not very useful), but we keep them because it's easy to+-- track them.++data CallStats = CallStats+    { read_depth       :: {-# UNPACK #-} !Int       -- number of contributing reads+    , reads_mapq0      :: {-# UNPACK #-} !Int       -- number of (non-)contributing reads with MAPQ==0+    , sum_mapq         :: {-# UNPACK #-} !Int       -- sum of map qualities of contributing reads+    , sum_mapq_squared :: {-# UNPACK #-} !Int }     -- sum of squared map qualities of contributing reads+  deriving (Show, Eq, Generic)++instance Monoid CallStats where+    mempty      = CallStats { read_depth       = 0+                            , reads_mapq0      = 0+                            , sum_mapq         = 0+                            , sum_mapq_squared = 0 }+    mappend     = (<>)++instance Semigroup CallStats where+    x <> y = CallStats { read_depth       = read_depth x + read_depth y+                       , reads_mapq0      = reads_mapq0 x + reads_mapq0 y+                       , sum_mapq         = sum_mapq x + sum_mapq y+                       , sum_mapq_squared = sum_mapq_squared x + sum_mapq_squared y }++newtype V_Nuc  = V_Nuc  (U.Vector Nucleotide)  deriving (Eq, Ord, Show)+newtype V_Nucs = V_Nucs (U.Vector Nucleotides) deriving (Eq, Ord, Show)++data IndelVariant = IndelVariant { deleted_bases  :: !V_Nucs, inserted_bases :: !V_Nuc }+      deriving (Eq, Ord, Show, Generic)+++-- | Map quality and a list of encountered bases, with damage+-- information and reference base if known.+type BasePile  =                          [DamagedBase]++-- | Map quality and a list of encountered indel variants.  The deletion+-- has the reference sequence, if known, an insertion has the inserted+-- sequence with damage information.+type IndelPile = [( Qual, ([Nucleotides], [DamagedBase]) )]   -- a list of indel variants++-- | Running pileup results in a series of piles.  A 'Pile' has the+-- basic statistics of a 'VarCall', but no likelihood values and a+-- pristine list of variants instead of a proper call.  We emit one pile+-- with two 'BasePile's (one for each strand) and one 'IndelPile' (the+-- one immediately following) at a time.++data Pile' a b = Pile { p_refseq     :: {-# UNPACK #-} !Refseq+                      , p_pos        :: {-# UNPACK #-} !Int+                      , p_snp_stat   :: {-# UNPACK #-} !CallStats+                      , p_snp_pile   :: a+                      , p_indel_stat :: {-# UNPACK #-} !CallStats+                      , p_indel_pile :: b }+  deriving Show++-- | Raw pile.  Bases and indels are piled separately on forward and+-- backward strands.+type Pile = Pile' (BasePile, BasePile) (IndelPile, IndelPile)++-- | The pileup enumeratee takes 'BamRaw's, dissects them, interleaves+-- the pieces appropriately, and generates 'Pile's.  The output will+-- contain at most one 'BasePile' and one 'IndelPile' for each position,+-- piles are sorted by position.+--+-- This top level driver receives 'BamRaw's.  Unaligned reads and+-- duplicates are skipped (but not those merely failing quality checks).+-- Processing stops when the first read with invalid 'br_rname' is+-- encountered or a t end of file.++{-# INLINE pileup #-}+pileup :: Stream (Of PosPrimChunks) IO b -> Stream (Of Pile) IO b+pileup = runPileM pileup' finish (Refseq 0) 0 ([],[]) (Empty,Empty)+  where+    finish () _ _ ([],[]) (Empty,Empty) inp = lift (Q.effects inp)+    finish () _ _ _ _ _ = error "logic error: leftovers after pileup"+++-- | The pileup logic keeps a current coordinate (just two integers) and+-- two running queues: one of /active/ 'PrimBase's that contribute to+-- current genotype calling and on of /waiting/ 'PrimBase's that will+-- contribute at a later point.+--+-- This is the CPS version of multiple state and environment monads.  It+-- is somewhat faster than direct style and gives more control over when+-- evaluation happens.++newtype PileM m a = PileM { runPileM :: forall r . (a -> PileF m r) -> PileF m r }++-- | The things we drag along in 'PileM'.  Notes:+-- * The /active/ queue is a simple stack.  We add at the front when we+--   encounter reads, which reverses them.  When traversing it, we traverse+--   reads backwards, but since we accumulate the 'BasePile', it gets reversed+--   back.  The new /active/ queue, however, is no longer reversed (as it should+--   be).  So after the traversal, we reverse it again.  (Yes, it is harder to+--   understand than using a proper deque type, but it is cheaper.+--   There may not be much point in the reversing, though.)++type PileF m r = Refseq -> Int ->                               -- current position+                 ( [PrimBase], [PrimBase] ) ->                  -- active queues+                 ( Heap, Heap ) ->                              -- waiting queues+                 Stream (Of PosPrimChunks) m r ->               -- input stream+                 Stream (Of Pile) m r                           -- output stream++instance Functor (PileM m) where+    {-# INLINE fmap #-}+    fmap f (PileM m) = PileM $ \k -> m (k . f)++instance Applicative (PileM m) where+    {-# INLINE pure #-}+    pure a = PileM $ \k -> k a+    {-# INLINE (<*>) #-}+    u <*> v = PileM $ \k -> runPileM u (\a -> runPileM v (k . a))++instance Monad (PileM m) where+    {-# INLINE return #-}+    return a = PileM $ \k -> k a+    {-# INLINE (>>=) #-}+    m >>=  k = PileM $ \k' -> runPileM m (\a -> runPileM (k a) k')++--  -- XXX+-- {-# INLINE get_refseq #-}+-- get_refseq :: PileM m Refseq+-- get_refseq = PileM $ \k r -> k r r++-- {-# INLINE get_pos #-}+-- get_pos :: PileM m Int+-- get_pos = PileM $ \k r p -> k p r p++{-# INLINE upd_pos #-}+upd_pos :: (Int -> Int) -> PileM m ()+upd_pos f = PileM $ \k r p -> k () r $! f p++{-# INLINE yieldPile #-}+yieldPile :: Monad m => CallStats -> BasePile -> BasePile -> CallStats -> IndelPile -> IndelPile -> PileM m ()+yieldPile x1 x2a x2b x3 x4a x4b = PileM $ \ !kont !r !p !a !w !inp ->+    let pile = Pile r p x1 (x2a,x2b) x3 (x4a,x4b)+    in Q.cons pile $ kont () r p a w inp++-- | The actual pileup algorithm.  If /active/ contains something,+-- continue here.  Else find the coordinate to continue from, which is+-- the minimum of the next /waiting/ coordinate and the next coordinate+-- in input; if found, continue there, else we're all done.+pileup' :: Monad m => PileM m ()+pileup' = PileM $ \ !k !refseq !pos !active !waiting inp0 -> do++    inp <- lift $ inspect inp0+    let inp1        = either pure wrap inp+        cont2 rs po = runPileM pileup'' k     rs po  active waiting inp1+        leave       =                k () refseq pos active waiting inp1++    case (active, getMinKeysH waiting, inp) of+        ( (_:_,_),       _,                   _  ) -> cont2 refseq pos+        ( (_,_:_),       _,                   _  ) -> cont2 refseq pos+        (    _,    Just nw, Left              _  ) -> cont2 refseq nw+        (    _,    Nothing, Left              _  ) -> leave+        (    _,    Nothing, Right ((r,p,_,_):>_) ) -> cont2 r p+        (    _,    Just nw, Right ((r,p,_,_):>_) )+                            | (refseq,nw) <= (r,p) -> cont2 refseq nw+                            | otherwise            -> cont2 r p+  where+    getMinKeysH :: (Heap, Heap) -> Maybe Int+    getMinKeysH (a,b) = case (getMinKeyH a, getMinKeyH b) of+        ( Nothing, Nothing ) -> Nothing+        ( Just  x, Nothing ) -> Just  x+        ( Nothing, Just  y ) -> Just  y+        ( Just  x, Just  y ) -> Just (min x y)+++pileup'' :: Monad m => PileM m ()+pileup'' = do+    -- Input is still 'BamRaw', since these can be relied on to be+    -- sorted.  First see if there is any input at the current location,+    -- if so, dissect it and add it to the appropriate queue.+    p'feed_input+    p'check_waiting+    ((fin_bsL, fin_bpL), (fin_bsR, fin_bpR), (fin_isL, fin_ipL), (fin_isR, fin_ipR)) <- p'scan_active++    -- Output, but don't bother emitting empty piles.  Note that a plain+    -- basecall still yields an entry in the 'IndelPile'.  This is necessary,+    -- because actual indel calling will want to know how many reads /did not/+    -- show the variant.  However, if no reads show any variant, and here is the+    -- first place where we notice that, the pile is useless.+    let uninteresting (_,(d,i)) = null d && null i+    unless (null fin_bpL && null fin_bpR && all uninteresting fin_ipL && all uninteresting fin_ipR) $+        yieldPile (fin_bsL <> fin_bsR) fin_bpL fin_bpR+                  (fin_isL <> fin_isR) fin_ipL fin_ipR++    -- Bump coordinate and loop.  (Note that the bump to the next+    -- reference /sequence/ is done implicitly, because we will run out of+    -- reads and restart in 'pileup''.)+    upd_pos succ+    pileup'++-- | Feeds input as long as it starts at the current position+p'feed_input :: Monad m => PileM m ()+p'feed_input = PileM $ \kont rs po ac@(af,ar) wt@(wf,wr) ->+    lift . inspect >=> \case+        Right ((rs', po', str, prim) :> bs)+            | rs == rs' && po == po' ->+                case prim of+                    EndOfRead     -> runPileM p'feed_input kont rs po ac wt                                       bs+                    Indel _ _ !pb -> runPileM p'feed_input kont rs po (if str then (af,pb:ar) else (pb:af,ar)) wt bs+                    Seek   !p !pb -> runPileM p'feed_input kont rs po ac (if str then (wf,wr') else (wf',wr))     bs+                      where wf' = Node p pb Empty Empty `unionH` wf+                            wr' = Node p pb Empty Empty `unionH` wr+        inp -> kont () rs po ac wt $ either pure wrap inp++-- | Checks /waiting/ queue.  If there is anything waiting for the+-- current position, moves it to /active/ queue.+p'check_waiting :: PileM m ()+p'check_waiting = PileM $ \kont rs po (af0,ar0) (wf0,wr0) ->+        let go1 af wf = case viewMinH wf of+                Just (!mk, !pb, !wf') | mk == po -> go1 (pb:af) wf'+                _                                -> go2 af wf ar0 wr0++            go2 af wf ar wr = case viewMinH wr of+                Just (!mk, !pb, !wr') | mk == po -> go2 af wf (pb:ar) wr'+                _                                -> kont () rs po (af,ar) (wf,wr)++        in go1 af0 wf0+++-- | Separately scans the two /active/ queues and makes one 'BasePile'+-- from each.  Also sees what's next in the 'PrimChunks':  'Indel's+-- contribute to two separate 'IndelPile's, 'Seek's are pushed back to+-- the /waiting/ queue, 'EndOfRead's are removed, and everything else is+-- added to two fresh /active/ queues.+p'scan_active :: PileM m (( CallStats, BasePile ),  ( CallStats, BasePile ),+                          ( CallStats, IndelPile ), ( CallStats, IndelPile ))+p'scan_active = do+    (bpf,ipf) <- PileM $ \kont rs pos (af,ar) (wf,wr) -> go (\r af' wf' -> kont r rs pos (af',ar) (wf',wr)) [] wf mempty mempty af+    (bpr,ipr) <- PileM $ \kont rs pos (af,ar) (wf,wr) -> go (\r ar' wr' -> kont r rs pos (af,ar') (wf,wr')) [] wr mempty mempty ar+    return (bpf,bpr,ipf,ipr)+  where+    go k !ac !wt !bpile !ipile [                           ] = k (bpile, ipile) (reverse ac) wt+    go k !ac !wt !bpile !ipile (Base nwt qs mq pchunks : bs) =+        case pchunks of+            _ | nwt > 0     -> b' `seq` go k  (b':ac)   wt     bpile     ipile  bs+            Seek p' pb'     -> go k      ac (ins p' pb' wt) (z bpile)    ipile  bs+            Indel nd ni pb' -> go k (pb':ac)            wt  (z bpile) (y ipile) bs where y = put (,) mq (nd,ni)+            EndOfRead       -> go k      ac             wt  (z bpile)    ipile  bs+        where+            b' = Base (nwt-1) qs mq pchunks+            z  = put (\q x -> x { db_qual = min q (db_qual x) }) mq qs++    ins q v w = Node q v Empty Empty `unionH` w++    put f (Q !q) !x (!st,!vs) = ( st { read_depth       = read_depth st + 1+                                     , reads_mapq0      = reads_mapq0 st + (if q == 0 then 1 else 0)+                                     , sum_mapq         = sum_mapq st + fromIntegral q+                                     , sum_mapq_squared = sum_mapq_squared st + fromIntegral q * fromIntegral q }+                                , f (Q q) x : vs )+++-- | We need a simple priority queue.  Here's a skew heap (specialized+-- to strict 'Int' priorities and 'PrimBase' values).+data Heap = Empty | Node {-# UNPACK #-} !Int PrimBase Heap Heap++unionH :: Heap -> Heap -> Heap+Empty                 `unionH` t2                    = t2+t1                    `unionH` Empty                 = t1+t1@(Node k1 x1 l1 r1) `unionH` t2@(Node k2 x2 l2 r2)+   | k1 <= k2                                        = Node k1 x1 (t2 `unionH` r1) l1+   | otherwise                                       = Node k2 x2 (t1 `unionH` r2) l2++getMinKeyH :: Heap -> Maybe Int+getMinKeyH Empty          = Nothing+getMinKeyH (Node x _ _ _) = Just x++viewMinH :: Heap -> Maybe (Int, PrimBase, Heap)+viewMinH Empty          = Nothing+viewMinH (Node k v l r) = Just (k, v, l `unionH` r)+

@@ -0,0 +1,261 @@+-- | Parsers for BAM and SAM.++module Bio.Bam.Reader (+    decodeBam,+    decodeBamFile,+    decodeBamFiles,++    decodePlainBam,+    decodePlainSam,+    getBamMeta,+    getBamRaw,+    getSamRec,++    concatInputs,+    mergeInputsOn,+    guardRefCompat,+    coordinates,+    qnames+                      ) where++import Bio.Bam.Header+import Bio.Bam.Rec+import Bio.Bam.Writer               ( packBam )+import Bio.Streaming+import Bio.Streaming.Bgzf           ( getBgzfHdr, bgunzip )+import Bio.Prelude+import Data.Attoparsec.ByteString   ( anyWord8 )++import qualified Data.Attoparsec.ByteString.Char8   as P+import qualified Data.ByteString                    as B+import qualified Data.ByteString.Char8              as C+import qualified Data.HashMap.Strict                as M+import qualified Data.Vector.Generic                as V+import qualified Data.Vector.Storable               as W+import qualified Data.Vector.Unboxed                as U+import qualified Bio.Streaming.Bytes                as S+import qualified Bio.Streaming.Parse                as S+import qualified Streaming.Prelude                  as Q++{- | Decodes either BAM or SAM.++The input can be plain, gzip'ed or bgzf'd and either BAM or SAM.  BAM+is reliably recognized, anything else is treated as SAM.  The offsets+stored in BAM records make sense only for uncompressed or bgzf'd BAM.+-}+decodeBam :: MonadIO m+          => S.ByteStream m r+          -> m (BamMeta, Stream (Of BamRaw) m r)+decodeBam = getBgzfHdr >=> S.splitAt' 4 . pgunzip >=> unbam+  where+    unbam ("BAM\SOH" :> s) = decodePlainBam s+    unbam (magic     :> s) = decodePlainSam (S.consChunk magic s)++    pgunzip (Nothing, hdr, s) = S.gunzip (S.consChunk hdr s)+    pgunzip (Just _,  hdr, s) =  bgunzip (S.consChunk hdr s)+{-# INLINE decodeBam #-}++decodeBamFile :: (MonadIO m, MonadMask m) => FilePath -> (BamMeta -> Stream (Of BamRaw) m () -> m r) -> m r+decodeBamFile f k = streamFile f $ decodeBam >=> uncurry k+{-# INLINE decodeBamFile #-}++{- | Reads multiple bam files.++A continuation is run on the list of headers and streams.  Since no+attempt is made to unify the headers, this will work for completely+unrelated bam files.  All files are opened at the same time, which might+run into the file descriptor limit given some ridiculous workflows.+-}+decodeBamFiles :: (MonadMask m, MonadIO m) => [FilePath] -> ([(BamMeta, Stream (Of BamRaw) m ())] -> m r) -> m r+decodeBamFiles [      ] k = k []+decodeBamFiles ("-":fs) k = decodeBam (streamHandle stdin)   >>= \b -> decodeBamFiles fs $ \bs -> k (b:bs)+decodeBamFiles ( f :fs) k = streamFile f $ \s -> decodeBam s >>= \b -> decodeBamFiles fs $ \bs -> k (b:bs)+{-# INLINE decodeBamFiles #-}++decodePlainBam :: MonadIO m => S.ByteStream m r -> m (BamMeta, Stream (Of BamRaw) m r)+decodePlainBam =+    S.parseIO (const getBamMeta) >=>+    either (const . liftIO $ throwM S.EofException)+           (return . fmap (Q.unfoldr (S.parseIO getBamRaw)))++getBamMeta :: Monad m => S.Parser r m BamMeta+getBamMeta = liftM2 mmerge get_bam_header get_ref_array+  where+    get_bam_header  = do hdr_len <- S.getWord32+                         S.isolate (fromIntegral hdr_len) (S.atto parseBamMeta)++    get_ref_array = do nref <- S.getWord32+                       V.fromList `liftM` replicateM (fromIntegral nref)+                            (do nm <- S.getWord32 >>= S.getString . fromIntegral+                                ln <- S.getWord32+                                return $! BamSQ (C.init nm) (fromIntegral ln) [])++    -- Need to merge information from header into actual reference list.+    -- The latter is the authoritative source for the *order* of the+    -- sequences, so leftovers from the header are discarded.  Merging+    -- is by name.  So we merge information from the header into the+    -- list, then replace the header information.+    mmerge meta refs =+        let tbl = M.fromList [ (sq_name sq, sq) | sq <- V.toList (unRefs (meta_refs meta)) ]+        in meta { meta_refs = Refs $ fmap (\s -> maybe s (mmerge' s) (M.lookup (sq_name s) tbl)) refs }++    mmerge' l r | sq_length l == sq_length r = l { sq_other_shit = sq_other_shit l ++ sq_other_shit r }+                | otherwise                  = l -- contradiction in header, but we'll just ignore it+{-# INLINABLE getBamMeta #-}+++data ShortRecord = ShortRecord deriving Typeable++instance Exception ShortRecord+instance Show ShortRecord where show _ = "short BAM record"++getBamRaw :: Monad m => Int64 -> S.Parser r m BamRaw+getBamRaw o = do+        bsize <- fromIntegral `liftM` S.getWord32+        when (bsize < 32) $ throwM ShortRecord+        s <- S.getString bsize+        unless (B.length s == bsize) S.abortParse+        return $ bamRaw o s+{-# INLINABLE getBamRaw #-}++{- | Streaming parser for SAM files.++It parses plain uncompressed SAM+and returns a result compatible with 'decodePlainBam'.  Since it is+supposed to work the same way as the BAM parser, it requires a+symbol table for the reference names.  This is extracted from the @SQ+lines in the header.  Note that reading SAM tends to be inefficient;+if you care about performance at all, use BAM.+-}+decodePlainSam :: MonadIO m => S.ByteStream m r -> m (BamMeta, Stream (Of BamRaw) m r)+decodePlainSam s = do+    (hdr,rest) <- either (\r -> (mempty, pure r)) id `liftM` S.parseIO (const $ S.atto parseBamMeta) s+    let !refs = M.fromList $ zip [ nm | BamSQ { sq_name = nm } <- V.toList (unRefs (meta_refs hdr))] [toEnum 0..]+        ref x = M.lookupDefault invalidRefseq x refs+    return (hdr, Q.mapM (liftIO . either throwM packBam . getSamRec ref) (S.lines' rest))+++getSamRec :: (Bytes -> Refseq) -> Bytes -> Either S.ParseError BamRec+getSamRec ref s = case P.parseOnly record s of+    Left  e -> Left $ S.ParseError [unpack s] e+    Right b -> Right b+  where+    record = do b_qname <- word+                b_flag  <- num+                b_rname <- ref <$> word+                b_pos   <- subtract 1 <$> num+                b_mapq  <- Q <$> num'+                b_cigar <- W.fromList <$> cigar+                b_mrnm  <- rnext <*> pure b_rname+                b_mpos  <- subtract 1 <$> num+                b_isize <- snum+                b_seq   <- sequ+                b_qual  <- quals <*> pure b_seq+                b_exts  <- exts+                let b_virtual_offset = 0+                return BamRec{..}++    sep      = P.endOfInput <|> () <$ P.char '\t'+    word     = P.takeTill ('\t' ==) <* sep+    num      = P.decimal <* sep+    num'     = P.decimal <* sep+    snum     = P.signed P.decimal <* sep++    rnext    = id <$ P.char '=' <* sep <|> const . ref <$> word+    sequ     = (V.empty <$ P.char '*' <|>+               V.fromList . map toNucleotides . C.unpack <$> P.takeWhile is_nuc) <* sep++    quals    = defaultQs <$ P.char '*' <* sep <|> bsToVec <$> word+        where+            defaultQs sq = W.replicate (V.length sq) (Q 0xff)+            bsToVec qs _ = W.fromList . map (Q . subtract 33) $ B.unpack qs++    cigar    = [] <$ P.char '*' <* sep <|>+               P.manyTill (flip (:*) <$> P.decimal <*> cigop) sep++    cigop    = P.choice $ zipWith (\c r -> r <$ P.char c) "MIDNSHP" [Mat,Ins,Del,Nop,SMa,HMa,Pad]+    exts     = ext `P.sepBy` sep+    ext      = (\a b v -> (fromString [a,b],v)) <$> P.anyChar <*> P.anyChar <*> (P.char ':' *> value)++    value    = P.char 'A' *> P.char ':' *> (Char <$>               anyWord8) <|>+               P.char 'i' *> P.char ':' *> (Int  <$>     P.signed P.decimal) <|>+               P.char 'Z' *> P.char ':' *> (Text <$>   P.takeTill ('\t' ==)) <|>+               P.char 'H' *> P.char ':' *> (Bin  <$>               hexarray) <|>+               P.char 'f' *> P.char ':' *> (Float . realToFrac <$> P.double) <|>+               P.char 'B' *> P.char ':' *> (+                    P.satisfy (P.inClass "cCsSiI") *> (intArr   <$> many (P.char ',' *> P.signed P.decimal)) <|>+                    P.char 'f'                     *> (floatArr <$> many (P.char ',' *> P.double)))++    intArr   is = IntArr   $ U.fromList is+    floatArr fs = FloatArr $ U.fromList $ map realToFrac fs+    hexarray    = B.pack . repack . C.unpack <$> P.takeWhile (P.inClass "0-9A-Fa-f")+    repack (a:b:cs) = fromIntegral (digitToInt a * 16 + digitToInt b) : repack cs ; repack _ = []+    is_nuc = P.inClass "acgtswkmrybdhvnACGTSWKMRYBDHVN"+++data IncompatibleRefs = IncompatibleRefs FilePath FilePath deriving Typeable++instance Exception IncompatibleRefs+instance Show IncompatibleRefs where+    show (IncompatibleRefs a b) = "references in " ++ a ++ " and " ++ b ++ " are incompatible"++guardRefCompat :: MonadThrow m => (FilePath,BamMeta) -> (FilePath,BamMeta) -> m ()+guardRefCompat (f0,hdr0) (f1,hdr1) =+    unless (p hdr1 `isPrefixOf` p hdr0) $ throwM $ IncompatibleRefs f0 f1+  where+    p = V.toList . unRefs . meta_refs+++{- | Reads multiple bam inputs in sequence.++Only one file is opened at a time, so they must also be consumed in+sequence.  If you can afford to open all inputs simultaneously, you+probably want to use 'mergeInputsOn' instead.  The filename \"-\" refers+to stdin, if no filenames are given, stdin is read.  Since we can't look+ahead into further files, the header of the first input is used+for the result, and an exception is thrown if one of the subsequent+headers is incompatible with the first one.+-}+concatInputs :: (MonadIO m, MonadMask m) => [FilePath] -> (BamMeta -> Stream (Of BamRaw) m () -> m r) -> m r+concatInputs fs0 k = streamInputs fs0 (go1 $ fs0 ++ repeat "-")+  where+    go1 fs = inspect >=> \case+        Left () -> k mempty (pure ())+        Right s -> do (hdr,bs) <- decodeBam s+                      k hdr (bs >>= go (head fs) hdr (tail fs))++    go f0 hdr0 fs = lift . inspect >=> \case+        Left () -> pure ()+        Right s -> do (hdr,bs) <- lift $ decodeBam s+                      lift $ guardRefCompat (f0,hdr0) (head fs,hdr)+                      bs >>= go f0 hdr0 (tail fs)+{-# INLINABLE concatInputs #-}++{- | Reads multiple bam files and merges them.++If the inputs are all sorted by the thing being merged on, the output+will be sorted, too.  The headers are all merged sensibly, even if their+reference lists differ.  However, for performance reasons, we don't want+to change the rname and mrnm fields in potentially all records.  So+instead of allowing arbitrary reference lists to be merged, we throw an+exception unless every input is compatible with the effective reference+list.+-}+mergeInputsOn :: (Ord x, MonadIO m, MonadMask m)+              => (BamRaw -> x) -> [FilePath]+              -> (BamMeta -> Stream (Of BamRaw) m () -> m r) -> m r+mergeInputsOn _ [] k = decodeBam (streamHandle stdin) >>= uncurry k+mergeInputsOn p fs k = decodeBamFiles fs $ \bs -> do+    let hdr = foldMap fst bs+    sequence_ $ zipWith (\f (h,_) -> guardRefCompat ("*",hdr) (f,h)) fs bs+    k hdr (foldr (\a b -> void $ mergeStreamsOn p (snd a) b) (pure ()) bs)+{-# INLINABLE mergeInputsOn #-}++coordinates :: BamRaw -> (Refseq, Int)+coordinates = (b_rname &&& b_pos) . unpackBam+{-# INLINE coordinates #-}++qnames :: BamRaw -> Bytes+qnames = b_qname . unpackBam+{-# INLINE qnames #-}+

@@ -0,0 +1,378 @@+{-# LANGUAGE TypeFamilies #-}+-- | Parsers and Printers for BAM and SAM.++module Bio.Bam.Rec (+    BamRaw,+    bamRaw,+    virt_offset,+    raw_data,++    BamRec(..),+    unpackBam,+    nullBamRec,+    getMd,++    Cigar(..),+    CigOp(..),+    alignedLength,++    Nucleotides(..), Vector_Nucs_half,+    Extensions, Ext(..),+    extAsInt, extAsString, setQualFlag,+    deleteE, insertE, updateE, adjustE,++    isPaired,+    isProperlyPaired,+    isUnmapped,+    isMateUnmapped,+    isReversed,+    isMateReversed,+    isFirstMate,+    isSecondMate,+    isAuxillary,+    isSecondary,+    isFailsQC,+    isDuplicate,+    isSupplementary,+    isTrimmed,+    isMerged,+    isAlternative,+    isExactIndex,+    type_mask+) where++import Bio.Bam.Header+import Bio.Prelude+import Bio.Util.Storable++import Control.Monad.Primitive      ( unsafePrimToPrim, unsafeInlineIO )+import Foreign.C.Types              ( CInt(..), CSize(..) )+import Foreign.Marshal.Alloc        ( alloca )++import qualified Data.ByteString                    as B+import qualified Data.ByteString.Char8              as S+import qualified Data.ByteString.Internal           as B+import qualified Data.ByteString.Unsafe             as B+import qualified Data.Vector.Generic                as V+import qualified Data.Vector.Generic.Mutable        as VM+import qualified Data.Vector.Storable               as VS+import qualified Data.Vector.Unboxed                as U+++-- | Cigar line in BAM coding+-- Bam encodes an operation and a length into a single integer, we keep+-- those integers in an array.+data Cigar = !CigOp :* !Int deriving (Eq, Ord)+infix 9 :*++data CigOp = Mat | Ins | Del | Nop | SMa | HMa | Pad+    deriving ( Eq, Ord, Enum, Show, Bounded, Ix )++instance Show Cigar where+    showsPrec _ (op :* num) = shows num . (:) (S.index "MIDNSHP" (fromEnum op))++instance Storable Cigar where+    sizeOf    _ = 4+    alignment _ = 1++    peek p = do w <- fromIntegral <$> peekUnalnWord32LE p+                return $ toEnum (w .&. 0xf) :* shiftR w 4++    poke p (op :* num) = pokeUnalnWord32LE p . fromIntegral $ fromEnum op .|. shiftL num 4+++-- | Extracts the aligned length from a cigar line.+-- This gives the length of an alignment as measured on the reference,+-- which is different from the length on the query or the length of the+-- alignment.+{-# INLINE alignedLength #-}+alignedLength :: V.Vector v Cigar => v Cigar -> Int+alignedLength = V.foldl' (\a -> (a +) . l) 0+  where l (op :* n) = if op == Mat || op == Del || op == Nop then n else 0+++-- | internal representation of a BAM record+data BamRec = BamRec {+        b_qname :: Bytes,+        b_flag  :: Int,+        b_rname :: Refseq,+        b_pos   :: Int,+        b_mapq  :: Qual,+        b_cigar :: VS.Vector Cigar,+        b_mrnm  :: Refseq,+        b_mpos  :: Int,+        b_isize :: Int,+        b_seq   :: Vector_Nucs_half Nucleotides,+        b_qual  :: VS.Vector Qual,+        b_exts  :: Extensions,+        b_virtual_offset :: Int64 -- ^ virtual offset for indexing purposes+    } deriving Show++nullBamRec :: BamRec+nullBamRec = BamRec {+        b_qname = S.empty,+        b_flag  = flagUnmapped,+        b_rname = invalidRefseq,+        b_pos   = invalidPos,+        b_mapq  = Q 0,+        b_cigar = VS.empty,+        b_mrnm  = invalidRefseq,+        b_mpos  = invalidPos,+        b_isize = 0,+        b_seq   = V.empty,+        b_qual  = VS.empty,+        b_exts  = [],+        b_virtual_offset = 0+    }++getMd :: BamRec -> Maybe [MdOp]+getMd r = case lookup "MD" $ b_exts r of+    Just (Text mdfield) -> readMd mdfield+    Just (Char mdfield) -> readMd $ B.singleton mdfield+    _                   -> Nothing++-- | A vector that packs two 'Nucleotides' into one byte, just like Bam does.+data Vector_Nucs_half a = Vector_Nucs_half !Int !Int !(ForeignPtr Word8)++-- | A mutable vector that packs two 'Nucleotides' into one byte, just like Bam does.+data MVector_Nucs_half s a = MVector_Nucs_half !Int !Int !(ForeignPtr Word8)++type instance V.Mutable Vector_Nucs_half = MVector_Nucs_half++instance V.Vector Vector_Nucs_half Nucleotides where+    {-# INLINE basicUnsafeFreeze #-}+    basicUnsafeFreeze (MVector_Nucs_half o l fp) = return $  Vector_Nucs_half o l fp+    {-# INLINE basicUnsafeThaw #-}+    basicUnsafeThaw    (Vector_Nucs_half o l fp) = return $ MVector_Nucs_half o l fp++    {-# INLINE basicLength #-}+    basicLength          (Vector_Nucs_half _ l  _) = l+    {-# INLINE basicUnsafeSlice #-}+    basicUnsafeSlice s l (Vector_Nucs_half o _ fp) = Vector_Nucs_half (o + s) l fp++    {-# INLINE basicUnsafeIndexM #-}+    basicUnsafeIndexM (Vector_Nucs_half o _ fp) i+        | even (o+i) = return . Ns $! (b `shiftR` 4) .&. 0xF+        | otherwise  = return . Ns $!  b             .&. 0xF+      where !b = unsafeInlineIO $ withForeignPtr fp $ \p -> peekByteOff p ((o+i) `shiftR` 1)++instance VM.MVector MVector_Nucs_half Nucleotides where+    {-# INLINE basicLength #-}+    basicLength          (MVector_Nucs_half _ l  _) = l+    {-# INLINE basicUnsafeSlice #-}+    basicUnsafeSlice s l (MVector_Nucs_half o _ fp) = MVector_Nucs_half (o + s) l fp++    {-# INLINE basicOverlaps #-}+    basicOverlaps (MVector_Nucs_half _ _ fp1) (MVector_Nucs_half _ _ fp2) = fp1 == fp2+    {-# INLINE basicUnsafeNew #-}+    basicUnsafeNew l = unsafePrimToPrim $ MVector_Nucs_half 0 l <$> mallocForeignPtrBytes ((l+1) `shiftR` 1)++    {-# INLINE basicInitialize #-}+    basicInitialize v@(MVector_Nucs_half o l fp)++        | even    o = do unsafePrimToPrim $ withForeignPtr fp $ \p ->+                            memset (plusPtr p (o `shiftR` 1)) 0 (fromIntegral $ l `shiftR` 1)+                         when (odd l) $ VM.basicUnsafeWrite v (l-1) (Ns 0)++        | otherwise = do when (odd o) $ VM.basicUnsafeWrite v 0 (Ns 0)+                         unsafePrimToPrim $ withForeignPtr fp $ \p ->+                            memset (plusPtr p ((o+1) `shiftR` 1)) 0 (fromIntegral $ (l-1) `shiftR` 1)+                         when (even l) $ VM.basicUnsafeWrite v (l-1) (Ns 0)+++    {-# INLINE basicUnsafeRead #-}+    basicUnsafeRead (MVector_Nucs_half o _ fp) i+        | even (o+i) = liftM (Ns . (.&.) 0xF . (`shiftR` 4)) b+        | otherwise  = liftM (Ns . (.&.) 0xF               ) b+      where b = unsafePrimToPrim $ withForeignPtr fp $ \p -> peekByteOff p ((o+i) `shiftR` 1)++    {-# INLINE basicUnsafeWrite #-}+    basicUnsafeWrite (MVector_Nucs_half o _ fp) i (Ns x) =+        unsafePrimToPrim $ withForeignPtr fp $ \p -> do+            y <- peekByteOff p ((o+i) `shiftR` 1)+            let y' | even (o+i) = x `shiftL` 4 .|. y .&. 0x0F+                   | otherwise  = x            .|. y .&. 0xF0+            pokeByteOff p ((o+i) `shiftR` 1) y'++foreign import ccall unsafe "string.h memset" memset+    :: Ptr Word8 -> CInt -> CSize -> IO ()++instance Show (Vector_Nucs_half Nucleotides) where+    show = show . V.toList++-- | Bam record in its native encoding along with virtual address.+data BamRaw = BamRaw { virt_offset :: {-# UNPACK #-} !Int64+                     , raw_data    :: {-# UNPACK #-} !Bytes }++-- | Smart constructor.  Makes sure we got a at least a full record.+{-# INLINE bamRaw #-}+bamRaw :: Int64 -> Bytes -> BamRaw+bamRaw o s = if good then BamRaw o s else error $ "broken BAM record " ++ shows (S.length s, m) " " ++ show (S.unpack (S.take 10 s))+  where+    good | S.length s < 32 = False+         | otherwise       = S.length s >= sum m+    m = [ 32, l_rnm, l_seq, (l_seq+1) `div` 2, l_cig * 4 ]+    l_rnm = fromIntegral (B.unsafeIndex s  8) - 1+    l_cig = fromIntegral (B.unsafeIndex s 12)             .|. fromIntegral (B.unsafeIndex s 13) `shiftL`  8+    l_seq = fromIntegral (B.unsafeIndex s 16)             .|. fromIntegral (B.unsafeIndex s 17) `shiftL`  8 .|.+            fromIntegral (B.unsafeIndex s 18) `shiftL` 16 .|. fromIntegral (B.unsafeIndex s 19) `shiftL` 24++{-# INLINE[1] unpackBam #-}+unpackBam :: BamRaw -> BamRec+unpackBam br = BamRec {+        b_rname =      Refseq $ getWord32  0,+        b_pos   =               getInt32   4,+        b_mapq  =           Q $ getInt8    9,+        b_flag  =               getInt16  14,+        b_mrnm  =      Refseq $ getWord32 20,+        b_mpos  =               getInt32  24,+        b_isize =               getInt32  28,++        b_qname = B.unsafeTake l_read_name $ B.unsafeDrop 32 $ raw_data br,+        b_cigar = VS.unsafeCast $ VS.unsafeFromForeignPtr fp (off0+off_c) (4*l_cigar),+        b_seq   = Vector_Nucs_half (2 * (off_s+off0)) l_seq fp,+        b_qual  = VS.unsafeCast $ VS.unsafeFromForeignPtr fp (off0+off_q) l_seq,++        b_exts  = unpackExtensions $ S.drop off_e $ raw_data br,+        b_virtual_offset = virt_offset br }+  where+        (fp, off0, _) = B.toForeignPtr $ raw_data br+        off_c =    33 + l_read_name+        off_s = off_c + 4 * l_cigar+        off_q = off_s + (l_seq + 1) `div` 2+        off_e = off_q +  l_seq++        l_read_name = getInt8    8 - 1+        l_seq       = getWord32 16+        l_cigar     = getInt16  12++        getInt8 :: Num a => Int -> a+        getInt8  o = fromIntegral (B.unsafeIndex (raw_data br) o)++        getInt16 :: Num a => Int -> a+        getInt16 o = unsafeDupablePerformIO $ B.unsafeUseAsCString (raw_data br) $+                     fmap fromIntegral . peekUnalnWord16LE . flip plusPtr o++        getWord32 :: Num a => Int -> a+        getWord32 o = unsafeDupablePerformIO $ B.unsafeUseAsCString (raw_data br) $+                      fmap fromIntegral . peekUnalnWord32LE . flip plusPtr o++        -- ensures proper sign extension+        getInt32 :: Num a => Int -> a+        getInt32 o = fromIntegral (getWord32 o :: Int32)++-- | A collection of extension fields.  A 'BamKey' is actually two ASCII+-- characters.+type Extensions = [( BamKey, Ext )]++-- | Deletes all occurences of some extension field.+deleteE :: BamKey -> Extensions -> Extensions+deleteE k = filter ((/=) k . fst)++-- | Blindly inserts an extension field.  This can create duplicates+-- (and there is no telling how other tools react to that).+insertE :: BamKey -> Ext -> Extensions -> Extensions+insertE k v = (:) (k,v)++-- | Deletes all occurences of an extension field, then inserts it with+-- a new value.  This is safer than 'insertE', but also more expensive.+updateE :: BamKey -> Ext -> Extensions -> Extensions+updateE k v = insertE k v . deleteE k++-- | Adjusts a named extension by applying a function.+adjustE :: (Ext -> Ext) -> BamKey -> Extensions -> Extensions+adjustE _ _ [         ]             = []+adjustE f k ((k',v):es) | k  ==  k' = (k', f v) : es+                        | otherwise = (k',   v) : adjustE f k es++data Ext = Int Int | Float Float | Text Bytes | Bin Bytes | Char Word8+         | IntArr (U.Vector Int) | FloatArr (U.Vector Float)+    deriving (Show, Eq, Ord)++{-# INLINE unpackExtensions #-}+unpackExtensions :: Bytes -> Extensions+unpackExtensions = go+  where+    go s | S.length s < 4 = []+         | otherwise = let key = fromString [ S.index s 0, S.index s 1 ]+                       in case S.index s 2 of+                         'Z' -> case S.break (== '\0') (S.drop 3 s) of (l,r) -> (key, Text l) : go (S.drop 1 r)+                         'H' -> case S.break (== '\0') (S.drop 3 s) of (l,r) -> (key, Bin  l) : go (S.drop 1 r)+                         'A' -> (key, Char (B.index s 3)) : go (S.drop 4 s)+                         'B' -> let tp = S.index s 3+                                    n  = getInt 'I' (S.drop 4 s)+                                in case tp of+                                      'f' -> (key, FloatArr (U.fromListN (n+1) [ getFloat (S.drop i s) | i <- [8, 12 ..] ]))+                                             : go (S.drop (12+4*n) s)+                                      _   -> (key, IntArr (U.fromListN (n+1) [ getInt tp (S.drop i s) | i <- [8, 8 + size tp ..] ]))+                                             : go (S.drop (8 + size tp * (n+1)) s)+                         'f' -> (key, Float (getFloat (S.drop 3 s))) : go (S.drop 7 s)+                         tp  -> (key, Int  (getInt tp (S.drop 3 s))) : go (S.drop (3 + size tp) s)++    size 'C' = 1+    size 'c' = 1+    size 'S' = 2+    size 's' = 2+    size 'I' = 4+    size 'i' = 4+    size 'f' = 4+    size  _  = 0++    getInt 'C' s | S.length s >= 1 = fromIntegral              ((B.index s 0) :: Word8)+    getInt 'c' s | S.length s >= 1 = fromIntegral (fromIntegral (B.index s 0) ::  Int8)+    getInt 'S' s | S.length s >= 2 = fromIntegral                         (i :: Word16)+        where i = unsafeDupablePerformIO $ B.unsafeUseAsCString s $ peekUnalnWord16LE+    getInt 's' s | S.length s >= 2 = fromIntegral            (fromIntegral i ::  Int16)+        where i = unsafeDupablePerformIO $ B.unsafeUseAsCString s $ peekUnalnWord16LE+    getInt 'I' s | S.length s >= 4 = fromIntegral                         (i :: Word32)+        where i = unsafeDupablePerformIO $ B.unsafeUseAsCString s $ peekUnalnWord32LE+    getInt 'i' s | S.length s >= 4 = fromIntegral            (fromIntegral i ::  Int32)+        where i = unsafeDupablePerformIO $ B.unsafeUseAsCString s $ peekUnalnWord32LE+    getInt _ _ = 0++    getFloat s = unsafeDupablePerformIO $ alloca $ \buf ->+                 pokeByteOff buf 0 (getInt 'I' s :: Word32) >> peek buf+++isPaired, isProperlyPaired, isUnmapped, isMateUnmapped, isReversed,+    isMateReversed, isFirstMate, isSecondMate, isAuxillary, isSecondary,+    isFailsQC, isDuplicate, isSupplementary,+    isTrimmed, isMerged, isAlternative, isExactIndex :: BamRec -> Bool++isPaired         = flip testBit  0 . b_flag+isProperlyPaired = flip testBit  1 . b_flag+isUnmapped       = flip testBit  2 . b_flag+isMateUnmapped   = flip testBit  3 . b_flag+isReversed       = flip testBit  4 . b_flag+isMateReversed   = flip testBit  5 . b_flag+isFirstMate      = flip testBit  6 . b_flag+isSecondMate     = flip testBit  7 . b_flag+isAuxillary      = flip testBit  8 . b_flag+isSecondary      = flip testBit  8 . b_flag+isFailsQC        = flip testBit  9 . b_flag+isDuplicate      = flip testBit 10 . b_flag+isSupplementary  = flip testBit 11 . b_flag++isTrimmed        = flip testBit 0 . extAsInt 0 "FF"+isMerged         = flip testBit 1 . extAsInt 0 "FF"+isAlternative    = flip testBit 2 . extAsInt 0 "FF"+isExactIndex     = flip testBit 3 . extAsInt 0 "FF"++type_mask :: Int+type_mask = flagFirstMate .|. flagSecondMate .|. flagPaired++extAsInt :: Int -> BamKey -> BamRec -> Int+extAsInt d nm br = case lookup nm (b_exts br) of Just (Int i) -> i ; _ -> d++extAsString :: BamKey -> BamRec -> Bytes+extAsString nm br = case lookup nm (b_exts br) of+    Just (Char c) -> B.singleton c+    Just (Text s) -> s+    _             -> B.empty++setQualFlag :: Char -> BamRec -> BamRec+setQualFlag c br = br { b_exts = updateE "ZQ" (Text s') $ b_exts br }+  where+    s  = extAsString "ZQ" br+    s' = if c `S.elem` s then s else c `S.cons` s+

@@ -0,0 +1,53 @@+module Bio.Bam.Regions+    ( Region(..)+    , Regions(..)+    , Subsequence(..)++    , toList+    , fromList+    , overlaps+    ) where++import Bio.Bam.Header ( Refseq(..) )+import Bio.Prelude hiding ( toList )++import qualified Data.IntMap.Strict as IM++data Region = Region { refseq :: !Refseq, start :: !Int, end :: !Int }+  deriving (Eq, Ord, Show)++-- | A subset of a genome.  The idea is to map the reference sequence+-- (represented by its number) to a 'Subseqeunce'.+newtype Regions = Regions (IntMap Subsequence) deriving Show++-- | A mostly contiguous subset of a sequence, stored as a set of+-- non-overlapping intervals in an 'IntMap' from start position to end+-- position (half-open intervals, naturally).+newtype Subsequence = Subsequence (IntMap Int) deriving Show++toList :: Regions -> [(Refseq, Subsequence)]+toList (Regions m) = [ (Refseq $ fromIntegral k, v) | (k,v) <- IM.toList m ]++fromList :: [Region] -> Regions+fromList = foldl' (flip add) (Regions IM.empty)++add :: Region -> Regions -> Regions+add (Region (Refseq r) b e) (Regions m) =+    let single = Just . Subsequence $ IM.singleton b e+    in Regions $ IM.alter (maybe single (Just . addInt b e)) (fromIntegral r) m+++addInt :: Int -> Int -> Subsequence -> Subsequence+addInt b e (Subsequence m0) = Subsequence $ merge_into b e m0+  where+    merge_into x y m = case IM.lookupLT y m of+        Just (u,v) | x < u && y <= v -> merge_into x v $ IM.delete u m    -- extend to the left+                   | x < u           -> merge_into x y $ IM.delete u m    -- subsume+                   | y <= v          -> m                                 -- subsumed+                   | x <= v          -> merge_into u y $ IM.delete u m    -- extend to the right+        _                            -> IM.insert  x y m                  -- no overlap++overlaps :: Int -> Int -> Subsequence -> Bool+overlaps b e (Subsequence m) = case IM.lookupLT e m of+        Just (_,v) -> b < v+        Nothing    -> False

@@ -0,0 +1,691 @@+module Bio.Bam.Rmdup(+            rmdup, Collapse, cons_collapse, cheap_collapse,+            cons_collapse_keep, cheap_collapse_keep,+            check_sort, normalizeTo, wrapTo,+            ECig(..), toECig, setMD, toCigar+    ) where++import Bio.Bam.Header+import Bio.Bam.Rec+import Bio.Prelude hiding ( left, right )+import Bio.Streaming++import qualified Data.ByteString        as B+import qualified Data.ByteString.Char8  as T+import qualified Data.Map.Strict        as M+import qualified Data.Vector.Generic    as V+import qualified Data.Vector.Storable   as W+import qualified Data.Vector.Unboxed    as U+import qualified Streaming.Prelude      as Q++data Collapse = Collapse {+        collapse  :: [BamRec] -> (Decision,[BamRec]),    -- cluster to consensus and stuff or representative and stuff+        originals :: [BamRec] -> [BamRec] }              -- treatment of the redundant original reads++data Decision = Consensus      { fromDecision :: BamRec }+              | Representative { fromDecision :: BamRec }++cons_collapse :: Qual -> Collapse+cons_collapse maxq = Collapse (do_collapse maxq) (const [])++cons_collapse_keep :: Qual -> Collapse+cons_collapse_keep maxq = Collapse (do_collapse maxq) (map (\b -> b { b_flag = b_flag b .|. flagDuplicate }))++cheap_collapse :: Collapse+cheap_collapse = Collapse do_cheap_collapse (const [])++cheap_collapse_keep :: Collapse+cheap_collapse_keep = Collapse do_cheap_collapse (map (\b -> b { b_flag = b_flag b .|. flagDuplicate }))+++-- | Removes duplicates from an aligned, sorted BAM stream.+--+-- The incoming stream must be sorted by coordinate, and we check for+-- violations of that assumption.  We cannot assume that length was+-- taken into account when sorting (samtools doesn't do so), so+-- duplicates may be separated by reads that start at the same position+-- but have different length or different strand.+--+-- We are looking at three different kinds of reads:  paired reads, true+-- single ended reads, merged or trimmed reads.  They are somewhat+-- different, but here's the situation if we wanted to treat them+-- separately.  These conditions define a set of duplicates:+--+-- Merged or trimmed:  We compare the leftmost coordinates and the+-- aligned length.  If the library prep is strand-preserving, we also+-- compare the strand.+--+-- Paired: We compare both left-most coordinates (b_pos and b_mpos).  If+-- the library prep is strand-preserving, only first-mates can be+-- duplicates of first-mates.  Else a first-mate can be the duplicate of+-- a second-mate.  There may be pairs with one unmapped mate.  This is+-- not a problem as they get assigned synthetic coordinates and will be+-- handled smoothly.+--+-- True singles:  We compare only the leftmost coordinate.  It does not+-- matter if the library prep is strand-preserving, the strand always+-- matters.+--+-- Across these classes, we can see more duplicates:+--+-- Merged/trimmed and paired:  these can be duplicates if the merging+-- failed for the pair.  We would need to compare the outer coordinates+-- of the merged reads to the two 5' coordinates of the pair.  However,+-- since we don't have access to the mate, we cannot actually do+-- anything right here.  This case should be solved externally by+-- merging those pairs that overlap in coordinate space.+--+-- Single and paired:  in the single case, we only have one coordinate+-- to compare.  This will inevitably lead to trouble, as we could find+-- that the single might be the duplicate of two pairs, but those two+-- pairs are definitely not duplicates of each other.  We solve it by+-- removing the single read(s).+--+-- Single and merged/trimmed:  same trouble as in the single+paired+-- case.  We remove the single to solve it.+--+--+-- In principle, we might want to allow some wiggle room in the+-- coordinates.  So far, this has not been implemented.  It adds the+-- complication that groups of separated reads can turn into a set of+-- duplicates because of the appearance of a new reads.  Needs some+-- thinking about... or maybe it's not too important.+--+-- Once a set of duplicates is collected, we perform a majority vote on+-- the correct CIGAR line.  Of all those reads that agree on this CIGAR+-- line, a consensus is called, quality scores are adjusted and clamped+-- to a maximum, the MD field is updated and the XP field is assigned+-- the number of reads in the original cluster.  The new MAPQ becomes+-- the RMSQ of the map qualities of all reads.+--+-- Treatment of Read Groups:  We generalize by providing a "label"+-- function; only reads that have the same label are considered+-- duplicates of each other.  The typical label function would extract+-- read groups, libraries or samples.++rmdup :: (Monad m, Ord l) => (BamRec -> l) -> Bool -> Collapse+      -> Q.Stream (Of BamRec) m r -> Q.Stream (Of (Int,BamRec)) m r+rmdup label strand_preserved collapse_cfg =+    -- Easiest way to go about this:  We simply collect everything that+    -- starts at some specific coordinate and group it appropriately.+    -- Treat the groups separately, output, go on.+    check_sort (b_cpos . snd) "internal error, output isn't sorted anymore" .+    mapGroups ( sortBy (comparing $ V.length . b_seq . snd)+              . concatMap (do_rmdup strand_preserved collapse_cfg)+              . M.elems . accumMap label id ) .+    check_sort b_cpos "input must be sorted for rmdup to work"+  where+    b_cpos = b_rname &&& b_pos++    mapGroups f = lift . inspect >=> either pure (\(a :> s) -> mg1 f [] a s)++    mg1 f acc a s =+        lift (inspect s) >>= \case+            Left r  -> Q.each (f (a:acc)) >> pure r+            Right (b :> s')+                | b_cpos a == b_cpos b -> mg1 f (b:acc) a s'+                | otherwise            -> Q.each (f (a:acc)) >> mg1 f [] b s'++check_sort :: (Monad m, Ord b) => (a -> b) -> String -> Stream (Of a) m r -> Stream (Of a) m r+check_sort f msg = lift . inspect >=> either pure step+  where+    step (a :> s) = lift (inspect s) >>= either (Q.cons a . pure) (step' a)+    step' a (b :> s)+        | f a > f b = fail $ "rmdup: " ++ msg+        | otherwise = Q.cons a $ step (b :> s)+{-# INLINE check_sort #-}++{- | Workhorse for duplicate removal.++ - Unmapped fragments should not be considered to be duplicates of+   mapped fragments.  The /unmapped/ flag can serve for that:  while+   there are two classes of /unmapped/ reads (those that are not mapped+   and those that are mapped to an invalid position), the two sets will+   always have different coordinates.  (Unfortunately, correct duplicate+   removal now relies on correct /unmapped/ and /mate unmapped/ flags,+   and we don't get them from unmodified BWA.  So correct operation+   requires patched BWA or a run of @bam-fixpair@.)++   (1) Other definitions (e.g. lack of CIGAR) don't work, because that+       information won't be available for the mate.++   (2) This would amount to making the /unmapped/ flag part of the+       coordinate, but samtools is not going to take it into account+       when sorting.++   (3) Instead, both flags become part of the /mate pos/ grouping+       criterion.++ - First Mates should (probably) not be considered duplicates of Second+   Mates.  This is unconditionally true for libraries with A\/B-style+   adapters (definitely 454, probably Mathias' ds protocol) and the ss+   protocol, it is not true for fork adapter protocols (vanilla Illumina+   protocol).  So it has to be an option, which would ideally be derived+   from header information.++ - This code ignores read groups, but it will do a majority vote on the+   @RG@ field and call consensi for the index sequences.  If you believe+   that duplicates across read groups are impossible, you must call it+   with an appropriately filtered stream.++ - Half-Aligned Pairs (meaning one known coordinate, while the validity+   of the alignments is immaterial) are rather complicated:++   (1) Given that only one coordinate is known (5' of the aligned mate),+       we want to treat them like true singles.  But the unaligned mate+       should be kept if possible, though it should not contribute to a+       consensus sequence.  We assume nothing about the unaligned mate,+       not even that it /shouldn't/ be aligned, never mind the fact that+       it /couldn't/ be.  (The difference is in the finite abilities of+       real world aligners, naturally.)++   (2) Therefore, aligned reads with unaligned mates go to the same+       potential duplicate set as true singletons.  If at least one pair+       exists that might be a duplicate of those, all singletons and+       half-aligned mates are discarded.  Else a consensus is computed+       and replaces the aligned mates.++   (3) The unaligned mates end up in the same place in a BAM stream as+       the aligned mates (therefore we see them and can treat them+       locally).  We cannot call a consensus, since these molecules may+       well have different length, so we select one.  It doesn't really+       matter which one is selected, and since we're treating both mates+       at the same time, it doesn't even need to be reproducible without+       local information.  This is made to be the mate of the consensus.++   (4) See 'merge_singles' for how it's actually done.+-}++do_rmdup :: Bool -> Collapse -> [BamRec] -> [(Int,BamRec)]+do_rmdup strand_preserved Collapse{..} rds =+        results ++ map ((,) 0) (originals (leftovers ++ r1 ++ r2 ++ r3))+    where+        (results, leftovers) = merge_singles singles' unaligned' $+                [ (str, second fromDecision b) | ((_,str  ),b) <- M.toList merged' ] +++                [ (str, second fromDecision b) | ((_,str,_),b) <- M.toList pairs' ]++        (raw_pairs, raw_singles)       = partition isPaired rds+        (merged, true_singles)         = partition (liftA2 (||) isMerged isTrimmed) raw_singles++        (pairs, raw_half_pairs)        = partition b_totally_aligned raw_pairs+        (half_unaligned, half_aligned) = partition isUnmapped raw_half_pairs++        mkMap :: Ord a => (BamRec -> a) -> [BamRec] -> (M.Map a (Int,Decision), [BamRec])+        mkMap f x = let m1 = M.map (length &&& collapse) $ accumMap f id x+                    in (M.map (second fst) m1, concatMap (snd.snd) $ M.elems m1)++        (pairs',r1)   = mkMap (\b -> (b_mate_pos b,   b_strand b, b_mate b)) pairs+        (merged',r2)  = mkMap (\b -> (alignedLength (b_cigar b), b_strand b))           merged+        (singles',r3) = mkMap                         b_strand (true_singles++half_aligned)+        unaligned'    = accumMap b_strand id half_unaligned++        b_strand b = strand_preserved && isReversed  b+        b_mate   b = strand_preserved && isFirstMate b+++-- | Merging information about true singles, merged singles,+-- half-aligned pairs, actually aligned pairs.+--+-- We collected aligned reads with unaligned mates together with aligned+-- true singles (@singles@).  We collected the unaligned mates, which+-- necessarily have the exact same alignment coordinates, separately+-- (@unaligned@).  If we don't find a matching true pair (that case is+-- already handled smoothly), we keep the highest quality unaligned+-- mate, pair it with the consensus of the aligned mates and aligned+-- singletons, and give it the lexically smallest name of the+-- half-aligned pairs.++-- NOTE:  I need to decide when to run 'make_singleton'.  Basically,+-- when we call a consensus for half-aligned pairs and keep+-- everything(?).  Then we don't have a mate for the consensus... though+-- we could decide to duplicate one mate read to get it.++merge_singles :: M.Map Bool (Int,Decision)              -- strand --> true singles & half aligned+              -> M.Map Bool [BamRec]                    -- strand --> half unaligned+              -> [ (Bool, (Int, BamRec)) ]              -- strand --> paireds & mergeds+              -> ([(Int,BamRec)],[BamRec])              -- results, leftovers++merge_singles singles unaligneds = go+  where+    -- Say we generated a consensus or passed something through.  If+    -- there is a singleton consensus with the same strand, we should+    -- add in its XP field and discard it.  If there is a singleton+    -- representative, we add in its XP field and put it into the+    -- leftovers.  If there is unaligned stuff here that has the same+    -- strand, it goes to the leftovers.+    go ( (str, (m,v)) : paireds) =+        let (r,l) = merge_singles (M.delete str singles) (M.delete str unaligneds) paireds+            unal  = M.findWithDefault [] str unaligneds ++ l++        in case M.lookup str singles of+            Nothing                    -> (              (m,v) : r,     unal )+            Just (n, Consensus      w) -> ( (n, add_xp_of w v) : r,     unal )+            Just (n, Representative w) -> ( (n, add_xp_of w v) : r, w : unal )++    -- No more pairs, delegate the problem+    go [] = merge_halves unaligneds (M.toList singles)++    add_xp_of w v = v { b_exts = updateE "XP" (Int $ extAsInt 1 "XP" w `oplus` extAsInt 1 "XP" v) (b_exts v) }++-- | Merging of half-aligned reads.  The first argument is a map of+-- unaligned reads (their mates are aligned to the current position),+-- the second is a list of reads that are aligned (their mates are not+-- aligned).+--+-- So, suppose we're looking at a 'Representative' that was passed+-- through.  We need to emit it along with its mate, which may be hidden+-- inside a list.  (Alternatively, we could force it to single, but that+-- fails if we're passing everything along somehow.)+--+-- Suppose we're looking at a 'Consensus'.  We could pair it with some+-- mate (which we'd need to duplicate), or we could turn it into a+-- singleton.  Duplication is ugly, so in this case, we force it to+-- singleton.++merge_halves :: M.Map Bool [BamRec]                     -- strand --> half unaligned+             -> [(Bool, (Int,Decision))]                -- strand --> true singles & half aligned+             -> ([(Int,BamRec)],[BamRec])               -- results, leftovers++-- Emitting a consensus: make it a single.  Nothing goes to leftovers;+-- we may still need it for something else to be emitted.  (While that+-- would be strange, making sure the BAM file stays completely valid is+-- probably better.)+merge_halves unaligneds ((_, (n, Consensus v)) : singles) = ( (n, v { b_flag = b_flag v .&. complement pflags }) : r, l )+  where+    (r,l)  = merge_halves unaligneds singles+    pflags = flagPaired .|. flagProperlyPaired .|. flagMateUnmapped .|. flagMateReversed .|. flagFirstMate .|. flagSecondMate+++-- Emitting a representative:  find the mate in the list of unaligned+-- reads (take up to one match to be robust), and emit that, too, as a+-- result.  Everything else goes to leftovers.  If the representative+-- happens to be unpaired, no mate is found and that case therefore is+-- handled smoothly.+merge_halves unaligneds ((str, (n, Representative v)) : singles) = ((n,v) : map ((,)1) (take 1 same) ++ r, drop 1 same ++ diff ++ l)+  where+    (r,l)          = merge_halves (M.delete str unaligneds) singles+    (same,diff)    = partition (is_mate_of v) $ M.findWithDefault [] str unaligneds+    is_mate_of a b = b_qname a == b_qname b && isPaired a && isPaired b && isFirstMate a == isSecondMate b++-- No more singles, all unaligneds are leftovers.+merge_halves unaligneds [] = ( [], concat $ M.elems unaligneds )+++++type MPos = (Refseq, Int, Bool, Bool)++b_mate_pos :: BamRec -> MPos+b_mate_pos b = (b_mrnm b, b_mpos b, isUnmapped b, isMateUnmapped b)++b_totally_aligned :: BamRec -> Bool+b_totally_aligned b = not (isUnmapped b || isMateUnmapped b)+++accumMap :: Ord k => (a -> k) -> (a -> v) -> [a] -> M.Map k [v]+accumMap f g = go M.empty+  where+    go m [    ] = m+    go m (a:as) = let ws = M.findWithDefault [] (f a) m ; g' = g a+                  in g' `seq` go (M.insert (f a) (g':ws) m) as+++{- We need to deal sensibly with each field, but different fields have+   different needs.  We can take the value from the first read to+   preserve determinism or because all reads should be equal anyway,+   aggregate over all reads computing either RMSQ or the most common+   value, delete a field because it wouldn't make sense anymore or+   because doing something sensible would be hard and we're going to+   ignore it anyway, or we calculate some special value; see below.+   Unknown fields will be taken from the first read, which seems to be a+   safe default.++   QNAME and most fields              taken from first+   FLAG qc fail                       majority vote+        dup                           deleted+   MAPQ                               rmsq+   CIGAR, SEQ, QUAL, MD, NM, XP       generated+   XA                                 concatenate all++   BQ, CM, FZ, Q2, R2, XM, XO, XG, YQ, EN+         deleted because they would become wrong++   CQ, CS, E2, FS, OQ, OP, OC, U2, H0, H1, H2, HI, NH, IH, ZQ+         delete because they will be ignored anyway++   AM, AS, MQ, PQ, SM, UQ+         compute rmsq++   X0, X1, XT, XS, XF, XE, BC, LB, RG, XI, YI, XJ, YJ+         majority vote -}++do_collapse :: Qual -> [BamRec] -> (Decision, [BamRec])+do_collapse maxq [br] | V.all (<= maxq) (b_qual br) = ( Representative br, [  ] )     -- no modifcation, pass through+                      | otherwise                   = ( Consensus   lq_br, [br] )     -- qualities reduced, must keep original+  where+    lq_br = br { b_qual  = V.map (min maxq) $ b_qual br+               , b_virtual_offset = 0+               , b_qname = b_qname br `B.snoc` c2w 'c' }++do_collapse maxq  brs = ( Consensus b0 { b_exts  = modify_extensions $ b_exts b0+                                       , b_flag  = failflag .&. complement flagDuplicate+                                       , b_mapq  = Q $ rmsq $ map (unQ . b_mapq) $ good brs+                                       , b_cigar = cigar'+                                       , b_seq   = V.fromList $ map fst cons_seq_qual+                                       , b_qual  = V.fromList $ map snd cons_seq_qual+                                       , b_qname = b_qname b0 `B.snoc` 99+                                       , b_virtual_offset = 0 }, brs )              -- many modifications, must keep everything+  where+    !b0 = minimumBy (comparing b_qname) brs+    !most_fail = 2 * length (filter isFailsQC brs) > length brs+    !failflag | most_fail = b_flag b0 .|. flagFailsQC+              | otherwise = b_flag b0 .&. complement flagFailsQC++    rmsq xs = case foldl' (\(!n,!d) x -> (n + fromIntegral x * fromIntegral x, d + 1)) (0,0) xs of+        (!n,!d) -> round $ sqrt $ (n::Double) / fromIntegral (d::Int)++    maj xs = head . maximumBy (comparing length) . group . sort $ xs+    nub' = concatMap head . group . sort++    -- majority vote on the cigar lines, then filter+    !cigar' = maj $ map b_cigar brs+    good = filter ((==) cigar' . b_cigar)++    cons_seq_qual = [ consensus maxq [ (V.unsafeIndex (b_seq b) i, q)+                                     | b <- good brs, let q = if V.null (b_qual b) then Q 23 else b_qual b V.! i ]+                    | i <- [0 .. len - 1] ]+        where !len = V.length . b_seq . head $ good brs++    md' = case [ (b_seq b,md,b) | b <- good brs, Just md <- [ getMd b ] ] of+                [               ] -> []+                (seq1, md1,b) : _ -> case mk_new_md' [] (V.toList cigar') md1 (V.toList seq1) (map fst cons_seq_qual) of+                    Right x -> x+                    Left (MdFail cigs ms osq nsq) -> error $ unlines+                                    [ "Broken MD field when trying to construct new MD!"+                                    , "QNAME: " ++ show (b_qname b)+                                    , "POS:   " ++ shows (unRefseq (b_rname b)) ":" ++ show (b_pos b)+                                    , "CIGAR: " ++ show cigs+                                    , "MD:    " ++ show ms+                                    , "refseq:  " ++ show osq+                                    , "readseq: " ++ show nsq ]+++    nm' = sum $ [ n | Ins :* n <- W.toList cigar' ] ++ [ n | Del :* n <- W.toList cigar' ] ++ [ 1 | MdRep _ <- md' ]+    xa' = nub' [ T.split ';' xas | Just (Text xas) <- map (lookup "XA" . b_exts) brs ]++    modify_extensions es = foldr ($!) es $+        [ let vs = mapMaybe (lookup k . b_exts) brs+          in if null vs then id else updateE k $! maj vs | k <- do_maj ] +++        [ let vs = [ v | Just (Int v) <- map (lookup k . b_exts) brs ]+          in if null vs then id else updateE k $! Int (rmsq vs) | k <- do_rmsq ] +++        map deleteE useless +++        [ updateE "NM" $! Int nm'+        , updateE "XP" $! Int (foldl' (\a b -> a `oplus` extAsInt 1 "XP" b) 0 brs)+        , if null xa' then id else updateE "XA" $! (Text $ T.intercalate (T.singleton ';') xa')+        , if null md' then id else updateE "MD" $! (Text $ showMd md') ]++    useless = map fromString $ words "BQ CM FZ Q2 R2 XM XO XG YQ EN CQ CS E2 FS OQ OP OC U2 H0 H1 H2 HI NH IH ZQ"+    do_rmsq = map fromString $ words "AM AS MQ PQ SM UQ"+    do_maj  = map fromString $ words "X0 X1 XT XS XF XE BC LB RG XI XJ YI YJ"++minViewBy :: (a -> a -> Ordering) -> [a] -> (a,[a])+minViewBy  _  [    ] = error "minViewBy on empty list"+minViewBy cmp (x:xs) = go x [] xs+  where+    go m acc [    ] = (m,acc)+    go m acc (a:as) = case m `cmp` a of GT -> go a (m:acc) as+                                        _  -> go m (a:acc) as++data MdFail = MdFail [Cigar] [MdOp] [Nucleotides] [Nucleotides]++mk_new_md' :: [MdOp] -> [Cigar] -> [MdOp] -> [Nucleotides] -> [Nucleotides] -> Either MdFail [MdOp]+mk_new_md' acc [] [] [] [] = Right $ normalize [] acc+    where+        normalize          a  (MdNum  0:os) = normalize               a  os+        normalize (MdNum n:a) (MdNum  m:os) = normalize (MdNum  (n+m):a) os+        normalize          a  (MdDel []:os) = normalize               a  os+        normalize (MdDel u:a) (MdDel  v:os) = normalize (MdDel (v++u):a) os+        normalize          a  (       o:os) = normalize            (o:a) os+        normalize          a  [           ] = a++mk_new_md' acc ( _ :* 0 : cigs) mds  osq nsq = mk_new_md' acc cigs mds osq nsq+mk_new_md' acc cigs (MdNum  0 : mds) osq nsq = mk_new_md' acc cigs mds osq nsq+mk_new_md' acc cigs (MdDel [] : mds) osq nsq = mk_new_md' acc cigs mds osq nsq++mk_new_md' acc (Mat :* u : cigs) (MdRep b : mds) (_:osq) (n:nsq)+    | b == n    = mk_new_md' (MdNum 1 : acc) (Mat :* (u-1):cigs) mds osq nsq+    | otherwise = mk_new_md' (MdRep b : acc) (Mat :* (u-1):cigs) mds osq nsq++mk_new_md' acc (Mat :* u : cigs) (MdNum v : mds) (o:osq) (n:nsq)+    | o == n    = mk_new_md' (MdNum 1 : acc) (Mat :* (u-1):cigs) (MdNum (v-1) : mds) osq nsq+    | otherwise = mk_new_md' (MdRep o : acc) (Mat :* (u-1):cigs) (MdNum (v-1) : mds) osq nsq++mk_new_md' acc (Del :* n : cigs) (MdDel bs : mds) osq nsq | n == length bs = mk_new_md' (MdDel bs : acc)         cigs               mds  osq nsq+mk_new_md' acc (Del :* n : cigs) (MdDel (b:bs) : mds) osq nsq = mk_new_md' (MdDel     [b] : acc) (Del :* (n-1) : cigs) (MdDel    bs:mds) osq nsq+mk_new_md' acc (Del :* n : cigs) (MdRep   b    : mds) osq nsq = mk_new_md' (MdDel     [b] : acc) (Del :* (n-1) : cigs)              mds  osq nsq+mk_new_md' acc (Del :* n : cigs) (MdNum   m    : mds) osq nsq = mk_new_md' (MdDel [nucsN] : acc) (Del :* (n-1) : cigs) (MdNum (m-1):mds) osq nsq++mk_new_md' acc (Ins :* n : cigs) md osq nsq = mk_new_md' acc cigs md (drop n osq) (drop n nsq)+mk_new_md' acc (SMa :* n : cigs) md osq nsq = mk_new_md' acc cigs md (drop n osq) (drop n nsq)+mk_new_md' acc (HMa :* _ : cigs) md osq nsq = mk_new_md' acc cigs md         osq          nsq+mk_new_md' acc (Pad :* _ : cigs) md osq nsq = mk_new_md' acc cigs md         osq          nsq+mk_new_md' acc (Nop :* _ : cigs) md osq nsq = mk_new_md' acc cigs md         osq          nsq++mk_new_md' _acc cigs ms osq nsq = Left $ MdFail cigs ms osq nsq++consensus :: Qual -> [ (Nucleotides, Qual) ] -> (Nucleotides, Qual)+consensus (Q maxq) nqs =+    let accs :: U.Vector Int+        accs = U.accum (+) (U.replicate 16 0) [ (fromIntegral n, fromIntegral q) | (Ns n,Q q) <- nqs ]+    in case sortBy (flip $ comparing snd) $ zip [Ns 0 ..] $ U.toList accs of+        (n0,q0) : (_,q1) : _ ->+            let qr = fromIntegral $ (q0-q1) `min` fromIntegral maxq+            in if qr > 3 then (n0, Q qr) else (nucsN, Q 0)+        _ -> error "can't happen"+++-- Cheap version: simply takes the lexically first record, adds XP field+do_cheap_collapse :: [BamRec] -> ( Decision, [BamRec] )+do_cheap_collapse [b] = ( Representative                     b, [] )+do_cheap_collapse  bs = ( Representative $ replaceXP new_xp b0, bx )+  where+    (b0, bx) = minViewBy (comparing b_qname) bs+    new_xp   = foldl' (\a b -> a `oplus` extAsInt 1 "XP" b) 0 bs++replaceXP :: Int -> BamRec -> BamRec+replaceXP new_xp b0 = b0 { b_exts = updateE "XP" (Int new_xp) $ b_exts b0 }++oplus :: Int -> Int -> Int+_ `oplus` (-1) = -1+(-1) `oplus` _ = -1+a `oplus` b = a + b++-- | Normalize a read's alignment to fall into the canonical region+-- of [0..l].  Takes the name of the reference sequence and its length.+-- Returns @Left x@ if the coordinate decreased so the result is out of+-- order now, @Right x@ if the coordinate is unchanged.+normalizeTo :: Bytes -> Int -> BamRec -> Either BamRec BamRec+normalizeTo nm l b = lr $ b { b_pos  = b_pos b `mod` l+                            , b_mpos = b_mpos b `mod` l+                            , b_mapq = if dups_are_fine then Q 37 else b_mapq b+                            , b_exts = if dups_are_fine then deleteE "XA" (b_exts b) else b_exts b }+  where+    lr = if b_pos b >= l then Left else Right+    dups_are_fine  = all_match_XA (extAsString "XA" b)+    all_match_XA s = case T.split ';' s of [xa1, xa2] | T.null xa2 -> one_match_XA xa1+                                           [xa1]                   -> one_match_XA xa1+                                           _                       -> False+    one_match_XA s = case T.split ',' s of (sq:pos:_) | sq == nm   -> pos_match_XA pos ; _ -> False+    pos_match_XA s = case T.readInt s   of Just (p,z) | T.null z   -> int_match_XA p ;   _ -> False+    int_match_XA p | p >= 0    =  (p-1) `mod` l == b_pos b `mod` l && not (isReversed b)+                   | otherwise = (-p-1) `mod` l == b_pos b `mod` l && isReversed b+++-- | Wraps a read to be fully contained in the canonical interval+-- [0..l].  If the read overhangs, it is duplicated and both copies are+-- suitably masked.  A piece with changed coordinate that is now out of+-- order is returned as @Left x@, if the order is fine, it is returned+-- as @Right x@.+wrapTo :: Int -> BamRec -> [Either BamRec BamRec]+wrapTo l b = if overhangs then do_wrap else [Right b]+  where+    overhangs = not (isUnmapped b) && b_pos b < l && l < b_pos b + alignedLength (b_cigar b)++    do_wrap = case split_ecig (l - b_pos b) $ toECig (b_cigar b) (fromMaybe [] $ getMd b) of+                  (left,right) -> [ Right $ b { b_cigar = toCigar  left }            `setMD` left+                                  , Left  $ b { b_cigar = toCigar right, b_pos = 0 } `setMD` right ]++-- | Split an 'ECig' into two at some position.  The position is counted+-- in terms of the reference (therefore, deletions count, insertions+-- don't).  The parts that would be skipped if we were splitting lists+-- are replaced by soft masks.+split_ecig :: Int -> ECig -> (ECig, ECig)+split_ecig _    WithMD = (WithMD,       WithMD)+split_ecig _ WithoutMD = (WithoutMD, WithoutMD)+split_ecig 0       ecs = (mask_all ecs,    ecs)++split_ecig i (Ins' n ecs) = case split_ecig i ecs of (u,v) -> (Ins' n u, SMa' n v)+split_ecig i (SMa' n ecs) = case split_ecig i ecs of (u,v) -> (SMa' n u, SMa' n v)+split_ecig i (HMa' n ecs) = case split_ecig i ecs of (u,v) -> (HMa' n u, HMa' n v)+split_ecig i (Pad' n ecs) = case split_ecig i ecs of (u,v) -> (Pad' n u,        v)++split_ecig i (Mat' n ecs)+    | i >= n    = case split_ecig (i-n) ecs of (u,v) -> (Mat' n u, SMa' n v)+    | otherwise = (Mat' i $ SMa' (n-i) $ mask_all ecs, SMa' i $ Mat' (n-i) ecs)++split_ecig i (Rep' x ecs) = case split_ecig (i-1) ecs of (u,v) -> (Rep' x u, SMa' 1 v)+split_ecig i (Del' x ecs) = case split_ecig (i-1) ecs of (u,v) -> (Del' x u,        v)++split_ecig i (Nop' n ecs)+    | i >= n    = case split_ecig (i-n) ecs of (u,v) -> (Nop' n u,        v)+    | otherwise = (Nop' i $ mask_all ecs, Nop' (n-i) ecs)++mask_all :: ECig -> ECig+mask_all      WithMD = WithMD+mask_all   WithoutMD = WithoutMD+mask_all (Nop' _ ec) =          mask_all ec+mask_all (HMa' _ ec) =          mask_all ec+mask_all (Pad' _ ec) =          mask_all ec+mask_all (Del' _ ec) =          mask_all ec+mask_all (Rep' _ ec) = SMa' 1 $ mask_all ec+mask_all (Mat' n ec) = SMa' n $ mask_all ec+mask_all (Ins' n ec) = SMa' n $ mask_all ec+mask_all (SMa' n ec) = SMa' n $ mask_all ec++-- | Extended CIGAR.  This subsumes both the CIGAR string and the+-- optional MD field.  If we have MD on input, we generate it on output,+-- too.  And in between, we break everything into /very small/+-- operations.++data ECig = WithMD                      -- terminate, do generate MD field+          | WithoutMD                   -- terminate, don't bother with MD+          | Mat' Int ECig+          | Rep' Nucleotides ECig+          | Ins' Int ECig+          | Del' Nucleotides ECig+          | Nop' Int ECig+          | SMa' Int ECig+          | HMa' Int ECig+          | Pad' Int ECig+++toECig :: W.Vector Cigar -> [MdOp] -> ECig+toECig = go . W.toList+  where+    go        cs  (MdNum  0:mds) = go cs mds+    go        cs  (MdDel []:mds) = go cs mds+    go (_:*0 :cs)           mds  = go cs mds+    go [        ] [            ] = WithMD               -- all was fine to the very end+    go [        ]              _ = WithoutMD            -- here it wasn't fine++    go (Mat :* n : cs) (MdRep x:mds)   = Rep'   x   $ go     (Mat :* (n-1) : cs)             mds+    go (Mat :* n : cs) (MdNum m:mds)+       | n < m                         = Mat'   n   $ go                     cs (MdNum (m-n):mds)+       | n > m                         = Mat'   m   $ go     (Mat :* (n-m) : cs)             mds+       | otherwise                     = Mat'   n   $ go                     cs              mds+    go (Mat :* n : cs)            _    = Mat'   n   $ go'                    cs++    go (Ins :* n : cs)               mds  = Ins'   n   $ go                  cs              mds+    go (Del :* n : cs) (MdDel (x:xs):mds) = Del'   x   $ go  (Del :* (n-1) : cs) (MdDel xs:mds)+    go (Del :* n : cs)                 _  = Del' nucsN $ go' (Del :* (n-1) : cs)++    go (Nop :* n : cs) mds = Nop' n $ go cs mds+    go (SMa :* n : cs) mds = SMa' n $ go cs mds+    go (HMa :* n : cs) mds = HMa' n $ go cs mds+    go (Pad :* n : cs) mds = Pad' n $ go cs mds++    -- We jump here once the MD fiels ran out early or was messed up.+    -- We no longer bother with it (this also happens if the MD isn't+    -- present to begin with).+    go' (_ :* 0 : cs)   = go' cs+    go' [           ]   = WithoutMD                        -- we didn't have MD or it was broken++    go' (Mat :* n : cs) = Mat'   n   $ go'                 cs+    go' (Ins :* n : cs) = Ins'   n   $ go'                 cs+    go' (Del :* n : cs) = Del' nucsN $ go' (Del :* (n-1) : cs)++    go' (Nop :* n : cs) = Nop'   n   $ go' cs+    go' (SMa :* n : cs) = SMa'   n   $ go' cs+    go' (HMa :* n : cs) = HMa'   n   $ go' cs+    go' (Pad :* n : cs) = Pad'   n   $ go' cs+++-- We normalize matches, deletions and soft masks, because these are the+-- operations we generate.  Everything else is either already normalized+-- or nobody really cares anyway.+toCigar :: ECig -> W.Vector Cigar+toCigar = V.fromList . go+  where+    go       WithMD = []+    go    WithoutMD = []++    go (Ins' n ecs) = Ins :* n : go ecs+    go (Nop' n ecs) = Nop :* n : go ecs+    go (HMa' n ecs) = HMa :* n : go ecs+    go (Pad' n ecs) = Pad :* n : go ecs+    go (SMa' n ecs) = go_sma n ecs+    go (Mat' n ecs) = go_mat n ecs+    go (Rep' _ ecs) = go_mat 1 ecs+    go (Del' _ ecs) = go_del 1 ecs++    go_sma !n (SMa' m ecs) = go_sma (n+m) ecs+    go_sma !n         ecs  = SMa :* n : go ecs++    go_mat !n (Mat' m ecs) = go_mat (n+m) ecs+    go_mat !n (Rep' _ ecs) = go_mat (n+1) ecs+    go_mat !n         ecs  = Mat :* n : go ecs++    go_del !n (Del' _ ecs) = go_del (n+1) ecs+    go_del !n         ecs  = Del :* n : go ecs++++-- | Create an MD field from an extended CIGAR and place it in a record.+-- We build it piecemeal (in 'go'), call out to 'addNum', 'addRep',+-- 'addDel' to make sure the operations are not generated in a+-- degenerate manner, and finally check if we're even supposed to create+-- an MD field.+setMD :: BamRec -> ECig -> BamRec+setMD b ec = case go ec of+    Just md -> b { b_exts = updateE "MD" (Text $ showMd md) (b_exts b) }+    Nothing -> b { b_exts = deleteE "MD"                    (b_exts b) }+  where+    go  WithMD      = Just []+    go  WithoutMD   = Nothing++    go (Ins' _ ecs) = go ecs+    go (Nop' _ ecs) = go ecs+    go (SMa' _ ecs) = go ecs+    go (HMa' _ ecs) = go ecs+    go (Pad' _ ecs) = go ecs+    go (Mat' n ecs) = (if n ==  0 then id else fmap (addNum n)) $ go ecs+    go (Rep' x ecs) = (if isGap x then id else fmap (addRep x)) $ go ecs+    go (Del' x ecs) = (if isGap x then id else fmap (addDel x)) $ go ecs++    addNum n (MdNum m : mds) = MdNum (n+m) : mds+    addNum n            mds  = MdNum   n   : mds++    addRep x            mds  = MdRep   x   : mds++    addDel x (MdDel y : mds) = MdDel (x:y) : mds+    addDel x            mds  = MdDel  [x]  : mds

@@ -0,0 +1,442 @@+-- | Trimming of reads as found in BAM files.  Implements trimming low+-- quality sequence from the 3' end.++module Bio.Bam.Trim+        ( trim_3+        , trim_3'+        , trim_low_quality+        , default_fwd_adapters+        , default_rev_adapters+        , find_merge+        , mergeBam+        , find_trim+        , trimBam+        , mergeTrimBam+        , twoMins+        , merged_seq+        , merged_qual+        ) where++import Bio.Bam.Header+import Bio.Bam.Rec+import Bio.Bam.Rmdup        ( ECig(..), setMD, toECig )+import Bio.Prelude+import Bio.Streaming+import Foreign.C.Types      ( CInt(..) )++import qualified Data.ByteString                        as B+import qualified Data.Vector.Generic                    as V+import qualified Data.Vector.Storable                   as W++-- | Trims from the 3' end of a sequence.+-- @trim_3' p b@ trims the 3' end of the sequence in @b@ at the+-- earliest position such that @p@ evaluates to true on every suffix+-- that was trimmed off.  Note that the 3' end may be the beginning of+-- the sequence if it happens to be stored in reverse-complemented form.+-- Also note that trimming from the 3' end may not make sense for reads+-- that were constructed by merging paired end data (but we cannot take+-- care of that here).  Further note that trimming may break dependent+-- information, notably the "mate" information of the mate and many+-- optional fields.++trim_3' :: ([Nucleotides] -> [Qual] -> Bool) -> BamRec -> BamRec+trim_3' p b | b_flag b `testBit` 4 = trim_rev+            | otherwise            = trim_fwd+  where+    trim_fwd = let l = subtract 1 . length . takeWhile (uncurry p) $+                            zip (inits . reverse . V.toList $ b_seq b)+                                (inits . reverse . V.toList $ b_qual b)+               in trim_3 l b++    trim_rev = let l = subtract 1 . length . takeWhile (uncurry p) $+                            zip (inits . V.toList $ b_seq  b)+                                (inits . V.toList $ b_qual b)+               in trim_3 l b++trim_3 :: Int -> BamRec -> BamRec+trim_3 l b | b_flag b `testBit` 4 = trim_rev+           | otherwise            = trim_fwd+  where+    trim_fwd = let (_, cigar') = trim_back_cigar (b_cigar b) l+                   c = modMd (takeECig (V.length (b_seq  b) - l)) b+               in c { b_seq   = V.take (V.length (b_seq  c) - l) (b_seq  c)+                    , b_qual  = V.take (V.length (b_qual c) - l) (b_qual c)+                    , b_cigar = cigar'+                    , b_exts  = map (\(k,e) -> case e of+                                        Text t | k `elem` trim_set+                                          -> (k, Text (B.take (B.length t - l) t))+                                        _ -> (k,e)+                                    ) (b_exts c) }++    trim_rev = let (off, cigar') = trim_fwd_cigar (b_cigar b) l+                   c = modMd (dropECig l) b+               in c { b_seq   = V.drop l (b_seq  c)+                    , b_qual  = V.drop l (b_qual c)+                    , b_pos   = b_pos c + off+                    , b_cigar = cigar'+                    , b_exts  = map (\(k,e) -> case e of+                                        Text t | k `elem` trim_set+                                          -> (k, Text (B.drop l t))+                                        _ -> (k,e)+                                    ) (b_exts c) }++    trim_set = ["BQ","CQ","CS","E2","OQ","U2"]++    modMd :: (ECig -> ECig) -> BamRec -> BamRec+    modMd f br = maybe br (setMD br . f . toECig (b_cigar br)) (getMd br)++    endOf :: ECig -> ECig+    endOf  WithMD     = WithMD+    endOf  WithoutMD  = WithoutMD+    endOf (Mat' _ es) = endOf es+    endOf (Ins' _ es) = endOf es+    endOf (SMa' _ es) = endOf es+    endOf (Rep' _ es) = endOf es+    endOf (Del' _ es) = endOf es+    endOf (Nop' _ es) = endOf es+    endOf (HMa' _ es) = endOf es+    endOf (Pad' _ es) = endOf es++    takeECig :: Int -> ECig -> ECig+    takeECig 0  es          = endOf es+    takeECig _  WithMD      = WithMD+    takeECig _  WithoutMD   = WithoutMD+    takeECig n (Mat' m  es) = Mat' n  $ if n > m then takeECig (n-m) es else WithMD+    takeECig n (Ins' m  es) = Ins' n  $ if n > m then takeECig (n-m) es else WithMD+    takeECig n (SMa' m  es) = SMa' n  $ if n > m then takeECig (n-m) es else WithMD+    takeECig n (Rep' ns es) = Rep' ns $ takeECig (n-1) es+    takeECig n (Del' ns es) = Del' ns $ takeECig n es+    takeECig n (Nop' m  es) = Nop' m  $ takeECig n es+    takeECig n (HMa' m  es) = HMa' m  $ takeECig n es+    takeECig n (Pad' m  es) = Pad' m  $ takeECig n es++    dropECig :: Int -> ECig -> ECig+    dropECig 0  es         = es+    dropECig _  WithMD     = WithMD+    dropECig _  WithoutMD  = WithoutMD+    dropECig n (Mat' m es) = if n > m then dropECig (n-m) es else Mat' n WithMD+    dropECig n (Ins' m es) = if n > m then dropECig (n-m) es else Ins' n WithMD+    dropECig n (SMa' m es) = if n > m then dropECig (n-m) es else SMa' n WithMD+    dropECig n (Rep' _ es) = dropECig (n-1) es+    dropECig n (Del' _ es) = dropECig n es+    dropECig n (Nop' _ es) = dropECig n es+    dropECig n (HMa' _ es) = dropECig n es+    dropECig n (Pad' _ es) = dropECig n es+++trim_back_cigar, trim_fwd_cigar :: V.Vector v Cigar => v Cigar -> Int -> ( Int, v Cigar )+trim_back_cigar c l = (o, V.fromList $ reverse c') where (o,c') = sanitize_cigar . trim_cigar l $ reverse $ V.toList c+trim_fwd_cigar  c l = (o, V.fromList           c') where (o,c') = sanitize_cigar $ trim_cigar l $ V.toList c++sanitize_cigar :: (Int, [Cigar]) -> (Int, [Cigar])+sanitize_cigar (o, [        ])                          = (o, [])+sanitize_cigar (o, (op:*l):xs) | op == Pad              = sanitize_cigar (o,xs)         -- del P+                               | op == Del || op == Nop = sanitize_cigar (o + l, xs)    -- adjust D,N+                               | op == Ins              = (o, (SMa :* l):xs)            -- I --> S+                               | otherwise              = (o, (op :* l):xs)             -- rest is fine++trim_cigar :: Int -> [Cigar] -> (Int, [Cigar])+trim_cigar 0 cs = (0, cs)+trim_cigar _ [] = (0, [])+trim_cigar l ((op:*ll):cs) | bad_op op = let (o,cs') = trim_cigar l cs in (o + reflen op ll, cs')+                           | otherwise = case l `compare` ll of+    LT -> (reflen op  l, (op :* (ll-l)):cs)+    EQ -> (reflen op ll,                cs)+    GT -> let (o,cs') = trim_cigar (l - ll) cs in (o + reflen op ll, cs')++  where+    reflen op' = if ref_op op' then id else const 0+    bad_op o = o /= Mat && o /= Ins && o /= SMa+    ref_op o = o == Mat || o == Del+++-- | Trim predicate to get rid of low quality sequence.+-- @trim_low_quality q ns qs@ evaluates to true if all qualities in @qs@+-- are smaller (i.e. worse) than @q@.+trim_low_quality :: Qual -> a -> [Qual] -> Bool+trim_low_quality q = const $ all (< q)+++-- | Finds the merge point.  Input is list of forward adapters, list of+-- reverse adapters, sequence1, quality1, sequence2, quality2; output is+-- merge point and two qualities (YM, YN).+find_merge :: [W.Vector Nucleotides] -> [W.Vector Nucleotides]+           -> W.Vector Nucleotides -> W.Vector Qual+           -> W.Vector Nucleotides -> W.Vector Qual+           -> (Int, Int, Int)+find_merge ads1 ads2 r1 q1 r2 q2 = (mlen, score2 - score1, plain_score - score1)+  where+    plain_score = 6 * (V.length r1 + V.length r2)+    (score1, mlen, score2) = twoMins plain_score (V.length r1 + V.length r2) $+                             merge_score ads1 ads2 r1 q1 r2 q2++-- | Overlap-merging of read pairs.  We shall compute the likelihood+-- for every possible overlap, then select the most likely one (unless it+-- looks completely random), compute a quality from the second best+-- merge, then merge and clamp the quality accordingly.+-- (We could try looking for chimaera after completing the merge, if+-- only we knew which ones to expect?)+--+-- Two reads go in, with two adapter lists.  We return 'Nothing' if all+-- merges looked mostly random.  Else we return the two original reads,+-- flagged as 'eflagVestigial' *and* the merged version, flagged as+-- 'eflagMerged' and optionally 'eflagTrimmed'.  All reads contain the+-- computed qualities (in YM and YN), which we also return.+--+-- The merging automatically limits quality scores some of the time.  We+-- additionally impose a hard limit of 63 to avoid difficulties+-- representing the result, and even that is ridiculous.  Sane people+-- would further limit the returned quality!  (In practice, map quality+-- later imposes a limit anyway, so no worries...)++mergeBam :: Int -> Int -> [W.Vector Nucleotides] -> [W.Vector Nucleotides] -> BamRec -> BamRec -> [BamRec]+mergeBam lowq highq ads1 ads2 r1 r2+    | V.null (b_seq r1) && V.null (b_seq r2) = [              ]+    | qual1 < lowq || mlen < 0               = [ r1', r2'     ]+    | qual1 >= highq && mlen == 0            = [              ]+    | qual1 >= highq                         = [           rm ]+    | mlen < len_r1-20 || mlen < len_r2-20   = [           rm ]+    | otherwise         = map flag_alternative [ r1', r2', rm ]+  where+    len_r1    = V.length  $ b_seq  r1+    len_r2    = V.length  $ b_seq  r2++    b_seq_r1  = V.convert $ b_seq  r1+    b_seq_r2  = V.convert $ b_seq  r2+    b_qual_r1 = V.convert $ b_qual r1+    b_qual_r2 = V.convert $ b_qual r2++    (mlen, qual1, qual2) = find_merge ads1 ads2 b_seq_r1 b_qual_r1 b_seq_r2 b_qual_r2++    flag_alternative br = br { b_exts = updateE "FF" (Int $ extAsInt 0 "FF" br .|. eflagAlternative) $ b_exts br }+    store_quals      br = br { b_exts = updateE "YM" (Int qual1) $ updateE "YN" (Int qual2) $ b_exts br }+    pair_flags = flagPaired.|.flagProperlyPaired.|.flagMateUnmapped.|.flagMateReversed.|.flagFirstMate.|.flagSecondMate++    r1' = store_quals r1+    r2' = store_quals r2+    rm  = store_quals $ merged_read mlen (fromIntegral $ min 63 qual1)++    merged_read l qmax = nullBamRec {+                b_qname = b_qname r1,+                b_flag  = flagUnmapped .|. complement pair_flags .&. b_flag r1,+                b_seq   = V.convert $ merged_seq l b_seq_r1 b_qual_r1 b_seq_r2 b_qual_r2,+                b_qual  = V.convert $ merged_qual qmax l b_seq_r1 b_qual_r1 b_seq_r2 b_qual_r2,+                b_exts  = let ff = if l < len_r1 then eflagTrimmed else 0+                          in updateE "FF" (Int $ extAsInt 0 "FF" r1 .|. eflagMerged .|. ff) $ b_exts r1 }++{-# INLINE merged_seq #-}+merged_seq :: (V.Vector v Nucleotides, V.Vector v Qual)+           => Int -> v Nucleotides -> v Qual -> v Nucleotides -> v Qual -> v Nucleotides+merged_seq l b_seq_r1 b_qual_r1 b_seq_r2 b_qual_r2 = V.concat+        [ V.take (l - len_r2) b_seq_r1+        , V.zipWith4 zz          (V.take l $ V.drop (l - len_r2) b_seq_r1)+                                 (V.take l $ V.drop (l - len_r2) b_qual_r1)+                     (V.reverse $ V.take l $ V.drop (l - len_r1) b_seq_r2)+                     (V.reverse $ V.take l $ V.drop (l - len_r1) b_qual_r2)+        , V.reverse $ V.take (l - len_r1) b_seq_r2 ]+  where+    len_r1 = V.length b_qual_r1+    len_r2 = V.length b_qual_r2+    zz !n1 (Q !q1) !n2 (Q !q2) | n1 == compls n2 =        n1+                               | q1 > q2         =        n1+                               | otherwise       = compls n2++{-# INLINE merged_qual #-}+merged_qual :: (V.Vector v Nucleotides, V.Vector v Qual)+            => Word8 -> Int -> v Nucleotides -> v Qual -> v Nucleotides -> v Qual -> v Qual+merged_qual qmax l b_seq_r1 b_qual_r1 b_seq_r2 b_qual_r2 = V.concat+        [ V.take (l - len_r2) b_qual_r1+        , V.zipWith4 zz           (V.take l $ V.drop (l - len_r2) b_seq_r1)+                                  (V.take l $ V.drop (l - len_r2) b_qual_r1)+                      (V.reverse $ V.take l $ V.drop (l - len_r1) b_seq_r2)+                      (V.reverse $ V.take l $ V.drop (l - len_r1) b_qual_r2)+        , V.reverse $ V.take (l - len_r1) b_qual_r2 ]+  where+    len_r1 = V.length b_qual_r1+    len_r2 = V.length b_qual_r2+    zz !n1 (Q !q1) !n2 (Q !q2) | n1 == compls n2 = Q $ min qmax (q1 + q2)+                               | q1 > q2         = Q $           q1 - q2+                               | otherwise       = Q $           q2 - q1++++-- | Finds the trimming point.  Input is list of forward adapters,+-- sequence, quality; output is trim point and two qualities (YM, YN).+find_trim :: [W.Vector Nucleotides]+          -> W.Vector Nucleotides -> W.Vector Qual+          -> (Int, Int, Int)+find_trim ads1 r1 q1 = (mlen, score2 - score1, plain_score - score1)+  where+    plain_score = 6 * V.length r1+    (score1, mlen, score2) = twoMins plain_score (V.length r1) $+                             merge_score ads1 [V.empty] r1 q1 V.empty V.empty++-- | Trimming for a single read:  we need one adapter only (the one coming+-- /after/ the read), here provided as a list of options, and then we+-- merge with an empty second read.  Results in up to two reads (the+-- original, possibly flagged, and the trimmed one, definitely flagged,+-- and two qualities).+trimBam :: Int -> Int -> [W.Vector Nucleotides] -> BamRec -> [BamRec]+trimBam lowq highq ads1 r1+    | V.null (b_seq r1)              = [          ]+    | mlen == 0 && qual1 >= highq    = [          ]+    | qual1 < lowq || mlen < 0       = [ r1'      ]+    | qual1 >= highq                 = [      r1t ]+    | otherwise = map flag_alternative [ r1', r1t ]+  where+    -- the "merge" score if there is no trimming++    b_seq_r1 = V.convert $ b_seq r1+    b_qual_r1 = V.convert $ b_qual r1++    (mlen, qual1, qual2) = find_trim ads1 b_seq_r1 b_qual_r1++    flag_alternative br = br { b_exts = updateE "FF" (Int $ extAsInt 0 "FF" br .|. eflagAlternative) $ b_exts br }+    store_quals      br = br { b_exts = updateE "YM" (Int qual1) $ updateE "YN" (Int qual2) $ b_exts br }++    r1'  = store_quals r1+    r1t  = store_quals $ trimmed_read mlen++    trimmed_read l = nullBamRec {+            b_qname = b_qname r1,+            b_flag  = flagUnmapped .|. b_flag r1,+            b_seq   = V.take l $ b_seq  r1,+            b_qual  = V.take l $ b_qual r1,+            b_exts  = updateE "FF" (Int $ extAsInt 0 "FF" r1 .|. eflagTrimmed) $ b_exts r1 }+++-- | For merging, we don't need the complete adapters (length around 70!),+-- only a sufficient prefix.  Taking only the more-or-less constant+-- part (length around 30), there aren't all that many different+-- adapters in the world.  To deal with pretty much every library, we+-- only need the following forward adapters, which will be the default+-- (defined here in the direction they would be sequenced in):  Genomic+-- R2, Multiplex R2, Fraft P7.++default_fwd_adapters :: [ W.Vector Nucleotides ]+default_fwd_adapters = map (W.fromList. map toNucleotides)+         [ {- Genomic R2   -}  "AGATCGGAAGAGCGGTTCAG"+         , {- Multiplex R2 -}  "AGATCGGAAGAGCACACGTC"+         , {- Graft P7     -}  "AGATCGGAAGAGCTCGTATG" ]++-- | Like 'default_rev_adapters', these are the few adapters needed for+-- the reverse read (defined in the direction they would be sequenced in+-- as part of the second read):  Genomic R1, CL 72.++default_rev_adapters :: [ W.Vector Nucleotides ]+default_rev_adapters = map (W.fromList. map toNucleotides)+         [ {- Genomic_R1   -}  "AGATCGGAAGAGCGTCGTGT"+         , {- CL72         -}  "GGAAGAGCGTCGTGTAGGGA" ]++-- We need to compute the likelihood of a read pair given an assumed+-- insert length.  The likelihood of the first read is the likelihood of+-- a match with the adapter where it overlaps the 3' adapter, elsewhere+-- it's 1/4 per position.  The likelihood of the second read is the+-- likelihood of a match with the adapter where it overlaps the adapter,+-- the likehood of a read-read match where it overlaps read one, 1/4 per+-- position elsewhere.  (Yes, this ignores base composition.  It doesn't+-- matter enough.)++merge_score+    :: [ W.Vector Nucleotides ]                 -- 3' adapters as they appear in the first read+    -> [ W.Vector Nucleotides ]                 -- 5' adapters as they appear in the second read+    -> W.Vector Nucleotides -> W.Vector Qual    -- first read, qual+    -> W.Vector Nucleotides -> W.Vector Qual    -- second read, qual+    -> Int                                      -- assumed insert length+    -> Int                                      -- score (roughly sum of qualities at mismatches)+merge_score fwd_adapters rev_adapters !read1 !qual1 !read2 !qual2 !l+    =   6 * (l `min` V.length read1)                                        -- read1, part before adapter+      + 6 * (max 0 (l - V.length read1))                                    -- read2, part before overlap++      + foldl' (\acc fwd_ad -> min acc+                    (match_adapter l read1 qual1 fwd_ad +                   -- read1, match with forward adapter+                     6 * (max 0 (V.length read1 - V.length fwd_ad - l)))    -- read1, part after (known) adapter+               ) maxBound fwd_adapters++      + foldl' (\acc rev_ad -> min acc+                    (match_adapter l read2 qual2 rev_ad +                   -- read2, match with reverse adapter+                     6 * (max 0 (V.length read2 - V.length rev_ad - l)))    -- read2, part after (known) adapter+               ) maxBound rev_adapters++      + match_reads l read1 qual1 read2 qual2++{-# INLINE match_adapter #-}+match_adapter :: Int -> W.Vector Nucleotides -> W.Vector Qual -> W.Vector Nucleotides -> Int+match_adapter !off !rd !qs !ad+    | V.length rd /= V.length qs = error "read/qual length mismatch"+    | efflength <= 0             = 0+    | otherwise+        = fromIntegral . unsafePerformIO $+          W.unsafeWith rd $ \p_rd ->+          W.unsafeWith qs $ \p_qs ->+          W.unsafeWith ad $ \p_ad ->+          prim_match_ad (fromIntegral off)+                        (fromIntegral efflength)+                        p_rd p_qs p_ad+  where+    !efflength =  (V.length rd - off) `min` V.length ad++foreign import ccall unsafe "prim_match_ad"+    prim_match_ad :: CInt -> CInt+                  -> Ptr Nucleotides -> Ptr Qual+                  -> Ptr Nucleotides -> IO CInt+++-- | Computes overlap score for two reads (with qualities) assuming an+-- insert length.+{-# INLINE match_reads #-}+match_reads :: Int -> W.Vector Nucleotides -> W.Vector Qual -> W.Vector Nucleotides -> W.Vector Qual -> Int+match_reads !l !rd1 !qs1 !rd2 !qs2+    | V.length rd1 /= V.length qs1 || V.length rd2 /= V.length qs2 = error "read/qual length mismatch"+    | efflength <= 0                                               = 0+    | otherwise+        = fromIntegral . unsafePerformIO $+          W.unsafeWith rd1 $ \p_rd1 ->+          W.unsafeWith qs1 $ \p_qs1 ->+          W.unsafeWith rd2 $ \p_rd2 ->+          W.unsafeWith qs2 $ \p_qs2 ->+          prim_match_reads (fromIntegral minidx1)+                           (fromIntegral maxidx2)+                           (fromIntegral efflength)+                           p_rd1 p_qs1 p_rd2 p_qs2+  where+    -- vec1, forward+    !minidx1 = (l - V.length rd2) `max` 0+    -- vec2, backward+    !maxidx2 = l `min` V.length rd2+    -- effective length+    !efflength = ((V.length rd1 + V.length rd2 - l) `min` l) `max` 0+++foreign import ccall unsafe "prim_match_reads"+    prim_match_reads :: CInt -> CInt -> CInt+                     -> Ptr Nucleotides -> Ptr Qual+                     -> Ptr Nucleotides -> Ptr Qual -> IO CInt+++{-# INLINE twoMins #-}+twoMins :: (Bounded a, Ord a) => a -> Int -> (Int -> a) -> (a,Int,a)+twoMins a0 imax f = go a0 (-1) maxBound 0 0+  where+    go !m1 !i1 !m2 !i2 !i+        | i == imax = (m1,i1,m2)+        | otherwise =+            case f i of+                x | x < m1    -> go  x  i m1 i1 (i+1)+                  | x < m2    -> go m1 i1  x  i (i+1)+                  | otherwise -> go m1 i1 m2 i2 (i+1)+++mergeTrimBam :: Monad m+             => Int -> Int -> [W.Vector Nucleotides] -> [W.Vector Nucleotides]+             -> Stream (Of BamRec) m r -> Stream (Of BamRec) m r+mergeTrimBam lowq highq fwd_ads rev_ads = go+  where+    go = lift . inspect >=> either pure go1++    go1 (r1 :> s) | isPaired r1 = lift (inspect s) >>= go2 r1+                  | otherwise   = each (trimBam lowq highq fwd_ads r1) >> go s++    go2 r1 (Left          _) = error $ "Lone mate found: " ++ show (b_qname r1)+    go2 r1 (Right (r2 :> s)) = each (mergeBam lowq highq fwd_ads rev_ads r1 r2) >> go s+

@@ -0,0 +1,247 @@+-- | Printers for BAM and SAM.  BAM is properly supported, SAM can be+-- piped to standard output.++module Bio.Bam.Writer (+    IsBamRec(..),+    encodeBamWith,++    packBam,+    writeBamFile,+    writeBamHandle,+    pipeBamOutput,+    pipeSamOutput+                      ) where++import Bio.Bam.Header+import Bio.Bam.Rec+import Bio.Prelude+import Bio.Streaming+import Bio.Streaming.Bgzf++import Data.ByteString.Builder.Prim ( (>*<) )+import Data.ByteString.Internal     ( ByteString(..) )+import Data.ByteString.Lazy         ( foldrChunks )+import Foreign.Marshal.Alloc        ( alloca )++import qualified Bio.Streaming.Bytes                as S+import qualified Data.ByteString                    as B+import qualified Data.ByteString.Builder            as B+import qualified Data.ByteString.Builder.Extra      as B+import qualified Data.ByteString.Builder.Prim       as E+import qualified Data.Vector.Generic                as V+import qualified Data.Vector.Storable               as W+import qualified Data.Vector.Unboxed                as U+import qualified Streaming.Prelude                  as Q++{- | write in SAM format to stdout++This is useful for piping to other tools (say, AWK scripts) or for+debugging.  No convenience functions to send SAM to a file or to+compress it exist, because these are stupid ideas.+-}+pipeSamOutput :: (IsBamRec a, MonadIO m) => BamMeta -> Stream (Of a) m r -> m r+pipeSamOutput meta s = do+    liftIO . B.hPutBuilder stdout $ showBamMeta meta+    Q.mapM_ (liftIO . B.hPutBuilder stdout . encodeSamEntry (meta_refs meta) . unpackBamRec) s+{-# INLINE pipeSamOutput #-}++encodeSamEntry :: Refs -> BamRec -> B.Builder+encodeSamEntry refs b =+    B.byteStringCopy (b_qname b)                         <> B.char7 '\t' <>+    B.intDec         (b_flag b .&. 0xffff)               <> B.char7 '\t' <>+    B.byteStringCopy (sq_name $ getRef refs $ b_rname b) <> B.char7 '\t' <>+    B.intDec         (b_pos b + 1)                       <> B.char7 '\t' <>+    B.word8Dec       (unQ $ b_mapq b)                    <> B.char7 '\t' <>+    buildCigar       (b_cigar b)                         <> B.char7 '\t' <>+    buildMrnm        (b_mrnm b) (b_rname b)              <> B.char7 '\t' <>+    B.intDec         (b_mpos b + 1)                      <> B.char7 '\t' <>+    B.intDec         (b_isize b)                         <> B.char7 '\t' <>+    buildSeq         (b_seq b)                           <> B.char7 '\t' <>+    buildQual        (b_qual b)                          <>+    foldMap buildExt (b_exts b)                          <> B.char7 '\n'+  where+    buildCigar = E.primUnfoldrBounded+                    (E.intDec >*< E.liftFixedToBounded E.word8)+                    (vuncons $ \(op :* num) -> (num, B.index "MIDNSHP" (fromEnum op)))++    buildMrnm mrnm rname+        | isValidRefseq mrnm && mrnm == rname  =  B.char7 '='+        | otherwise                            =  B.byteString (sq_name $ getRef refs mrnm)++    buildSeq  = E.primUnfoldrFixed E.word8 (vuncons $ \(Ns x) -> B.index "-ACMGRSVTWYHKDBN" $ fromIntegral $ x .&. 15)+    buildQual = E.primUnfoldrFixed E.word8 (vuncons $ \(Q  q) -> q + 33)++    buildExt (BamKey k,v) = B.char7 '\t' <>+                            B.word8 (fromIntegral k .&. 0xff) <>+                            B.word8 (shiftR (fromIntegral k) 8 .&. 0xff) <>+                            B.char7 ':' <>+                            buildExtVal v++    buildExtVal (Int      i) = B.char7 'i' <> B.char7 ':' <> B.intDec i+    buildExtVal (Float    f) = B.char7 'f' <> B.char7 ':' <> B.floatDec f+    buildExtVal (Text     t) = B.char7 'Z' <> B.char7 ':' <> B.byteStringCopy t+    buildExtVal (Bin      x) = B.char7 'H' <> B.char7 ':' <> B.byteStringHex x+    buildExtVal (Char     c) = B.char7 'A' <> B.char7 ':' <> B.word8 c+    buildExtVal (IntArr   a) = B.char7 'B' <> B.char7 ':' <> B.char7 'i' <> buildArr   B.intDec a+    buildExtVal (FloatArr a) = B.char7 'B' <> B.char7 ':' <> B.char7 'f' <> buildArr B.floatDec a++    buildArr p = U.foldr (\x k -> B.char7 ',' <> p x <> k) mempty++    vuncons f v | V.null  v = Nothing+                | otherwise = Just (f (V.unsafeHead v), V.unsafeTail v)+++class IsBamRec a where+    pushBam :: a -> BgzfTokens -> BgzfTokens+    unpackBamRec :: a -> BamRec++instance IsBamRec BamRaw where+    {-# INLINE pushBam #-}+    pushBam = pushBamRaw+    {-# INLINE unpackBamRec #-}+    unpackBamRec = unpackBam++instance IsBamRec BamRec where+    {-# INLINE pushBam #-}+    pushBam = pushBamRec+    {-# INLINE unpackBamRec #-}+    unpackBamRec = id++instance (IsBamRec a, IsBamRec b) => IsBamRec (Either a b) where+    {-# INLINE pushBam #-}+    pushBam = either pushBam pushBam+    {-# INLINE unpackBamRec #-}+    unpackBamRec = either unpackBamRec unpackBamRec++-- | Encodes BAM records straight into a dynamic buffer, then BGZF's it.+-- Should be fairly direct and perform well.+encodeBamWith :: (IsBamRec a, MonadIO m) => Int -> BamMeta -> Stream (Of a) m r -> ByteStream m r+encodeBamWith lv meta = encodeBgzf lv . enc_bam+  where+    enc_bam bs = Q.cons pushHeader $ Q.map (Endo . pushBam) bs++    pushHeader :: Endo BgzfTokens+    pushHeader = Endo $ TkString "BAM\1"+                      . TkSetMark                        -- the length byte+                      . pushBuilder (showBamMeta meta)+                      . TkEndRecord                      -- fills the length in+                      . TkWord32 (fromIntegral . V.length . unRefs $ meta_refs meta)+                      . appEndo (foldMap (Endo . pushRef) (unRefs $ meta_refs meta))++    pushRef :: BamSQ -> BgzfTokens -> BgzfTokens+    pushRef bs = TkWord32 (fromIntegral $ B.length (sq_name bs) + 1)+               . TkString (sq_name bs)+               . TkWord8 0+               . TkWord32 (fromIntegral $ sq_length bs)++    pushBuilder :: B.Builder -> BgzfTokens -> BgzfTokens+    pushBuilder b tk = foldrChunks TkString tk (B.toLazyByteString b)+{-# INLINE encodeBamWith #-}++pushBamRaw :: BamRaw -> BgzfTokens -> BgzfTokens+pushBamRaw r = TkWord32 (fromIntegral $ B.length $ raw_data r) .+               TkString (raw_data r)+{-# INLINE pushBamRaw #-}++-- | Writes BAM encoded stuff to a file.+-- In reality, it cleverly writes to a temporary file and renames it+-- when done.+writeBamFile :: (IsBamRec a, MonadIO m, MonadMask m) => FilePath -> BamMeta -> Stream (Of a) m r -> m r+writeBamFile fp meta = S.writeFile fp . encodeBamWith 6 meta++-- | Write BAM encoded stuff to stdout.+-- This sends uncompressed(!) BAM to stdout.  Useful for piping to other+-- tools.  The output is still wrapped in a BGZF stream, because that's+-- what all tools expect; but the individuals blocks are not compressed.+pipeBamOutput :: (IsBamRec a, MonadIO m) => BamMeta -> Stream (Of a) m r -> m r+pipeBamOutput meta = S.hPut stdout . encodeBamWith 0 meta+{-# INLINE pipeBamOutput #-}++-- | Writes BAM encoded stuff to a 'Handle'.+writeBamHandle :: (IsBamRec a, MonadIO m) => Handle -> BamMeta -> Stream (Of a) m r -> m r+writeBamHandle hdl meta = S.hPut hdl . encodeBamWith 6 meta++{-# RULES+    "pushBam/unpackBam"     forall b . pushBamRec (unpackBam b) = pushBamRaw b+  #-}++{-# INLINE[1] pushBamRec #-}+pushBamRec :: BamRec -> BgzfTokens -> BgzfTokens+pushBamRec BamRec{..} =+      TkSetMark+    . TkWord32 (unRefseq b_rname)+    . TkWord32 (fromIntegral b_pos)+    . TkWord8  (fromIntegral $ B.length b_qname + 1)+    . TkWord8  (unQ b_mapq)+    . TkWord16 (fromIntegral bin)+    . TkWord16 (fromIntegral $ W.length b_cigar)+    . TkWord16 (fromIntegral b_flag)+    . TkWord32 (fromIntegral $ V.length b_seq)+    . TkWord32 (unRefseq b_mrnm)+    . TkWord32 (fromIntegral b_mpos)+    . TkWord32 (fromIntegral b_isize)+    . TkString b_qname+    . TkWord8 0+    . W.foldr ((.) . TkWord8) id (W.unsafeCast b_cigar :: W.Vector Word8)+    . pushSeq b_seq+    . W.foldr ((.) . TkWord8 . unQ) id b_qual+    . foldr ((.) . pushExt) id b_exts+    . TkEndRecord+  where+    bin = distinctBin b_pos (alignedLength b_cigar)++    pushSeq :: V.Vector vec Nucleotides => vec Nucleotides -> BgzfTokens -> BgzfTokens+    pushSeq v = case v V.!? 0 of+                    Nothing -> id+                    Just a  -> case v V.!? 1 of+                        Nothing -> TkWord8 (unNs a `shiftL` 4)+                        Just b  -> TkWord8 (unNs a `shiftL` 4 .|. unNs b) . pushSeq (V.drop 2 v)++    pushExt :: (BamKey, Ext) -> BgzfTokens -> BgzfTokens+    pushExt (BamKey k, e) = case e of+        Text  t -> common 'Z' . TkString t . TkWord8 0+        Bin   t -> common 'H' . TkString t . TkWord8 0+        Char  c -> common 'A' . TkWord8 c+        Float f -> common 'f' . TkWord32 (fromFloat f)++        Int i   -> case put_some_int (U.singleton i) of+                        (c,op) -> common c . op i++        IntArr  ia -> case put_some_int ia of+                        (c,op) -> common 'B' . TkWord8 (fromIntegral $ ord c)+                                  . TkWord32 (fromIntegral $ U.length ia-1)+                                  . U.foldr ((.) . op) id ia++        FloatArr fa -> common 'B' . TkWord8 (fromIntegral $ ord 'f')+                       . TkWord32 (fromIntegral $ U.length fa-1)+                       . U.foldr ((.) . TkWord32 . fromFloat) id fa+      where+        common :: Char -> BgzfTokens -> BgzfTokens+        common z = TkWord16 k . TkWord8 (fromIntegral $ ord z)++        put_some_int :: U.Vector Int -> (Char, Int -> BgzfTokens -> BgzfTokens)+        put_some_int is+            | U.all (between        0    0xff) is = ('C', TkWord8  . fromIntegral)+            | U.all (between   (-0x80)   0x7f) is = ('c', TkWord8  . fromIntegral)+            | U.all (between        0  0xffff) is = ('S', TkWord16 . fromIntegral)+            | U.all (between (-0x8000) 0x7fff) is = ('s', TkWord16 . fromIntegral)+            | U.all                      (> 0) is = ('I', TkWord32 . fromIntegral)+            | otherwise                           = ('i', TkWord32 . fromIntegral)++        between :: Int -> Int -> Int -> Bool+        between l r x = l <= x && x <= r++        fromFloat :: Float -> Word32+        fromFloat float = unsafeDupablePerformIO $ alloca $ \buf ->+                          pokeByteOff buf 0 float >> peek buf++packBam :: BamRec -> IO BamRaw+packBam br = do bb <- newBuffer 1000+                (bb', TkEnd) <- store_loop bb (pushBamRec br TkEnd)+                return . bamRaw 0 $ PS (buffer bb') 4 (used bb' - 4)+  where+    store_loop bb tk = do (bb',tk') <- fillBuffer bb tk+                          case tk' of TkEnd -> return (bb',tk')+                                      _     -> do bb'' <- expandBuffer (128*1024) bb'+                                                  store_loop bb'' tk'+

@@ -0,0 +1,339 @@+{-# LANGUAGE CPP #-}+-- | Common data types used everywhere.  This module is a collection of+-- very basic "bioinformatics" data types that are simple, but don't+-- make sense to define over and over.++module Bio.Base(+    Nucleotide(..), Nucleotides(..),+    Qual(..), toQual, fromQual, fromQualRaised, probToQual,+    Prob'(..), Prob, toProb, fromProb, qualToProb, pow,++    Pair(..),+    Word8,+    nucA, nucC, nucG, nucT,+    nucsA, nucsC, nucsG, nucsT, nucsN, gap,+    toNucleotide, toNucleotides, nucToNucs,+    showNucleotide, showNucleotides,+    isGap,+    isBase,+    isProperBase,+    properBases,+    compl, compls,++    Position(..),+    shiftPosition,+    p_is_reverse,++    Range(..),+    shiftRange,+    reverseRange,+    extendRange,+    insideRange,+    wrapRange+) where++import BasePrelude+#if MIN_VERSION_base(4,9,0)+                             hiding ( log1pexp, log1mexp )+#endif+import Bio.Util.Numeric             ( log1pexp, log1mexp )++import qualified Data.ByteString.Char8 as C+import qualified Data.Vector.Unboxed   as U++-- | A nucleotide base.  We only represent A,C,G,T.  The contained+-- 'Word8' ist guaranteed to be 0..3.+newtype Nucleotide = N { unN :: Word8 } deriving ( Eq, Ord, Enum, Ix, Storable )++instance Bounded Nucleotide where+    minBound = N 0+    maxBound = N 3++-- | A nucleotide base in an alignment.+-- Experience says we're dealing with Ns and gaps all the type, so+-- purity be damned, they are included as if they were real bases.+--+-- To allow @Nucleotides@s to be unpacked and incorporated into+-- containers, we choose to represent them the same way as the BAM file+-- format:  as a 4 bit wide field.  Gaps are encoded as 0 where they+-- make sense, N is 15.  The contained 'Word8' is guaranteed to be+-- 0..15.++newtype Nucleotides = Ns { unNs :: Word8 } deriving ( Eq, Ord, Enum, Ix, Storable )++instance Bounded Nucleotides where+    minBound = Ns  0+    maxBound = Ns 15++nucToNucs :: Nucleotide -> Nucleotides+nucToNucs (N x) = Ns $ 1 `shiftL` fromIntegral (x .&. 3)++-- | Qualities are stored in deciban, also known as the Phred scale.  To+-- represent a value @p@, we store @-10 * log_10 p@.  Operations work+-- directly on the \"Phred\" value, as the name suggests.  The same goes+-- for the 'Ord' instance:  greater quality means higher \"Phred\"+-- score, meand lower error probability.++newtype Qual = Q { unQ :: Word8 } deriving ( Eq, Ord, Storable, Bounded )++instance Show Qual where+    showsPrec p (Q q) = (:) 'q' . showsPrec p q++toQual :: (Floating a, RealFrac a) => a -> Qual+toQual a = Q $ round (-10 * log a / log 10)++fromQual :: Qual -> Double+fromQual (Q q) = 10 ** (- fromIntegral q / 10)++fromQualRaised :: Double -> Qual -> Double+fromQualRaised k (Q q) = 10 ** (- k * fromIntegral q / 10)++-- | A positive floating point value stored in log domain.  We store the+-- natural logarithm (makes computation easier), but allow conversions+-- to the familiar \"Phred\" scale used for 'Qual' values.+newtype Prob' a = Pr { unPr :: a } deriving ( Eq, Ord, Storable )++-- | Common way of using 'Prob''.+type Prob = Prob' Double++instance RealFloat a => Show (Prob' a) where+    showsPrec _ (Pr p) = (:) 'q' . showFFloat (Just 1) q+      where q = - 10 * p / log 10++instance (Floating a, Ord a) => Num (Prob' a) where+    {-# INLINE fromInteger #-}+    fromInteger a = Pr (log (fromInteger a))+    {-# INLINE (+) #-}+    Pr x + Pr y = Pr $ if x >= y then x + log1pexp (y-x) else y + log1pexp (x-y)+    {-# INLINE (-) #-}+    Pr x - Pr y = Pr $ if x >= y then x + log1mexp (y-x) else error "no negative error probabilities"+    {-# INLINE (*) #-}+    Pr a * Pr b = Pr $ a + b+    {-# INLINE negate #-}+    negate    _ = Pr $ error "no negative error probabilities"+    {-# INLINE abs #-}+    abs       x = x+    {-# INLINE signum #-}+    signum    _ = Pr 0++instance (Floating a, Fractional a, Ord a) => Fractional (Prob' a) where+    fromRational a = Pr (log (fromRational a))+    Pr a  /  Pr b = Pr (a - b)+    recip  (Pr a) = Pr (negate a)++infixr 8 `pow`+pow :: Num a => Prob' a -> a -> Prob' a+pow (Pr a) e = Pr $ a * e+++toProb :: Floating a => a -> Prob' a+toProb p = Pr (log p)++fromProb :: Floating a => Prob' a -> a+fromProb (Pr q) = exp q++qualToProb :: Floating a => Qual -> Prob' a+qualToProb (Q q) = Pr (- log 10 * fromIntegral q / 10)++probToQual :: (Floating a, RealFrac a) => Prob' a -> Qual+probToQual (Pr p) = Q (round (- 10 * p / log 10))++nucA, nucC, nucG, nucT :: Nucleotide+nucA = N 0+nucC = N 1+nucG = N 2+nucT = N 3++gap, nucsA, nucsC, nucsG, nucsT, nucsN :: Nucleotides+gap   = Ns 0+nucsA = Ns 1+nucsC = Ns 2+nucsG = Ns 4+nucsT = Ns 8+nucsN = Ns 15+++-- | Coordinates in a genome.+-- The position is zero-based, no questions about it.  Think of the+-- position as pointing to the crack between two bases: looking forward+-- you see the next base to the right, looking in the reverse direction+-- you see the complement of the first base to the left.+--+-- To encode the strand, we (virtually) reverse-complement any sequence+-- and prepend it to the normal one.  That way, reversed coordinates+-- have a negative sign and automatically make sense.  Position 0 could+-- either be the beginning of the sequence or the end on the reverse+-- strand... that ambiguity shouldn't really matter.++data Position = Pos {+        p_seq   :: {-# UNPACK #-} !C.ByteString,    -- ^ sequence (e.g. some chromosome)+        p_start :: {-# UNPACK #-} !Int              -- ^ offset, zero-based+    } deriving (Show, Eq, Ord)++p_is_reverse :: Position -> Bool+p_is_reverse = (< 0) . p_start++-- | Ranges in genomes+-- We combine a position with a length.  In 'Range pos len', 'pos' is+-- always the start of a stretch of length 'len'.  Positions therefore+-- move in the opposite direction on the reverse strand.  To get the+-- same stretch on the reverse strand, shift r_pos by r_length, then+-- reverse direction (or call reverseRange).+data Range = Range {+        r_pos    :: {-# UNPACK #-} !Position,+        r_length :: {-# UNPACK #-} !Int+    } deriving (Show, Eq, Ord)+++-- | Converts a character into a 'Nucleotides'.+-- The usual codes for A,C,G,T and U are understood, '-' and '.' become+-- gaps and everything else is an N.+toNucleotide :: Char -> Nucleotide+toNucleotide c = if ord c < 128 then N (ar `U.unsafeIndex` ord c) else N 0+  where+    ar = U.replicate 128 0 U.//+          ( [ (ord          x,  n) | (x, N n) <- pairs ] +++            [ (ord (toUpper x), n) | (x, N n) <- pairs ] )++    pairs = [ ('a', nucA), ('c', nucC), ('g', nucG), ('t', nucT) ]+++-- | Converts a character into a 'Nucleotides'.+-- The usual codes for A,C,G,T and U are understood, '-' and '.' become+-- gaps and everything else is an N.+toNucleotides :: Char -> Nucleotides+toNucleotides c = if ord c < 128 then Ns (ar `U.unsafeIndex` ord c) else nucsN+  where+    ar = U.replicate 128 (unNs nucsN) U.//+          ( [ (ord          x,  n) | (x, Ns n) <- pairs ] +++            [ (ord (toUpper x), n) | (x, Ns n) <- pairs ] )++    Ns a `plus` Ns b = Ns (a .|. b)++    pairs = [ ('a', nucsA), ('c', nucsC), ('g', nucsG), ('t', nucsT),+              ('u', nucsT), ('-', gap),  ('.', gap),+              ('b', nucsC `plus` nucsG `plus` nucsT),+              ('d', nucsA `plus` nucsG `plus` nucsT),+              ('h', nucsA `plus` nucsC `plus` nucsT),+              ('v', nucsA `plus` nucsC `plus` nucsG),+              ('k', nucsG `plus` nucsT),+              ('m', nucsA `plus` nucsC),+              ('s', nucsC `plus` nucsG),+              ('w', nucsA `plus` nucsT),+              ('r', nucsA `plus` nucsG),+              ('y', nucsC `plus` nucsT) ]++-- | Tests if a 'Nucleotides' is a base.+-- Returns 'True' for everything but gaps.+isBase :: Nucleotides -> Bool+isBase (Ns n) = n /= 0++-- | Tests if a 'Nucleotides' is a proper base.+-- Returns 'True' for A,C,G,T only.+isProperBase :: Nucleotides -> Bool+isProperBase x = x == nucsA || x == nucsC || x == nucsG || x == nucsT++properBases :: [ Nucleotides ]+properBases = [ nucsA, nucsC, nucsG, nucsT ]++-- | Tests if a 'Nucleotides' is a gap.+-- Returns true only for the gap.+isGap :: Nucleotides -> Bool+isGap x = x == gap+++{-# INLINE showNucleotide #-}+showNucleotide :: Nucleotide -> Char+showNucleotide (N x) = C.index "ACGT" $ fromIntegral $ x .&. 3++{-# INLINE showNucleotides #-}+showNucleotides :: Nucleotides -> Char+showNucleotides (Ns x) = C.index  "-ACMGRSVTWYHKDBN" $ fromIntegral $ x .&. 15++instance Show Nucleotide where+    show     x = [ showNucleotide x ]+    showList l = (map showNucleotide l ++)++instance Read Nucleotide where+    readsPrec _ ('a':cs) = [(nucA, cs)]+    readsPrec _ ('A':cs) = [(nucA, cs)]+    readsPrec _ ('c':cs) = [(nucC, cs)]+    readsPrec _ ('C':cs) = [(nucC, cs)]+    readsPrec _ ('g':cs) = [(nucG, cs)]+    readsPrec _ ('G':cs) = [(nucG, cs)]+    readsPrec _ ('t':cs) = [(nucT, cs)]+    readsPrec _ ('T':cs) = [(nucT, cs)]+    readsPrec _ ('u':cs) = [(nucT, cs)]+    readsPrec _ ('U':cs) = [(nucT, cs)]+    readsPrec _     _    = [          ]++    readList ('-':cs) = readList cs+    readList (c:cs) | isSpace c = readList cs+                    | otherwise = case reads (c:cs) of+                            [] -> [ ([],c:cs) ]+                            xs -> [ (n:ns,r2) | (n,r1) <- xs, (ns,r2) <- readList r1 ]+    readList [] = [([],[])]++instance Show Nucleotides where+    show     x = [ showNucleotides x ]+    showList l = (map showNucleotides l ++)++instance Read Nucleotides where+    readsPrec _ (c:cs) = [(toNucleotides c, cs)]+    readsPrec _ [    ] = []+    readList s = let (hd,tl) = span (\c -> isAlpha c || isSpace c || '-' == c) s+                 in [(map toNucleotides $ filter (not . isSpace) hd, tl)]++-- | Complements a Nucleotides.+{-# INLINE compl #-}+compl :: Nucleotide -> Nucleotide+compl (N n) = N $ n `xor` 3++-- | Complements a Nucleotides.+{-# INLINE compls #-}+compls :: Nucleotides -> Nucleotides+compls (Ns x) = Ns $ ar `U.unsafeIndex` fromIntegral (x .&. 15)+  where+    !ar = U.fromListN 16 [ 0, 8, 4, 12, 2, 10, 6, 14, 1, 9, 5, 13, 3, 11, 7, 15 ]+++-- | Moves a @Position@.  The position is moved forward according to the+-- strand, negative indexes move backward accordingly.+shiftPosition :: Int -> Position -> Position+shiftPosition a p = p { p_start = p_start p + a }++-- | Moves a @Range@.  This is just @shiftPosition@ lifted.+shiftRange :: Int -> Range -> Range+shiftRange a r = r { r_pos = shiftPosition a (r_pos r) }++-- | Reverses a 'Range' to give the same @Range@ on the opposite strand.+reverseRange :: Range -> Range+reverseRange (Range (Pos sq pos) len) = Range (Pos sq (-pos-len)) len++-- | Extends a range.  The length of the range is simply increased.+extendRange :: Int -> Range -> Range+extendRange a r = r { r_length = r_length r + a }++-- | Expands a subrange.+-- @(range1 `insideRange` range2)@ interprets @range1@ as a subrange of+-- @range2@ and computes its absolute coordinates.  The sequence name of+-- @range1@ is ignored.+insideRange :: Range -> Range -> Range+insideRange r1@(Range (Pos _ start1) length1) r2@(Range (Pos sq start2) length2)+    | start2 < 0         = reverseRange (insideRange r1 (reverseRange r2))+    | start1 <= length2  = Range (Pos sq (start2 + start1)) (min length1 (length2 - start1))+    | otherwise          = Range (Pos sq (start2 + length2)) 0+++-- | Wraps a range to a region.  This simply normalizes the start+-- position to be in the interval '[0,n)', which only makes sense if the+-- @Range@ is to be mapped onto a circular genome.  This works on both+-- strands and the strand information is retained.+wrapRange :: Int -> Range -> Range+wrapRange n (Range (Pos sq s) l) = Range (Pos sq (s `mod` n)) l+++-- | A strict pair.+data Pair a b = !a :!: !b deriving(Eq, Ord, Show, Read, Bounded, Ix)+infixl 2 :!:+

@@ -0,0 +1,65 @@+{-# LANGUAGE CPP #-}+module Bio.Prelude (+    module BasePrelude,+    module Bio.Base,+    module Bio.Util.Text,+    module Control.Monad.Catch,+    module Control.Monad.IO.Class,+    module Control.Monad.Trans.Class,+    module Data.Bifunctor,+    module Data.List.NonEmpty,+    module Data.Semigroup,+    module System.IO,++    Bytes, LazyBytes,+    Generic1(..),+    Hashable(..),+    Hashable1(..),+    Hashable2(..),+    HashMap,+    HashSet,+    IntMap,+    IntSet,+    NonEmpty(..),+    Semigroup(..),+    Text, LazyText+                   ) where++import BasePrelude hiding ( (<>), EOF+                          , bracket, bracket_, bracketOnError+                          , catch, catches, catchIOError, catchJust+                          , Handler, handle, handleJust+                          , finally, try, tryJust, onException+                          , mask, mask_, uninterruptibleMask, uninterruptibleMask_+#if MIN_VERSION_base(4,9,0)+                          , log1p, log1pexp, log1mexp, expm1+#endif+                          )++import Bio.Base+import Bio.Util.Text+import Control.Monad.Catch+import Control.Monad.IO.Class+import Control.Monad.Trans.Class+import Data.Bifunctor+import Data.ByteString              ( ByteString )+import Data.List.NonEmpty           ( NonEmpty(..) )+import Data.Semigroup               ( Semigroup(..) )+import Data.Text                    ( Text )+import Data.Hashable                ( Hashable(..) )+import Data.Hashable.Lifted         ( Hashable1(..), Hashable2(..) )+import Data.HashMap.Strict          ( HashMap )+import Data.HashSet                 ( HashSet )+import Data.IntMap                  ( IntMap )+import Data.IntSet                  ( IntSet )+import GHC.Generics                 ( Generic1(..) )+import System.IO                    ( hPrint, hPutStr, hPutStrLn, stderr, stdout, stdin+                                    , openBinaryFile, withBinaryFile, IOMode(..)+                                    , hFlush, hSeek, hClose, SeekMode(..) )++import qualified Data.ByteString.Lazy   as BL+import qualified Data.Text.Lazy         as TL++type Bytes     =    ByteString+type LazyBytes = BL.ByteString+type LazyText  = TL.Text

@@ -0,0 +1,195 @@+module Bio.Streaming+    ( MonadIO(..)+    , MonadMask+    , ByteStream++    , streamFile+    , streamHandle+    , streamInput+    , streamInputs+    , withOutputFile++    , protectTerm+    , psequence+    , progressGen+    , progressNum+    , progressPos++    , mergeStreams+    , mergeStreamsBy+    , mergeStreamsOn++    , module Streaming+    , module Streaming.Prelude )+  where++import Bio.Bam.Header+import Bio.Prelude+import Bio.Streaming.Bytes+import Bio.Util.Numeric                     ( showNum )+import Streaming                     hiding ( (<>) )+import Streaming.Internal                   ( Stream(..) )+import Streaming.Prelude                    ( each )+import System.IO++import qualified Streaming.Prelude      as Q++{- | Default buffer size in elements.++Since we often want to merge many files, a read should take more time+than a seek.  Assuming a rotating hard drive, this sets the sensible+buffer size to somewhat more than one MB.  A smaller buffer size would+surely work on SSDs, but the large buffer doesn't hurt either.+-}+defaultBufSize :: Int+defaultBufSize = 2*1024*1024++streamFile :: (MonadIO m, MonadMask m) => FilePath -> (ByteStream m () -> m r) -> m r+streamFile f k = bracket (liftIO $ openBinaryFile f ReadMode) (liftIO . hClose) (k . streamHandle)+{-# INLINE streamFile #-}++streamHandle :: MonadIO m => Handle -> ByteStream m ()+streamHandle = hGetContentsN defaultBufSize+{-# INLINE streamHandle #-}++-- | Reads 'stdin' if the filename is \"-\", else reads the named file.+streamInput :: (MonadIO m, MonadMask m) => FilePath -> (ByteStream m () -> m r) -> m r+streamInput "-" k = k (streamHandle stdin)+streamInput  f  k = streamFile f k+{-# INLINE streamInput #-}++{- | Reads multiple inputs in sequence.++Only one file is opened at a time, so they must also be consumed in+sequence.  The filename \"-\" refers to stdin, if no filenames are+given, stdin is read.+-}+streamInputs :: MonadIO m => [FilePath] -> (Stream (ByteStream m) m () -> r) -> r+streamInputs [] k = k $ yields (streamHandle stdin)+streamInputs fs k = k $ mapM_ go fs+  where+    go "-" = yields (streamHandle stdin)+    go  f  = yields $ do h <- liftIO $ openBinaryFile f ReadMode+                         streamHandle h+                         liftIO $ hClose h+{-# INLINE streamInputs #-}++{- | Protects the terminal from binary junk.++If @s@ is a 'Stream', then @protectTerm s@ throws an error if 'stdout'+is a terminal device, followed by the same 'Stream'.  This is most+usefully composed with functions that might otherwise write binary data+to an interactive terminal.+-}+protectTerm :: (Functor f, MonadIO m) => Stream f m r -> Stream f m r+protectTerm str = do+    t <- liftIO $ hIsTerminalDevice stdout+    when t . liftIO . throwM $ ErrorCall "cowardly refusing to write binary data to terminal"+    str+{-# INLINE protectTerm #-}++{- Like 'Streaming.sequence', but parallel.++This runs each element of a stream of actions.  A configurable number of+actions are buffered and run asynchronously.+-}+psequence :: MonadIO m => Int -> Stream (Of (IO a)) m b -> Stream (Of a) m b+psequence np = go emptyQ+  where+    -- if the queue is full, wait for the head element to complete+    go !qq s = case popQ qq of+        Just (a,qq') | lengthQ qq == np -> reap a >>= wrap . (:> go qq' s)+        _                               -> lift (inspect s) >>= go' qq++    -- if we have room for input, we get input+    go' !qq (Right (k :> s)) = liftIO (spawn k) >>= \a -> go (pushQ a qq) s+    go' !qq (Left         r) = goE r qq++    -- input ended, empty the queue+    goE r !qq = case popQ qq of+        Nothing      -> pure r+        Just (a,qq') -> reap a >>= wrap . (:> goE r qq')++    spawn :: IO a -> IO (MVar (Either SomeException a))+    spawn k = newEmptyMVar                  >>= \mv ->+              forkIO (try k >>= putMVar mv) >>+              return mv++    reap mv = liftIO (takeMVar mv) >>= either (liftIO . throwM) return+++-- A very simple queue data type.+-- Invariants: q = QQ l f b --> l == length f + length b+--                          --> l == 0 ==> null f++data QQ a = QQ !Int [a] [a]++emptyQ :: QQ a+emptyQ = QQ 0 [] []++lengthQ :: QQ a -> Int+lengthQ (QQ l _ _) = l++pushQ :: a -> QQ a -> QQ a+pushQ a (QQ l [] b) = QQ (l+1) (reverse (a:b)) []+pushQ a (QQ l  f b) = QQ (l+1) f (a:b)++popQ :: QQ a -> Maybe (a, QQ a)+popQ (QQ _ [    ] _) = Nothing+popQ (QQ l [ a  ] b) = Just (a, QQ (l-1) (reverse b) [])+popQ (QQ l (a:fs) b) = Just (a, QQ (l-1) fs b)+++mergeStreams :: (Monad m, Ord a)+             => Stream (Of a) m r -> Stream (Of a) m s -> Stream (Of a) m (r, s)+mergeStreams = mergeStreamsBy compare+{-# INLINE mergeStreams #-}++mergeStreamsOn :: (Monad m, Ord b)+               => (a -> b) -> Stream (Of a) m r -> Stream (Of a) m s -> Stream (Of a) m (r, s)+mergeStreamsOn f = mergeStreamsBy (comparing f)+{-# INLINE mergeStreamsOn #-}++mergeStreamsBy :: Monad m+               => (a -> a -> Ordering)+               -> Stream (Of a) m r -> Stream (Of a) m s -> Stream (Of a) m (r, s)+mergeStreamsBy cmp = go+  where+    go str0 str1 = case str0 of+      Return r0         -> (\r1 -> (r0, r1)) <$> str1+      Effect m          -> Effect $ liftM (\str -> go str str1) m+      Step (a :> rest0) -> case str1 of+        Return r1         -> (\r0 -> (r0, r1)) <$> str0+        Effect m          -> Effect $ liftM (go str0) m+        Step (b :> rest1) -> case cmp a b of+          LT -> Step (a :> go rest0 str1)+          EQ -> Step (a :> go rest0 str1) -- left-biased+          GT -> Step (b :> go str0 rest1)+{-# INLINABLE mergeStreamsBy #-}++-- | A general progress indicator that prints some message after a set+-- number of records have passed through.+progressGen :: MonadIO m+            => (Int -> a -> String) -> Int -> (String -> IO ())+            -> Q.Stream (Q.Of a) m r -> Q.Stream (Q.Of a) m r+progressGen msg sz put = go 0+  where+    go   !n = lift . Q.next >=> either pure (step $ succ n)+    step !n (a,s) = do when (n `mod` sz == 0) . liftIO . put $ "\27[K" ++ msg n a ++ "\r"+                       Q.cons a (go n s)++-- | A simple progress indicator that prints the number of records.+progressNum :: MonadIO m+            => String -> Int -> (String -> IO ())+            -> Q.Stream (Q.Of a) m r -> Q.Stream (Q.Of a) m r+progressNum msg = progressGen (\n _ -> msg ++ " " ++ showNum n)++-- | A simple progress indicator that prints a position every set number+-- of passed records.+progressPos :: MonadIO m+            => (a -> (Refseq, Int)) -> String -> Refs -> Int -> (String -> IO ())+            -> Q.Stream (Q.Of a) m r -> Q.Stream (Q.Of a) m r+progressPos f msg refs =+    progressGen $ \_ a -> let (!rs1, !po1) = f a+                              !nm = unpack . sq_name $ getRef refs rs1+                          in msg ++ " " ++ nm ++ ":" ++ showNum po1

@@ -0,0 +1,331 @@+{-# 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+                            ) where++import Bio.Prelude+import Bio.Streaming+import Foreign.C.Types                     ( CInt(..) )+import Foreign.Marshal.Utils               ( copyBytes, 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 s = do+    np <- liftIO $ getNumCapabilities+    S.fromChunks $ psequence (2*np) $ lift (getBgzfHdr s) >>= go+  where+    go (Nothing,    _hdr, s1) = lift (S.effects s1)+    go (Just bsize, _hdr, s1) = do+            blk :> s2 <- lift $ S.splitAt' bsize s1+            wrap (decompressChunk blk :> (lift (getBgzfHdr s2) >>= go))+{-# INLINABLE bgunzip #-}++getBgzfHdr :: Monad m => ByteStream m r -> m (Maybe Int, B.ByteString, ByteStream m r)+getBgzfHdr s0 = do+        hdr :> s1 <- S.splitAt' 18 s0+        if or [ B.length hdr < 18+              , B.index hdr 0 /= 139+              , B.index hdr 1 /= 31+              , B.index hdr 3 .&. 4 /= 4+              , B.index hdr 10 /= 6+              , B.index hdr 11 /= 0+              , B.index hdr 12 /= 66+              , B.index hdr 13 /= 67 ]+          then return (Nothing, hdr, s1)+          else do+            let bsize = fromIntegral (B.index hdr 16) + fromIntegral (B.index hdr 17) `shiftL` 8 - 16+            return (Just bsize, hdr, 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 { buffer :: {-# UNPACK #-} !(ForeignPtr Word8)+             , size   :: {-# UNPACK #-} !Int            -- total size of buffer+             , off    :: {-# UNPACK #-} !Int            -- offset of active portion+             , used   :: {-# UNPACK #-} !Int            -- used portion (inactive & active)+             , mark   :: {-# UNPACK #-} !Int            -- offset of mark+             , 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'++                | 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 sz = mallocForeignPtrBytes sz >>= \ar -> return $ BB ar sz 0 0 maxBound 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 minsz b = do+    let sz' = max (2 * (size b - used b)) minsz+    arr1 <- mallocForeignPtrBytes sz'+    withForeignPtr arr1 $ \d ->+        withForeignPtr (buffer b) $ \s ->+             copyBytes d (plusPtr s (off b)) (used b - off b)+    return BB{ buffer = arr1+             , size   = sz'+             , off    = 0+             , used   = used b - off b+             , mark   = if mark  b == maxBound then maxBound else mark  b - off b+             , mark2  = if mark2 b == maxBound then maxBound else mark2 b - off b }++compressChunk :: Int -> ForeignPtr Word8 -> Int -> Int -> IO B.ByteString+compressChunk lv fptr off slen =+    withForeignPtr fptr                 $ \ptr ->+    B.createAndTrim 65536               $ \buf ->+    with 65536                          $ \p_len -> do+        rc <- compress_chunk buf p_len (plusPtr ptr off) (fromIntegral slen) (fromIntegral lv)+        when (rc /= 0 && rc /= 1) . error $ "compress_chunk failed: " ++ show rc+        fromIntegral <$> peek p_len++decompressChunk :: B.ByteString -> IO B.ByteString+decompressChunk ck =+    B.unsafeUseAsCString ck                         $ \psrc ->+    peekByteOff psrc (B.length ck - 4)            >>= \dlen ->+    B.create (fromIntegral (dlen::Word32))          $ \pdest -> do+        rc <- decompress_chunk pdest (fromIntegral dlen) (castPtr psrc) (fromIntegral $ B.length ck)+        when (rc /= 0) . error $ "decompress_chunk failed: " ++ show 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 lv str = do+    np <- liftIO $ getNumCapabilities+    bb <- liftIO $ newBuffer (1024*1024)+    S.fromChunks $ psequence (2*np) $ lift (inspect str) >>= go bb+  where+    go :: MonadIO m+       => BB+       -> Either b (Of (Endo BgzfTokens) (Stream (Of (Endo BgzfTokens)) m b))+       -> Stream (Of (IO Bytes)) m b+    go bb0 (Left r) = final_flush bb0 r+    go bb0 (Right (f :> s))+        -- initially, we make sure we have reasonable space.  this may not be enough.+        | size bb0 - used bb0 < 1024 = liftIO (expandBuffer (1024*1024) bb0) >>= \bb' -> go' bb' (appEndo f TkEnd) s+        | otherwise                  =                                                   go' bb0 (appEndo f TkEnd) s++    go' bb0 tk s = liftIO (fillBuffer bb0 tk) >>= \(bb',tk') -> flush_blocks tk' bb' s++    -- We can flush anything that is between 'off' and the lower of 'mark'+    -- and 'used'.  When done, we bump 'off'.+    flush_blocks tk bb s+        | min (mark bb) (used bb) - off bb < maxBlockSize =+            case tk of TkEnd -> lift (inspect s) >>= go bb+                       _     -> -- we arrive here because we ran out of buffer space, so we expand it.+                                liftIO (expandBuffer (1024*1024) bb) >>= \bb' -> go' bb' tk s+        | otherwise =+            wrap $  compressChunk lv (buffer bb) (off bb) maxBlockSize+                 :> flush_blocks tk bb { off = off bb + maxBlockSize } s++    final_flush bb r+        | used bb > off bb =+            wrap $  compressChunk lv (buffer bb) (off bb) (used bb - off bb)+                 :> wrap (return bgzfEofMarker :> pure r)+        | otherwise =+            wrap (return bgzfEofMarker :> pure r)++    -- maximum block size for Bgzf: 64k with some room for+    -- headers and uncompressible stuff+    maxBlockSize = 65478+++fillBuffer :: BB -> BgzfTokens -> IO (BB, BgzfTokens)+fillBuffer bb0 tk = withForeignPtr (buffer bb0) (\p -> go_slowish p bb0 tk)+  where+    go_slowish p bb = go_fast p bb (used bb)++    go_fast p bb use tk1 = case tk1 of+        -- no space?  not our job.+        _ | size bb - use < 1024 -> return (bb { used = use },tk1)++        -- the actual end.+        TkEnd                    -> return (bb { used = use },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 tk' -> do pokeByteOff p use x+                               go_fast p bb (use + 4) tk'++        TkWord16   x tk' -> do pokeByteOff p use x+                               go_fast p bb (use + 2) tk'++        TkWord8    x tk' -> do pokeByteOff p use x+                               go_fast p bb (use + 1) tk'++        TkFloat    x tk' -> do pokeByteOff p use x+                               go_fast p bb (use + 4) tk'++        TkDouble   x tk' -> do pokeByteOff p use x+                               go_fast p bb (use + 8) tk'++        TkString   s tk'+            -- Too big, can't handle.  By returning with unfinished+            -- business, we will get progressively bigger buffers and+            -- eventually handle it.+            | B.length s > size bb - use -> return (bb { used = use },tk1)++            | otherwise  -> do let ln = B.length s+                               B.unsafeUseAsCString s $ \q ->+                                    copyBytes (p `plusPtr` use) q ln+                               go_fast p bb (use + ln) tk'++        TkDecimal  x tk' -> do ln <- int_loop (p `plusPtr` use) (fromIntegral x)+                               go_fast p bb (use + fromIntegral ln) tk'++        TkSetMark        tk' ->    go_slowish p bb { used = use + 4, mark = use } tk'++        TkEndRecord      tk' -> do let !l = use - mark bb - 4+                                   pokeByteOff p (mark bb) (fromIntegral l :: Word32)+                                   go_slowish p bb { used = use, mark = maxBound } tk'++        TkEndRecordPart1 tk' -> do let !l = use - mark bb - 4+                                   pokeByteOff p (mark bb - 4) (fromIntegral l :: Word32)+                                   go_slowish p bb { used = use, mark2 = use } tk'++        TkEndRecordPart2 tk' -> do let !l = use - mark2 bb+                                   pokeByteOff p (mark bb) (fromIntegral l :: Word32)+                                   go_slowish p bb { used = use, mark = maxBound } tk'+++        TkBclSpecial special_args tk' -> do+            l <- loop_bcl_special (p `plusPtr` use) special_args+            go_fast p bb (use + l) tk'++        TkLowLevel minsize proc tk'+            | size bb - use < minsize -> return (bb { used = use },tk1)+            | otherwise               -> do bb' <- proc bb { used = use }+                                            go_slowish p bb' 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 = "\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 p i = fromIntegral <$> int_loop p (fromIntegral i)++loop_bcl_special :: Ptr Word8 -> BclArgs -> IO Int+loop_bcl_special p (BclArgs tp vec stride u v i) =++    V.unsafeWith vec $ \q -> case tp of+        BclNucsBin -> do+            nuc_loop p (fromIntegral stride) (plusPtr q i) (fromIntegral u) (fromIntegral v)+            return $ (v - u + 2) `div` 2++        BclNucsWide -> do+            nuc_loop_wide p (fromIntegral stride) (plusPtr q i) (fromIntegral u) (fromIntegral v)+            return $ v - u + 1++        BclNucsAsc -> do+            nuc_loop_asc p (fromIntegral stride) (plusPtr q i) (fromIntegral u) (fromIntegral v)+            return $ v - u + 1++        BclNucsAscRev -> do+            nuc_loop_asc_rev p (fromIntegral stride) (plusPtr q i) (fromIntegral u) (fromIntegral v)+            return $ v - u + 1++        BclQualsBin -> do+            qual_loop p (fromIntegral stride) (plusPtr q i) (fromIntegral u) (fromIntegral v)+            return $ v - u + 1++        BclQualsAsc -> do+            qual_loop_asc p (fromIntegral stride) (plusPtr q i) (fromIntegral u) (fromIntegral v)+            return $ v - u + 1++        BclQualsAscRev -> do+            qual_loop_asc_rev p (fromIntegral stride) (plusPtr q i) (fromIntegral u) (fromIntegral v)+            return $ v - u + 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+

@@ -0,0 +1,780 @@+{-# LANGUAGE Rank2Types, TypeFamilies #-}++-- This library emulates Data.ByteStream.Lazy but includes a monadic element+-- and thus at certain points uses a `Stream`/`FreeT` type in place of lists.++-- |+-- Module      : ByteStream+-- Copyright   : (c) Don Stewart 2006+--               (c) Duncan Coutts 2006-2011+--               (c) Michael Thompson 2015+--               (c) Udo Stenzel 2018+-- License     : BSD-style+--+-- Maintainer  : u.stenzel@web.de+-- Stability   : experimental+-- Portability : portable+--+-- See the simple examples of use <https://gist.github.com/michaelt/6c6843e6dd8030e95d58 here>.+-- We begin with a slight modification of the documentation to "Data.ByteStream.Lazy":+--+-- A time and space-efficient implementation of effectful byte streams+-- using a stream of packed 'Word8' arrays, suitable for high performance+-- use, both in terms of large data quantities, or high speed+-- requirements. ByteStreams are encoded as streams of strict chunks+-- of bytes.+--+-- A key feature of ByteStreams is the means to manipulate large or+-- unbounded streams of data without requiring the entire sequence to be+-- resident in memory. To take advantage of this you have to write your+-- functions in a streaming style, e.g. classic pipeline composition. The+-- default I\/O chunk size is 32k, which should be good in most circumstances.+--+-- Some operations, such as 'concat', 'append', 'reverse' and 'cons', have+-- better complexity than their "Data.ByteStream" equivalents, due to+-- optimisations resulting from the list spine structure. For other+-- operations streaming, like lazy, ByteStreams are usually within a few percent of+-- strict ones.+--+-- This module is intended to be imported @qualified@, to avoid name+-- clashes with "Prelude" functions.  eg.+--+-- > import qualified Bio.Streaming.Bytes as B+--+-- Original GHC implementation by Bryan O\'Sullivan.+-- Rewritten to use 'Data.Array.Unboxed.UArray' by Simon Marlow.+-- Rewritten to support slices and use 'Foreign.ForeignPtr.ForeignPtr'+-- by David Roundy.+-- Rewritten again and extended by Don Stewart and Duncan Coutts.+-- Lazy variant by Duncan Coutts and Don Stewart.+-- Streaming variant by Michael Thompson, following the ideas of Gabriel Gonzales' pipes-bytestring+-- Adapted for use in biohazard by Udo Stenzel.+--+module Bio.Streaming.Bytes (+    -- * The @ByteStream@ type+    ByteStream(..)++    -- * Introducing and eliminating 'ByteStream's+    , empty            -- empty :: ByteStream m ()+    , singleton        -- singleton :: Monad m => Word8 -> ByteStream m ()+    , fromLazy         -- fromLazy :: Monad m => ByteStream -> ByteStream m ()+    , fromChunks       -- fromChunks :: Monad m => Stream (Of Bytes) m r -> ByteStream m r+    , toLazy           -- toLazy :: Monad m => ByteStream m () -> m ByteStream+    , toStrict         -- toStrict :: Monad m => ByteStream m () -> m ByteStream+    , effects+    , mwrap++    -- * Basic interface+    , cons             -- cons :: Monad m => Word8 -> ByteStream m r -> ByteStream m r+    , nextByte         -- nextByte :: Monad m => ByteStream m r -> m (Either r (Word8, ByteStream m r))+    , nextByteOff      -- nextByteOff :: Monad m => ByteStream m r -> m (Either r (Word8, Int64, ByteStream m r))++    -- * Substrings++    -- ** Breaking strings+    , break            -- break :: Monad m => (Word8 -> Bool) -> ByteStream m r -> ByteStream m (ByteStream m r)+    , drop             -- drop :: Monad m => GHC.Int.Int64 -> ByteStream m r -> ByteStream m r+    , dropWhile+    , splitAt          -- splitAt :: Monad m => GHC.Int.Int64 -> ByteStream m r -> ByteStream m (ByteStream m r)+    , splitAt'         -- splitAt' :: Monad m => Int -> ByteStream m r -> m (Of Bytes (ByteStream m r))+    , trim++    -- ** Breaking into many substrings+    , lines+    , lines'++    -- ** Special folds+    , concat          -- concat :: Monad m => Stream (ByteStream m) m r -> ByteStream m r++    -- * Builders+    , toByteStream+    , toByteStreamWith+    , concatBuilders++    -- * I\/O with 'ByteStream's++    -- ** Files+    , withOutputFile+    , writeFile        -- writeFile :: FilePath -> ByteStream IO r -> IO r++    -- ** I\/O with Handles+    , hGetContents     -- hGetContents :: Handle -> ByteStream IO ()+    , hGetContentsN    -- hGetContentsN :: Int -> Handle -> ByteStream IO ()+    , hPut             -- hPut :: Handle -> ByteStream IO r -> IO r++    -- * Simple chunkwise operations+    , nextChunk+    , nextChunkOff+    , consChunk             -- :: Bytes -> ByteStream m r -> ByteStream m r+    , consChunkOff          -- :: Bytes -> Int64 -> ByteStream m r -> ByteStream m r+    , chunk+    , copy+    , mapChunksM_++    -- * compression support+    , gzip+    , gunzip+    , gunzipWith++  ) where++import Bio.Prelude                      hiding (break,concat,drop,dropWhile,lines,splitAt,writeFile,empty,loop)+import Data.ByteString.Builder.Internal+        (Builder,builder,runBuilder,runBuilderWith,bufferSize+        ,AllocationStrategy,ChunkIOStream(..),buildStepToCIOS+        ,byteStringFromBuffer,safeStrategy,defaultChunkSize)+import GHC.Exts                                (SpecConstrAnnotation(..))+import Streaming                               (Of(..),Identity(..),destroy)+import Streaming.Internal                      (Stream (..))+import System.Directory                        (renameFile)++import qualified Codec.Compression.Zlib.Internal as Z+import qualified Data.ByteString                 as B+import qualified Data.ByteString.Internal        as B+import qualified Data.ByteString.Lazy.Internal   as L (foldrChunks,ByteString(..),smallChunkSize,defaultChunkSize)+import qualified Data.ByteString.Unsafe          as B+import qualified Streaming.Prelude               as Q++-- | A space-efficient representation of a succession of 'Word8' vectors, supporting many+-- efficient operations.+--+-- An effectful 'ByteStream' contains 8-bit bytes, or by using certain+-- operations can be interpreted as containing 8-bit characters.  It+-- also contains an offset, which will be needed to track the virtual+-- offsets in the BGZF decode.++data ByteStream m r =+  Empty r+  | Chunk {-# UNPACK #-} !Bytes {-# UNPACK #-} !Int64 (ByteStream m r)+  | Go (m (ByteStream m r))++instance Monad m => Functor (ByteStream m) where+  fmap f x = case x of+    Empty a        -> Empty (f a)+    Chunk bs o bss -> Chunk bs o (fmap f bss)+    Go mbss        -> Go (liftM (fmap f) mbss)++instance Monad m => Applicative (ByteStream m) where+  pure = Empty+  {-# INLINE pure #-}+  bf <*> bx = do {f <- bf; x <- bx; Empty (f x)}+  {-# INLINE (<*>) #-}+  (*>) = (>>)+  {-# INLINE (*>) #-}++instance Monad m => Monad (ByteStream m) where+  return = Empty+  {-# INLINE return #-}+  x0 >> y = loop SPEC x0 where+    loop !_ x = case x of   -- this seems to be insanely effective+      Empty _     -> y+      Chunk a o b -> Chunk a o (loop SPEC b)+      Go m        -> Go (liftM (loop SPEC) m)+  {-# INLINEABLE (>>) #-}+  x >>= f =+    loop SPEC2 x where -- unlike >> this SPEC seems pointless+      loop !_ y = case y of+        Empty a        -> f a+        Chunk bs o bss -> Chunk bs o (loop SPEC bss)+        Go mbss        -> Go (liftM (loop SPEC) mbss)+  {-# INLINEABLE (>>=) #-}++instance MonadIO m => MonadIO (ByteStream m) where+  liftIO io = Go (liftM Empty (liftIO io))+  {-# INLINE liftIO #-}++instance MonadTrans ByteStream where+  lift ma = Go $ liftM Empty ma+  {-# INLINE lift #-}++instance (r ~ ()) => IsString (ByteStream m r) where+  fromString = chunk . fromString+  {-# INLINE fromString #-}++instance (m ~ Identity, Show r) => Show (ByteStream m r) where+  show bs0 = case bs0 of  -- the implementation this instance deserves ...+    Empty r           -> "Empty (" ++ show r ++ ")"+    Go (Identity bs') -> "Go (Identity (" ++ show bs' ++ "))"+    Chunk bs'' o bs   -> "Chunk " ++ show bs'' ++ " " ++ show o ++ " (" ++ show bs ++ ")"++instance (Semigroup r, Monad m) => Semigroup (ByteStream m r) where+  (<>) = liftM2 (<>)+  {-# INLINE (<>) #-}++instance (Semigroup r, Monoid r, Monad m) => Monoid (ByteStream m r) where+  mempty = Empty mempty+  {-# INLINE mempty #-}+  mappend = (<>)+  {-# INLINE mappend #-}+++data SPEC = SPEC | SPEC2+{-# ANN type SPEC ForceSpecConstr #-}++-- --------------------------------------------------------------------------++-- | Smart constructor for 'Chunk'.+consChunk :: Bytes -> ByteStream m r -> ByteStream m r+consChunk c = consChunkOff c 0+{-# INLINE consChunk #-}++consChunkOff :: Bytes -> Int64 -> ByteStream m r -> ByteStream m r+consChunkOff c@(B.PS _ _ len) off cs+  | len == 0  = cs+  | otherwise = Chunk c off cs+{-# INLINE consChunkOff #-}++-- | Yield-style smart constructor for 'Chunk'.+chunk :: Bytes -> ByteStream m ()+chunk bs = consChunk bs empty+{-# INLINE chunk #-}+++{- | Reconceive an effect that results in an effectful bytestring as an effectful bytestring.+    Compare Streaming.mwrap. The closes equivalent of++>>> Streaming.wrap :: f (Stream f m r) -> Stream f m r++    is here  @consChunk@. @mwrap@ is the smart constructor for the internal @Go@ constructor.+-}+mwrap :: m (ByteStream m r) -> ByteStream m r+mwrap = Go+{-# INLINE mwrap #-}++-- | Construct a succession of chunks from its Church encoding (compare @GHC.Exts.build@)+materialize :: (forall x . (r -> x) -> (Bytes -> Int64 -> x -> x) -> (m x -> x) -> x)+            -> ByteStream m r+materialize phi = phi Empty Chunk Go+{-# INLINE[0] materialize #-}++-- | Resolve a succession of chunks into its Church encoding; this is+-- not a safe operation; it is equivalent to exposing the constructors+dematerialize :: Monad m+              => ByteStream m r+              -> (forall x . (r -> x) -> (Bytes -> Int64 -> x -> x) -> (m x -> x) -> x)+dematerialize x0 nil con fin = loop SPEC x0+  where+  loop !_ x = case x of+     Empty r      -> nil r+     Chunk b o bs -> con b o (loop SPEC bs )+     Go ms        -> fin (liftM (loop SPEC) ms)+{-# INLINE [1] dematerialize #-}++{-# RULES+  "dematerialize/materialize" forall (phi :: forall b . (r -> b) -> (Bytes -> Int64 -> b -> b) -> (m b -> b) -> b) . dematerialize (materialize phi) = phi ;+  #-}+------------------------------------------------------------------------++copy :: Monad m => ByteStream m r -> ByteStream (ByteStream m) r+copy = loop where+  loop str = case str of+    Empty r         -> Empty r+    Go m            -> Go (liftM loop (lift m))+    Chunk bs o rest -> Chunk bs o (Go (Chunk bs o (Empty (loop rest))))+{-# INLINABLE copy #-}++-- | /O(n)/ Concatenate a stream of byte streams.+concat :: Monad m => Stream (ByteStream m) m r -> ByteStream m r+concat x = destroy x join Go Empty+{-# INLINE concat #-}++-- | Perform the effects contained in an effectful bytestring, ignoring the bytes.+effects :: Monad m => ByteStream m r -> m r+effects bs = case bs of+  Empty r        -> return r+  Go m           -> m >>= effects+  Chunk _ _ rest -> effects rest+{-# INLINABLE effects #-}+++-- -----------------------------------------------------------------------------+-- Introducing and eliminating 'ByteStream's++{-| /O(1)/ The empty 'ByteStream' -- i.e. @return ()@ Note that @ByteStream m w@ is+  generally a monoid for monoidal values of @w@, like @()@+-}+empty :: ByteStream m ()+empty = Empty ()+{-# INLINE empty #-}++{-| /O(1)/ Yield a 'Word8' as a minimal 'ByteStream'+-}+singleton :: Word8 -> ByteStream m ()+singleton w = Chunk (B.singleton w) 0 (Empty ())+{-# INLINE singleton #-}++-- | /O(c)/ Converts a byte stream into a stream of individual strict bytestrings.+--   This of course exposes the internal chunk structure.+toChunks :: Monad m => ByteStream m r -> Stream (Of Bytes) m r+toChunks bs = dematerialize bs return (\b _ mx -> Step (b :> mx)) Effect+{-# INLINE toChunks #-}++mapChunksM_ :: Monad m => (Bytes -> m ()) -> ByteStream m r -> m r+mapChunksM_ f bs = dematerialize bs return (\c _ k -> f c >> k) join+{-# INLINE mapChunksM_ #-}+++-- | /O(c)/ Converts a stream of strict bytestrings into a byte stream.+fromChunks :: Monad m => Stream (Of Bytes) m r -> ByteStream m r+fromChunks bs = destroy bs+      (\(b :> mx) !i -> Chunk b i (mx (i + fromIntegral (B.length b))))+      (\k !i -> Go (k >>= \f -> return (f i)))+      (\r !_ -> return r) 0+{-# INLINE fromChunks #-}++{-| /O(n)/ Convert a monadic byte stream into a single strict 'ByteStream',+   retaining the return value of the original pair. This operation is+   for use with 'mapped'.++> mapped R.toStrict :: Monad m => Stream (ByteStream m) m r -> Stream (Of ByteStream) m r++   It is subject to all the objections one makes to Data.ByteStream.Lazy 'toStrict';+   all of these are devastating.+-}+toStrict :: Monad m => ByteStream m r -> m (Of Bytes r)+toStrict bs = do+  (bss :> r) <- Q.toList (toChunks bs)+  return $ (B.concat bss :> r)+{-# INLINE toStrict #-}++{-| /O(c)/ Transmute a pseudo-pure lazy bytestring to its representation+    as a monadic stream of chunks.++>>> Q.putStrLn $ Q.fromLazy "hi"+hi+>>>  Q.fromLazy "hi"+Chunk "hi" (Empty (()))  -- note: a 'show' instance works in the identity monad+>>>  Q.fromLazy $ BL.fromChunks ["here", "are", "some", "chunks"]+Chunk "here" (Chunk "are" (Chunk "some" (Chunk "chunks" (Empty (())))))++-}+fromLazy :: LazyBytes -> ByteStream m ()+fromLazy = L.foldrChunks consChunk empty+{-# INLINE fromLazy #-}++{-| /O(n)/ Convert an effectful byte stream into a single lazy 'ByteStream'+    with the same internal chunk structure, retaining the original+    return value.++    This is the canonical way of breaking streaming (@toStrict@ and the+    like are far more demonic). Essentially one is dividing the interleaved+    layers of effects and bytes into one immense layer of effects,+    followed by the memory of the succession of bytes.++    Because one preserves the return value, @toLazy@ is a suitable argument+    for 'Streaming.mapped'++>   B.mapped Q.toLazy :: Stream (ByteStream m) m r -> Stream (Of LazyBytes) m r++>>> Q.toLazy "hello"+"hello" :> ()+>>> B.toListM $ traverses Q.toLazy $ Q.lines "one\ntwo\nthree\nfour\nfive\n"+["one","two","three","four","five",""]  -- [LazyBytes]++-}+toLazy :: Monad m => ByteStream m r -> m (Of LazyBytes r)+toLazy bs0 = dematerialize bs0+                (\r -> return (L.Empty :> r))+                (\b _ mx -> do+                      (bs :> x) <- mx+                      return $ L.Chunk b bs :> x+                      )+                join+{-# INLINE toLazy #-}++-- | /O(1)/ 'cons' is analogous to '(:)' for lists.+cons :: Word8 -> ByteStream m r -> ByteStream m r+cons c cs = Chunk (B.singleton c) 0 cs+{-# INLINE cons #-}++-- | /O(1)/ Extract the head and tail of a 'ByteStream', or its return value+-- if it is empty. This is the \'natural\' uncons for an effectful byte stream.+nextByte :: Monad m => ByteStream m r -> m (Either r (Word8, ByteStream m r))+nextByte = liftM (either Left (\(a,_,b) -> Right (a,b))) . nextByteOff+{-# INLINE nextByte #-}++nextByteOff :: Monad m => ByteStream m r -> m (Either r (Word8, Int64, ByteStream m r))+nextByteOff (Empty r) = return (Left r)+nextByteOff (Chunk c o cs)+    = if B.null c+        then nextByteOff cs+        else return $ Right (B.unsafeHead c, o+                     , if B.length c == 1+                         then cs+                         else Chunk (B.unsafeTail c) (o+1) cs)+nextByteOff (Go m) = m >>= nextByteOff+{-# INLINABLE nextByteOff #-}++nextChunk :: Monad m => ByteStream m r -> m (Either r (Bytes, ByteStream m r))+nextChunk = liftM (either Left (\(a,_,b) -> Right (a,b))) . nextChunkOff+{-# INLINE nextChunk #-}++nextChunkOff :: Monad m => ByteStream m r -> m (Either r (Bytes, Int64, ByteStream m r))+nextChunkOff (Empty r)      = return (Left r)+nextChunkOff (Go m)         = m >>= nextChunkOff+nextChunkOff (Chunk c o cs)+    | B.null c              = nextChunkOff cs+    | otherwise             = return (Right (c,o,cs))+{-# INLINABLE nextChunkOff #-}++{-| /O(n\/c)/ 'drop' @n xs@ returns the suffix of @xs@ after the first @n@+    elements, or @[]@ if @n > 'length' xs@.++>>> Q.putStrLn $ Q.drop 6 "Wisconsin"+sin+>>> Q.putStrLn $ Q.drop 16 "Wisconsin"++>>>+-}+drop  :: Monad m => Int64 -> ByteStream m r -> ByteStream m r+drop i p | i <= 0 = p+drop i cs0 = drop' i cs0+  where drop' 0 cs           = cs+        drop' _ (Empty r)    = Empty r+        drop' n (Chunk c o cs) =+          if n < fromIntegral (B.length c)+            then Chunk (B.drop (fromIntegral n) c) (o+n) cs+            else drop' (n - fromIntegral (B.length c)) cs+        drop' n (Go m) = Go (liftM (drop' n) m)+{-# INLINABLE drop #-}+++{-| /O(n\/c)/ 'splitAt' @n xs@ is equivalent to @('take' n xs, 'drop' n xs)@.++>>> rest <- Q.putStrLn $ Q.splitAt 3 "therapist is a danger to good hyphenation, as Knuth notes"+the+>>> Q.putStrLn $ Q.splitAt 19 rest+rapist is a danger++-}+splitAt :: Monad m => Int64 -> ByteStream m r -> ByteStream m (ByteStream m r)+splitAt i cs0 | i <= 0 = Empty cs0+splitAt i cs0 = go i cs0+  where go 0 cs             = Empty cs+        go _ (Empty r)      = Empty (Empty r)+        go n (Chunk c o cs) =+          if n < fromIntegral (B.length c)+            then Chunk (B.take (fromIntegral n) c) o $+                     Empty (Chunk (B.drop (fromIntegral n) c) (o+n) cs)+            else Chunk c o (go (n - fromIntegral (B.length c)) cs)+        go n (Go m) = Go (liftM (go n) m)+{-# INLINABLE splitAt #-}++-- | Strictly splits off a piece.  This breaks streaming, so reserve its+-- use for small strings or when conversion to strict 'Bytes' is needed+-- anyway.+splitAt' :: Monad m => Int -> ByteStream m r -> m (Of Bytes (ByteStream m r))+splitAt' i cs0 | i <= 0 = return $! B.empty :> cs0+splitAt' i cs0 = go i [] cs0+  where go 0 acc cs             = return $! B.concat (reverse acc) :> cs+        go _ acc (Empty r)      = return $! B.concat (reverse acc) :> Empty r+        go n acc (Chunk c o cs) =+          if n < B.length c+            then return $! B.concat (reverse (B.take n c : acc))+                        :> Chunk (B.drop n c) (o + fromIntegral n) cs+            else go (n - B.length c) (c:acc) cs+        go n acc (Go m) = m >>= go n acc+{-# INLINABLE splitAt' #-}++trim :: Monad m => Int64 -> ByteStream m () -> ByteStream m ()+trim eoff = go+  where+    go (Empty     _)             = Empty ()+    go (Go        m)             = lift m >>= go+    go (Chunk c o s) | o <  eoff = Chunk c o (go s)+                     | otherwise = Empty ()+{-# INLINABLE trim #-}++-- | 'dropWhile' @p xs@ returns the suffix remaining after 'takeWhile' @p xs@.+dropWhile :: Monad m => (Word8 -> Bool) -> ByteStream m r -> ByteStream m r+dropWhile pr = drop' where+  drop' bs = case bs of+    Empty r      -> Empty r+    Go m         -> Go (liftM drop' m)+    Chunk c o cs -> case findIndexOrEnd (not.pr) c of+        0                  -> Chunk c o cs+        n | n < B.length c -> Chunk (B.drop n c) (o + fromIntegral n) cs+          | otherwise      -> drop' cs+{-# INLINABLE dropWhile #-}++-- | 'break' @p@ is equivalent to @'span' ('not' . p)@.+break :: Monad m => (Word8 -> Bool) -> ByteStream m r -> ByteStream m (ByteStream m r)+break f cs0 = break' cs0+  where break' (Empty r)        = Empty (Empty r)+        break' (Chunk c o cs) =+          case findIndexOrEnd f c of+            0                  -> Empty (Chunk c o cs)+            n | n < B.length c -> Chunk (B.take n c) o $+                                      Empty (Chunk (B.drop n c) (o + fromIntegral n) cs)+              | otherwise      -> Chunk c o (break' cs)+        break' (Go m) = Go (liftM break' m)+{-# INLINABLE break #-}++{- | Read entire handle contents /lazily/ into a 'ByteStream'. Chunks+    are read on demand, in at most @k@-sized chunks. It does not block+    waiting for a whole @k@-sized chunk, so if less than @k@ bytes are+    available then they will be returned immediately as a smaller chunk.++    The handle is closed on EOF.++    Note: the 'Handle' should be placed in binary mode with+    'System.IO.hSetBinaryMode' for 'hGetContentsN' to+    work correctly.+-}+hGetContentsN :: MonadIO m => Int -> Handle -> ByteStream m ()+hGetContentsN k h = loop 0+  where+    loop !o = do+        c <- liftIO (B.hGetSome h k)+        -- only blocks if there is no data available+        if B.null c+          then Empty ()+          else Chunk c o (loop (o + fromIntegral (B.length c)))+{-# INLINABLE hGetContentsN #-} -- very effective inline pragma++{-| Read entire handle contents /lazily/ into a 'ByteStream'. Chunks+    are read on demand, using the default chunk size.++    Note: the 'Handle' should be placed in binary mode with+    'System.IO.hSetBinaryMode' for 'hGetContents' to+    work correctly.+-}+hGetContents :: MonadIO m => Handle -> ByteStream m ()+hGetContents = hGetContentsN defaultChunkSize+{-# INLINE hGetContents #-}+++withOutputFile :: (MonadIO m, MonadMask m) => FilePath -> (Handle -> m a) -> m a+withOutputFile "-" k = k stdout+withOutputFile  f  k = bracket (liftIO $ openBinaryFile (f++".#~#") WriteMode) (liftIO . hClose) $ \hdl ->+                       k hdl >>= \r -> liftIO (renameFile (f++".#~#") f) >> return r+{-# INLINE withOutputFile #-}++{-| Writes a 'ByteStream' to a file.  Actually writes to a temporary+    file and renames it on successful completion.  The filename \"-\"+    causes it to write to stdout instead.+ -}+writeFile :: (MonadIO m, MonadMask m) => FilePath -> ByteStream m r -> m r+writeFile f str = withOutputFile f $ \hdl -> hPut hdl str+{-# INLINE writeFile #-}++-- | Outputs a 'ByteStream' to the specified 'Handle'.+hPut ::  MonadIO m => Handle -> ByteStream m r -> m r+hPut h cs = dematerialize cs return (\x _ y -> liftIO (B.hPut h x) >> y) (>>= id)+{-# INLINE hPut #-}++-- -- ---------------------------------------------------------------------+-- -- Internal utilities++-- | 'findIndexOrEnd' is a variant of findIndex, that returns the length+-- of the string if no element is found, rather than Nothing.+findIndexOrEnd :: (Word8 -> Bool) -> Bytes -> Int+findIndexOrEnd k (B.PS x s l) =+    unsafeDupablePerformIO $+    withForeignPtr x $ \f -> go (f `plusPtr` s) 0+  where+    go !ptr !n | n >= l    = return l+               | otherwise = do w <- peek ptr+                                if k w+                                  then return n+                                  else go (ptr `plusPtr` 1) (n+1)+{-# INLINABLE findIndexOrEnd #-}++{- Take a builder constructed otherwise and convert it to a genuine+   streaming bytestring.++>>>  Q.putStrLn $ Q.toByteStream $ stringUtf8 "哈斯克尔" <> stringUtf8 " " <> integerDec 98+哈斯克尔 98++    <https://gist.github.com/michaelt/6ea89ca95a77b0ef91f3 This benchmark> shows its+    indistinguishable performance is indistinguishable from @toLazyByteStream@+-}++toByteStream :: MonadIO m => Builder -> ByteStream m ()+toByteStream = toByteStreamWith (safeStrategy L.smallChunkSize L.defaultChunkSize)+{-# INLINE toByteStream #-}++{-| Take a builder and convert it to a genuine+   streaming bytestring, using a specific allocation strategy.+-}+toByteStreamWith :: MonadIO m => AllocationStrategy -> Builder -> ByteStream m ()+toByteStreamWith strategy builder0 = do+       cios <- liftIO (buildStepToCIOS strategy (runBuilder builder0))+       let loop !o cios0 = case cios0 of+              Yield1 bs io   -> Chunk bs o $ do+                    cios1 <- liftIO io+                    loop (o + fromIntegral (B.length bs)) cios1+              Finished buf r -> trimmedChunkFromBuffer o buf (Empty r)+           trimmedChunkFromBuffer o buffer k+              | B.null bs                            = k+              |  2 * B.length bs < bufferSize buffer = Chunk (B.copy bs) o k+              | otherwise                            = Chunk bs          o k+              where+                bs = byteStringFromBuffer buffer+       loop 0 cios+{-# INLINABLE toByteStreamWith #-}+{-# SPECIALIZE toByteStreamWith :: AllocationStrategy -> Builder -> ByteStream IO () #-}+++{- Concatenate a stream of builders (not a streaming bytestring!) into a single builder.++>>> let aa = yield (integerDec 10000) >> yield (string8 " is a number.") >> yield (char8 '\n')+>>>  hPutBuilder  IO.stdout $ concatBuilders aa+10000 is a number.++-}+concatBuilders :: Stream (Of Builder) IO () -> Builder+concatBuilders p = builder $ \bstep r -> do+  case p of+    Return _          -> runBuilderWith mempty bstep r+    Step (b :> rest)  -> runBuilderWith (b `mappend` concatBuilders rest) bstep r+    Effect m            -> m >>= \p' -> runBuilderWith (concatBuilders p') bstep r+{-# INLINABLE concatBuilders #-}++{- | Turns a ByteStream into a connected stream of ByteStreams that+     divide at newline characters. The resulting strings do not contain+     newlines.  This is the genuinely streaming 'lines' which only+     breaks chunks, and thus never increases the use of memory.++     Because 'ByteStream's are usually read in binary mode, with no line+     ending conversion, this function recognizes both @\\n@ and @\\r\\n@+     endings (regardless of the current platform). -}++lines :: Monad m => ByteStream m r -> Stream (ByteStream m) m r+lines text0 = loop1 text0+  where+    loop1 :: Monad m => ByteStream m r -> Stream (ByteStream m) m r+    loop1 text =+      case text of+        Empty r -> Return r+        Go m -> Effect $ liftM loop1 m+        Chunk c _ cs+          | B.null c -> loop1 cs+          | otherwise -> Step (loop2 Nothing text)+    loop2 :: Monad m => Maybe Int64 -> ByteStream m r -> ByteStream m (Stream (ByteStream m) m r)+    loop2 prevCr text =+      case text of+        Empty r -> case prevCr of+          Just  o -> Chunk (B.singleton 13) o (Empty (Return r))+          Nothing -> Empty (Return r)+        Go m -> Go $ liftM (loop2 prevCr) m+        Chunk c o cs ->+          case B.elemIndex 10 c of+            Nothing -> case B.length c of+              0 -> loop2 prevCr cs+              l -> if B.unsafeLast c == 13+                     then Chunk (B.unsafeInit c) o (loop2 (Just (o-1 + fromIntegral l)) cs)+                     else Chunk c o (loop2 Nothing cs)+            Just i -> do+              let prefixLength =+                    if i >= 1 && B.unsafeIndex c (i-1) == 13 -- \r\n (dos)+                      then i-1+                      else i+                  rest =+                    if B.length c > i+1+                      then Chunk (B.drop (i+1) c) (o+1 + fromIntegral i) cs+                      else cs+                  result = Chunk (B.unsafeTake prefixLength c) o (Empty (loop1 rest))+              case prevCr of+                Just oo | i > 0 -> Chunk (B.singleton 13) oo result+                _               -> result+{-# INLINABLE lines #-}++{- | Turns a 'ByteStream' into a stream of strict 'Bytes' that divide at+     newline characters. The resulting strings do not contain newlines.+     This will cost memory if the lines are very long, and it does not+     recognize DOS line endings. -}++lines' :: Monad m => ByteStream m r -> Stream (Of Bytes) m r+lines' = loop1 []+  where+    loop1 :: Monad m => [Bytes] -> ByteStream m r -> Stream (Of Bytes) m r+    loop1 acc text =+      case text of+        Empty r -> Return r+        Go m    -> Effect $ liftM (loop1 acc) m+        Chunk c o cs+          | B.null c  -> loop1 acc cs+          | otherwise ->+              case B.elemIndex 10 c of+                Just  i -> Q.cons (if null acc then B.take i c else B.concat (reverse (B.take i c : acc)))+                                  (loop1 [] (Chunk (B.drop (i+1) c) (o+1 + fromIntegral i) cs))+                Nothing -> loop1 (c:acc) cs+{-# INLINABLE lines' #-}++-- --------------------------------------------------------------------------++{-| Decompresses GZip if present.  If any GZip stream is found, all+    such streams are decompressed and any remaining data is discarded.+    Else, the input is returned unchanged.  If the input is BGZF, the+    result will contain meaningful virtual offsets.  If the input+    contains exactly one GZip stream, the result will have meaningfull+    offsets into the uncompressed data.  Else, the offsets will be+    bogus. -}++gunzip :: MonadIO m => ByteStream m r -> ByteStream m r+gunzip = gunzipWith id+{-# INLINABLE gunzip #-}++{-| Checks if the input is GZip at all, and runs gunzip if it is.  If+    it isn't, it runs 'k' on the input. -}++gunzipWith :: MonadIO m => (ByteStream m r -> ByteStream m r)+                        -> ByteStream m r -> ByteStream m r+gunzipWith k s0 = lift (nextByteOff s0) >>= \case+    Right (31, o, s') -> lift (nextByte s') >>= \case+        Right (139,s'') -> gunzipLoop o $ Chunk (B.pack [31,139]) o s''+        Right ( c, s'') -> k $ Chunk (B.pack [31,c]) o s''+        Left     r      -> k $ Chunk (B.singleton 31) o (pure r)+    Right ( c, o, s')   -> k $ Chunk (B.singleton c) o s'+    Left       r        -> k $ pure r+{-# INLINABLE gunzipWith #-}++{-| Decompresses a gzip stream.  If the leftovers look like another+    gzip stream, it recurses (some files, notably those produced by+    bgzip, contain multiple streams).  Otherwise, the leftovers are+    discarded (some compressed HETFA files appear to have junk at the+    end). -}++gunzipLoop :: MonadIO m => Int64 -> ByteStream m r -> ByteStream m r+gunzipLoop o = go o (shiftL o 16) $ Z.decompressIO Z.gzipOrZlibFormat Z.defaultDecompressParams+  where+    -- get next chunk, make sure it is empty iff the input ended+    go inoff outoff (Z.DecompressInputRequired next) inp =+        lift (nextChunk inp) >>= \case+            Left r          -> do z <- liftIO (next B.empty)+                                  go inoff outoff z (pure r)+            Right (ck,inp')+                | B.null ck ->    go inoff outoff (Z.DecompressInputRequired next) inp'+                | otherwise -> do z <- liftIO (next ck)+                                  go (inoff + fromIntegral (B.length ck)) outoff z inp'++    go inoff outoff (Z.DecompressOutputAvailable outchunk next) inp = do+        z <- Chunk outchunk outoff (liftIO next)+        go inoff (outoff + fromIntegral (B.length outchunk)) z inp++    go inoff _outoff (Z.DecompressStreamEnd inchunk) inp =+        -- decompress leftovers if possible, else return+        gunzipWith (lift . effects) (Chunk inchunk (inoff - fromIntegral (B.length inchunk)) inp)++    go _inoff _outoff (Z.DecompressStreamError derr) _inp =+        liftIO $ throwIO derr++-- | Compresses a byte stream using GZip with default parameters.+gzip :: MonadIO m => ByteStream m r -> ByteStream m r+gzip = go $ Z.compressIO Z.gzipFormat Z.defaultCompressParams+  where+    -- get next chunk, make sure it is empty iff the input ended+    go (Z.CompressInputRequired next) inp =+        lift (nextChunk inp) >>= \case+            Left r          -> liftIO (next B.empty) >>= flip go (pure r)+            Right (ck,inp')+                | B.null ck -> go (Z.CompressInputRequired next) inp'+                | otherwise -> liftIO (next ck) >>= flip go inp'++    go (Z.CompressOutputAvailable outchunk next) inp =+        chunk outchunk >> liftIO next >>= flip go inp++    go Z.CompressStreamEnd inp = lift (effects inp)++

@@ -0,0 +1,45 @@+module Bio.Streaming.Furrow+    ( Furrow(..)+    , evertStream+    , afford+    , drain+    ) where++import Bio.Prelude+import Bio.Streaming++{- | A tiny stream that can be afforded to incrementally.++The streaming abstraction works fine if multiple sources feed into a+small constant number of functions, but fails if there is an+unpredictable number of such consumers.  In that case, 'evertStream'+should be used to turn each consumer into a 'Furrow'.  It's then+possible to incrementally 'afford' stuff to each 'Furrow' in a+collection in a simple loop.  To get the final value, 'drain' each+'Furrow'.+-}+newtype Furrow a m r = Furrow (Stream ((->) (Maybe a)) m r) deriving+  (Functor, Applicative, Monad, MonadTrans, MonadIO, MFunctor, MMonad)++instance MonadThrow m => MonadThrow (Furrow a m) where+    throwM = Furrow . lift . throwM++afford :: Monad m => Furrow a m b -> a -> m (Furrow a m b)+afford (Furrow s) a = inspect s >>= \case+    Left  b -> return (Furrow (pure b))+    Right f -> return (Furrow (f (Just a)))++drain :: Monad m => Furrow a m b -> m b+drain (Furrow s) = inspect s >>= \case+    Left  b -> return b+    Right f -> inspect (f Nothing) >>= \case+        Left  b -> return b+        Right _ -> error "continuedAfterEOF"++-- | Turns a function that consumes a stream into a furrow.  Idea and+-- some code stolen from \"streaming-eversion\".+evertStream :: Monad m => (Stream (Of a) (Furrow a m) () -> Furrow a m b) -> Furrow a m b+evertStream consumer = consumer cat+  where+    cat = lift (Furrow (yields id)) >>= maybe (pure ()) (\a -> wrap (a :> cat))+

@@ -0,0 +1,140 @@+{-# LANGUAGE Rank2Types #-}+module Bio.Streaming.Parse+    ( Parser+    , ParseError(..)+    , EofException(..)+    , parse+    , parseIO+    , parseM+    , abortParse+    , isFinished+    , drop+    , dropLine+    , getByte+    , getString+    , getWord32+    , getWord64+    , isolate+    , atto+    ) where++-- ^ Parsers for use with 'ByteStream's.++import Bio.Prelude                       hiding ( drop )+import Bio.Streaming.Bytes                      ( ByteStream )++import qualified Bio.Streaming.Bytes            as S+import qualified Data.Attoparsec.ByteString     as A+import qualified Data.ByteString                as B+import qualified Streaming.Prelude              as Q++newtype Parser r m a = P {+    runP :: forall x .+            (a -> ByteStream m r -> m x)+         -> (r -> m x)+         -> (SomeException -> m x)+         -> ByteStream m r -> m x }++instance Functor (Parser r m) where+    fmap f p = P $ \sk -> runP p (sk . f)++instance Applicative (Parser r m) where+    pure a = P $ \sk _rk _ek -> sk a+    a <*> b = P $ \sk rk ek -> runP a (\f -> runP b (\x -> sk (f x)) rk ek) rk ek++instance Monad (Parser r m) where+    return = pure+    m >>= k = P $ \sk rk ek -> runP m (\a -> runP (k a) sk rk ek) rk ek++instance MonadIO m => MonadIO (Parser r m) where+    liftIO m = P $ \sk _rk _ek s -> liftIO m >>= \a -> sk a s++instance MonadTrans (Parser r) where+    lift m = P $ \sk _rk _ek s -> m >>= \a -> sk a s++instance MonadThrow (Parser r m) where+    throwM e = P $ \_sk _rk ek _s -> ek (toException e)++modify :: (ByteStream m r -> ByteStream m r) -> Parser r m ()+modify f = P $ \sk _rk _ek -> sk () . f++parse :: Monad m => (Int64 -> Parser r m a) -> ByteStream m r -> m (Either SomeException (Either r (a, ByteStream m r)))+parse p = go+  where+    go    (S.Empty     r)             = return $ Right $ Left r+    go    (S.Go        k)             = k >>= go+    go ck@(S.Chunk c o s) | B.null  c = go s+                          | otherwise = runP (p o) (\a t -> return . Right $ Right (a,t))+                                                   (return . Right . Left)+                                                   (return . Left)+                                                   ck++parseIO :: MonadIO m => (Int64 -> Parser r m a) -> ByteStream m r -> m (Either r (a, ByteStream m r))+parseIO p = parse p >=> either (liftIO . throwM) return++parseM :: MonadThrow m => (Int64 -> Parser r m a) -> ByteStream m r -> m (Either r (a, ByteStream m r))+parseM p = parse p >=> either throwM return++abortParse :: Monad m => Parser r m a+abortParse = P $ \_sk rk _ek -> S.effects >=> rk++liftFun :: Monad m => (ByteStream m r -> m (a, ByteStream m r)) -> Parser r m a+liftFun f = P $ \sk _rk _ek -> f >=> uncurry sk++isFinished :: Monad m => Parser r m Bool+isFinished = liftFun go+  where+    go    (S.Empty     r)             = return (True, S.Empty r)+    go    (S.Go        k)             = k >>= go+    go ck@(S.Chunk c _ s) | B.null  c = go s+                          | otherwise = return (False, ck)++drop :: Monad m => Int -> Parser r m ()+drop l = modify $ S.drop (fromIntegral l)++dropLine :: Monad m => Parser r m ()+dropLine = modify $ S.drop 1 . S.dropWhile (/= 10)++getByte :: Monad m => Parser r m Word8+getByte = P $ \sk _rk ek -> S.nextByte >=> either (const $ ek (toException EofException)) (uncurry sk)++getString :: Monad m => Int -> Parser r m B.ByteString+getString l = liftFun $ liftM Q.lazily . S.splitAt' l++getWord32 :: Monad m => Parser r m Word32+getWord32 = liftM (fst . B.foldl (\(a,i) w -> (a + shiftL (fromIntegral w) i, i + 8)) (0,0)) (getString 4)++getWord64 :: Monad m => Parser r m Word64+getWord64 = liftM (fst . B.foldl (\(a,i) w -> (a + shiftL (fromIntegral w) i, i + 8)) (0,0)) (getString 8)++isolate :: Monad m => Int -> Parser (ByteStream m r) m a -> Parser r m a+isolate l p = P $ \sk rk ek -> runP p (\a -> S.effects >=> sk a)+                                      (S.effects >=> rk)+                                      ek . S.splitAt (fromIntegral l)++data ParseError = ParseError {errorContexts :: [String], errorMessage :: String}+    deriving (Show, Typeable)++data EofException = EofException+    deriving (Show, Typeable)++instance Exception ParseError+instance Exception EofException++atto :: Monad m => A.Parser a -> Parser r m a+atto = go . A.parse+  where+    go k = P $ \sk rk ek ->+        S.nextChunk >=> \case+            Left r -> case k B.empty of+                      A.Fail _ err dsc -> ek $ toException (ParseError err dsc)+                      A.Partial _      -> ek $ toException EofException+                      A.Done rest v    -> sk v (S.consChunk rest (pure r))+            Right (c,s')+                | B.null c -> runP (go k) sk rk ek s'+                | otherwise -> case k c of+                      A.Fail _ err dsc -> ek $ toException (ParseError err dsc)+                      A.Partial k'     -> runP (go k') sk rk ek s'+                      A.Done rest v    -> sk v (S.consChunk rest s')++

@@ -0,0 +1,35 @@+module Bio.Streaming.Vector ( stream2vector, stream2vectorN ) where++import Bio.Prelude+import Streaming++import qualified Data.Vector.Generic            as VG+import qualified Data.Vector.Generic.Mutable    as VM++-- | Equivalent to @stream2vector . Streaming.Prelude.take n@, but+-- terminates early and is thereby more efficient.+stream2vectorN :: (MonadIO m, VG.Vector v a) => Int -> Stream (Of a) m () -> m (v a)+stream2vectorN n s0 = do+    mv <- liftIO $ VM.new n+    go mv 0 s0+  where+    go !mv !i s+        | i == n    = liftIO $ VG.unsafeFreeze mv+        | otherwise =+            inspect s >>= \case+                Left        ()  -> liftIO $ VG.unsafeFreeze $ VM.take i mv+                Right (a :> s') -> liftIO (VM.write mv i a) >> go mv (i+1) s'++-- | Reads the whole stream into a 'VG.Vector'.+stream2vector :: (MonadIO m, VG.Vector v a) => Stream (Of a) m r -> m (Of (v a) r)+stream2vector s0 = do+    mv <- liftIO $ VM.new 1024+    go mv 0 s0+  where+    go !mv !i =+        inspect >=> \case+            Left        r  -> liftM (:> r) $ liftIO $ VG.unsafeFreeze $ VM.take i mv+            Right (a :> s) -> do mv' <- if VM.length mv == i then liftIO (VM.grow mv (VM.length mv)) else return mv+                                 liftIO $ VM.write mv' i a+                                 go mv' (i+1) s+

@@ -0,0 +1,296 @@+-- | Would you believe it?  The 2bit format stores blocks of Ns in a table at+-- the beginning of a sequence, then packs four bases into a byte.  So it+-- is neither possible nor necessary to store Ns in the main sequence, and+-- you would think they aren't stored there, right?  And they aren't.+-- Instead Ts are stored which the reader has to replace with Ns.+--+-- The sensible way to treat these is probably to just say there are two+-- kinds of implied annotation (repeats and large gaps for a typical+-- genome), which can be interpreted in whatever way fits.  And that's why+-- we have 'Mask' and 'getSubseqWith'.++module Bio.TwoBit (+        TwoBitFile(..),+        TwoBitSequence(..),+        openTwoBit,++        getFwdSubseqWith,+        getSubseq,+        getSubseqWith,+        getSubseqAscii,+        getSubseqMasked,+        getLazySubseq,+        getFragment,+        getFwdSubseqV,+        getSeqnames,+        lookupSequence,+        getSeqLength,+        clampPosition,+        getRandomSeq,++        takeOverlap,+        mergeBlocks,+        Mask(..)+    ) where++import           Bio.Prelude hiding ( left, right, chr )+import           Bio.Util.MMap+import           Bio.Util.Storable+import           Control.Monad.Trans.State ( StateT(..), get, evalStateT )+import qualified Data.ByteString                as B+import qualified Data.ByteString.Unsafe         as B+import qualified Data.IntMap.Strict             as I+import qualified Data.HashMap.Lazy              as M+import qualified Data.Vector.Unboxed            as U+import           Foreign.C.Types ( CChar )++data TwoBitFile = TBF {+    tbf_raw :: B.ByteString,+    -- This map is intentionally lazy.  May or may not be important.+    tbf_seqs :: !(M.HashMap Bytes TwoBitSequence)+}++data TwoBitSequence = TBS { tbs_n_blocks   :: !(I.IntMap Int)+                          , tbs_m_blocks   :: !(I.IntMap Int)+                          , tbs_dna_offset :: {-# UNPACK #-} !Int+                          , tbs_dna_size   :: {-# UNPACK #-} !Int }++-- | Brings a 2bit file into memory.  The file is mmap'ed, so it will+-- not work on streams that are not actual files.  It's also unsafe if+-- the file is modified in any way.+openTwoBit :: FilePath -> IO TwoBitFile+openTwoBit fp = do+        raw <- unsafeMMapFile fp+        B.unsafeUseAsCString raw $ \praw ->+        -- return $ flip runGet (L.fromChunks [raw]) $ do+            flip evalStateT praw $ do+                    sig <- getWord32be+                    getWord32 <- case sig :: Word32 of+                            0x1A412743 -> return getWord32be+                            0x4327411A -> return getWord32le+                            _          -> fail $ "invalid .2bit signature " ++ showHex sig []++                    version <- getWord32+                    unless (version == 0) $ fail $ "wrong .2bit version " ++ show version++                    nseqs <- getWord32+                    _reserved <- getWord32++                    TBF raw <$> foldM (\ix _ -> do !key <- getWord8 >>= getByteString+                                                   !off <- getWord32+                                                   return $! M.insert key (mkBlockIndex raw getWord32 off) ix+                                      ) M.empty [1..nseqs]++type Get = StateT (Ptr CChar) IO++getWord8, getWord32be, getWord32le :: Num a => Get a+getWord8    = StateT $ \p -> peekUnalnWord32BE  p >>= \w -> return (fromIntegral w, plusPtr p 1)+getWord32be = StateT $ \p -> peekUnalnWord32BE  p >>= \w -> return (fromIntegral w, plusPtr p 4)+getWord32le = StateT $ \p -> peekUnalnWord32LE  p >>= \w -> return (fromIntegral w, plusPtr p 4)++getByteString :: Int -> Get Bytes+getByteString l = StateT $ \p -> B.packCStringLen (p,l) >>= \s -> return (s, plusPtr p l)++mkBlockIndex :: B.ByteString -> Get Int -> Int -> TwoBitSequence+mkBlockIndex raw getWord32 ofs =+    unsafePerformIO $+    B.unsafeUseAsCString raw $ \praw ->+    evalStateT getBlock (plusPtr praw ofs)+  where+    getBlock = do p0 <- get+                  ds <- getWord32+                  nb <- readBlockList+                  mb <- readBlockList+                  _  <- getWord32+                  p1 <- get+                  return $! TBS (I.fromList nb) (I.fromList mb) (ofs + minusPtr p1 p0) ds++    readBlockList = getWord32 >>= \n -> liftM2 zip (repM n getWord32) (repM n getWord32)++-- | Repeat monadic action @n@ times.  Returns result in reverse(!)+-- order, but doesn't build a huge list of thunks in memory.+repM :: Monad m => Int -> m a -> m [a]+repM n0 m = go [] n0+  where+    go acc 0 = return acc+    go acc n = m >>= \x -> x `seq` go (x:acc) (n-1)++takeOverlap :: Int -> I.IntMap Int -> [(Int,Int)]+takeOverlap k m = dropWhile far_left $+                  maybe id (\(kv,_) -> (:) kv) (I.maxViewWithKey left) $+                  maybe id (\v -> (:) (k,v)) middle $+                  I.toAscList right+  where+    (left, middle, right) = I.splitLookup k m+    far_left (s,l) = s+l <= k++data Mask = None | Soft | Hard | Both deriving (Eq, Ord, Enum, Show)++getFwdSubseqWith :: TwoBitFile -> TwoBitSequence                -- raw data, sequence+                 -> (Word8 -> Mask -> a)                        -- mask function+                 -> Int -> [a]                                  -- start, lazy result+getFwdSubseqWith TBF{..} TBS{..} nt start =+    do_mask (takeOverlap start tbs_n_blocks `mergeBlocks` takeOverlap start tbs_m_blocks) start .+    drop (start .&. 3) .+    B.foldr toDNA [] .+    B.drop (tbs_dna_offset + (start `shiftR` 2)) $ tbf_raw+  where+    toDNA b = (++) [ 3 .&. (b `shiftR` x) | x <- [6,4,2,0] ]++    do_mask            _ _ [] = []+    do_mask [          ] _ ws = map (`nt` None) ws+    do_mask ((s,l,m):is) p ws+        | p < s     = map (`nt` None) (take  (s-p)  ws) ++ do_mask ((s,l,m):is)  s   (drop  (s-p)  ws)+        | otherwise = map (`nt`    m) (take (s+l-p) ws) ++ do_mask          is (s+l) (drop (s+l-p) ws)++-- | Merge blocks of Ns and blocks of Ms into single list of blocks with+-- masking annotation.  Gaps remain.  Used internally only.+mergeBlocks :: [(Int,Int)] -> [(Int,Int)] -> [(Int,Int,Mask)]+mergeBlocks ((_,0):nbs) mbs = mergeBlocks nbs mbs+mergeBlocks nbs ((_,0):mbs) = mergeBlocks nbs mbs++mergeBlocks ((ns,nl):nbs) ((ms,ml):mbs)+    | ns < ms   = let l = min (ms-ns) nl in (ns,l, Hard) : mergeBlocks ((ns+l,nl-l):nbs) ((ms,ml):mbs)+    | ms < ns   = let l = min (ns-ms) ml in (ms,l, Soft) : mergeBlocks ((ns,nl):nbs) ((ms+l,ml-l):mbs)+    | otherwise = let l = min nl ml in (ns,l, Both) : mergeBlocks ((ns+l,nl-l):nbs) ((ms+l,ml-l):mbs)++mergeBlocks ((ns,nl):nbs) [] = (ns,nl, Hard) : mergeBlocks nbs []+mergeBlocks [] ((ms,ml):mbs) = (ms,ml, Soft) : mergeBlocks [] mbs++mergeBlocks [     ] [     ] = []+++-- | Extract a subsequence and apply masking.  TwoBit file can represent+-- two kinds of masking (hard and soft), where hard masking is usually+-- realized by replacing everything by Ns and soft masking is done by+-- lowercasing.  Here, we take a user supplied function to apply+-- masking.+getSubseqWith :: (Nucleotide -> Mask -> a) -> TwoBitFile -> Range -> [a]+getSubseqWith maskf tbf Range{ r_pos = Pos { p_seq = chr, p_start = start }, r_length = len } = do+    let sq1 = fromMaybe (error $ unpack chr ++ " doesn't exist") $ M.lookup chr (tbf_seqs tbf)+    let go = getFwdSubseqWith tbf sq1+    if start < 0+        then reverse $ take len $ go (maskf . cmp_nt) (-start-len)+        else           take len $ go (maskf . fwd_nt)   start+  where+    fwd_nt = (!!) [nucT, nucC, nucA, nucG] . fromIntegral+    cmp_nt = (!!) [nucA, nucG, nucT, nucC] . fromIntegral++-- | Works only in forward direction.+getLazySubseq :: TwoBitFile -> Position -> [Nucleotide]+getLazySubseq tbf Pos{ p_seq = chr, p_start = start } = do+    let sq1 = fromMaybe (error $ unpack chr ++ " doesn't exist") $ M.lookup chr (tbf_seqs tbf)+    let go  = getFwdSubseqWith tbf sq1+    if start < 0+        then error "sorry, can't go backwards"+        -- then reverse $ take len $ go (maskf . cmp_nt) (-start-len)+        else go fwd_nt start+  where+    fwd_nt n _ = [nucT, nucC, nucA, nucG] !! fromIntegral n+++-- | Extract a subsequence without masking.+getSubseq :: TwoBitFile -> Range -> [Nucleotide]+getSubseq = getSubseqWith const++-- | Extract a subsequence with typical masking:  soft masking is+-- ignored, hard masked regions are replaced with Ns.+getSubseqMasked :: TwoBitFile -> Range -> [Nucleotides]+getSubseqMasked = getSubseqWith mymask+  where+    mymask n None = nucToNucs n+    mymask n Soft = nucToNucs n+    mymask _ Hard = nucsN+    mymask _ Both = nucsN++-- | Extract a subsequence with masking for biologists:  soft masking is+-- done by lowercasing, hard masking by printing an N.+getSubseqAscii :: TwoBitFile -> Range -> String+getSubseqAscii = getSubseqWith mymask+  where+    mymask n None = showNucleotide n+    mymask n Soft = toLower (showNucleotide n)+    mymask _ Hard = 'N'+    mymask _ Both = 'N'+++getSeqnames :: TwoBitFile -> [Bytes]+getSeqnames = M.keys . tbf_seqs++lookupSequence :: TwoBitFile -> Bytes -> Maybe TwoBitSequence+lookupSequence tbf sq = M.lookup sq . tbf_seqs $ tbf++getSeqLength :: TwoBitFile -> Bytes -> Int+getSeqLength tbf chr =+    maybe (error $ shows chr " doesn't exist") tbs_dna_size $+    M.lookup chr (tbf_seqs tbf)++-- | limits a range to a position within the actual sequence+clampPosition :: TwoBitFile -> Range -> Range+clampPosition tbf (Range (Pos n start) len) = Range (Pos n start') (end' - start')+  where+    size   = getSeqLength tbf n+    start' = if start < 0 then max start (-size) else start+    end'   = min (start + len) $ if start < 0 then 0 else size+++-- | Sample a piece of random sequence uniformly from the genome.+-- Only pieces that are not hard masked are sampled, soft masking is+-- allowed, but not reported.+-- On a 32bit platform, this will fail for genomes larger than 1G bases.+-- However, if you're running this code on a 32bit platform, you have+-- bigger problems to worry about.+getRandomSeq :: TwoBitFile                   -- ^ 2bit file+             -> Int                          -- ^ desired length+             -> (Int -> g -> (Int, g))       -- ^ draw random int below limit+             -> g                            -- ^ RNG+             -> ((Range, [Nucleotide]), g)   -- ^ position, sequence, new RNG+getRandomSeq tbf len rndInt = draw+  where+    names = getSeqnames tbf+    lengths = map (getSeqLength tbf) names+    total = sum lengths+    frags = I.fromList $ zip (scanl (+) 0 lengths) names++    draw g0 | good      = ((r', sq), gn)+            | otherwise = draw gn+      where+        (p0, gn) = rndInt (2*total) g0+        p = p0 `shiftR` 1+        (o,s) = fst $ fromJust $ I.maxViewWithKey $ fst $ I.split (p+1) frags+        r' = (if odd p0 then id else reverseRange) $ clampPosition tbf $ Range (Pos s (p-o)) len+        sq = catMaybes $ getSubseqWith mask2maybe tbf r'+        good = r_length r' == len && length sq == len++        mask2maybe n None = Just n+        mask2maybe n Soft = Just n+        mask2maybe _ Hard = Nothing+        mask2maybe _ Both = Nothing++-- | Gets a fragment from a 2bit file.  The result always has the+-- desired length; if necessary, it is padded with Ns.  Be careful about+-- the unconventional encoding: 0..4 == TCAGN+getFragment :: TwoBitFile -> Bytes -> Int -> Int -> U.Vector Word8+getFragment tbf chr p l =+    case lookupSequence tbf chr of+        Nothing  -> U.replicate l 4+        Just tbs -> getFwdSubseqV tbf tbs p l++-- Careful about weird encoding: 0..4 == TCAGN+getFwdSubseqV :: TwoBitFile -> TwoBitSequence -> Int -> Int -> U.Vector Word8+getFwdSubseqV TBF{..} TBS{..} start len = U.unfoldrN len step ini+  where+    ini = (start, takeOverlap start tbs_n_blocks)++    step (off, nbs)+        | off < 0                   = Just (4, (succ off, nbs))+        | off >= tbs_dna_size       = Just (4, (succ off, nbs))+        | otherwise = case nbs of+            [        ]             -> Just (y, (succ off, [ ]))+            (s,l):nbs' | off < s   -> Just (y, (succ off, nbs))+                       | off < s+l -> Just (4, (succ off, nbs))+                       | otherwise -> Just (y, (succ off, nbs'))+      where+        x = B.index tbf_raw (tbs_dna_offset + off `shiftR` 2)+        y = x `shiftR` (6 - 2 * (off .&. 3)) .&. 3     -- T,C,A,G+