diff --git a/biohazard.cabal b/biohazard.cabal --- a/biohazard.cabal +++ b/biohazard.cabal @@ -1,11 +1,8 @@ Name: biohazard -Version: 0.6.15 +Version: 0.6.16 Synopsis: bioinformatics support library Description: This is a collection of modules I separated from - various bioinformatics tools. The hope is to make - them reusable and easier to maintain. Also includes - some of these tools and a bunch that work on mitochondrial - sequences. + various bioinformatics tools. Category: Bioinformatics Homepage: http://github.com/udo-stenzel/biohazard @@ -53,42 +50,36 @@ Bio.Iteratee.Bytes, Bio.Iteratee.Exception, Bio.Iteratee.IO, - Bio.Iteratee.IO.Base, - Bio.Iteratee.IO.Fd, - Bio.Iteratee.IO.Handle, Bio.Iteratee.Iteratee, Bio.Iteratee.List, Bio.Iteratee.ZLib, Bio.Prelude, Bio.TwoBit, + Bio.Util.MMap, Bio.Util.Numeric, Bio.Util.Zlib - Build-depends: aeson >= 0.7 && < 1.1, - async >= 2.0 && < 2.2, + Build-depends: async >= 2.0 && < 2.2, attoparsec >= 0.10 && < 0.14, - base >= 4.6 && < 4.10, - base-prelude >= 1.0 && < 1.3, + base >= 4.6 && < 4.11, + base-prelude == 1.0.* || == 1.2.*, binary >= 0.7 && < 0.9, bytestring >= 0.10.2 && < 0.11, - bytestring-mmap >= 0.2 && < 1.0, containers >= 0.4.1 && < 0.6, - directory >= 1.2 && < 2.0, + directory >= 1.2 && < 1.4, exceptions >= 0.6 && < 0.9, - filepath >= 1.3 && < 2.0, + filepath >= 1.3 && < 1.5, hashable >= 1.0 && < 1.3, - monad-control == 1.0.*, primitive >= 0.5 && < 0.7, random >= 1.0 && < 1.2, scientific == 0.3.*, stm == 2.4.*, - text >= 1.0 && < 2.0, + text >= 1.0 && < 1.3, transformers >= 0.4.1 && < 0.6, - transformers-base >= 0.4 && < 0.6, unix >= 2.5 && < 2.8, unordered-containers >= 0.2.3 && < 0.3, vector >= 0.11 && < 0.13, - vector-algorithms >= 0.3 && < 1.0, + vector-algorithms >= 0.3 && < 0.8, vector-th-unbox == 0.2.*, zlib == 0.6.* @@ -109,6 +100,7 @@ Other-Extensions: CPP, DeriveGeneric, ExistentialQuantification, + ForeignFunctionInterface, FunctionalDependencies, GeneralizedNewtypeDeriving, PatternGuards, @@ -123,6 +115,7 @@ Hs-source-dirs: src Install-Includes: src/cbits/myers_align.h C-sources: src/cbits/loops.c, + src/cbits/mmap.c, src/cbits/myers_align.c, src/cbits/trim.c CC-options: -fPIC diff --git a/src/Bio/Adna.hs b/src/Bio/Adna.hs --- a/src/Bio/Adna.hs +++ b/src/Bio/Adna.hs @@ -34,7 +34,6 @@ import Bio.Bam import Bio.Prelude import Bio.TwoBit -import Data.Aeson import qualified Data.Vector as V import qualified Data.Vector.Generic as G @@ -59,15 +58,6 @@ newtype Mat44D = Mat44D (U.Vector Double) deriving (Show, Generic) newtype MMat44D = MMat44D (UM.IOVector Double) - -instance ToJSON Mat44D where - toJSON (Mat44D v) = Array $ V.fromListN 4 - [ toJSON $ U.slice i 4 v - | i <- [0, 4, 8, 12] ] - -instance FromJSON Mat44D where - parseJSON = withArray "matrix" $ - fmap Mat44D . fmap U.concat . mapM parseJSON . V.toList -- | A 'DamageModel' is a function that gives substitution matrices for -- each position in a read. The 'DamageModel' can depend on whether the diff --git a/src/Bio/Bam/Index.hs b/src/Bio/Bam/Index.hs --- a/src/Bio/Bam/Index.hs +++ b/src/Bio/Bam/Index.hs @@ -149,13 +149,13 @@ -- two, and finally in the file itself. The first file that exists and -- can actually be parsed, is used. readBamIndex :: FilePath -> IO (BamIndex ()) -readBamIndex fp | takeExtension fp == ".bai" = fileDriver readBaiIndex fp - | takeExtension fp == ".csi" = fileDriver readBaiIndex fp +readBamIndex fp | takeExtension fp == ".bai" = enumFile defaultBufSize fp readBaiIndex >>= run + | takeExtension fp == ".csi" = enumFile defaultBufSize fp readBaiIndex >>= run | otherwise = tryIx (fp <.> "bai") $ tryIx (dropExtension fp <.> "bai") $ tryIx (fp <.> "csi") $ tryIx (dropExtension fp <.> "csi") $ - fileDriver readBaiIndex fp + enumFile defaultBufSize fp readBaiIndex >>= run where tryIx f k = do e <- doesFileExist f if e then do r <- enumFile defaultBufSize f readBaiIndex >>= tryRun diff --git a/src/Bio/Bam/Reader.hs b/src/Bio/Bam/Reader.hs --- a/src/Bio/Bam/Reader.hs +++ b/src/Bio/Bam/Reader.hs @@ -212,11 +212,11 @@ concatDefaultInputs it0 = liftIO getArgs >>= \fs -> concatInputs fs it0 concatInputs :: (MonadIO m, MonadMask m) => [FilePath] -> Enumerator' BamMeta [BamRaw] m a -concatInputs [ ] = \k -> enumHandle defaultBufSize stdin (decodeAnyBam k) >>= run +concatInputs [ ] = \k -> enumFd defaultBufSize stdInput (decodeAnyBam k) >>= run concatInputs (fp0:fps0) = \k -> enum1 fp0 k >>= go fps0 where - enum1 "-" k1 = enumHandle defaultBufSize stdin (decodeAnyBam k1) >>= run - enum1 fp k1 = enumFile defaultBufSize fp (decodeAnyBam k1) >>= run + enum1 "-" k1 = enumFd defaultBufSize stdInput (decodeAnyBam k1) >>= run + enum1 fp k1 = enumFile defaultBufSize fp (decodeAnyBam k1) >>= run go [ ] = return go (fp1:fps) = enum1 fp1 . const >=> go fps @@ -229,11 +229,11 @@ mergeInputs :: (MonadIO m, MonadMask m) => (BamMeta -> Enumeratee [BamRaw] [BamRaw] (Iteratee [BamRaw] m) a) -> [FilePath] -> Enumerator' BamMeta [BamRaw] m a -mergeInputs _ [ ] = \k -> enumHandle defaultBufSize stdin (decodeAnyBam k) >>= run +mergeInputs _ [ ] = \k -> enumFd defaultBufSize stdInput (decodeAnyBam k) >>= run mergeInputs (?) (fp0:fps0) = go fp0 fps0 where - enum1 "-" k1 = enumHandle defaultBufSize stdin (decodeAnyBam k1) >>= run - enum1 fp k1 = enumFile defaultBufSize fp (decodeAnyBam k1) >>= run + enum1 "-" k1 = enumFd defaultBufSize stdInput (decodeAnyBam k1) >>= run + enum1 fp k1 = enumFile defaultBufSize fp (decodeAnyBam k1) >>= run go fp [ ] = enum1 fp go fp (fp1:fps) = mergeEnums' (go fp1 fps) (enum1 fp) (?) @@ -258,7 +258,7 @@ refs <- liftBlock get_ref_array convStream getBamRaw $ inner $! mmerge meta refs where - get_bam_header = do magic <- iGetString 4 + get_bam_header = do magic <- iGetString 4 when (magic /= "BAM\SOH") $ do s <- iGetString 10 fail $ "BAM signature not found: " ++ show magic ++ " " ++ show s diff --git a/src/Bio/Iteratee.hs b/src/Bio/Iteratee.hs --- a/src/Bio/Iteratee.hs +++ b/src/Bio/Iteratee.hs @@ -3,7 +3,6 @@ module Bio.Iteratee ( iGetString, - iterGet, iterLoop, iLookAhead, @@ -63,7 +62,6 @@ import Control.Monad.Catch ( MonadMask(..) ) import Control.Monad.IO.Class import Control.Monad.Trans.Class -import Data.Binary.Get import System.IO ( hIsTerminalDevice ) import qualified Control.Monad.Catch as CMC @@ -102,23 +100,6 @@ iterLoop it a = do e <- isFinished if e then return a else it a >>= iterLoop it - --- | Convert a 'Get' into an 'Iteratee'. The 'Get' is applied once, the --- decoded data is returned, unneded input remains in the stream. -iterGet :: Get a -> Iteratee S.ByteString m a -iterGet = go . runGetIncremental - where - go (Fail _ _ err) = throwErr (iterStrExc err) - go (Done rest _ a) = idone a (Chunk rest) - go (Partial dec) = liftI $ \ck -> case ck of - Chunk s -> go (dec $ Just s) - EOF mx -> case dec Nothing of - Fail _ _ err -> throwErr (iterStrExc err) - Partial _ -> throwErr (iterStrExc "") - Done rest _ a | S.null rest -> idone a (EOF mx) - | otherwise -> idone a (Chunk rest) - - infixl 1 $== {-# INLINE ($==) #-} -- | Compose an 'Enumerator\'' with an 'Enumeratee', giving a new @@ -147,15 +128,15 @@ type Enumeratee' h ei eo m b = (h -> Iteratee eo m b) -> Iteratee ei m (Iteratee eo m b) enumAuxFile :: (MonadIO m, MonadMask m) => FilePath -> Iteratee S.ByteString m a -> m a -enumAuxFile fp it = liftIO (findAuxFile fp) >>= fileDriver it +enumAuxFile fp it = liftIO (findAuxFile fp) >>= \f -> enumFile defaultBufSize f it >>= run enumDefaultInputs :: (MonadIO m, MonadMask m) => Enumerator S.ByteString m a enumDefaultInputs it0 = liftIO getArgs >>= flip enumInputs it0 enumInputs :: (MonadIO m, MonadMask m) => [FilePath] -> Enumerator S.ByteString m a -enumInputs [] = enumHandle defaultBufSize stdin +enumInputs [] = enumFd defaultBufSize stdInput enumInputs xs = go xs - where go ("-":fs) = enumHandle defaultBufSize stdin >=> go fs + where go ("-":fs) = enumFd defaultBufSize stdInput >=> go fs go ( f :fs) = enumFile defaultBufSize f >=> go fs go [ ] = return diff --git a/src/Bio/Iteratee/Base.hs b/src/Bio/Iteratee/Base.hs --- a/src/Bio/Iteratee/Base.hs +++ b/src/Bio/Iteratee/Base.hs @@ -35,11 +35,9 @@ import Bio.Iteratee.Exception import Bio.Prelude -import Control.Monad.Base import Control.Monad.Catch as CIO import Control.Monad.IO.Class import Control.Monad.Trans.Class -import Control.Monad.Trans.Control import qualified Control.Exception as E import qualified Data.ByteString as B @@ -170,8 +168,8 @@ instance NullPoint s => MonadTrans (Iteratee s) where lift m = Iteratee $ \onDone _ -> m >>= flip onDone (Chunk emptyP) -instance (MonadBase b m, Nullable s, NullPoint s) => MonadBase b (Iteratee s m) where - liftBase = lift . liftBase +-- instance (MonadBase b m, Nullable s, NullPoint s) => MonadBase b (Iteratee s m) where + -- liftBase = lift . liftBase instance (MonadIO m, Nullable s, NullPoint s) => MonadIO (Iteratee s m) where liftIO = lift . liftIO @@ -188,28 +186,6 @@ instance (MonadMask m, Nullable s, NullPoint s) => MonadMask (Iteratee s m) where mask q = Iteratee $ \od oc -> CIO.mask $ \u -> runIter (q $ ilift u) od oc uninterruptibleMask q = Iteratee $ \od oc -> CIO.uninterruptibleMask $ \u -> runIter (q $ ilift u) od oc - - -instance forall s. (NullPoint s, Nullable s) => MonadTransControl (Iteratee s) where - type StT (Iteratee s) x = Either (x, Stream s) (Maybe SomeException) - - liftWith f = lift $ f $ \t -> - (runIter t (\x s -> return $ Left (x,s)) - (\_ e -> return $ Right e) ) - restoreT = join . lift . liftM - (either (uncurry idone) - (te . fromMaybe (iterStrExc - "iteratee: error in MonadTransControl instance"))) - where - te :: SomeException -> Iteratee s m a - te e = icont (const (te e)) (Just e) - {-# INLINE liftWith #-} - {-# INLINE restoreT #-} - -instance (MonadBaseControl b m, Nullable s) => MonadBaseControl b (Iteratee s m) where - type StM (Iteratee s m) a = ComposeSt (Iteratee s) m a - liftBaseWith = defaultLiftBaseWith - restoreM = defaultRestoreM -- |Send 'EOF' to the @Iteratee@ and disregard the unconsumed part of the diff --git a/src/Bio/Iteratee/Exception.hs b/src/Bio/Iteratee/Exception.hs --- a/src/Bio/Iteratee/Exception.hs +++ b/src/Bio/Iteratee/Exception.hs @@ -41,6 +41,7 @@ -- * Exception types IFException (..) ,Exception (..) -- from Control.Exception + ,FileOffset -- from System.Posix.Types -- ** Enumerator exceptions ,EnumException (..) ,DivergentException (..) @@ -61,10 +62,10 @@ ) where -import Bio.Iteratee.IO.Base import Control.Exception import Data.Data import Prelude +import System.Posix.Types ( FileOffset ) -- ---------------------------------------------- diff --git a/src/Bio/Iteratee/IO.hs b/src/Bio/Iteratee/IO.hs --- a/src/Bio/Iteratee/IO.hs +++ b/src/Bio/Iteratee/IO.hs @@ -1,39 +1,26 @@ -{-# LANGUAGE ConstraintKinds #-} - --- |Random and Binary IO with generic Iteratees. +-- |Random and Binary IO with generic Iteratees, using File Descriptors for IO. +-- when available, these are the preferred functions for performing IO as they +-- run in constant space and function properly with sockets, pipes, etc. module Bio.Iteratee.IO( -- * Data - defaultBufSize, + defaultBufSize -- * File enumerators - -- ** Handle-based enumerators - H.enumHandle, - H.enumHandleRandom, - enumFile, - enumFileRandom, - -- ** FileDescriptor based enumerators - FD.enumFd, - FD.enumFdRandom, - -- * Iteratee drivers - -- These are FileDescriptor-based on POSIX systems, otherwise they are - -- Handle-based. The Handle-based drivers are accessible on POSIX systems - -- at Data.Iteratee.IO.Handle - fileDriver, - fileDriverVBuf, - fileDriverRandom, - fileDriverRandomVBuf, + ,enumFile + ,enumFileRandom + -- * FileDescriptor based enumerators for monadic iteratees + ,enumFd + ,enumFdCatch + ,enumFdRandom ) - where import Bio.Iteratee.Iteratee -import Bio.Prelude +import Bio.Prelude hiding ( bracket ) import Control.Monad.Catch import Control.Monad.IO.Class - -import qualified Bio.Iteratee.IO.Handle as H -import qualified Bio.Iteratee.IO.Fd as FD - +import Data.ByteString.Internal (createAndTrim) +import System.IO (SeekMode(..)) -- | Default buffer size in elements. This was 1024 in "Data.Iteratee", -- which is obviously too small. Since we often want to merge many @@ -42,54 +29,60 @@ defaultBufSize :: Int defaultBufSize = 2*1024*1024 +-- ------------------------------------------------------------------------ +-- Binary Random IO enumerators --- If Posix is available, use the fileDriverRandomFd as fileDriverRandom. Otherwise, use a handle-based variant. -enumFile - :: (MonadIO m, MonadMask m) => - Int - -> FilePath - -> Enumerator Bytes m a -enumFile = FD.enumFile +makefdCallback :: MonadIO m => Int -> Fd -> st -> m (Either SomeException ((Bool, st), Bytes)) +makefdCallback bufsize fd st = do + s <- liftIO . createAndTrim bufsize $ \p -> + fromIntegral <$> fdReadBuf fd (castPtr p) (fromIntegral bufsize) + return $ Right ((True, st), s) -enumFileRandom - :: (MonadIO m, MonadMask m) => - Int - -> FilePath - -> Enumerator Bytes m a -enumFileRandom = FD.enumFileRandom +-- |The enumerator of a POSIX File Descriptor. This version enumerates +-- over the entire contents of a file, in order, unless stopped by +-- the iteratee. In particular, seeking is not supported. +enumFd :: MonadIO m => Int -> Fd -> Enumerator Bytes m a +enumFd bufsize fd = enumFromCallback (makefdCallback bufsize fd) () --- |Process a file using the given Iteratee. This function wraps --- enumFd as a convenience. -fileDriver - :: (MonadIO m, MonadMask m) => - Iteratee Bytes m a - -> FilePath - -> m a -fileDriver = FD.fileDriverFd defaultBufSize +-- |A variant of enumFd that catches exceptions raised by the @Iteratee@. +enumFdCatch + :: (IException e, MonadIO m) + => Int + -> Fd + -> (e -> m (Maybe EnumException)) + -> Enumerator Bytes m a +enumFdCatch bufsize fd handler = enumFromCallbackCatch (makefdCallback bufsize fd) handler () --- |A version of fileDriver with a user-specified buffer size (in elements). -fileDriverVBuf - :: (MonadIO m, MonadMask m) => - Int - -> Iteratee Bytes m a - -> FilePath - -> m a -fileDriverVBuf = FD.fileDriverFd +-- |The enumerator of a POSIX File Descriptor: a variation of @enumFd@ that +-- supports RandomIO (seek requests). +enumFdRandom :: MonadIO m => Int -> Fd -> Enumerator Bytes m a +enumFdRandom bs fd iter = enumFdCatch bs fd handler iter + where + handler (SeekException off) = + Nothing <$ (liftIO . fdSeek fd AbsoluteSeek $ fromIntegral off) --- |Process a file using the given Iteratee. This function wraps --- enumFdRandom as a convenience. -fileDriverRandom - :: (MonadIO m, MonadMask m) => - Iteratee Bytes m a - -> FilePath - -> m a -fileDriverRandom = FD.fileDriverRandomFd defaultBufSize +enumFile' :: (MonadIO m, MonadMask m) => + (Int -> Fd -> Enumerator s m a) + -> Int -- ^Buffer size + -> FilePath + -> Enumerator s m a +enumFile' enumf bufsize filepath iter = bracket + (liftIO $ openFd filepath ReadOnly Nothing defaultFileFlags) + (liftIO . closeFd) + (flip (enumf bufsize) iter) -fileDriverRandomVBuf - :: (MonadIO m, MonadMask m) => - Int - -> Iteratee Bytes m a - -> FilePath - -> m a -fileDriverRandomVBuf = FD.fileDriverRandomFd +enumFile :: + (MonadIO m, MonadMask m) + => Int -- ^Buffer size + -> FilePath + -> Enumerator Bytes m a +enumFile = enumFile' enumFd + +enumFileRandom :: + (MonadIO m, MonadMask m) + => Int -- ^Buffer size + -> FilePath + -> Enumerator Bytes m a +enumFileRandom = enumFile' enumFdRandom + diff --git a/src/Bio/Iteratee/IO/Base.hs b/src/Bio/Iteratee/IO/Base.hs deleted file mode 100644 --- a/src/Bio/Iteratee/IO/Base.hs +++ /dev/null @@ -1,105 +0,0 @@ -{-# LANGUAGE ForeignFunctionInterface, CPP #-} - --- Low-level IO operations --- These operations are either missing from the GHC run-time library, --- or implemented suboptimally or heavy-handedly - -module Bio.Iteratee.IO.Base ( - FileOffset, - myfdRead, - myfdSeek, - Errno(..), - select'read'pending -) - -where - -import Control.Monad -import Data.Bits -- for select -import Foreign.C -import Foreign.Marshal.Array -- for select -import Foreign.Ptr -import Prelude -import System.IO (SeekMode(..)) -import System.Posix - --- |Alas, GHC provides no function to read from Fd to an allocated buffer. --- The library function fdRead is not appropriate as it returns a string --- already. I'd rather get data from a buffer. --- Furthermore, fdRead (at least in GHC) allocates a new buffer each --- time it is called. This is a waste. Yet another problem with fdRead --- is in raising an exception on any IOError or even EOF. I'd rather --- avoid exceptions altogether. - -myfdRead :: Fd -> Ptr CChar -> ByteCount -> IO (Either Errno ByteCount) -myfdRead (Fd fd) ptr n = do - n' <- cRead fd ptr n - if n' == -1 then liftM Left getErrno - else return . Right . fromIntegral $ n' - -foreign import ccall unsafe "unistd.h read" cRead - :: CInt -> Ptr CChar -> CSize -> IO CInt - --- |The following fseek procedure throws no exceptions. -myfdSeek:: Fd -> SeekMode -> FileOffset -> IO (Either Errno FileOffset) -myfdSeek (Fd fd) mode off = do - n' <- cLSeek fd off (mode2Int mode) - if n' == -1 then liftM Left getErrno - else return . Right $ n' - where mode2Int :: SeekMode -> CInt -- From GHC source - mode2Int AbsoluteSeek = 0 - mode2Int RelativeSeek = 1 - mode2Int SeekFromEnd = 2 - -foreign import ccall unsafe "unistd.h lseek" cLSeek - :: CInt -> FileOffset -> CInt -> IO FileOffset - - --- Darn! GHC doesn't provide the real select over several descriptors! --- We have to implement it ourselves - -type FDSET = CUInt -type TIMEVAL = CLong -- Two longs -foreign import ccall "unistd.h select" c_select - :: CInt -> Ptr FDSET -> Ptr FDSET -> Ptr FDSET -> Ptr TIMEVAL -> IO CInt - --- Convert a file descriptor to an FDSet (for use with select) --- essentially encode a file descriptor in a big-endian notation -fd2fds :: CInt -> [FDSET] -fd2fds fd = replicate nb 0 ++ [setBit 0 off] - where - (nb,off) = quotRem (fromIntegral fd) bitSize_FDSET - -bitSize_FDSET :: Int -#if MIN_VERSION_base(4,7,0) -bitSize_FDSET = finiteBitSize (undefined::FDSET) -#else -bitSize_FDSET = bitSize (undefined::FDSET) -#endif - -fds2mfd :: [FDSET] -> [CInt] -fds2mfd fds = [fromIntegral (j+i*bitSize_FDSET) | - (afds,i) <- zip fds [0..], j <- [0..bitSize_FDSET], - testBit afds j] - -unFd :: Fd -> CInt -unFd (Fd x) = x - --- |poll if file descriptors have something to read --- Return the list of read-pending descriptors -select'read'pending :: [Fd] -> IO (Either Errno [Fd]) -select'read'pending mfd = - withArray ([0,1]::[TIMEVAL]) $ \_timeout -> - withArray fds $ \readfs -> do - rc <- c_select (fdmax+1) readfs nullPtr nullPtr nullPtr - if rc == -1 - then liftM Left getErrno - -- because the wait was indefinite, rc must be positive! - else liftM (Right . map Fd . fds2mfd) (peekArray (length fds) readfs) - where - fds :: [FDSET] - fds = foldr ormax [] (map (fd2fds . unFd) mfd) - fdmax = maximum $ map fromIntegral mfd - ormax [] x = x - ormax x [] = x - ormax (a:ar) (b:br) = (a .|. b) : ormax ar br diff --git a/src/Bio/Iteratee/IO/Fd.hs b/src/Bio/Iteratee/IO/Fd.hs deleted file mode 100644 --- a/src/Bio/Iteratee/IO/Fd.hs +++ /dev/null @@ -1,145 +0,0 @@ --- |Random and Binary IO with generic Iteratees, using File Descriptors for IO. --- when available, these are the preferred functions for performing IO as they --- run in constant space and function properly with sockets, pipes, etc. - -module Bio.Iteratee.IO.Fd( - -- * File enumerators - -- ** FileDescriptor based enumerators for monadic iteratees - enumFd - ,enumFdCatch - ,enumFdRandom - ,enumFile - ,enumFileRandom - -- * Iteratee drivers - ,fileDriverFd - ,fileDriverRandomFd -) - -where - -import Bio.Iteratee.IO.Base -import Bio.Iteratee.Iteratee -import Bio.Prelude -import Control.Monad.Catch as CIO -import Control.Monad.IO.Class -import Data.ByteString (packCStringLen) -import Foreign.Marshal.Alloc -import System.IO (SeekMode(..)) - - --- ------------------------------------------------------------------------ --- Binary Random IO enumerators - -makefdCallback :: - MonadIO m => - Ptr el - -> ByteCount - -> Fd - -> st - -> m (Either SomeException ((Bool, st), Bytes)) -makefdCallback p bufsize fd st = do - n <- liftIO $ myfdRead fd (castPtr p) bufsize - case n of - Left _ -> return $ Left (error "myfdRead failed") - Right 0 -> liftIO yield >> return (Right ((False, st), emptyP)) - Right n' -> liftM (\s -> Right ((True, st), s)) $ - readFromPtr p (fromIntegral n') - where - readFromPtr buf l = liftIO $ packCStringLen (castPtr buf, l) - --- |The enumerator of a POSIX File Descriptor. This version enumerates --- over the entire contents of a file, in order, unless stopped by --- the iteratee. In particular, seeking is not supported. -enumFd - :: (MonadIO m, MonadMask m) => - Int - -> Fd - -> Enumerator Bytes m a -enumFd bufsize fd iter = - CIO.bracket (liftIO $ mallocBytes bufsize) - (liftIO . free) - (\p -> enumFromCallback (makefdCallback p (fromIntegral bufsize) fd) () iter) - --- |A variant of enumFd that catches exceptions raised by the @Iteratee@. -enumFdCatch - :: (IException e, MonadIO m, MonadMask m) - => Int - -> Fd - -> (e -> m (Maybe EnumException)) - -> Enumerator Bytes m a -enumFdCatch bufsize fd handler iter = - CIO.bracket (liftIO $ mallocBytes bufsize) - (liftIO . free) - (\p -> enumFromCallbackCatch (makefdCallback p (fromIntegral bufsize) fd) handler () iter) - - --- |The enumerator of a POSIX File Descriptor: a variation of @enumFd@ that --- supports RandomIO (seek requests). -enumFdRandom - :: (MonadIO m, MonadMask m) => - Int - -> Fd - -> Enumerator Bytes m a -enumFdRandom bs fd iter = enumFdCatch bs fd handler iter - where - handler (SeekException off) = - liftM (either - (const . Just $ enStrExc "Error seeking within file descriptor") - (const Nothing)) - . liftIO . myfdSeek fd AbsoluteSeek $ fromIntegral off - -fileDriver - :: (MonadIO m, MonadMask m) => - (Int -> Fd -> Enumerator s m a) - -> Int - -> Iteratee s m a - -> FilePath - -> m a -fileDriver enumf bufsize iter filepath = CIO.bracket - (liftIO $ openFd filepath ReadOnly Nothing defaultFileFlags) - (liftIO . closeFd) - (run <=< flip (enumf bufsize) iter) - --- |Process a file using the given @Iteratee@. -fileDriverFd - :: (MonadIO m, MonadMask m) => - Int -- ^Buffer size (number of elements) - -> Iteratee Bytes m a - -> FilePath - -> m a -fileDriverFd = fileDriver enumFd - --- |A version of fileDriverFd that supports seeking. -fileDriverRandomFd - :: (MonadIO m, MonadMask m) => - Int - -> Iteratee Bytes m a - -> FilePath - -> m a -fileDriverRandomFd = fileDriver enumFdRandom - -enumFile' :: (MonadIO m, MonadMask m) => - (Int -> Fd -> Enumerator s m a) - -> Int -- ^Buffer size - -> FilePath - -> Enumerator s m a -enumFile' enumf bufsize filepath iter = CIO.bracket - (liftIO $ openFd filepath ReadOnly Nothing defaultFileFlags) - (liftIO . closeFd) - (flip (enumf bufsize) iter) - -enumFile :: - (MonadIO m, MonadMask m) - => Int -- ^Buffer size - -> FilePath - -> Enumerator Bytes m a -enumFile = enumFile' enumFd - -enumFileRandom :: - (MonadIO m, MonadMask m) - => Int -- ^Buffer size - -> FilePath - -> Enumerator Bytes m a -enumFileRandom = enumFile' enumFdRandom - - diff --git a/src/Bio/Iteratee/IO/Handle.hs b/src/Bio/Iteratee/IO/Handle.hs deleted file mode 100644 --- a/src/Bio/Iteratee/IO/Handle.hs +++ /dev/null @@ -1,145 +0,0 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE ScopedTypeVariables #-} - --- |Random and Binary IO with generic Iteratees. These functions use Handles --- for IO operations, and are provided for compatibility. When available, --- the File Descriptor based functions are preferred as these wastefully --- allocate memory rather than running in constant space. - -module Bio.Iteratee.IO.Handle( - -- * File enumerators - enumHandle - ,enumHandleCatch - ,enumHandleRandom - ,enumFile - ,enumFileRandom - -- * Iteratee drivers - ,fileDriverHandle - ,fileDriverRandomHandle -) - -where - -import Bio.Iteratee.Iteratee -import Bio.Prelude -import Control.Monad.Catch as CIO -import Control.Monad.IO.Class -import Data.ByteString (packCStringLen) -import Foreign.Marshal.Alloc -import System.IO - --- ------------------------------------------------------------------------ --- Binary Random IO enumerators - -makeHandleCallback :: - MonadIO m => - Ptr Word8 - -> Int - -> Handle - -> st - -> m (Either SomeException ((Bool, st), Bytes)) -makeHandleCallback p bsize h st = do - n' <- liftIO (CIO.try $ hGetBuf h p bsize :: IO (Either SomeException Int)) - case n' of - Left e -> return $ Left e - Right 0 -> return $ Right ((False, st), emptyP) - Right n -> liftM (\s -> Right ((True, st), s)) $ - readFromPtr p (fromIntegral n) - where - readFromPtr buf l = liftIO $ packCStringLen (castPtr buf, l) - - --- |The (monadic) enumerator of a file Handle. This version enumerates --- over the entire contents of a file, in order, unless stopped by --- the iteratee. In particular, seeking is not supported. --- Data is read into a buffer of the specified size. -enumHandle :: - (MonadIO m, MonadMask m) => - Int -- ^Buffer size (number of elements per read) - -> Handle - -> Enumerator Bytes m a -enumHandle bufsize h i = - CIO.bracket (liftIO $ mallocBytes bufsize) - (liftIO . free) - (\p -> enumFromCallback (makeHandleCallback p bufsize h) () i) - --- |An enumerator of a file handle that catches exceptions raised by --- the Iteratee. -enumHandleCatch - :: - forall e m a.(IException e, - MonadIO m, MonadMask m) => - Int -- ^Buffer size (number of elements per read) - -> Handle - -> (e -> m (Maybe EnumException)) - -> Enumerator Bytes m a -enumHandleCatch bufsize h handler i = - CIO.bracket (liftIO $ mallocBytes bufsize) - (liftIO . free) - (\p -> enumFromCallbackCatch (makeHandleCallback p bufsize h) handler () i) - - --- |The enumerator of a Handle: a variation of enumHandle that --- supports RandomIO (seek requests). --- Data is read into a buffer of the specified size. -enumHandleRandom :: - forall m a.(MonadIO m, MonadMask m) => - Int -- ^ Buffer size (number of elements per read) - -> Handle - -> Enumerator Bytes m a -enumHandleRandom bs h i = enumHandleCatch bs h handler i - where - handler (SeekException off) = - liftM (either - (Just . EnumException :: IOException -> Maybe EnumException) - (const Nothing)) - . liftIO . CIO.try $ hSeek h AbsoluteSeek $ fromIntegral off - --- ---------------------------------------------- --- File Driver wrapper functions. - -enumFile' :: (MonadIO m, MonadMask m) => - (Int -> Handle -> Enumerator s m a) - -> Int -- ^Buffer size - -> FilePath - -> Enumerator s m a -enumFile' enumf bufsize filepath iter = CIO.bracket - (liftIO $ openBinaryFile filepath ReadMode) - (liftIO . hClose) - (flip (enumf bufsize) iter) - -enumFile :: - (MonadIO m, MonadMask m) - => Int -- ^Buffer size - -> FilePath - -> Enumerator Bytes m a -enumFile = enumFile' enumHandle - -enumFileRandom :: - (MonadIO m, MonadMask m) - => Int -- ^Buffer size - -> FilePath - -> Enumerator Bytes m a -enumFileRandom = enumFile' enumHandleRandom - --- |Process a file using the given @Iteratee@. This function wraps --- @enumHandle@ as a convenience. -fileDriverHandle - :: (MonadIO m, MonadMask m) => - Int -- ^Buffer size (number of elements) - -> Iteratee Bytes m a - -> FilePath - -> m a -fileDriverHandle bufsize iter filepath = - enumFile bufsize filepath iter >>= run - --- |A version of @fileDriverHandle@ that supports seeking. -fileDriverRandomHandle - :: (MonadIO m, MonadMask m) => - Int -- ^ Buffer size (number of elements) - -> Iteratee Bytes m a - -> FilePath - -> m a -fileDriverRandomHandle bufsize iter filepath = - enumFileRandom bufsize filepath iter >>= run - diff --git a/src/Bio/Iteratee/Iteratee.hs b/src/Bio/Iteratee/Iteratee.hs --- a/src/Bio/Iteratee/Iteratee.hs +++ b/src/Bio/Iteratee/Iteratee.hs @@ -62,13 +62,11 @@ ,(<><) -- * Misc. ,seek - ,FileOffset -- * Classes ,module Bio.Iteratee.Base ) where -import Bio.Iteratee.IO.Base import Bio.Iteratee.Base import Bio.Prelude hiding (loop) import Control.Monad.IO.Class diff --git a/src/Bio/TwoBit.hs b/src/Bio/TwoBit.hs --- a/src/Bio/TwoBit.hs +++ b/src/Bio/TwoBit.hs @@ -23,15 +23,13 @@ ) where import Bio.Prelude hiding ( left, right, chr ) +import Bio.Util.MMap import Data.Binary.Get -import qualified Data.ByteString as B -import qualified Data.ByteString.Lazy as L --- can't use Data.IntMap.Strict to remain compatible with --- containers-0.4.1 and therefore ghc 7.4 :-( -import qualified Data.IntMap as I -import qualified Data.HashMap.Lazy as M -import qualified Data.Vector.Unboxed as U -import System.IO.Posix.MMap +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as L +import qualified Data.IntMap as I +import qualified Data.HashMap.Lazy as M +import qualified Data.Vector.Unboxed as U import System.Random -- ^ Would you believe it? The 2bit format stores blocks of Ns in a table at @@ -62,25 +60,25 @@ -- 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 - return $ flip runGet (L.fromChunks [raw]) $ do - sig <- getWord32be - getWord32 <- case sig of - 0x1A412743 -> return $ fromIntegral `fmap` getWord32be - 0x4327411A -> return $ fromIntegral `fmap` getWord32le - _ -> fail $ "invalid .2bit signature " ++ showHex sig [] - - version <- getWord32 - unless (version == 0) $ fail $ "wrong .2bit version " ++ show version +openTwoBit fp = do + raw <- unsafeMMapFile fp + return $ flip runGet (L.fromChunks [raw]) $ do + sig <- getWord32be + getWord32 <- case sig of + 0x1A412743 -> return $ fromIntegral `fmap` getWord32be + 0x4327411A -> return $ fromIntegral `fmap` getWord32le + _ -> fail $ "invalid .2bit signature " ++ showHex sig [] - nseqs <- getWord32 - _reserved <- getWord32 + version <- getWord32 + unless (version == 0) $ fail $ "wrong .2bit version " ++ show version - TBF raw <$> foldM (\ix _ -> do !key <- getWord8 >>= getByteString . fromIntegral - !off <- getWord32 - return $! M.insert key (mkBlockIndex raw getWord32 off) ix - ) M.empty [1..nseqs] + nseqs <- getWord32 + _reserved <- getWord32 + TBF raw <$> foldM (\ix _ -> do !key <- getWord8 >>= getByteString . fromIntegral + !off <- getWord32 + return $! M.insert key (mkBlockIndex raw getWord32 off) ix + ) M.empty [1..nseqs] mkBlockIndex :: B.ByteString -> Get Int -> Int -> TwoBitSequence mkBlockIndex raw getWord32 ofs = runGet getBlock $ L.fromChunks [B.drop ofs raw] diff --git a/src/Bio/Util/MMap.hs b/src/Bio/Util/MMap.hs new file mode 100644 --- /dev/null +++ b/src/Bio/Util/MMap.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE ForeignFunctionInterface #-} +module Bio.Util.MMap where + +import Bio.Prelude hiding ( left, right, chr ) +import Data.ByteString.Internal ( fromForeignPtr ) +import Foreign.C.Types + +unsafeMMapFile :: FilePath -> IO Bytes +unsafeMMapFile fp = + bracket (openFd fp ReadOnly Nothing defaultFileFlags) closeFd $ \fd -> do + stat <- getFdStatus fd + let size = fromIntegral (fileSize stat) + if size <= 0 + then return mempty + else do + ptr <- c_mmap size (fromIntegral fd) + if ptr == nullPtr + then error "unable to mmap file" + else do + fptr <- newForeignPtrEnv c_munmap (intPtrToPtr $ fromIntegral size) ptr + return $ fromForeignPtr fptr 0 (fromIntegral size) + +foreign import ccall unsafe "my_mmap" c_mmap :: CSize -> CInt -> IO (Ptr Word8) +foreign import ccall unsafe "&my_munmap" c_munmap :: FunPtr (Ptr () -> Ptr Word8 -> IO ()) + + diff --git a/src/cbits/mmap.c b/src/cbits/mmap.c new file mode 100644 --- /dev/null +++ b/src/cbits/mmap.c @@ -0,0 +1,10 @@ +#include + +unsigned char *my_mmap(size_t len, int fd) { + void *result = mmap(0, len, PROT_READ, MAP_SHARED, fd, 0); + return (unsigned char*)( result == MAP_FAILED ? 0 : result ); +} + +void my_munmap(void *len, unsigned char *p) { + munmap( p, (size_t)len ) ; +}