diff --git a/DPutils.cabal b/DPutils.cabal --- a/DPutils.cabal +++ b/DPutils.cabal @@ -1,5 +1,5 @@ Name: DPutils -Version: 0.0.0.2 +Version: 0.0.1.0 License: BSD3 License-file: LICENSE Maintainer: choener@bioinf.uni-leipzig.de @@ -27,21 +27,29 @@ Library Exposed-modules: + Data.Char.Util Data.Paired.Common Data.Paired.Foldable Data.Paired.Vector + Data.Vector.Generic.Unstream Math.TriangularNumbers Pipes.Parallel + Pipes.Split.ByteString build-depends: base >= 4.7 && < 5.0 + , bytestring , containers - , kan-extensions >= 4.0 && < 6.0 - , parallel >= 3.0 && < 4.0 - , pipes >= 4.0 && < 4.3 + , kan-extensions >= 4.0 + , parallel >= 3.0 + , pipes >= 4.0 , QuickCheck >= 2.7 - , vector >= 0.10 && < 0.12 + , stringsearch >= 0.3 + , transformers >= 0.5 + , vector >= 0.10 default-extensions: BangPatterns , CPP + , RankNTypes , ScopedTypeVariables + , TypeFamilies , FlexibleContexts default-language: Haskell2010 @@ -63,18 +71,27 @@ default-language: Haskell2010 default-extensions: CPP + , RankNTypes + , ScopedTypeVariables , TemplateHaskell build-depends: base + , bytestring , containers - , DPutils , kan-extensions + , lens >= 4.0 + , mtl , parallel , pipes + , pipes-bytestring >= 2.0 + , pipes-parse >= 3.0 , QuickCheck - , tasty >= 0.11 - , tasty-quickcheck >= 0.8 - , tasty-th >= 0.1 + , quickcheck-instances >= 0.3 + , tasty >= 0.11 + , tasty-quickcheck >= 0.8 + , tasty-th >= 0.1 , vector + -- + , DPutils @@ -83,8 +100,9 @@ exitcode-stdio-1.0 build-depends: base , criterion >= 1.1 - , DPutils , vector + -- + , DPutils hs-source-dirs: tests main-is: diff --git a/Data/Char/Util.hs b/Data/Char/Util.hs new file mode 100644 --- /dev/null +++ b/Data/Char/Util.hs @@ -0,0 +1,16 @@ + +-- | Convert between @Word8@ and @Char@. Mostly for attoparsec's bytestring +-- module. + +module Data.Char.Util where + +import Data.Word (Word8) + +c2w8 :: Char -> Word8 +c2w8 = fromIntegral . fromEnum +{-# Inline c2w8 #-} + +w82c :: Word8 -> Char +w82c = toEnum . fromIntegral +{-# Inline w82c #-} + diff --git a/Data/Vector/Generic/Unstream.hs b/Data/Vector/Generic/Unstream.hs new file mode 100644 --- /dev/null +++ b/Data/Vector/Generic/Unstream.hs @@ -0,0 +1,36 @@ + +-- | Helper functions for turnings streams into vectors. +-- +-- Mostly very similar to bundle conversion functions from the @vector@ +-- package. + +module Data.Vector.Generic.Unstream where + +import Control.Monad.ST +import GHC.Conc (pseq) +import qualified Data.Vector.Fusion.Stream.Monadic as SM +import qualified Data.Vector.Generic as VG +import qualified Data.Vector.Generic.Mutable as VGM +import System.IO.Unsafe (unsafePerformIO) + +-- for testing + +import qualified Data.Vector.Unboxed as VU + + + +-- | Turns a stream into a vector. +-- +-- TODO insert index checks? Generalized @flag devel@ + +streamToVectorM :: forall m v a . (Monad m, VG.Vector v a) => SM.Stream m a -> m (v a) +streamToVectorM s = do + let mv' = unsafePerformIO $ VGM.unsafeNew 1 + let put (v',i) x = + do let v = unsafePerformIO $ if (i < VGM.length v') then return v' else VGM.unsafeGrow v' (max 1 $ VGM.length v') + seq (unsafePerformIO $ VGM.unsafeWrite v i x) (return (v,i+1)) + {-# Inline [0] put #-} + (mv,written) <- SM.foldlM' put (mv',0) s + mv `pseq` return . unsafePerformIO . VG.freeze $ VGM.unsafeSlice 0 written mv +{-# Inline streamToVectorM #-} + diff --git a/Pipes/Split/ByteString.hs b/Pipes/Split/ByteString.hs new file mode 100644 --- /dev/null +++ b/Pipes/Split/ByteString.hs @@ -0,0 +1,140 @@ + +-- | Split incombing bytestrings based on bytestrings. + +module Pipes.Split.ByteString where + +import Control.Monad (join,unless) +import Control.Monad.Trans.Class (lift) +import Data.ByteString (ByteString) +import Data.ByteString.Search (indices) +import Data.Monoid ((<>)) +import Debug.Trace +import Pipes (Producer,next,yield) +import qualified Data.ByteString as BS + + + +type Lens' a b = forall f . Functor f => (b -> f b) -> (a -> f a) + +-- | Splits bytestrings after each pattern @pat@. Tries to minimize the +-- number of intermediate bytestring constructors. +-- +-- The following function @ske@ expects a string @str@ and a pattern @pat@ +-- and then returns a tuple with the splitted bytestrings in @fst@ and the +-- return value in @snd@. +-- +-- The inner parser @parse@ uses @zoom@ to draw the full inner producer, +-- which should contain just one bytestring, namely one of the split off +-- ones. @parse@ doesn't do anything with the inner producer, except +-- returning the contained bytestring. +-- +-- @parse@ returns @Right $ concat xs@ on a correct parse, and @Left []@ +-- once the input has been exhausted. +-- +-- @ +-- ske :: ByteString -> ByteString -> ([ByteString],[ByteString],[ByteString]) +-- ske pat str | BS.null pat || BS.null str = ([],[],[]) +-- ske pat str = +-- let parse = do +-- xs <- zoom (splitKeepEnd pat) PP.drawAll +-- case xs of +-- [] -> return $ Left [] +-- xs -> return $ Right $ BS.concat xs +-- (a,(b,p)) = runIdentity . P.toListM' $ PP.parsed parse $ PP.yield str +-- in (a,b, fst . runIdentity . P.toListM' $ p) +-- @ + +splitKeepEnd :: Monad m => ByteString -> Lens' (Producer ByteString m x) (Producer ByteString m (Producer ByteString m x)) +splitKeepEnd pat k p0 = fmap join (k (go BS.empty p0)) where + go pre p = do + x <- lift (next p) + case x of + Left r -> return $ return r + Right (bs, p') -> do + case fnd (pre <> bs) of + -- no hit yet, send the bs down, keep some suffix + [] -> do + unless (BS.null bs) (yield bs) + let pfx = BS.drop (BS.length bs - l + 1) bs + go pfx p' + -- at least one hit, split off the correct part, remainder goes + -- back. + (k:_) -> do + let (y,suf) = BS.splitAt (k - BS.length pre + l) bs + yield y + return (yield suf >> p') + l = BS.length pat + fnd = indices pat +{-# Inlineable splitKeepEnd #-} + + + +-- | Split a string into substrings, where each substring starts with @pat@ +-- and continues until just before the next @pat@ (or until there is no +-- more input). +-- +-- Any prefix that does not start with the substring is /kept/! +-- +-- Since each substring is supposed to start with @pat@, there is a small +-- problem. What about a header that prefixes the string we are interested +-- in? + +splitKeepStart :: Monad m => ByteString -> Lens' (Producer ByteString m x) (Producer ByteString m (Producer ByteString m x)) +splitKeepStart = splitGeneric (\bs k p l -> BS.splitAt (k - p) bs) +{-# Inlineable splitKeepStart #-} + + + +-- | Generic splitting function. Takes a bytestring @[a,b,c]@ (where +-- @a,b,c@ are substrings of the bytestring!) and performs the split. +-- + +splitGeneric + :: Monad m + => (ByteString -> Int -> Int -> Int -> (ByteString,ByteString)) + -- ^ splitter function + -> ByteString + -- ^ pattern to split on + -> Lens' (Producer ByteString m x) (Producer ByteString m (Producer ByteString m x)) + -- ^ lens into the individual split off bytestrings +splitGeneric splt pat k p0 = fmap join (k (go BS.empty p0)) where + go pre p = do + x <- lift (next p) + case x of + Left r -> do + -- yield final split off string + unless (BS.null pre) (yield pre) + return $ return r + Right (bs, p') -> do + -- will not search in the part of the prefix that *can not contain* + -- the @pat@tern. + case fnd ((BS.drop (BS.length pre - l) pre) <> bs) of + -- no hit yet, send the prefix down completely, make bs new + -- prefix if possible. If either @pre@ or @bs@ are too short, we + -- keep @pre <> bs@ for the next round. This should not happen if + -- the pattern is reasonably short compared to the size of the + -- bytestring chunks. + [] -> do + if (BS.length bs >= l) + then yield pre >> go bs p' + else go (pre <> bs) p' + -- at least one hit, split off the correct part, remainder goes + -- back. + (k:_) -> do + let (y,suf) = splt bs k (BS.length pre) l + yield y + return (yield suf >> p') + l = BS.length pat + fnd = indices pat +{-# Inline splitGeneric #-} + + + +-- manual splitting, for @splitKeepEnd@ + +referenceByteStringTokenizer pat str | BS.null pat || BS.null str = [] +referenceByteStringTokenizer pat str + = (h `BS.append` BS.take (BS.length pat) t) + : if BS.null t then [] else referenceByteStringTokenizer pat (BS.drop (BS.length pat) t) + where (h,t) = BS.breakSubstring pat str + diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,3 +1,9 @@ +0.0.1.0 +------- + +- Pipes.Split.ByteString splits a bytestring based on a given pattern (example + usage in tests/properties.hs) + 0.0.0.2 ------- diff --git a/tests/properties.hs b/tests/properties.hs --- a/tests/properties.hs +++ b/tests/properties.hs @@ -1,19 +1,30 @@ module Main where -import Data.List as L -import Data.Map.Strict as M -import Data.Tuple (swap) -import Data.Vector as V -import Debug.Trace -import Test.QuickCheck -import Test.Tasty -import Test.Tasty.QuickCheck as QC -import Test.Tasty.TH +import Control.Lens +import Control.Monad.Identity +import Data.ByteString (ByteString) +import Data.List as L +import Data.Map.Strict as M +import Data.Tuple (swap) +import Data.Vector as V +import Debug.Trace +import qualified Data.ByteString.Char8 as BS +import qualified Data.ByteString.Lazy as BSL +import qualified Pipes as P +import qualified Pipes.ByteString as PB +import qualified Pipes.Parse as PP +import qualified Pipes.Prelude as P +import Test.QuickCheck +import Test.QuickCheck.Instances +import Test.Tasty +import Test.Tasty.QuickCheck as QC +import Test.Tasty.TH -import Data.Paired.Vector as DPV -import Data.Paired.Foldable as DPF -import Math.TriangularNumbers +import Data.Paired.Foldable as DPF +import Data.Paired.Vector as DPV +import Math.TriangularNumbers +import Pipes.Split.ByteString @@ -138,6 +149,64 @@ | (k,(i,j)) <- ls ] -- + +-- | Check if both splitKeepEnd and simple tokenization provide the same +-- result. + +prop_splitKeepEndStrict :: String -> Small Int -> Small Int -> Bool +prop_splitKeepEndStrict str' (Small k) (Small l) + | tt == ss = True + | otherwise = traceShow ("ske",pat,str,k,l,tt,ss,ee) False + where str = BS.concat . L.replicate skeMult $ BS.pack str' + -- make a small pattern with a chance that it repeats + pat = BS.take (l `mod` 2 + 1) $ BS.drop (k `mod` 10) str + -- what ske thinks is a good split + (ss,ee,_) = ske pat str + -- manual splitting + tt = referenceByteStringTokenizer pat str + +-- | Check if both splitKeepEnd and simple tokenization provide the same +-- result. + +prop_splitKeepEndLazy :: String -> Small Int -> Small Int -> Bool +prop_splitKeepEndLazy str' (Small k) (Small l) + | tt == ll = True + | otherwise = traceShow ("ske'",pat,str',str,strL,k,l,tt,ll,ee,rr) False + where str = BS.concat . L.replicate skeMult $ BS.pack str' + strL = BSL.fromChunks $ L.replicate skeMult $ BS.pack str' + -- make a small pattern with a chance that it repeats + pat = BS.take (l `mod` 2 + 1) $ BS.drop (k `mod` 10) str + -- what we get with the lazy version + (ll,ee,rr) = ske' pat strL + -- manual splitting + tt = referenceByteStringTokenizer pat str + +-- The actual splitting system + +ske :: ByteString -> ByteString -> ([ByteString],[ByteString],[ByteString]) +ske pat str | BS.null pat || BS.null str = ([],[],[]) +ske pat str = + let parse = do + xs <- zoom (splitKeepEnd pat) PP.drawAll + case xs of + [] -> return $ Left [] + xs -> return $ Right $ BS.concat xs + (a,(b,p)) = runIdentity . P.toListM' $ PP.parsed parse $ PP.yield str + in (a,b, fst . runIdentity . P.toListM' $ p) + +ske' :: ByteString -> BSL.ByteString -> ([ByteString],[ByteString],[ByteString]) +ske' pat _ | BS.null pat = ([],[],[]) +ske' pat str = + let parse = do + xs <- zoom (splitKeepEnd pat) PP.drawAll + case xs of + [] -> return $ Left [] + xs -> return $ Right $ BS.concat xs + (a,(b,p)) = runIdentity . P.toListM' $ PP.parsed parse $ PB.fromLazy str + in (a,b, fst . runIdentity . P.toListM' $ p) + +skeMult :: Int +skeMult = 1000 main :: IO () main = $(defaultMainGenerator)