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.1.0 -License: BSD3 +Version: 0.1.1.0 +License: BSD-3-Clause License-file: LICENSE Maintainer: choener@bioinf.uni-leipzig.de -author: Christian Hoener zu Siederdissen, 2016 -copyright: Christian Hoener zu Siederdissen, 2016 +author: Christian Hoener zu Siederdissen, 2016-2021 +copyright: Christian Hoener zu Siederdissen, 2016-2021 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 == 7.8.4, GHC == 7.10.3, GHC == 8.0.1 +tested-with: GHC == 8.8, GHC == 8.10, GHC == 9.0 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,32 +26,44 @@ -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 +common deps + build-depends: base >= 4.7 && < 5.0 + , attoparsec >= 0.13 , bytestring , containers - , kan-extensions >= 4.0 - , parallel >= 3.0 - , pipes >= 4.0 - , QuickCheck >= 2.7 - , stringsearch >= 0.3 - , transformers >= 0.5 - , vector >= 0.10 + , 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 + , smallcheck >= 1.1 + , streaming >= 0.1 + , streaming-bytestring >= 0.1 + , stringsearch >= 0.3 + , transformers >= 0.5 + , vector >= 0.10 default-extensions: BangPatterns , CPP + , DeriveGeneric + , DeriveFunctor + , DeriveFoldable + , DeriveTraversable + , FlexibleContexts + , FlexibleInstances + , GADTs + , LambdaCase + , MultiParamTypeClasses , RankNTypes , ScopedTypeVariables + , TemplateHaskell + , TypeApplications , TypeFamilies - , FlexibleContexts + , UndecidableInstances + , UnicodeSyntax default-language: Haskell2010 ghc-options: @@ -58,59 +71,81 @@ -funbox-strict-fields +Library + import: deps + Exposed-modules: + Data.Attoparsec.ByteString.Streaming + Data.ByteString.Streaming.Split + Data.Char.Util + Data.Info + Data.Ord.Fast + 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 + hs-source-dirs: + lib + + test-suite properties + import: + deps + build-depends: base + , tasty >= 0.11 + , tasty-quickcheck >= 0.8 + , tasty-smallcheck >= 0.8 + , tasty-th >= 0.1 + -- + , 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 - , kan-extensions - , lens >= 4.0 - , mtl - , parallel - , pipes - , pipes-bytestring >= 2.0 - , pipes-parse >= 3.0 - , QuickCheck - , quickcheck-instances >= 0.3 - , tasty >= 0.11 - , tasty-quickcheck >= 0.8 - , tasty-th >= 0.1 - , vector - -- - , DPutils benchmark benchmark + import: deps + build-depends: base + , criterion >= 1.1 type: exitcode-stdio-1.0 - build-depends: base - , criterion >= 1.1 - , vector - -- - , DPutils + build-depends: + DPutils hs-source-dirs: tests main-is: benchmark.hs + + + +benchmark streaming + import: deps + type: + exitcode-stdio-1.0 + build-depends: DPutils + , timeit >= 2.0 + hs-source-dirs: + tests + main-is: + streaming.hs default-language: Haskell2010 ghc-options: - -O2 + -O2 -rtsopts "-with-rtsopts=-K10M -M10M" diff --git a/Data/Char/Util.hs b/Data/Char/Util.hs deleted file mode 100644 --- a/Data/Char/Util.hs +++ /dev/null @@ -1,16 +0,0 @@ - --- | 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/Paired/Common.hs b/Data/Paired/Common.hs deleted file mode 100644 --- a/Data/Paired/Common.hs +++ /dev/null @@ -1,29 +0,0 @@ - -module Data.Paired.Common where - - - --- | Shall we combine elements on the main diagonal as well? --- --- If we choose @NoDiag@, we deal with upper triangular matrices that are --- effectively one element smaller. - -data OnDiag = OnDiag | NoDiag - deriving (Eq) - --- | Select only a subset of the possible enumerations. - -data Enumerate - -- | Enumerate all elements - = All - -- | Enumerate from a value and at most @N@ elements - | FromN Int Int - deriving (Eq) - --- | If the size of the input is known before-hand or not. - -data SizeHint - = UnknownSize - | KnownSize Int - deriving (Eq) - diff --git a/Data/Paired/Foldable.hs b/Data/Paired/Foldable.hs deleted file mode 100644 --- a/Data/Paired/Foldable.hs +++ /dev/null @@ -1,121 +0,0 @@ - --- | Efficient enumeration of subsets of triangular elements. Given a list --- @[1..n]@ we want to enumerate a subset @[(i,j)]@ of ordered pairs in --- such a way that we only have to hold the elements necessary for this --- subset in memory. - -module Data.Paired.Foldable where - -import Data.IntMap as IM -import Data.Foldable as F -import Data.List as L -import Control.Arrow ((***)) -import Data.Vector as V -import Data.Vector.Generic as VG -import Debug.Trace (traceShow) -import Text.Printf - -import Data.Paired.Common -import Math.TriangularNumbers - - - --- | Generalized upper triangular elements. Given a list of elements --- @[e_1,...,e_k]@, we want to return pairs @(e_i,e_j)@ such that we have --- all ordered pairs with @i SizeHint - -- ^ If the size of @t a@ is known beforehand, give the appropriate - -- @KnownSize n@, otherwise give @UnknownSize@. Using @UnknownSize@ will - -- force the complete spine of @t a@. - -> OnDiag - -- ^ The enumeration will include the pairs on the main diagonal with - -- @OnDiag@, meaning @(i,i)@ will be included for all @i@. Otherwise, - -- @NoDiag@ will exclude these elements. - -> Enumerate - -- ^ Either enumerate @All@ elements or enumerate the @s@ elements - -- starting at @k@ with @FromN k s@. - -> t a - -- ^ The foldable data structure to enumerate over. - -> Either String (IntMap a, Int, [((Int,Int),(a,a))]) - -- ^ If there is any error then return @Left errorMsg@. Otherwise we have - -- @Right (imap, numElems, list)@. The @imap@ structure holds the subset - -- of elements with which we actually generate elements. @numElems@ is - -- the total number of elements that will be generated. This is - -- calculated without touch @list@. Finally, @list@ is the lazy list of - -- elements to be generated. -upperTri sz d e xs - | szLen /= readLen = Left $ printf "Expected SizeHint %d elements, but processed only %d elements!" szLen readLen - | otherwise = Right (imp, numElems, ys) - where ys = case e of {All -> id ; FromN _ s -> L.take s} - . L.unfoldr go $ initEnum e d - -- how many elements we will emit depends on enumeration and on - -- diagonal element counting - numElems - | All <- e = allSize - | FromN s k <- e = if s+k > allSize then max 0 (allSize - s) else k - -- The length of the input. With a given size hint, @xs :: t a@ - -- will only be touched once. -#if MIN_VERSION_base(4,8,0) - szLen = case sz of { UnknownSize -> F.length xs ; KnownSize z -> z } -#else - szLen = case sz of { UnknownSize -> L.length . F.toList $ xs ; KnownSize z -> z } -#endif - szLn' = case d of { OnDiag -> szLen - 1 ; NoDiag -> szLen - 2 } - -- Construct an intmap @imp@ of all elements in the accepted range. - -- At the same time, return the length or size of the foldable - -- container we gave as input. @xs@ is touched only once and can - -- be efficiently consumed. - (!imp,!readLen) = F.foldl' (\(!i,!l) x -> (if inRange l then IM.insert l x i else i,l+1)) (IM.empty, 0) xs - allSize = szLen * (szLen + if d == OnDiag then 1 else -1) `div` 2 - -- we need three ranges. @cMin@ and @cMax@ are the range for the - -- slow-moving first element in the tuple. @rMin@ and @rMax@ are - -- the first and last element of the range starting at @cMin@ (we - -- can actually start at @cMax@ but it doesn't matter). - -- Finally, @lMin@ and @lMax@ are the range to the left of @cMin@. - (lMin,lMax,cMin,cMax,rMin,rMax) = case e of - All -> (0, szLen-1, 0, szLen-1, 0, szLen-1) - FromN s k -> - let (cmin,rmin) = fromLinear szLn' s - (cmax,_ ) = fromLinear szLn' (s+k) - rmax = rmin+k -- if this is @>= len@ we are safe anyway. - lmin = if rmin+k >= szLen then 0 else cmin - lmax = if rmin+k >= szLen then lmin + toLinear szLn' (cmin+1,cmin+1+rmin+k-szLn') else cmax - in (lmin, lmax, cmin, cmax, rmin, rmax) - -- Determine if an element at linear index @z@ is in the range to - -- be consumed. - inRange z = lMin <= z && z <= lMax - || cMin <= z && z <= cMax - || rMin <= z && z <= rMax - -- index into the generated vector @xs@ when generating elements - -- via @go@ - go (k,l) - | k >= szLen = Nothing - | l >= szLen = go (k+1,k+1 + if d == OnDiag then 0 else 1) - | otherwise = Just (((k,l),(imp IM.! k, imp IM.! l)), (k,l+1)) - -- Initialize the enumeration at the correct pair @(i,j)@. From - -- then on we can @take@ the correct number of elements, or stream - -- all of them. - initEnum All OnDiag = (0,0) - initEnum All NoDiag = (0,1) - initEnum (FromN s k) OnDiag - | s >= allSize = (szLen,szLen) - | otherwise = fromLinear szLn' s - initEnum (FromN s k) NoDiag - | s >= allSize = (szLen,szLen) - | otherwise = id *** (+1) $ fromLinear szLn' s - diff --git a/Data/Paired/Vector.hs b/Data/Paired/Vector.hs deleted file mode 100644 --- a/Data/Paired/Vector.hs +++ /dev/null @@ -1,46 +0,0 @@ - -module Data.Paired.Vector - ( module Data.Paired.Vector - , module Data.Paired.Common - ) where - -import Data.Vector.Generic as VG - -import Data.Paired.Common - - - --- | Upper triangular elements. - -upperTriVG - :: (Vector v a, Vector w (a,a)) - => OnDiag - -> v a - -> (Int, w (a,a)) -upperTriVG d as = (z, unfoldrN z go (0,if d == OnDiag then 0 else 1)) - where la = VG.length as - z = la * (la + if d == OnDiag then 1 else 0) `div` 2 - go (k,l) - | k >= la = Nothing - | l >= la = go (k+1,k+1 + if d == OnDiag then 0 else 1) - | otherwise = Just ((as `VG.unsafeIndex` k, as `VG.unsafeIndex` l), (k,l+1)) -{-# Inline upperTriVG #-} - --- | Outer pairing of all @as@ with all @bs@. This one is quasi-trivial, --- but here for completeness. - -rectangularVG - :: (Vector va a, Vector vb b, Vector w (a,b)) - => va a - -> vb b - -> (Int, w (a,b)) -rectangularVG as bs = (z, unfoldrN z go (0,0)) - where la = VG.length as - lb = VG.length bs - z = la * lb - go (k,l) - | k >= la = Nothing - | l >= lb = go (k+1,0) - | otherwise = Just ((as `VG.unsafeIndex` k, bs `VG.unsafeIndex` l), (k,l+1)) -{-# Inline rectangularVG #-} - diff --git a/Data/Vector/Generic/Unstream.hs b/Data/Vector/Generic/Unstream.hs deleted file mode 100644 --- a/Data/Vector/Generic/Unstream.hs +++ /dev/null @@ -1,36 +0,0 @@ - --- | 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/Math/TriangularNumbers.hs b/Math/TriangularNumbers.hs deleted file mode 100644 --- a/Math/TriangularNumbers.hs +++ /dev/null @@ -1,78 +0,0 @@ - --- | Triangular numbers and various helper functions. --- --- Main use is for linearization of triangular array indexing. --- --- Triangular numbers: --- @ --- T_n = Σ_{k=1)^n k = 1 + 2 + 3 + ... + n = --- --- n * (n+1) / 2 = (n+1) `choose` 2 --- @ --- --- - -module Math.TriangularNumbers where - - - --- | Triangular numbers. --- --- https://oeis.org/A000217 - -triangularNumber :: Int -> Int -triangularNumber x = (x * (x+1)) `quot` 2 -{-# INLINE triangularNumber #-} - --- | Size of an upper triangle starting at 'i' and ending at 'j'. "(0,N)" what --- be the normal thing to use. - -linearizeUppertri :: (Int,Int) -> Int -linearizeUppertri (i,j) = triangularNumber $ j-i+1 -{-# INLINE linearizeUppertri #-} - --- | Subword indexing. Given the longest subword and the current subword, --- calculate a linear index "[0,..]". "(l,n)" in this case means "l"ower bound, --- length "n". And "(i,j)" is the normal index. --- --- @ --- 0 1 2 3 <- j = ... --- --- 0 1 2 3 i=0 --- _ 4 5 6 i=1 --- _ _ 7 8 i=2 --- 9 i=3 --- --- i=2, j=3 -> (4+1) * i - tri i + j --- --- _ --- _ _ the triangular number to subtract. --- @ - -toLinear :: Int -> (Int,Int) -> Int -toLinear n (i,j) = adr n (i,j) - where - adr n (i,j) = (n+1)*i - triangularNumber i + j - {-# Inline adr #-} -{-# INLINE toLinear #-} - - - --- | Linear index to paired. --- --- We have indices in @[0,N]@, and linear index @k@. --- --- @ --- (N+1)*i - (i*(i+1)/2) + j == K --- @ - -fromLinear :: Int -> Int -> (Int,Int) -fromLinear n' k' = (i,j) - where ll = (2*n+1) / 2 - rr = sqrt $ ((2*(n+1)+1) / 2)^2 - 2*k - n = fromIntegral n' - k = fromIntegral k' - i = floor $ ll - rr + 1 - j = k' - toLinear n' (i,0) -{-# Inline fromLinear #-} - diff --git a/Pipes/Parallel.hs b/Pipes/Parallel.hs deleted file mode 100644 --- a/Pipes/Parallel.hs +++ /dev/null @@ -1,60 +0,0 @@ - --- | Pipes that introduce parallelism on different levels. - -module Pipes.Parallel where - -import Control.Monad.Codensity (lowerCodensity) -import Control.Monad (replicateM) -import Control.Parallel.Strategies (Strategy, parMap) -import Pipes - - - --- | Evaluates chunks of pipes elements in parallel with a pure function. - -pipePar - :: (Monad m) - => Int - -- ^ number of elements to evaluate in parallel - -> Strategy b - -- ^ with which strategy - -> (a -> b) - -- ^ function to be mapped in parallel - -> Pipe a b m () -pipePar n strat f = pipeParBA n strat f (\as -> return ((),as)) (\() bs -> return bs) -{- - where - go = do - xs <- lowerCodensity . replicateM n $ lift await - let ys = parMap strat f xs - lowerCodensity $ mapM_ (lift . yield) ys - go --} - --- | Evaluates chunks of pipes elements in parallel with a pure function. --- Before and after each parallel step, a monadic function is run. This --- allows generation of certain statistics or information during runs. - -pipeParBA - :: (Monad m) - => Int - -- ^ number of elements to evaluate in parallel - -> Strategy b - -- ^ with which strategy - -> (a -> b) - -- ^ pure function to run in parallel - -> ([a] -> m (x,[a])) - -- ^ function to run before - -> (x -> [b] -> m [b]) - -- ^ function to run after - -> Pipe a b m () -pipeParBA n strat f bef aft = go - where - go = do - as' <- lowerCodensity . replicateM n $ lift await - (x,as) <- lift $ bef as' - let bs' = parMap strat f as - bs <- lift $ aft x bs' - lowerCodensity $ mapM_ (lift . yield) bs - go - diff --git a/Pipes/Split/ByteString.hs b/Pipes/Split/ByteString.hs deleted file mode 100644 --- a/Pipes/Split/ByteString.hs +++ /dev/null @@ -1,140 +0,0 @@ - --- | 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/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,4 +1,4 @@ -[![Build Status](https://travis-ci.org/choener/DPutils.svg?branch=master)](https://travis-ci.org/choener/DPutils) +![github action: master](https://github.com/choener/DPutils/actions/workflows/action.yml/badge.svg) # DPutils diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,3 +1,22 @@ +0.1.1.0 +------- + +- Data.Ord.Fast provides fast versions of min/max (until GHC catches up) +- Data.Info for "hand-written" Show-like instances to be used in an interactive environment. The + info might, for example, return the length, beginning, and end of a string. + +0.1.0.0 +------- + +- DP.Backtraced.Core provide a "core" system for backtraces in DP algorithms, + splitting out individual tapes + +0.0.2.0 +------- + +- Data.ByteString.Streaming.Split with generic splitting operations for the + bytestring-streaming library + 0.0.1.0 ------- diff --git a/lib/DP/Backtraced/Core.hs b/lib/DP/Backtraced/Core.hs new file mode 100644 --- /dev/null +++ b/lib/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/lib/Data/Attoparsec/ByteString/Streaming.hs b/lib/Data/Attoparsec/ByteString/Streaming.hs new file mode 100644 --- /dev/null +++ b/lib/Data/Attoparsec/ByteString/Streaming.hs @@ -0,0 +1,42 @@ + +-- | Taken from Michael Thompson + +module Data.Attoparsec.ByteString.Streaming where + +import qualified Data.Attoparsec.ByteString as A +import Data.ByteString.Streaming +import Data.ByteString.Streaming.Internal +import qualified Data.ByteString as B +import Streaming.Internal (Stream (..)) +import Streaming hiding (concats, unfold) + + + +type Message = ([String], String) + +-- | The parsed function from @streaming-utils@ + +parsed + :: Monad m + => A.Parser a -- ^ Attoparsec parser + -> ByteString m r -- ^ Raw input + -> Stream (Of a) m (Either (Message, ByteString m r) r) +parsed parser = begin + where + begin p0 = case p0 of -- inspect for null chunks before + Go m -> lift m >>= begin -- feeding attoparsec + Empty r -> Return (Right r) + Chunk bs p1 | B.null bs -> begin p1 + | otherwise -> step (chunk bs >>) (A.parse parser bs) p1 + step diffP res p0 = case res of + A.Fail _ c m -> Return (Left ((c,m), diffP p0)) + A.Done bs a | B.null bs -> Step (a :> begin p0) + | otherwise -> Step (a :> begin (chunk bs >> p0)) + A.Partial k -> do + x <- lift (nextChunk p0) + case x of + Left e -> step diffP (k mempty) (return e) + Right (bs,p1) | B.null bs -> step diffP res p1 + | otherwise -> step (diffP . (chunk bs >>)) (k bs) p1 +{-# INLINABLE parsed #-} + diff --git a/lib/Data/ByteString/Streaming/Split.hs b/lib/Data/ByteString/Streaming/Split.hs new file mode 100644 --- /dev/null +++ b/lib/Data/ByteString/Streaming/Split.hs @@ -0,0 +1,60 @@ + +-- | Splitting functions for @ByteString m r@ into @Stream (ByteString m) m r@. +-- +-- TODO These functions need quickcheck tests. + +module Data.ByteString.Streaming.Split where + +import Data.ByteString.Streaming.Char8 as S8 +import Data.ByteString.Streaming.Internal as SI +import Streaming.Internal (Stream(..)) + + + +-- | Split a @ByteString m r@ after every @k@ characters. +-- +-- Streams in constant memory. +-- +-- BUG: Once the stream is exhausted, it will still call @splitAt@, forever +-- creating empty @ByteString@s. + +splitsByteStringAt ∷ Monad m ⇒ Int → ByteString m r → Stream (ByteString m) m r +splitsByteStringAt !k = loop where + loop (Empty r) = return r + loop p = Step $ fmap loop $ S8.splitAt (fromIntegral k) p +{- -- this version would consume all memory + loop p = SI.Effect $ do + e ← nextChunk p + return $ case e of + Left r → SI.Return r + Right (a,p') → SI.Step (fmap loop (S8.splitAt (fromIntegral k) (chunk a >> p'))) + -} +{-# Inlinable splitsByteStringAt #-} + + + +-- | For lists, this would be @sbs (f :: [a] -> ([a],[a])) -> [a] -> [[a]]@. +-- Takes a function that splits the bytestring into two elements repeatedly, +-- where the first is followed by the repeated application of the function. +-- +-- cf. +-- +-- TODO these functions should go into a helper library + +separatesByteString + ∷ Monad m + ⇒ (ByteString m r → ByteString m (ByteString m r)) + → ByteString m r + → Stream (ByteString m) m r +separatesByteString f = loop where + loop (Empty r) = return r + loop p = Step $ fmap loop $ f p +{- + loop p = SI.Effect $ do + e ← nextChunk p + return $ case e of + Left r → SI.Return r + Right (a,p') → SI.Step (fmap loop (f (chunk a >> p'))) +-} +{-# Inlinable separatesByteString #-} + diff --git a/lib/Data/Char/Util.hs b/lib/Data/Char/Util.hs new file mode 100644 --- /dev/null +++ b/lib/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/lib/Data/Info.hs b/lib/Data/Info.hs new file mode 100644 --- /dev/null +++ b/lib/Data/Info.hs @@ -0,0 +1,24 @@ + +-- | Similar to @Show@, this module provides a string via @info@. This string gives convenient +-- user-information on objects. + +module Data.Info where + +import Data.List (concat,intersperse) +import qualified Data.Vector.Unboxed as VU + + + +class Info c where + -- | The string returned by 'info' should be around 60 chars per line, and one line if possible. + info :: c -> String + +instance (Info a, Info b, Info c) => Info (a,b,c) where + info (a,b,c) = concat $ intersperse " " [info a, info b, info c] + +instance (VU.Unbox a, Info a) => Info (VU.Vector a) where + info = concatMap info . VU.toList + +instance Info Int where + info = show + diff --git a/lib/Data/Ord/Fast.hs b/lib/Data/Ord/Fast.hs new file mode 100644 --- /dev/null +++ b/lib/Data/Ord/Fast.hs @@ -0,0 +1,46 @@ + +{-# Language MagicHash #-} +{-# Language ForeignFunctionInterface #-} +{-# Language UnliftedFFITypes #-} +{-# Language GHCForeignImportPrim #-} +{-# Language UnboxedTuples #-} +{-# Language CPP #-} + +-- | This module provides a small set of function for extremely fast @max@ and +-- @min@ operations that are branchless. +-- +-- This should be temporary, since GHC is supposed to get the branchless variants. +-- +-- NOTE these do not seem to be faster anyway. + +module Data.Ord.Fast where + +import GHC.Exts + + + +class FastMinMax x where + fastmin :: x -> x -> x + fastmax :: x -> x -> x + -- | Clamp values to @>=0@. + clamp :: x -> x + +instance FastMinMax Int where + fastmin (I# x) (I# y) = + let !xmy = x -# y + res = I# ( y +# ( xmy `andI#` uncheckedIShiftRA# xmy 63# ) ) + in res + {-# Inline fastmin #-} + fastmax (I# x) (I# y) = + let !xmy = x -# y + res = I# ( x -# ( xmy `andI#` uncheckedIShiftRA# xmy 63# ) ) + in res + -- FROM: https://ghc.gitlab.haskell.org/ghc/doc/libraries/ghc-bignum-1.0/src/GHC-Num-Primitives.html#maxI%23 + -- NOTE: slightly slower than the above version + --fastmax (I# x) (I# y) + -- | isTrue# (x >=# y) = I# x + -- | True = I# y + {-# Inline fastmax #-} + clamp (I# x) = I# (andI# x (notI# (uncheckedIShiftRA# x 63#))) + {-# Inline clamp #-} + diff --git a/lib/Data/Paired/Common.hs b/lib/Data/Paired/Common.hs new file mode 100644 --- /dev/null +++ b/lib/Data/Paired/Common.hs @@ -0,0 +1,29 @@ + +module Data.Paired.Common where + + + +-- | Shall we combine elements on the main diagonal as well? +-- +-- If we choose @NoDiag@, we deal with upper triangular matrices that are +-- effectively one element smaller. + +data OnDiag = OnDiag | NoDiag + deriving (Eq) + +-- | Select only a subset of the possible enumerations. + +data Enumerate + -- | Enumerate all elements + = All + -- | Enumerate from a value and at most @N@ elements + | FromN Int Int + deriving (Eq) + +-- | If the size of the input is known before-hand or not. + +data SizeHint + = UnknownSize + | KnownSize Int + deriving (Eq) + diff --git a/lib/Data/Paired/Foldable.hs b/lib/Data/Paired/Foldable.hs new file mode 100644 --- /dev/null +++ b/lib/Data/Paired/Foldable.hs @@ -0,0 +1,121 @@ + +-- | Efficient enumeration of subsets of triangular elements. Given a list +-- @[1..n]@ we want to enumerate a subset @[(i,j)]@ of ordered pairs in +-- such a way that we only have to hold the elements necessary for this +-- subset in memory. + +module Data.Paired.Foldable where + +import Data.IntMap as IM +import Data.Foldable as F +import Data.List as L +import Control.Arrow ((***)) +import Data.Vector as V +import Data.Vector.Generic as VG +import Debug.Trace (traceShow) +import Text.Printf + +import Data.Paired.Common +import Math.TriangularNumbers + + + +-- | Generalized upper triangular elements. Given a list of elements +-- @[e_1,...,e_k]@, we want to return pairs @(e_i,e_j)@ such that we have +-- all ordered pairs with @i SizeHint + -- ^ If the size of @t a@ is known beforehand, give the appropriate + -- @KnownSize n@, otherwise give @UnknownSize@. Using @UnknownSize@ will + -- force the complete spine of @t a@. + -> OnDiag + -- ^ The enumeration will include the pairs on the main diagonal with + -- @OnDiag@, meaning @(i,i)@ will be included for all @i@. Otherwise, + -- @NoDiag@ will exclude these elements. + -> Enumerate + -- ^ Either enumerate @All@ elements or enumerate the @s@ elements + -- starting at @k@ with @FromN k s@. + -> t a + -- ^ The foldable data structure to enumerate over. + -> Either String (IntMap a, Int, [((Int,Int),(a,a))]) + -- ^ If there is any error then return @Left errorMsg@. Otherwise we have + -- @Right (imap, numElems, list)@. The @imap@ structure holds the subset + -- of elements with which we actually generate elements. @numElems@ is + -- the total number of elements that will be generated. This is + -- calculated without touch @list@. Finally, @list@ is the lazy list of + -- elements to be generated. +upperTri sz d e xs + | szLen /= readLen = Left $ printf "Expected SizeHint %d elements, but processed only %d elements!" szLen readLen + | otherwise = Right (imp, numElems, ys) + where ys = case e of {All -> id ; FromN _ s -> L.take s} + . L.unfoldr go $ initEnum e d + -- how many elements we will emit depends on enumeration and on + -- diagonal element counting + numElems + | All <- e = allSize + | FromN s k <- e = if s+k > allSize then max 0 (allSize - s) else k + -- The length of the input. With a given size hint, @xs :: t a@ + -- will only be touched once. +#if MIN_VERSION_base(4,8,0) + szLen = case sz of { UnknownSize -> F.length xs ; KnownSize z -> z } +#else + szLen = case sz of { UnknownSize -> L.length . F.toList $ xs ; KnownSize z -> z } +#endif + szLn' = case d of { OnDiag -> szLen - 1 ; NoDiag -> szLen - 2 } + -- Construct an intmap @imp@ of all elements in the accepted range. + -- At the same time, return the length or size of the foldable + -- container we gave as input. @xs@ is touched only once and can + -- be efficiently consumed. + (!imp,!readLen) = F.foldl' (\(!i,!l) x -> (if inRange l then IM.insert l x i else i,l+1)) (IM.empty, 0) xs + allSize = szLen * (szLen + if d == OnDiag then 1 else -1) `div` 2 + -- we need three ranges. @cMin@ and @cMax@ are the range for the + -- slow-moving first element in the tuple. @rMin@ and @rMax@ are + -- the first and last element of the range starting at @cMin@ (we + -- can actually start at @cMax@ but it doesn't matter). + -- Finally, @lMin@ and @lMax@ are the range to the left of @cMin@. + (lMin,lMax,cMin,cMax,rMin,rMax) = case e of + All -> (0, szLen-1, 0, szLen-1, 0, szLen-1) + FromN s k -> + let (cmin,rmin) = fromLinear szLn' s + (cmax,_ ) = fromLinear szLn' (s+k) + rmax = rmin+k -- if this is @>= len@ we are safe anyway. + lmin = if rmin+k >= szLen then 0 else cmin + lmax = if rmin+k >= szLen then lmin + toLinear szLn' (cmin+1,cmin+1+rmin+k-szLn') else cmax + in (lmin, lmax, cmin, cmax, rmin, rmax) + -- Determine if an element at linear index @z@ is in the range to + -- be consumed. + inRange z = lMin <= z && z <= lMax + || cMin <= z && z <= cMax + || rMin <= z && z <= rMax + -- index into the generated vector @xs@ when generating elements + -- via @go@ + go (k,l) + | k >= szLen = Nothing + | l >= szLen = go (k+1,k+1 + if d == OnDiag then 0 else 1) + | otherwise = Just (((k,l),(imp IM.! k, imp IM.! l)), (k,l+1)) + -- Initialize the enumeration at the correct pair @(i,j)@. From + -- then on we can @take@ the correct number of elements, or stream + -- all of them. + initEnum All OnDiag = (0,0) + initEnum All NoDiag = (0,1) + initEnum (FromN s k) OnDiag + | s >= allSize = (szLen,szLen) + | otherwise = fromLinear szLn' s + initEnum (FromN s k) NoDiag + | s >= allSize = (szLen,szLen) + | otherwise = id *** (+1) $ fromLinear szLn' s + diff --git a/lib/Data/Paired/Vector.hs b/lib/Data/Paired/Vector.hs new file mode 100644 --- /dev/null +++ b/lib/Data/Paired/Vector.hs @@ -0,0 +1,46 @@ + +module Data.Paired.Vector + ( module Data.Paired.Vector + , module Data.Paired.Common + ) where + +import Data.Vector.Generic as VG + +import Data.Paired.Common + + + +-- | Upper triangular elements. + +upperTriVG + :: (Vector v a, Vector w (a,a)) + => OnDiag + -> v a + -> (Int, w (a,a)) +upperTriVG d as = (z, unfoldrN z go (0,if d == OnDiag then 0 else 1)) + where la = VG.length as + z = la * (la + if d == OnDiag then 1 else 0) `div` 2 + go (k,l) + | k >= la = Nothing + | l >= la = go (k+1,k+1 + if d == OnDiag then 0 else 1) + | otherwise = Just ((as `VG.unsafeIndex` k, as `VG.unsafeIndex` l), (k,l+1)) +{-# Inline upperTriVG #-} + +-- | Outer pairing of all @as@ with all @bs@. This one is quasi-trivial, +-- but here for completeness. + +rectangularVG + :: (Vector va a, Vector vb b, Vector w (a,b)) + => va a + -> vb b + -> (Int, w (a,b)) +rectangularVG as bs = (z, unfoldrN z go (0,0)) + where la = VG.length as + lb = VG.length bs + z = la * lb + go (k,l) + | k >= la = Nothing + | l >= lb = go (k+1,0) + | otherwise = Just ((as `VG.unsafeIndex` k, bs `VG.unsafeIndex` l), (k,l+1)) +{-# Inline rectangularVG #-} + diff --git a/lib/Data/Vector/Generic/Unstream.hs b/lib/Data/Vector/Generic/Unstream.hs new file mode 100644 --- /dev/null +++ b/lib/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/lib/Math/TriangularNumbers.hs b/lib/Math/TriangularNumbers.hs new file mode 100644 --- /dev/null +++ b/lib/Math/TriangularNumbers.hs @@ -0,0 +1,78 @@ + +-- | Triangular numbers and various helper functions. +-- +-- Main use is for linearization of triangular array indexing. +-- +-- Triangular numbers: +-- @ +-- T_n = Σ_{k=1)^n k = 1 + 2 + 3 + ... + n = +-- +-- n * (n+1) / 2 = (n+1) `choose` 2 +-- @ +-- +-- + +module Math.TriangularNumbers where + + + +-- | Triangular numbers. +-- +-- https://oeis.org/A000217 + +triangularNumber :: Int -> Int +triangularNumber x = (x * (x+1)) `quot` 2 +{-# INLINE triangularNumber #-} + +-- | Size of an upper triangle starting at 'i' and ending at 'j'. "(0,N)" what +-- be the normal thing to use. + +linearizeUppertri :: (Int,Int) -> Int +linearizeUppertri (i,j) = triangularNumber $ j-i+1 +{-# INLINE linearizeUppertri #-} + +-- | Subword indexing. Given the longest subword and the current subword, +-- calculate a linear index "[0,..]". "(l,n)" in this case means "l"ower bound, +-- length "n". And "(i,j)" is the normal index. +-- +-- @ +-- 0 1 2 3 <- j = ... +-- +-- 0 1 2 3 i=0 +-- _ 4 5 6 i=1 +-- _ _ 7 8 i=2 +-- 9 i=3 +-- +-- i=2, j=3 -> (4+1) * i - tri i + j +-- +-- _ +-- _ _ the triangular number to subtract. +-- @ + +toLinear :: Int -> (Int,Int) -> Int +toLinear n (i,j) = adr n (i,j) + where + adr n (i,j) = (n+1)*i - triangularNumber i + j + {-# Inline adr #-} +{-# INLINE toLinear #-} + + + +-- | Linear index to paired. +-- +-- We have indices in @[0,N]@, and linear index @k@. +-- +-- @ +-- (N+1)*i - (i*(i+1)/2) + j == K +-- @ + +fromLinear :: Int -> Int -> (Int,Int) +fromLinear n' k' = (i,j) + where ll = (2*n+1) / 2 + rr = sqrt $ ((2*(n+1)+1) / 2)^2 - 2*k + n = fromIntegral n' + k = fromIntegral k' + i = floor $ ll - rr + 1 + j = k' - toLinear n' (i,0) +{-# Inline fromLinear #-} + diff --git a/lib/Pipes/Parallel.hs b/lib/Pipes/Parallel.hs new file mode 100644 --- /dev/null +++ b/lib/Pipes/Parallel.hs @@ -0,0 +1,60 @@ + +-- | Pipes that introduce parallelism on different levels. + +module Pipes.Parallel where + +import Control.Monad.Codensity (lowerCodensity) +import Control.Monad (replicateM) +import Control.Parallel.Strategies (Strategy, parMap) +import Pipes + + + +-- | Evaluates chunks of pipes elements in parallel with a pure function. + +pipePar + :: (Monad m) + => Int + -- ^ number of elements to evaluate in parallel + -> Strategy b + -- ^ with which strategy + -> (a -> b) + -- ^ function to be mapped in parallel + -> Pipe a b m () +pipePar n strat f = pipeParBA n strat f (\as -> return ((),as)) (\() bs -> return bs) +{- + where + go = do + xs <- lowerCodensity . replicateM n $ lift await + let ys = parMap strat f xs + lowerCodensity $ mapM_ (lift . yield) ys + go +-} + +-- | Evaluates chunks of pipes elements in parallel with a pure function. +-- Before and after each parallel step, a monadic function is run. This +-- allows generation of certain statistics or information during runs. + +pipeParBA + :: (Monad m) + => Int + -- ^ number of elements to evaluate in parallel + -> Strategy b + -- ^ with which strategy + -> (a -> b) + -- ^ pure function to run in parallel + -> ([a] -> m (x,[a])) + -- ^ function to run before + -> (x -> [b] -> m [b]) + -- ^ function to run after + -> Pipe a b m () +pipeParBA n strat f bef aft = go + where + go = do + as' <- lowerCodensity . replicateM n $ lift await + (x,as) <- lift $ bef as' + let bs' = parMap strat f as + bs <- lift $ aft x bs' + lowerCodensity $ mapM_ (lift . yield) bs + go + diff --git a/lib/Pipes/Split/ByteString.hs b/lib/Pipes/Split/ByteString.hs new file mode 100644 --- /dev/null +++ b/lib/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/lib/Streaming/Primitive.hs b/lib/Streaming/Primitive.hs new file mode 100644 --- /dev/null +++ b/lib/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/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,213 +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 Test.QuickCheck.Instances +--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 -- +--import Pipes.Split.ByteString --- | Check if both splitKeepEnd and simple tokenization provide the same --- result. +import QuickCheck +import SmallCheck -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) +main = do + defaultMain $ testGroup "all tests" [testQuickCheck, testSmallCheck] diff --git a/tests/streaming.hs b/tests/streaming.hs new file mode 100644 --- /dev/null +++ b/tests/streaming.hs @@ -0,0 +1,55 @@ + +-- | Test the performance of splitting and consuming a *very long* bytestring +-- using @streaming@. + +module Main where + +import Data.Functor.Of +import qualified Data.ByteString.Char8 as BS8 +import qualified Data.ByteString.Lazy.Char8 as BSL8 +import qualified Data.ByteString.Streaming.Char8 as SB8 +import System.TimeIt +import Text.Printf + +import qualified Data.ByteString.Streaming.Split as SBS + + + +genLong + ∷ ( Monad m ) + ⇒ Int + → SB8.ByteString m () +genLong = SB8.fromLazy . BSL8.fromChunks . go + where + -- create chunks of strict char8 bytestring to concatenate. + go !k + | k <= 0 = [] + | otherwise = chunk : go (k-1) + -- the chunk to use for concatenation. + !chunk = BS8.pack $ ['A'..'Z'] ++ "\n" ++ ['a'..'z'] +{-# Inlinable genLong #-} + +-- | Generate long strings, split them after every 10 characters (which is +-- different from the chunk length), concatenate the resulting strings, and get +-- the total string length. +-- +-- This function should run in constant memory. + +longLength ∷ ( Monad m ) ⇒ Int → m (Of Int ()) +longLength = SB8.length . SB8.concat . SBS.splitsByteStringAt 10 . genLong + +otherLength ∷ ( Monad m ) ⇒ Int → m (Of Int ()) +otherLength = SB8.length . SB8.concat . SBS.separatesByteString (SB8.splitAt 10) . genLong + +benchmark ∷ (Int → IO (Of Int ())) → Int → Int → IO () +benchmark !f !k !l = do + (!seconds, !n :> ()) ← timeItT $ f l + printf "53 * 10^%2d = %10d characters in %9.6f seconds\n" k n seconds + +main = do + putStrLn "longLength" + mapM_ (uncurry (benchmark longLength)) [(k ∷ Int, 10^k) | k ← [0..7]] + putStrLn "otherLength" + mapM_ (uncurry (benchmark otherLength)) [(k ∷ Int, 10^k) | k ← [0..7]] + return () +