diff --git a/DP/Backtraced/Core.hs b/DP/Backtraced/Core.hs new file mode 100644 --- /dev/null +++ b/DP/Backtraced/Core.hs @@ -0,0 +1,78 @@ + +-- | The base constructors for generic backtracing. +-- +-- NOTE this currently can capture dot-bracket notation, but not deep +-- semantics. + +module DP.Backtraced.Core where + +import Control.Lens +import Data.Foldable +import GHC.Generics (Generic) +import qualified Data.Sequence as Seq +import qualified Test.QuickCheck as QC +import qualified Test.SmallCheck.Series as SC + +-- | This is a bit like a lazy "Data.Sequence" in terms of constructors. We can +-- not be spine-strict, otherwise we'd use @Data.Sequence@ and enjoy the better +-- performance. + +data Backtraced ty where + -- | This backtrace is done + Epsilon ∷ Backtraced ty + -- | Expand a backtrace to the left. This is lazy, since backtracing relies + -- on laziness. + Cons ∷ ty → Backtraced ty → Backtraced ty + -- | Expand lazily to the right. + Snoc ∷ Backtraced ty → ty → Backtraced ty + -- | concatenate two structures + Append ∷ Backtraced ty → Backtraced ty → Backtraced ty + deriving (Eq,Ord,Show,Read,Generic,Functor,Foldable,Traversable) + +-- | This is somewhat tricky, since we might have to walk down the structure +-- quite a bit and shuffle constructors without changing the actual leaf order. + +instance Cons (Backtraced ty) (Backtraced ty') ty ty' where + {-# Inlinable _Cons #-} + _Cons = + let go1 Epsilon = Left Epsilon + go1 (Cons x xs) = Right (x,xs) + go1 (Snoc xs x) = go2 xs (Left x) + go1 (Append xs ys) = go2 xs (Right ys) + go2 Epsilon (Left y) = Right (y,Epsilon) + go2 Epsilon (Right ys) = go1 ys + go2 (Cons x xs) (Left y) = Right (x,Snoc xs y) + go2 (Cons x xs) (Right ys) = Right (x, Append xs ys) + go2 (Snoc xs x) (Left y) = go2 xs (Right $ x `Cons` Epsilon `Snoc` y) + go2 (Snoc xs x) (Right ys) = go2 xs (Right $ x `Cons` ys) + go2 (Append xs ys) (Left z) = go2 xs (Right $ ys `Snoc` z) + go2 (Append xs ys) (Right zs) = go2 xs (Right $ ys `Append` zs) + in prism (uncurry Cons) go1 + +instance Snoc (Backtraced ty) (Backtraced ty') ty ty' where + {-# Inlinable _Snoc #-} + _Snoc = + let go1 Epsilon = Left Epsilon + go1 (Cons x xs) = go2 (Left x) xs + go1 (Snoc xs x) = Right (xs,x) + go1 (Append xs ys) = go2 (Right xs) ys + go2 (Left x) Epsilon = Right (Epsilon,x) + go2 (Right xs) Epsilon = go1 xs + go2 (Left x) (Cons y ys) = go2 (Right $ x `Cons` (y `Cons` Epsilon)) ys + go2 (Right xs) (Cons y ys) = go2 (Right $ xs `Snoc` y) ys + go2 (Left x) (Snoc ys y) = Right (x `Cons` ys, y) + go2 (Right xs) (Snoc ys y) = Right (xs `Append` ys, y) + go2 (Left x) (Append ys zs) = go2 (Right $ x `Cons` ys) zs + go2 (Right xs) (Append ys zs) = go2 (Right $ xs `Append` ys) zs + in prism (uncurry Snoc) go1 + +(<|) = Cons +(|>) = Snoc +(><) = Append + +infixr 5 <| +infixr 5 >< +infixl 5 |> + +instance SC.Serial m a ⇒ SC.Serial m (Backtraced a) + diff --git a/DPutils.cabal b/DPutils.cabal --- a/DPutils.cabal +++ b/DPutils.cabal @@ -1,20 +1,21 @@ +Cabal-version: 2.2 Name: DPutils -Version: 0.0.2.0 -License: BSD3 +Version: 0.1.0.0 +License: BSD-3-Clause License-file: LICENSE Maintainer: choener@bioinf.uni-leipzig.de -author: Christian Hoener zu Siederdissen, 2016-2018 -copyright: Christian Hoener zu Siederdissen, 2016-2018 +author: Christian Hoener zu Siederdissen, 2016-2019 +copyright: Christian Hoener zu Siederdissen, 2016-2019 homepage: https://github.com/choener/DPutils bug-reports: https://github.com/choener/DPutils/issues Stability: Experimental Category: Data Build-type: Simple -Cabal-version: >=1.10.0 tested-with: GHC == 8.4.4 Synopsis: utilities for DP Description: - Small set of utility functions + Small set of utility functions, as well as the base types for + generic backtracing. . @@ -25,37 +26,48 @@ -Library - Exposed-modules: - Data.Attoparsec.ByteString.Streaming - Data.ByteString.Streaming.Split - Data.Char.Util - Data.Paired.Common - Data.Paired.Foldable - Data.Paired.Vector - Data.Vector.Generic.Unstream - Math.TriangularNumbers - Pipes.Parallel - Pipes.Split.ByteString +common deps build-depends: base >= 4.7 && < 5.0 , attoparsec >= 0.13 , bytestring , containers + , criterion >= 1.1 , kan-extensions >= 4.0 + , lens >= 4.0 + , mtl , parallel >= 3.0 , pipes >= 4.0 + , pipes-bytestring >= 2.0 + , pipes-parse >= 3.0 + , primitive >= 0.6 , QuickCheck >= 2.7 , streaming >= 0.1 , streaming-bytestring >= 0.1 , stringsearch >= 0.3 + , smallcheck >= 1.1 + , tasty >= 0.11 + , tasty-quickcheck >= 0.8 + , tasty-smallcheck >= 0.8 + , tasty-th >= 0.1 , transformers >= 0.5 , vector >= 0.10 default-extensions: BangPatterns , CPP + , DeriveGeneric + , DeriveFunctor + , DeriveFoldable + , DeriveTraversable , FlexibleContexts + , FlexibleInstances + , GADTs + , LambdaCase + , MultiParamTypeClasses , RankNTypes , ScopedTypeVariables + , TemplateHaskell + , TypeApplications , TypeFamilies + , UndecidableInstances , UnicodeSyntax default-language: Haskell2010 @@ -64,81 +76,61 @@ -funbox-strict-fields +Library + import: deps + Exposed-modules: + Data.Attoparsec.ByteString.Streaming + Data.ByteString.Streaming.Split + Data.Char.Util + Data.Paired.Common + Data.Paired.Foldable + Data.Paired.Vector + Data.Vector.Generic.Unstream + DP.Backtraced.Core + Math.TriangularNumbers + Pipes.Parallel + Pipes.Split.ByteString + Streaming.Primitive + + test-suite properties + import: + deps + build-depends: + DPutils type: exitcode-stdio-1.0 main-is: properties.hs + other-modules: + QuickCheck + SmallCheck ghc-options: - -O2 -threaded -rtsopts -with-rtsopts=-N + -threaded -rtsopts -with-rtsopts=-N hs-source-dirs: tests - default-language: - Haskell2010 - default-extensions: CPP - , RankNTypes - , ScopedTypeVariables - , TemplateHaskell - build-depends: base - , bytestring - , containers - , lens >= 4.0 - , mtl - , pipes - , pipes-bytestring >= 2.0 - , pipes-parse >= 3.0 - , QuickCheck - , streaming - , streaming-bytestring - , tasty >= 0.11 - , tasty-quickcheck >= 0.8 - , tasty-th >= 0.1 - , vector - -- - , DPutils benchmark benchmark + import: deps type: exitcode-stdio-1.0 - build-depends: base - , criterion >= 1.1 - , streaming - , streaming-bytestring - , vector - -- - , DPutils hs-source-dirs: tests main-is: benchmark.hs - default-language: - Haskell2010 - ghc-options: - -O2 benchmark streaming + import: deps type: exitcode-stdio-1.0 - build-depends: base - , streaming - , streaming-bytestring - , bytestring - , timeit >= 2.0 - -- - , DPutils + build-depends: timeit >= 2.0 hs-source-dirs: tests - default-extensions: BangPatterns - , CPP - , RankNTypes - , ScopedTypeVariables - , TemplateHaskell - , UnicodeSyntax main-is: streaming.hs default-language: diff --git a/Streaming/Primitive.hs b/Streaming/Primitive.hs new file mode 100644 --- /dev/null +++ b/Streaming/Primitive.hs @@ -0,0 +1,16 @@ + +module Streaming.Primitive where + +import Control.Monad.Primitive +import Streaming + + + +-- | Orphan instance providing a primitive monad instance for streams. Allows +-- impurely folds into mutable vectors from streams. + +instance (Monad m, PrimMonad m, Functor f) ⇒ PrimMonad (Stream f m) where + type PrimState (Stream f m) = PrimState m + {-# Inline primitive #-} + primitive = lift . primitive + diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,3 +1,9 @@ +0.1.0.0 +------- + +- DP.Backtraced.Core provide a "core" system for backtraces in DP algorithms, + splitting out individual tapes + 0.0.2.0 ------- diff --git a/tests/QuickCheck.hs b/tests/QuickCheck.hs new file mode 100644 --- /dev/null +++ b/tests/QuickCheck.hs @@ -0,0 +1,203 @@ + +module QuickCheck 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.QuickCheck as QC +import Test.Tasty.TH + +import Data.Paired.Foldable as DPF +import Data.Paired.Vector as DPV +import Math.TriangularNumbers + +-- * Data.Paired.Vector + +-- | + +prop_vector_upperTri_On :: NonNegative Int -> Bool +prop_vector_upperTri_On (NonNegative k) = V.toList vs == ls + where vs = snd $ upperTriVG OnDiag v + ls = [ (a,b) + | as@(a:_) <- L.init . L.tails $ V.toList v + , b <- as + ] + v = V.enumFromTo 0 k + +-- | + +prop_vector_upperTri_No :: NonNegative Int -> Bool +prop_vector_upperTri_No (NonNegative k) = V.toList vs == ls + where vs = snd $ upperTriVG NoDiag v + ls = [ (a,b) + | (a:as) <- L.init . L.tails $ V.toList v + , b <- as + ] + v = V.enumFromTo 0 k + +-- | + +prop_vector_rectangular :: NonNegative Int -> NonNegative Int -> Bool +prop_vector_rectangular (NonNegative k) (NonNegative l) = V.toList vs == ls + where vs = snd $ rectangularVG as bs + ls = [ (a,b) + | a <- V.toList as + , b <- V.toList bs + ] + as = V.enumFromTo 0 k + bs = V.enumFromTo 0 l + + + +-- * Data.Paired.Foldable + +-- | Generalized upper triangular elements. We want to enumerate all +-- elements, including those on the main diagonal. + +prop_foldable_upperTri_On_All :: (NonNegative Int, Bool) -> Bool +prop_foldable_upperTri_On_All (NonNegative n, b) + | chk = True + | otherwise = traceShow (ls,vs) False + where Right (_,_,vs) = DPF.upperTri (if b then KnownSize n else UnknownSize) OnDiag All xs + ls = [ ((a,b),(a,b)) + | as@(a:_) <- L.init . L.tails $ xs + , b <- as + ] + xs = [ 0 .. n-1 ] + chk = vs == ls + +-- | Only a subset of elements, starting at @k@ (counting from 0) and +-- taking @s@ elements. + +prop_foldable_upperTri_On_FromN :: (NonNegative Int, NonNegative Int, NonNegative Int, Bool) -> Bool +prop_foldable_upperTri_On_FromN (NonNegative n, NonNegative k, NonNegative s, b) + | chk = True + | otherwise = traceShow (ls,vs) False + where Right (_,_,vs) = DPF.upperTri (if b then KnownSize n else UnknownSize) OnDiag (FromN k s) xs + ls = L.take s + . L.drop k + $ [ ((a,b),(a,b)) + | as@(a:_) <- L.init . L.tails $ xs + , b <- as + ] + xs = [ 0 .. n-1 ] + chk = vs == ls + +prop_foldable_upperTri_No_All :: (NonNegative Int, Bool) -> Bool +prop_foldable_upperTri_No_All (NonNegative n, b) + | chk = True + | otherwise = traceShow (ls,vs) False + where Right (_,_,vs) = DPF.upperTri (if b then KnownSize n else UnknownSize) NoDiag All xs + ls = [ ((a,b),(a,b)) + | (a:as) <- L.init . L.tails $ xs + , b <- as + ] + xs = [ 0 .. n-1 ] + chk = vs == ls + +prop_foldable_upperTri_No_FromN :: (NonNegative Int, NonNegative Int, NonNegative Int, Bool) -> Bool +prop_foldable_upperTri_No_FromN (NonNegative n, NonNegative k, NonNegative s, b) + | chk = True + | otherwise = traceShow (ls,vs) False + where Right (_,_,vs) = DPF.upperTri (if b then KnownSize n else UnknownSize) NoDiag (FromN k s) xs + ls = L.take s + . L.drop k + $ [ ((a,b),(a,b)) + | (a:as) <- L.init . L.tails $ xs + , b <- as + ] + xs = [ 0 .. n-1 ] + chk = vs == ls + + + +-- * Math.TriangularNumbers + +-- | Test that each index pair @(i,j)@ is assigned a unique linear index +-- @k@ given @0 <= i <= j <= n@. + +prop_uniqueLinear :: NonNegative Int -> Bool +prop_uniqueLinear (NonNegative n) = M.null $ M.filter ((/=1) . L.length) mp + where mp = M.fromListWith (L.++) [ (toLinear n (i,j), [(i,j)]) | i <- [0..n], j <- [i..n] ] + +-- | Back and forth translation between paired and linear indices is +-- unique. + +prop_BackForth :: NonNegative Int -> Bool +prop_BackForth (NonNegative n) = L.and xs + where mb = M.fromList ls + mf = M.fromList $ L.map swap ls + ls = [ (toLinear n (i,j), (i,j)) | i <- [0..n], j <- [i..n] ] + xs = [ (mb M.! k == (i,j)) && (mf M.! (i,j) == k) && fromLinear n k == (i,j) + | (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 + + + +-- * Streaming tests. + + +testQuickCheck = $(testGroupGenerator) + diff --git a/tests/SmallCheck.hs b/tests/SmallCheck.hs new file mode 100644 --- /dev/null +++ b/tests/SmallCheck.hs @@ -0,0 +1,31 @@ + +module SmallCheck where + +import Control.Arrow (second) +import Control.Lens +import Data.Foldable +import Debug.Trace +import Test.SmallCheck +import Test.SmallCheck.Drivers +import Test.Tasty.SmallCheck as SC +import Test.Tasty.TH + +import DP.Backtraced.Core + + + +-- prop_BackTraced_Cons +-- ∷ forall m +-- . ( Monad m ) +-- ⇒ Proxy a → Property m + +-- xprop_Backtraced_Cons ∷ Monad m ⇒ m (Maybe PropertyFailure) +prop_Backtraced_Cons = changeDepth (const 4) $ + {- smallCheckM 4 $ -} \(bt ∷ Backtraced Bool) → + let lst = toList bt + btC ∷ Maybe (Bool,[Bool]) + btC = fmap (second toList) $ bt^?_Cons +-- in traceShow (bt) $ traceShow (bt^?_Cons,lst^?_Cons) (btC == lst^?_Cons) -- bt^._Cons == lst^._Cons + in btC == lst^?_Cons + +testSmallCheck = $(testGroupGenerator) diff --git a/tests/properties.hs b/tests/properties.hs --- a/tests/properties.hs +++ b/tests/properties.hs @@ -1,217 +1,26 @@ module Main where -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 Control.Lens +--import Control.Monad.Identity +--import Data.ByteString (ByteString) +--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.Tasty -import Test.Tasty.QuickCheck as QC -import Test.Tasty.TH - -import Data.Paired.Foldable as DPF -import Data.Paired.Vector as DPV -import Math.TriangularNumbers -import Pipes.Split.ByteString - - - --- * Data.Paired.Vector - --- | - -prop_vector_upperTri_On :: NonNegative Int -> Bool -prop_vector_upperTri_On (NonNegative k) = V.toList vs == ls - where vs = snd $ upperTriVG OnDiag v - ls = [ (a,b) - | as@(a:_) <- L.init . L.tails $ V.toList v - , b <- as - ] - v = V.enumFromTo 0 k - --- | - -prop_vector_upperTri_No :: NonNegative Int -> Bool -prop_vector_upperTri_No (NonNegative k) = V.toList vs == ls - where vs = snd $ upperTriVG NoDiag v - ls = [ (a,b) - | (a:as) <- L.init . L.tails $ V.toList v - , b <- as - ] - v = V.enumFromTo 0 k - --- | - -prop_vector_rectangular :: NonNegative Int -> NonNegative Int -> Bool -prop_vector_rectangular (NonNegative k) (NonNegative l) = V.toList vs == ls - where vs = snd $ rectangularVG as bs - ls = [ (a,b) - | a <- V.toList as - , b <- V.toList bs - ] - as = V.enumFromTo 0 k - bs = V.enumFromTo 0 l - - - --- * Data.Paired.Foldable - --- | Generalized upper triangular elements. We want to enumerate all --- elements, including those on the main diagonal. - -prop_foldable_upperTri_On_All :: (NonNegative Int, Bool) -> Bool -prop_foldable_upperTri_On_All (NonNegative n, b) - | chk = True - | otherwise = traceShow (ls,vs) False - where Right (_,_,vs) = DPF.upperTri (if b then KnownSize n else UnknownSize) OnDiag All xs - ls = [ ((a,b),(a,b)) - | as@(a:_) <- L.init . L.tails $ xs - , b <- as - ] - xs = [ 0 .. n-1 ] - chk = vs == ls - --- | Only a subset of elements, starting at @k@ (counting from 0) and --- taking @s@ elements. - -prop_foldable_upperTri_On_FromN :: (NonNegative Int, NonNegative Int, NonNegative Int, Bool) -> Bool -prop_foldable_upperTri_On_FromN (NonNegative n, NonNegative k, NonNegative s, b) - | chk = True - | otherwise = traceShow (ls,vs) False - where Right (_,_,vs) = DPF.upperTri (if b then KnownSize n else UnknownSize) OnDiag (FromN k s) xs - ls = L.take s - . L.drop k - $ [ ((a,b),(a,b)) - | as@(a:_) <- L.init . L.tails $ xs - , b <- as - ] - xs = [ 0 .. n-1 ] - chk = vs == ls - -prop_foldable_upperTri_No_All :: (NonNegative Int, Bool) -> Bool -prop_foldable_upperTri_No_All (NonNegative n, b) - | chk = True - | otherwise = traceShow (ls,vs) False - where Right (_,_,vs) = DPF.upperTri (if b then KnownSize n else UnknownSize) NoDiag All xs - ls = [ ((a,b),(a,b)) - | (a:as) <- L.init . L.tails $ xs - , b <- as - ] - xs = [ 0 .. n-1 ] - chk = vs == ls - -prop_foldable_upperTri_No_FromN :: (NonNegative Int, NonNegative Int, NonNegative Int, Bool) -> Bool -prop_foldable_upperTri_No_FromN (NonNegative n, NonNegative k, NonNegative s, b) - | chk = True - | otherwise = traceShow (ls,vs) False - where Right (_,_,vs) = DPF.upperTri (if b then KnownSize n else UnknownSize) NoDiag (FromN k s) xs - ls = L.take s - . L.drop k - $ [ ((a,b),(a,b)) - | (a:as) <- L.init . L.tails $ xs - , b <- as - ] - xs = [ 0 .. n-1 ] - chk = vs == ls - - - --- * Math.TriangularNumbers - --- | Test that each index pair @(i,j)@ is assigned a unique linear index --- @k@ given @0 <= i <= j <= n@. - -prop_uniqueLinear :: NonNegative Int -> Bool -prop_uniqueLinear (NonNegative n) = M.null $ M.filter ((/=1) . L.length) mp - where mp = M.fromListWith (L.++) [ (toLinear n (i,j), [(i,j)]) | i <- [0..n], j <- [i..n] ] - --- | Back and forth translation between paired and linear indices is --- unique. - -prop_BackForth :: NonNegative Int -> Bool -prop_BackForth (NonNegative n) = L.and xs - where mb = M.fromList ls - mf = M.fromList $ L.map swap ls - ls = [ (toLinear n (i,j), (i,j)) | i <- [0..n], j <- [i..n] ] - xs = [ (mb M.! k == (i,j)) && (mf M.! (i,j) == k) && fromLinear n k == (i,j) - | (k,(i,j)) <- ls ] - +--import Test.Tasty.SmallCheck as SC -- - --- | 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) +--import Pipes.Split.ByteString -skeMult :: Int -skeMult = 1000 +import QuickCheck +import SmallCheck --- * Streaming tests. - - main :: IO () -main = $(defaultMainGenerator) +main = do + defaultMain $ testGroup "all tests" [testQuickCheck, testSmallCheck]