1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
|
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE StrictData #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE ViewPatterns #-}
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
module Data.FastQ where
import Control.Monad
import Control.Monad.IO.Class (MonadIO, liftIO)
import Data.ByteString (ByteString)
import qualified Data.ByteString as B
import qualified Data.ByteString.Char8 as BC
import Data.ByteString.Lazy.Internal (defaultChunkSize)
import Data.Function
import Data.Streaming.Zlib
import Data.Word (Word8)
import Lens.Micro
import Lens.Micro.TH
import Streamly.Data.Array (Array)
import qualified Streamly.Data.Fold as F
import Streamly.Data.Stream (Stream)
import qualified Streamly.Data.Stream as S
import qualified Streamly.External.ByteString as SB
import Streamly.Internal.Data.Stream.Chunked as AS
import Streamly.Internal.Data.Stream.StreamD.Type (Step (..))
import Streamly.Internal.Data.Unfold.Type (Unfold (..))
import System.IO
import Prelude hiding (Read)
data Read = Read
{ _qual :: ByteString,
_nucs :: ByteString,
_header :: ByteString
}
deriving (Eq, Show, Ord)
makeLenses ''Read
type ReadPair = (Read, Read)
gzipWindow :: WindowBits
gzipWindow = WindowBits 31
parse :: MonadIO m => FilePath -> FilePath -> Stream m ReadPair
parse l r =
S.zipWith
parseEntry
(S.unfold streamBGZFile l & AS.splitOn 64 & S.drop 1)
(S.unfold streamBGZFile r & AS.splitOn 64 & S.drop 1)
where
streamBGZFile :: MonadIO m => Unfold m FilePath (Array Word8)
streamBGZFile = Unfold step seed
where
seed path = liftIO $ do
h <- openFile path ReadMode
i <- initInflate gzipWindow
pure $ Just (h, i, Nothing)
step Nothing = pure Stop
step (Just (h, i, Nothing)) = liftIO $ do
complete <- isCompleteInflate i
(frag, unused, i) <-
if complete
then do
f <- finishInflate i
u <- getUnusedInflate i
(f,u,) <$> initInflate gzipWindow
else pure ("", "", i)
if unused == ""
then do
chunk <- B.hGet h defaultChunkSize
if chunk == B.empty
then do
hClose h
str <- finishInflate i
pure $ Yield (SB.toArray $ frag <> str) Nothing
else do
popper <- feedInflate i $ chunk
pure $ Yield (SB.toArray frag) (Just (h, i, Just popper))
else do
popper <- feedInflate i $ unused
pure $ Yield (SB.toArray frag) (Just (h, i, Just popper))
step (Just (h, i, Just popper)) = liftIO $ do
popper >>= \case
PRNext str -> pure $ Yield (SB.toArray str) (Just (h, i, Just popper))
PRDone -> pure $ Yield (SB.toArray "") (Just (h, i, Nothing))
PRError e -> error $ "parse:" <> show e
parseEntry l r =
case (SB.fromArray l & BC.lines, SB.fromArray r & BC.lines) of
([hdr, seq, "+", qual], [hdr', seq', "+", qual']) -> (Read qual seq hdr, Read qual' seq' hdr')
e -> error $ "parseEntry:" <> show e
unparse :: FilePath -> FilePath -> Stream IO ReadPair -> IO ()
unparse l r str = do
lh <- openFile l WriteMode
rh <- openFile r WriteMode
ld <- initDeflate 0 gzipWindow
rd <- initDeflate 0 gzipWindow
fmap unparse' str & S.fold (F.drainMapM $ writeFiles lh rh ld rd)
flush rd rh
flush ld lh
hClose rh
hClose lh
where
writeFiles l r ld rd (a, b) = do
putCompressed ld l a
putCompressed rd r b
putCompressed d h chunk = do
popper <- feedDeflate d chunk
writePopper h popper
flush d h = finishDeflate d & writePopper h
writePopper h p =
p >>= \case
PRNext str -> do
B.hPut h str
writePopper h p
PRDone -> pure ()
PRError e -> error $ "parse:" <> show e
unparse' :: ReadPair -> (ByteString, ByteString)
unparse' read =
( BC.unlines ["@" <> read ^. _1 . header, read ^. _1 . nucs, "+", read ^. _1 . qual],
BC.unlines ["@" <> read ^. _2 . header, read ^. _2 . nucs, "+", read ^. _2 . qual]
)
|