packages feed

stringsearch 0.3.3 → 0.3.4

raw patch · 8 files changed

+1123/−862 lines, 8 files

Files

CHANGES view
@@ -1,3 +1,6 @@+0.3.4:+- split implementation of Boyer-Moore between strict and lazy targets+- set spec-constr-count to 4 for ghc-7 0.3.3: - updated email address 0.3.2:
Data/ByteString/Lazy/Search.hs view
@@ -53,7 +53,7 @@                                   , strictify                                   ) where -import qualified Data.ByteString.Search.Internal.BoyerMoore as BM+import qualified Data.ByteString.Lazy.Search.Internal.BoyerMoore as BM import Data.ByteString.Search.Substitution import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L
+ Data/ByteString/Lazy/Search/Internal/BoyerMoore.hs view
@@ -0,0 +1,910 @@+{-# LANGUAGE BangPatterns #-}+{-# OPTIONS_HADDOCK hide, prune #-}+-- |+-- Module         : Data.ByteString.Lazy.Search.Internal.BoyerMoore+-- Copyright      : Daniel Fischer+--                  Chris Kuklewicz+-- Licence        : BSD3+-- Maintainer     : Daniel Fischer <daniel.is.fischer@googlemail.com>+-- Stability      : Provisional+-- Portability    : non-portable (BangPatterns)+--+-- Fast overlapping Boyer-Moore search of both strict and lazy+-- 'S.ByteString' values. Breaking, splitting and replacing+-- using the Boyer-Moore algorithm.+--+-- Descriptions of the algorithm can be found at+-- <http://www-igm.univ-mlv.fr/~lecroq/string/node14.html#SECTION00140>+-- and+-- <http://en.wikipedia.org/wiki/Boyer-Moore_string_search_algorithm>+--+-- Original authors: Daniel Fischer (daniel.is.fischer at googlemail.com) and+-- Chris Kuklewicz (haskell at list.mightyreason.com).++module Data.ByteString.Lazy.Search.Internal.BoyerMoore (+                                           matchLL+                                         , matchSL++                                           --  Non-overlapping+                                         , matchNOL++                                            --  Replacing substrings+                                            -- replacing+                                         , replaceAllL+                                            --  Breaking on substrings+                                            -- breaking+                                         , breakSubstringL+                                         , breakAfterL+                                         , breakFindAfterL+                                            --  Splitting on substrings+                                            -- splitting+                                         , splitKeepEndL+                                         , splitKeepFrontL+                                         , splitDropL+                                         ) where+++import Data.ByteString.Search.Internal.Utils+                (occurs, suffShifts, ldrop, lsplit, keep, release, strictify)+import Data.ByteString.Search.Substitution++import qualified Data.ByteString as S+import qualified Data.ByteString.Lazy as L+import Data.ByteString.Unsafe (unsafeIndex)++import Data.Array.Base (unsafeAt)++import Data.Word (Word8)+import Data.Int (Int64)++-- overview+--+-- This module exports three search functions for searching in lazy+-- ByteSrings, one for searching non-overlapping occurrences of a strict+-- pattern, and one each for searchin overlapping occurrences of a strict+-- resp. lazy pattern. The common base name is @match@, the suffix+-- indicates the type of search. These functions+-- return (for a non-empty pattern) a list of all the indices of the target+-- string where an occurrence of the pattern begins, if some occurrences+-- overlap, all starting indices are reported. The list is produced lazily,+-- so not necessarily the entire target string is searched.+--+-- The behaviour of these functions when given an empty pattern has changed.+-- Formerly, the @matchXY@ functions returned an empty list then, now it's+-- @[0 .. 'length' target]@.+--+-- Newly added are functions to replace all (non-overlapping) occurrences+-- of a pattern within a string, functions to break ByteStrings at the first+-- occurrence of a pattern and functions to split ByteStrings at each+-- occurrence of a pattern. None of these functions does copying, so they+-- don't introduce large memory overhead.+--+-- Internally, a lazy pattern is always converted to a strict ByteString,+-- which is necessary for an efficient implementation of the algorithm.+-- The limit this imposes on the length of the pattern is probably+-- irrelevant in practice, but perhaps it should be mentioned.+-- This also means that the @matchL*@ functions are mere convenience wrappers.+-- Except for the initial 'strictify'ing, there's no difference between lazy+-- and strict patterns, they call the same workers. There is, however, a+-- difference between strict and lazy target strings.+-- For the new functions, no such wrappers are provided, you have to+-- 'strictify' lazy patterns yourself.++-- caution+--+-- When working with a lazy target string, the relation between the pattern+-- length and the chunk size can play a big r&#244;le.+-- Crossing chunk boundaries is relatively expensive, so when that becomes+-- a frequent occurrence, as may happen when the pattern length is close+-- to or larger than the chunk size, performance is likely to degrade.+-- If it is needed, steps can be taken to ameliorate that effect, but unless+-- entirely separate functions are introduced, that would hurt the+-- performance for the more common case of patterns much shorter than+-- the default chunk size.++-- performance+--+-- In general, the Boyer-Moore algorithm is the most efficient method to+-- search for a pattern inside a string, so most of the time, you'll want+-- to use the functions of this module, hence this is where the most work+-- has gone. Very short patterns are an exception to this, for those you+-- should consider using a finite automaton+-- ("Data.ByteString.Search.DFA.Array"). That is also often the better+-- choice for searching longer periodic patterns in a lazy ByteString+-- with many matches.+--+-- Operating on a strict target string is mostly faster than on a lazy+-- target string, but the difference is usually small (according to my+-- tests).+--+-- The known exceptions to this rule of thumb are+--+-- [long targets] Then the smaller memory footprint of a lazy target often+-- gives (much) better performance.+--+-- [high number of matches] When there are very many matches, strict target+-- strings are much faster, especially if the pattern is periodic.+--+-- If both conditions hold, either may outweigh the other.++-- complexity+--+-- Preprocessing the pattern is /O/(@patternLength@ + &#963;) in time and+-- space (&#963; is the alphabet size, 256 here) for all functions.+-- The time complexity of the searching phase for @matchXY@+-- is /O/(@targetLength@ \/ @patternLength@) in the best case.+-- For non-periodic patterns, the worst case complexity is+-- /O/(@targetLength@), but for periodic patterns, the worst case complexity+-- is /O/(@targetLength@ * @patternLength@) for the original Boyer-Moore+-- algorithm.+--+-- The searching functions in this module now contain a modification which+-- drastically improves the performance for periodic patterns.+-- I believe that for strict target strings, the worst case is now+-- /O/(@targetLength@) also for periodic patterns and for lazy target strings,+-- my semi-educated guess is+-- /O/(@targetLength@ * (1 + @patternLength@ \/ @chunkSize@)).+-- I may be very wrong, though.+--+-- The other functions don't have to deal with possible overlapping+-- patterns, hence the worst case complexity for the processing phase+-- is /O/(@targetLength@) (respectively /O/(@firstIndex + patternLength@)+-- for the breaking functions if the pattern occurs).++-- currying+--+-- These functions can all be usefully curried. Given only a pattern+-- the curried version will compute the supporting lookup tables only+-- once, allowing for efficient re-use.  Similarly, the curried+-- 'matchLL' and 'matchLS' will compute the concatenated pattern only+-- once.++-- overflow+--+-- The current code uses @Int@ to keep track of the locations in the+-- target string.  If the length of the pattern plus the length of any+-- strict chunk of the target string is greater than+-- @'maxBound' :: 'Int'@ then this will overflow causing an error.  We+-- try to detect this and call 'error' before a segfault occurs.++------------------------------------------------------------------------------+--                                 Wrappers                                 --+------------------------------------------------------------------------------++-- matching+--+-- These functions find the indices of all (possibly overlapping)+-- occurrences of a pattern in a target string.+-- If the pattern is empty, the result is @[0 .. length target]@.+-- If the pattern is much shorter than the target string+-- and the pattern does not occur very near the beginning of the target,+--+-- > not . null $ matchSS pattern target+--+-- is a much more efficient version of 'S.isInfixOf'.++-- | @matchLL@ finds the starting indices of all possibly overlapping+--   occurrences of the pattern in the target string.+--   It is a simple wrapper for 'Data.ByteString.Lazy.Search.indices'.+--   If the pattern is empty, the result is @[0 .. 'length' target]@.+{-# INLINE matchLL #-}+matchLL :: L.ByteString     -- ^ Lazy pattern+        -> L.ByteString     -- ^ Lazy target string+        -> [Int64]          -- ^ Offsets of matches+matchLL pat = search . L.toChunks+  where+    search  = lazySearcher True (strictify pat)++-- | @matchSL@ finds the starting indices of all possibly overlapping+--   occurrences of the pattern in the target string.+--   It is an alias for 'Data.ByteString.Lazy.Search.indices'.+--   If the pattern is empty, the result is @[0 .. 'length' target]@.+{-# INLINE matchSL #-}+matchSL :: S.ByteString     -- ^ Strict pattern+        -> L.ByteString     -- ^ Lazy target string+        -> [Int64]          -- ^ Offsets of matches+matchSL pat = search . L.toChunks+  where+    search = lazySearcher True pat++-- | matchNOL finds the indices of all non-overlapping occurrences+--   of the pattern in the lazy target string.+{-# INLINE matchNOL #-}+matchNOL :: S.ByteString    -- ^ Strict pattern+         -> L.ByteString    -- ^ Lazy target string+         -> [Int64]         -- ^ Offsets of matches+matchNOL pat = search . L.toChunks+  where+    search = lazySearcher False pat++-- replacing+--+--   These functions replace all (non-overlapping) occurrences of a pattern+--   in the target string. If some occurrences overlap, the earliest is+--   replaced and replacing continues at the index after the replaced+--   occurrence, for example+--+-- > replaceAllL \"ana\" \"olog\" \"banana\" == \"bologna\",+-- > replaceAllS \"abacab\" \"u\" \"abacabacabacab\" == \"uacu\",+-- > replaceAllS \"aa\" \"aaa\" \"aaaa\" == \"aaaaaa\".+--+--   Equality of pattern and substitution is not checked, but+--+-- > pat == sub => 'strictify' (replaceAllS pat sub str) == str,+-- > pat == sub => replaceAllL pat sub str == str.+--+--   The result is a lazily generated lazy ByteString, the first chunks will+--   generally be available before the entire target has been scanned.+--   If the pattern is empty, but not the substitution, the result is+--   equivalent to @'cycle' sub@.++{-# INLINE replaceAllL #-}+replaceAllL :: Substitution rep+            => S.ByteString  -- ^ Pattern to replace+            -> rep           -- ^ Substitution string+            -> L.ByteString  -- ^ Target string+            -> L.ByteString  -- ^ Lazy result+replaceAllL pat+    | S.null pat = \sub -> prependCycle sub+    | S.length pat == 1 =+      let breaker = lazyBreak pat+          repl subst strs+              | null strs = []+              | otherwise =+                case breaker strs of+                  (pre, mtch) ->+                        pre ++ case mtch of+                                [] -> []+                                _  -> subst (repl subst (ldrop 1 mtch))+      in \sub -> let repl1 = repl (substitution sub)+                 in L.fromChunks . repl1 . L.toChunks+    | otherwise =+      let repl = lazyRepl pat+      in \sub -> let repl1 = repl (substitution sub)+                 in L.fromChunks . repl1 . L.toChunks++-- breaking+--+-- Break a string on a pattern. The first component of the result+-- contains the prefix of the string before the first occurrence of the+-- pattern, the second component contains the remainder.+-- The following relations hold:+--+-- > breakSubstringX \"\" str = (\"\", str)+-- > not (pat `isInfixOf` str) == null (snd $ breakSunbstringX pat str)+-- > True == case breakSubstringX pat str of+-- >          (x, y) -> not (pat `isInfixOf` x)+-- >                       && (null y || pat `isPrefixOf` y)++-- | The analogous function for a lazy target string.+--   The first component is generated lazily, so parts of it can be+--   available before the pattern is detected (or found to be absent).+{-# INLINE breakSubstringL #-}+breakSubstringL :: S.ByteString  -- ^ Pattern to break on+                -> L.ByteString  -- ^ String to break up+                -> (L.ByteString, L.ByteString)+                    -- ^ Prefix and remainder of broken string+breakSubstringL pat = breaker . L.toChunks+  where+    lbrk = lazyBreak pat+    breaker strs = let (f, b) = lbrk strs+                   in (L.fromChunks f, L.fromChunks b)++breakAfterL :: S.ByteString+            -> L.ByteString+            -> (L.ByteString, L.ByteString)+breakAfterL pat+  | S.null pat      = \str -> (L.empty, str)+breakAfterL pat     = breaker' . L.toChunks+  where+    !patLen = S.length pat+    breaker = lazyBreak pat+    breaker' strs =+      let (pre, mtch) = breaker strs+          (pl, a) = if null mtch then ([],[]) else lsplit patLen mtch+      in (L.fromChunks (pre ++ pl), L.fromChunks a)++breakFindAfterL :: S.ByteString+                -> L.ByteString+                -> ((L.ByteString, L.ByteString), Bool)+breakFindAfterL pat+  | S.null pat  = \str -> ((L.empty, str), True)+breakFindAfterL pat = breaker' . L.toChunks+  where+    !patLen = S.length pat+    breaker = lazyBreak pat+    breaker' strs =+      let (pre, mtch) = breaker strs+          (pl, a) = if null mtch then ([],[]) else lsplit patLen mtch+      in ((L.fromChunks (pre ++ pl), L.fromChunks a), not (null mtch))++-- splitting+--+-- These functions implement various splitting strategies.+--+-- If the pattern to split on is empty, all functions return an+-- infinite list of empty ByteStrings.+-- Otherwise, the names are rather self-explanatory.+--+-- For nonempty patterns, the following relations hold:+--+-- > concat (splitKeepXY pat str) == str+-- > concat ('Data.List.intersperse' pat (splitDropX pat str)) == str.+--+-- All fragments except possibly the last in the result of+-- @splitKeepEndX pat@ end with @pat@, none of the fragments contains+-- more than one occurrence of @pat@ or is empty.+--+-- All fragments except possibly the first in the result of+-- @splitKeepFrontX pat@ begin with @pat@, none of the fragments+-- contains more than one occurrence of @patq or is empty.+--+-- > splitDropX pat str == map dropPat (splitKeepFrontX pat str)+-- >   where+-- >     patLen = length pat+-- >     dropPat frag+-- >        | pat `isPrefixOf` frag = drop patLen frag+-- >        | otherwise             = frag+--+-- but @splitDropX@ is a little more efficient than that.++{-# INLINE splitKeepEndL #-}+splitKeepEndL :: S.ByteString    -- ^ Pattern to split on+              -> L.ByteString    -- ^ String to split+              -> [L.ByteString]  -- ^ List of fragments+splitKeepEndL pat+    | S.null pat    = const (repeat L.empty)+    | otherwise     =+      let splitter = lazySplitKeepEnd pat+      in  map L.fromChunks . splitter . L.toChunks++{-# INLINE splitKeepFrontL #-}+splitKeepFrontL :: S.ByteString    -- ^ Pattern to split on+                -> L.ByteString    -- ^ String to split+                -> [L.ByteString]  -- ^ List of fragments+splitKeepFrontL pat+    | S.null pat    = const (repeat L.empty)+    | otherwise     =+      let splitter = lazySplitKeepFront pat+      in  map L.fromChunks . splitter . L.toChunks+++{-# INLINE splitDropL #-}+splitDropL :: S.ByteString    -- ^ Pattern to split on+           -> L.ByteString    -- ^ String to split+           -> [L.ByteString]  -- ^ List of fragments+splitDropL pat+    | S.null pat    = const (repeat L.empty)+    | otherwise     =+      let splitter = lazySplitDrop pat+      in map L.fromChunks . splitter . L.toChunks++------------------------------------------------------------------------------+--                             Search Functions                             --+------------------------------------------------------------------------------++lazySearcher :: Bool -> S.ByteString -> [S.ByteString] -> [Int64]+lazySearcher _ !pat+    | S.null pat        =+      let zgo !prior [] = [prior]+          zgo prior (!str : rest) =+              let !l = S.length str+                  !prior' = prior + fromIntegral l+              in [prior + fromIntegral i | i <- [0 .. l-1]] ++ zgo prior' rest+      in zgo 0+    | S.length pat == 1 =+      let !w = S.head pat+          ixes = S.elemIndices w+          go _ [] = []+          go !prior (!str : rest)+            = let !prior' = prior + fromIntegral (S.length str)+              in map ((+ prior) . fromIntegral) (ixes str) ++ go prior' rest+      in go 0+lazySearcher !overlap pat = searcher+  where+    {-# INLINE patAt #-}+    patAt :: Int -> Word8+    patAt !i = unsafeIndex pat i++    !patLen = S.length pat+    !patEnd = patLen - 1+    {-# INLINE preEnd #-}+    preEnd  = patEnd - 1+    !maxLen = maxBound - patLen+    !occT   = occurs pat        -- for bad-character-shift+    !suffT  = suffShifts pat    -- for good-suffix-shift+    !skip   = if overlap then unsafeAt suffT 0 else patLen+    -- shift after a complete match+    !kept   = patLen - skip     -- length of known prefix after full match+    !pe     = patAt patEnd      -- last pattern byte for fast comparison++    {-# INLINE occ #-}+    occ !w = unsafeAt occT (fromIntegral w)++    {-# INLINE suff #-}+    suff !i = unsafeAt suffT i++    searcher lst = case lst of+                    []      -> []+                    (h : t) ->+                      if maxLen < S.length h+                        then error "Overflow in BoyerMoore.lazySearcher"+                        else seek 0 [] h t 0 patEnd++    -- seek is used to position the "zipper" of (past, str, future) to the+    -- correct S.ByteString to search. This is done by ensuring that+    -- 0 <= strPos < strLen, where strPos = diffPos + patPos.+    -- Note that future is not a strict parameter. The bytes being compared+    -- will then be (strAt strPos) and (patAt patPos).+    -- Splitting this into specialised versions is possible, but it would+    -- only be useful if the pattern length is close to (or larger than)+    -- the chunk size. For ordinary patterns of at most a few hundred bytes,+    -- the overhead of yet more code-paths and larger code size will probably+    -- outweigh the small gains in the relatively rare calls to seek.+    seek :: Int64 -> [S.ByteString] -> S.ByteString+            -> [S.ByteString] -> Int -> Int -> [Int64]+    seek !prior !past !str future !diffPos !patPos+        | strPos < 0 =  -- need to look at previous chunk+            case past of+                (h : t) ->+                    let !hLen = S.length h+                    in seek (prior - fromIntegral hLen) t h (str : future)+                                (diffPos + hLen) patPos+                []      -> error "seek back too far!"+        | strEnd < strPos =  -- need to look at next chunk if there is+            case future of+                (h : t) ->+                    let {-# INLINE prior' #-}+                        prior' = prior + fromIntegral strLen+                        !diffPos' = diffPos - strLen+                        {-# INLINE past' #-}+                        past' = release (-diffPos') (str : past)+                    in if maxLen < S.length h+                        then error "Overflow in BoyerMoore.lazySearcher"+                        else seek prior' past' h t diffPos' patPos+                []      -> []+        | patPos == patEnd  = checkEnd strPos+        | diffPos < 0       = matcherN diffPos patPos+        | otherwise         = matcherP diffPos patPos+          where+            !strPos  = diffPos + patPos+            !strLen  = S.length str+            !strEnd  = strLen - 1+            !maxDiff = strLen - patLen++            {-# INLINE strAt #-}+            strAt !i = unsafeIndex str i++            -- While comparing the last byte of the pattern, the bad-+            -- character-shift is always at least as large as the good-+            -- suffix-shift. Eliminating the unnecessary memory reads and+            -- comparison speeds things up noticeably.+            checkEnd !sI  -- index in string to compare to last of pattern+              | strEnd < sI = seek prior past str future (sI - patEnd) patEnd+              | otherwise   =+                case strAt sI of+                  !c | c == pe   ->+                       if sI < patEnd+                        then case sI of+                              0 -> seek prior past str future (-patEnd) preEnd+                              _ -> matcherN (sI - patEnd) preEnd+                        else matcherP (sI - patEnd) preEnd+                     | otherwise -> checkEnd (sI + patEnd + occ c)++            -- Once the last byte has matched, we enter the full matcher+            -- diff is the offset of the window, patI the index of the+            -- pattern byte to compare next.++            -- matcherN is the tight loop that walks backwards from the end+            -- of the pattern checking for matching bytes. The offset is+            -- always negative, so no complete match can occur here.+            -- When a byte matches, we need to check whether we've reached+            -- the front of this chunk, otherwise whether we need the next.+            matcherN !diff !patI =+              case strAt (diff + patI) of+                !c  | c == patAt patI   ->+                        if diff + patI == 0+                            then seek prior past str future diff (patI - 1)+                            else matcherN diff (patI - 1)+                    | otherwise         ->+                        let {-# INLINE badShift #-}+                            badShift = patI + occ c+                            {-# INLINE goodShift #-}+                            goodShift = suff patI+                            !diff' = diff + max badShift goodShift+                        in if maxDiff < diff'+                            then seek prior past str future diff' patEnd+                            else checkEnd (diff' + patEnd)++            -- matcherP is the tight loop for non-negative offsets.+            -- When the pattern is shifted, we must check whether we leave+            -- the current chunk, otherwise we only need to check for a+            -- complete match.+            matcherP !diff !patI =+              case strAt (diff + patI) of+                !c  | c == patAt patI   ->+                      if patI == 0+                        then prior + fromIntegral diff :+                              let !diff' = diff + skip+                              in if maxDiff < diff'+                                then seek prior past str future diff' patEnd+                                else+                                  if skip == patLen+                                    then+                                      checkEnd (diff' + patEnd)+                                    else+                                      afterMatch diff' patEnd+                        else matcherP diff (patI - 1)+                    | otherwise         ->+                        let {-# INLINE badShift #-}+                            badShift = patI + occ c+                            {-# INLINE goodShift #-}+                            goodShift = suff patI+                            !diff' = diff + max badShift goodShift+                        in if maxDiff < diff'+                            then seek prior past str future diff' patEnd+                            else checkEnd (diff' + patEnd)++            -- After a full match, we know how long a prefix of the pattern+            -- still matches. Do not re-compare the prefix to prevent O(m*n)+            -- behaviour for periodic patterns.+            -- This breaks down at chunk boundaries, but except for long+            -- patterns with a short period, that shouldn't matter much.+            afterMatch !diff !patI =+              case strAt (diff + patI) of+                !c  | c == patAt patI ->+                      if patI == kept+                        then prior + fromIntegral diff :+                            let !diff' = diff + skip+                            in if maxDiff < diff'+                                then seek prior past str future diff' patEnd+                                else afterMatch diff' patEnd+                        else afterMatch diff (patI - 1)+                    | patI == patEnd  ->+                        checkEnd (diff + (2*patEnd) + occ c)+                    | otherwise       ->+                        let {-# INLINE badShift #-}+                            badShift = patI + occ c+                            {-# INLINE goodShift #-}+                            goodShift = suff patI+                            !diff' = diff + max badShift goodShift+                        in if maxDiff < diff'+                            then seek prior past str future diff' patEnd+                            else checkEnd (diff' + patEnd)++------------------------------------------------------------------------------+--                            Breaking Functions                            --+------------------------------------------------------------------------------++-- Ugh! Code duplication ahead!+-- But we want to get the first component lazily, so it's no good to find+-- the first index (if any) and then split.+-- Therefore bite the bullet and copy most of the code of lazySearcher.+-- No need for afterMatch here, fortunately.+lazyBreak ::S.ByteString -> [S.ByteString] -> ([S.ByteString], [S.ByteString])+lazyBreak !pat+  | S.null pat  = \lst -> ([],lst)+  | S.length pat == 1 =+    let !w = S.head pat+        go [] = ([], [])+        go (!str : rest) =+            case S.elemIndices w str of+                []    -> let (pre, post) = go rest in (str : pre, post)+                (i:_) -> if i == 0+                            then ([], str : rest)+                            else ([S.take i str], S.drop i str : rest)+    in go+lazyBreak pat = breaker+  where+    !patLen = S.length pat+    !patEnd = patLen - 1+    !occT   = occurs pat+    !suffT  = suffShifts pat+    !maxLen = maxBound - patLen+    !pe     = patAt patEnd++    {-# INLINE patAt #-}+    patAt !i = unsafeIndex pat i++    {-# INLINE occ #-}+    occ !w = unsafeAt occT (fromIntegral w)++    {-# INLINE suff #-}+    suff !i = unsafeAt suffT i++    breaker lst =+      case lst of+        []    -> ([],[])+        (h:t) ->+          if maxLen < S.length h+            then error "Overflow in BoyerMoore.lazyBreak"+            else seek [] h t 0 patEnd++    seek :: [S.ByteString] -> S.ByteString -> [S.ByteString]+                -> Int -> Int -> ([S.ByteString], [S.ByteString])+    seek !past !str future !offset !patPos+      | strPos < 0 =+        case past of+          [] -> error "not enough past!"+          (h : t) -> seek t h (str : future) (offset + S.length h) patPos+      | strEnd < strPos =+        case future of+          []      -> (foldr (flip (.) . (:)) id past [str], [])+          (h : t) ->+            let !off' = offset - strLen+                (past', !discharge) = keep (-off') (str : past)+            in if maxLen < S.length h+                then error "Overflow in BoyerMoore.lazyBreak (future)"+                else let (pre,post) = seek past' h t off' patPos+                     in (foldr (flip (.) . (:)) id discharge pre, post)+      | patPos == patEnd = checkEnd strPos+      | offset < 0 = matcherN offset patPos+      | otherwise  = matcherP offset patPos+      where+        {-# INLINE strAt #-}+        strAt !i = unsafeIndex str i++        !strLen = S.length str+        !strEnd = strLen - 1+        !maxOff = strLen - patLen+        !strPos = offset + patPos++        checkEnd !sI+          | strEnd < sI = seek past str future (sI - patEnd) patEnd+          | otherwise   =+            case strAt sI of+              !c  | c == pe   ->+                    if sI < patEnd+                      then (if sI == 0+                              then seek past str future (-patEnd) (patEnd - 1)+                              else matcherN (sI - patEnd) (patEnd - 1))+                      else matcherP (sI - patEnd) (patEnd - 1)+                  | otherwise -> checkEnd (sI + patEnd + occ c)++        matcherN !off !patI =+          case strAt (off + patI) of+            !c  | c == patAt patI ->+                  if off + patI == 0+                    then seek past str future off (patI - 1)+                    else matcherN off (patI - 1)+                | otherwise ->+                    let !off' = off + max (suff patI) (patI + occ c)+                    in if maxOff < off'+                        then seek past str future off' patEnd+                        else checkEnd (off' + patEnd)++        matcherP !off !patI =+          case strAt (off + patI) of+            !c  | c == patAt patI ->+                  if patI == 0+                    then let !pre = if off == 0 then [] else [S.take off str]+                             !post = S.drop off str+                         in (foldr (flip (.) . (:)) id past pre, post:future)+                    else matcherP off (patI - 1)+                | otherwise ->+                    let !off' = off + max (suff patI) (patI + occ c)+                    in if maxOff < off'+                        then seek past str future off' patEnd+                        else checkEnd (off' + patEnd)+++------------------------------------------------------------------------------+--                            Splitting Functions                           --+------------------------------------------------------------------------------++-- non-empty pattern+lazySplitKeepFront :: S.ByteString -> [S.ByteString] -> [[S.ByteString]]+lazySplitKeepFront pat = splitter'+  where+    !patLen = S.length pat+    breaker = lazyBreak pat+    splitter' strs = case splitter strs of+                        ([]:rest) -> rest+                        other -> other+    splitter [] = []+    splitter strs =+      case breaker strs of+        (pre, mtch) ->+           pre : case mtch of+                    [] -> []+                    _  -> case lsplit patLen mtch of+                            (pt, rst) ->+                              if null rst+                                then [pt]+                                else let (h : t) = splitter rst+                                     in (pt ++ h) : t++-- non-empty pattern+lazySplitKeepEnd :: S.ByteString -> [S.ByteString] -> [[S.ByteString]]+lazySplitKeepEnd pat = splitter+  where+    !patLen = S.length pat+    breaker = lazyBreak pat+    splitter [] = []+    splitter strs =+      case breaker strs of+        (pre, mtch) ->+            let (h : t) = if null mtch+                            then [[]]+                            else case lsplit patLen mtch of+                                    (pt, rst) -> pt : splitter rst+            in (pre ++ h) : t++lazySplitDrop :: S.ByteString -> [S.ByteString] -> [[S.ByteString]]+lazySplitDrop pat = splitter+  where+    !patLen = S.length pat+    breaker = lazyBreak pat+    splitter [] = []+    splitter strs = splitter' strs+    splitter' [] = [[]]+    splitter' strs = case breaker strs of+                        (pre,mtch) ->+                            pre : case mtch of+                                    [] -> []+                                    _  -> splitter' (ldrop patLen mtch)++------------------------------------------------------------------------------+--                            Replacing Functions                           --+------------------------------------------------------------------------------++{-++These would be really nice.+Unfortunately they're too slow, so instead, there's another instance of+almost the same code as in lazySearcher below.++-- variant of below+lazyFRepl :: S.ByteString -> ([S.ByteString] -> [S.ByteString])+                -> [S.ByteString] -> [S.ByteString]+lazyFRepl pat = repl+  where+    !patLen = S.length pat+    breaker = lazyBreak pat+    repl sub = replacer+      where+        replacer [] = []+        replacer strs =+          let (pre, mtch) = breaker strs+          in pre ++ case mtch of+                      [] -> []+                      _  -> sub (replacer (ldrop patLen mtch))++-- This is nice and short. I really hope it's performing well!+lazyBRepl :: S.ByteString -> S.ByteString -> [S.ByteString] -> [S.ByteString]+lazyBRepl pat !sub = replacer+  where+    !patLen = S.length pat+    breaker = lazyBreak pat+    replacer [] = []+    replacer strs = let (pre, mtch) = breaker strs+                    in pre ++ case mtch of+                                [] -> []+                                _  -> sub : replacer (ldrop patLen mtch)+-}++-- Yet more code duplication.+--+-- Benchmark it against an implementation using lazyBreak and,+-- unless it's significantly faster, NUKE IT!!+--+-- Sigh, it is significantly faster. 10 - 25 %.+-- I could live with the 10, but 25 is too much.+--+-- Hmm, maybe an implementation via+-- replace pat sub = L.intercalate sub . split pat+-- would be competitive now.+-- TODO: test speed and space usage.+--+-- replacing loop for lazy ByteStrings as list of chunks,+-- called only for non-empty patterns+lazyRepl :: S.ByteString -> ([S.ByteString] -> [S.ByteString])+            -> [S.ByteString] -> [S.ByteString]+lazyRepl pat = replacer+ where+  !patLen = S.length pat+  !patEnd = patLen - 1+  !occT   = occurs pat+  !suffT  = suffShifts pat+  !maxLen = maxBound - patLen+  !pe     = patAt patEnd++  {-# INLINE patAt #-}+  patAt !i = unsafeIndex pat i++  {-# INLINE occ #-}+  occ !w = unsafeAt occT (fromIntegral w)++  {-# INLINE suff #-}+  suff !i = unsafeAt suffT i++  replacer sub lst =+      case lst of+        []    -> []+        (h:t) ->+          if maxLen < S.length h+            then error "Overflow in BoyerMoore.lazyRepl"+            else seek [] h t 0 patEnd+   where+        chop _ [] = []+        chop !k (!str : rest)+          | k < s     =+            if maxLen < (s - k)+                then error "Overflow in BoyerMoore.lazyRepl (chop)"+                else seek [] (S.drop k str) rest 0 patEnd+          | otherwise = chop (k-s) rest+            where+              !s = S.length str++        seek :: [S.ByteString] -> S.ByteString -> [S.ByteString]+                                    -> Int -> Int -> [S.ByteString]+        seek !past !str fut !offset !patPos+          | strPos < 0 =+            case past of+              [] -> error "not enough past!"+              (h : t) -> seek t h (str : fut) (offset + S.length h) patPos+          | strEnd < strPos =+            case fut of+              []      -> foldr (flip (.) . (:)) id past [str]+              (h : t) ->+                let !off' = offset - strLen+                    (past', !discharge) = keep (-off') (str : past)+                in if maxLen < S.length h+                    then error "Overflow in BoyerMoore.lazyRepl (future)"+                    else foldr (flip (.) . (:)) id discharge $+                                            seek past' h t off' patPos+          | patPos == patEnd = checkEnd strPos+          | offset < 0 = matcherN offset patPos+          | otherwise  = matcherP offset patPos+            where+              {-# INLINE strAt #-}+              strAt !i = unsafeIndex str i++              !strLen = S.length str+              !strEnd = strLen - 1+              !maxOff = strLen - patLen+              !strPos = offset + patPos++              checkEnd !sI+                | strEnd < sI = seek past str fut (sI - patEnd) patEnd+                | otherwise   =+                  case strAt sI of+                    !c  | c == pe   ->+                          if sI < patEnd+                            then (if sI == 0+                              then seek past str fut (-patEnd) (patEnd - 1)+                              else matcherN (sI - patEnd) (patEnd - 1))+                          else matcherP (sI - patEnd) (patEnd - 1)+                        | otherwise -> checkEnd (sI + patEnd + occ c)++              matcherN !off !patI =+                case strAt (off + patI) of+                  !c  | c == patAt patI ->+                        if off + patI == 0+                          then seek past str fut off (patI - 1)+                          else matcherN off (patI - 1)+                      | otherwise ->+                        let !off' = off + max (suff patI) (patI + occ c)+                        in if maxOff < off'+                            then seek past str fut off' patEnd+                            else checkEnd (off' + patEnd)++              matcherP !off !patI =+                case strAt (off + patI) of+                  !c  | c == patAt patI ->+                        if patI == 0+                          then foldr (flip (.) . (:)) id past $+                            let pre = if off == 0+                                        then id+                                        else (S.take off str :)+                            in pre . sub $+                                let !p = off + patLen+                                in if p < strLen+                                    then seek [] (S.drop p str) fut 0 patEnd+                                    else chop (p - strLen) fut+                        else matcherP off (patI - 1)+                      | otherwise ->+                        let !off' = off + max (suff patI) (patI + occ c)+                        in if maxOff < off'+                            then seek past str fut off' patEnd+                            else checkEnd (off' + patEnd)
Data/ByteString/Search.hs view
@@ -1,6 +1,6 @@ -- | -- Module         : Data.ByteString.Search--- Copyright      : Daniel Fischer+-- Copyright      : Daniel Fischer (2007-2011) --                  Chris Kuklewicz -- Licence        : BSD3 -- Maintainer     : Daniel Fischer <daniel.is.fischer@googlemail.com>
Data/ByteString/Search/BoyerMoore.hs view
@@ -54,7 +54,9 @@                                          ) where  import Data.ByteString.Search.Internal.BoyerMoore-            (matchLL, matchLS, matchSL, matchSS)+            (matchLS, matchSS)+import Data.ByteString.Lazy.Search.Internal.BoyerMoore+            (matchLL, matchSL)  -- $overview --
Data/ByteString/Search/Internal/BoyerMoore.hs view
@@ -22,39 +22,29 @@ -- Chris Kuklewicz (haskell at list.mightyreason.com).  module Data.ByteString.Search.Internal.BoyerMoore (-                                           matchLL-                                         , matchLS-                                         , matchSL+                                           matchLS                                          , matchSS                                             --  Non-overlapping-                                         , matchNOL                                          , matchNOS                                              --  Replacing substrings                                             -- replacing                                          , replaceAllS-                                         , replaceAllL                                             --  Breaking on substrings                                             -- breaking                                          , breakSubstringS                                          , breakAfterS-                                         , breakSubstringL-                                         , breakAfterL-                                         , breakFindAfterL                                             --  Splitting on substrings                                             -- splitting                                          , splitKeepEndS                                          , splitKeepFrontS                                          , splitDropS-                                         , splitKeepEndL-                                         , splitKeepFrontL-                                         , splitDropL                                          ) where   import Data.ByteString.Search.Internal.Utils-                (ldrop, lsplit, keep, release, strictify)+                (occurs, suffShifts, strictify) import Data.ByteString.Search.Substitution  import qualified Data.ByteString as S@@ -62,19 +52,17 @@ import qualified Data.ByteString.Lazy.Internal as LI import Data.ByteString.Unsafe (unsafeIndex) -import Data.Array.Base (unsafeRead, unsafeWrite, unsafeAt)-import Data.Array.ST-import Data.Array.Unboxed+import Data.Array.Base (unsafeAt)  import Data.Word (Word8)-import Data.Int (Int64)  -- overview ----- This module exports four search functions, one for each combination of--- strict and lazy ByteStrings as pattern and target. The common base name--- is @match@, the two-letter suffix indicates the types of the pattern--- (first letter of the suffix) and target (second letter). These functions+-- This module exports three search functions for searching in strict+-- ByteStrings. One for searching non-overlapping occurrences of a strict+-- pattern and one each for possibly overlapping occurrences of a lazy+-- resp. strict pattern. The common base name is @match@, the suffix+-- indicates the type of search to perform. These functions -- return (for a non-empty pattern) a list of all the indices of the target -- string where an occurrence of the pattern begins, if some occurrences -- overlap, all starting indices are reported. The list is produced lazily,@@ -194,18 +182,6 @@ -- -- is a much more efficient version of 'S.isInfixOf'. --- | @matchLL@ finds the starting indices of all possibly overlapping---   occurrences of the pattern in the target string.---   It is a simple wrapper for 'Data.ByteString.Lazy.Search.indices'.---   If the pattern is empty, the result is @[0 .. 'length' target]@.-{-# INLINE matchLL #-}-matchLL :: L.ByteString     -- ^ Lazy pattern-        -> L.ByteString     -- ^ Lazy target string-        -> [Int64]          -- ^ Offsets of matches-matchLL pat = search . L.toChunks-  where-    search  = lazySearcher True (strictify pat)- -- | @matchLS@ finds the starting indices of all possibly overlapping --   occurrences of the pattern in the target string. --   It is a simple wrapper for 'Data.ByteString.Search.indices'.@@ -218,18 +194,6 @@   where     search = strictSearcher True (strictify pat) --- | @matchSL@ finds the starting indices of all possibly overlapping---   occurrences of the pattern in the target string.---   It is an alias for 'Data.ByteString.Lazy.Search.indices'.---   If the pattern is empty, the result is @[0 .. 'length' target]@.-{-# INLINE matchSL #-}-matchSL :: S.ByteString     -- ^ Strict pattern-        -> L.ByteString     -- ^ Lazy target string-        -> [Int64]          -- ^ Offsets of matches-matchSL pat = search . L.toChunks-  where-    search = lazySearcher True pat- -- | @matchSS@ finds the starting indices of all possibly overlapping --   occurrences of the pattern in the target string. --   It is an alias for 'Data.ByteString.Search.indices'.@@ -242,16 +206,6 @@   where     search = strictSearcher True pat --- | matchNOL finds the indices of all non-overlapping occurrences---   of the pattern in the lazy target string.-{-# INLINE matchNOL #-}-matchNOL :: S.ByteString    -- ^ Strict pattern-         -> L.ByteString    -- ^ Lazy target string-         -> [Int64]         -- ^ Offsets of matches-matchNOL pat = search . L.toChunks-  where-    search = lazySearcher False pat- -- | matchNOS finds the indices of all non-overlapping occurrences --   of the pattern in the Strict target string. {-# INLINE matchNOS #-}@@ -295,31 +249,6 @@       let repl = strictRepl pat       in \sub -> L.fromChunks . repl (substitution sub) -{-# INLINE replaceAllL #-}-replaceAllL :: Substitution rep-            => S.ByteString  -- ^ Pattern to replace-            -> rep           -- ^ Substitution string-            -> L.ByteString  -- ^ Target string-            -> L.ByteString  -- ^ Lazy result-replaceAllL pat-    | S.null pat = \sub -> prependCycle sub-    | S.length pat == 1 =-      let breaker = lazyBreak pat-          repl subst strs-              | null strs = []-              | otherwise =-                case breaker strs of-                  (pre, mtch) ->-                        pre ++ case mtch of-                                [] -> []-                                _  -> subst (repl subst (ldrop 1 mtch))-      in \sub -> let repl1 = repl (substitution sub)-                 in L.fromChunks . repl1 . L.toChunks-    | otherwise =-      let repl = lazyRepl pat-      in \sub -> let repl1 = repl (substitution sub)-                 in L.fromChunks . repl1 . L.toChunks- -- breaking -- -- Break a string on a pattern. The first component of the result@@ -355,48 +284,6 @@                     []    -> (str, S.empty)                     (i:_) -> S.splitAt (i + patLen) str --- | The analogous function for a lazy target string.---   The first component is generated lazily, so parts of it can be---   available before the pattern is detected (or found to be absent).-{-# INLINE breakSubstringL #-}-breakSubstringL :: S.ByteString  -- ^ Pattern to break on-                -> L.ByteString  -- ^ String to break up-                -> (L.ByteString, L.ByteString)-                    -- ^ Prefix and remainder of broken string-breakSubstringL pat = breaker . L.toChunks-  where-    lbrk = lazyBreak pat-    breaker strs = let (f, b) = lbrk strs-                   in (L.fromChunks f, L.fromChunks b)--breakAfterL :: S.ByteString-            -> L.ByteString-            -> (L.ByteString, L.ByteString)-breakAfterL pat-  | S.null pat      = \str -> (L.empty, str)-breakAfterL pat     = breaker' . L.toChunks-  where-    !patLen = S.length pat-    breaker = lazyBreak pat-    breaker' strs =-      let (pre, mtch) = breaker strs-          (pl, a) = if null mtch then ([],[]) else lsplit patLen mtch-      in (L.fromChunks (pre ++ pl), L.fromChunks a)--breakFindAfterL :: S.ByteString-                -> L.ByteString-                -> ((L.ByteString, L.ByteString), Bool)-breakFindAfterL pat-  | S.null pat  = \str -> ((L.empty, str), True)-breakFindAfterL pat = breaker' . L.toChunks-  where-    !patLen = S.length pat-    breaker = lazyBreak pat-    breaker' strs =-      let (pre, mtch) = breaker strs-          (pl, a) = if null mtch then ([],[]) else lsplit patLen mtch-      in ((L.fromChunks (pre ++ pl), L.fromChunks a), not (null mtch))- -- splitting -- -- These functions implement various splitting strategies.@@ -446,37 +333,6 @@            -> [S.ByteString]  -- ^ List of fragments splitDropS = strictSplitDrop -{-# INLINE splitKeepEndL #-}-splitKeepEndL :: S.ByteString    -- ^ Pattern to split on-              -> L.ByteString    -- ^ String to split-              -> [L.ByteString]  -- ^ List of fragments-splitKeepEndL pat-    | S.null pat    = const (repeat L.empty)-    | otherwise     =-      let splitter = lazySplitKeepEnd pat-      in  map L.fromChunks . splitter . L.toChunks--{-# INLINE splitKeepFrontL #-}-splitKeepFrontL :: S.ByteString    -- ^ Pattern to split on-                -> L.ByteString    -- ^ String to split-                -> [L.ByteString]  -- ^ List of fragments-splitKeepFrontL pat-    | S.null pat    = const (repeat L.empty)-    | otherwise     =-      let splitter = lazySplitKeepFront pat-      in  map L.fromChunks . splitter . L.toChunks---{-# INLINE splitDropL #-}-splitDropL :: S.ByteString    -- ^ Pattern to split on-           -> L.ByteString    -- ^ String to split-           -> [L.ByteString]  -- ^ List of fragments-splitDropL pat-    | S.null pat    = const (repeat L.empty)-    | otherwise     =-      let splitter = lazySplitDrop pat-      in map L.fromChunks . splitter . L.toChunks- ------------------------------------------------------------------------------ --                             Search Functions                             -- ------------------------------------------------------------------------------@@ -578,196 +434,6 @@                                 then []                                 else checkEnd (diff' + patEnd) --lazySearcher :: Bool -> S.ByteString -> [S.ByteString] -> [Int64]-lazySearcher _ !pat-    | S.null pat        =-      let zgo !prior [] = [prior]-          zgo prior (!str : rest) =-              let !l = S.length str-                  !prior' = prior + fromIntegral l-              in [prior + fromIntegral i | i <- [0 .. l-1]] ++ zgo prior' rest-      in zgo 0-    | S.length pat == 1 =-      let !w = S.head pat-          ixes = S.elemIndices w-          go _ [] = []-          go !prior (!str : rest)-            = let !prior' = prior + fromIntegral (S.length str)-              in map ((+ prior) . fromIntegral) (ixes str) ++ go prior' rest-      in go 0-lazySearcher !overlap pat = searcher-  where-    {-# INLINE patAt #-}-    patAt :: Int -> Word8-    patAt !i = unsafeIndex pat i--    !patLen = S.length pat-    !patEnd = patLen - 1-    {-# INLINE preEnd #-}-    preEnd  = patEnd - 1-    !maxLen = maxBound - patLen-    !occT   = occurs pat        -- for bad-character-shift-    !suffT  = suffShifts pat    -- for good-suffix-shift-    !skip   = if overlap then unsafeAt suffT 0 else patLen-    -- shift after a complete match-    !kept   = patLen - skip     -- length of known prefix after full match-    !pe     = patAt patEnd      -- last pattern byte for fast comparison--    {-# INLINE occ #-}-    occ !w = unsafeAt occT (fromIntegral w)--    {-# INLINE suff #-}-    suff !i = unsafeAt suffT i--    searcher lst = case lst of-                    []      -> []-                    (h : t) ->-                      if maxLen < S.length h-                        then error "Overflow in BoyerMoore.lazySearcher"-                        else seek 0 [] h t 0 patEnd--    -- seek is used to position the "zipper" of (past, str, future) to the-    -- correct S.ByteString to search. This is done by ensuring that-    -- 0 <= strPos < strLen, where strPos = diffPos + patPos.-    -- Note that future is not a strict parameter. The bytes being compared-    -- will then be (strAt strPos) and (patAt patPos).-    -- Splitting this into specialised versions is possible, but it would-    -- only be useful if the pattern length is close to (or larger than)-    -- the chunk size. For ordinary patterns of at most a few hundred bytes,-    -- the overhead of yet more code-paths and larger code size will probably-    -- outweigh the small gains in the relatively rare calls to seek.-    seek :: Int64 -> [S.ByteString] -> S.ByteString-            -> [S.ByteString] -> Int -> Int -> [Int64]-    seek !prior !past !str future !diffPos !patPos-        | strPos < 0 =  -- need to look at previous chunk-            case past of-                (h : t) ->-                    let !hLen = S.length h-                    in seek (prior - fromIntegral hLen) t h (str : future)-                                (diffPos + hLen) patPos-                []      -> error "seek back too far!"-        | strEnd < strPos =  -- need to look at next chunk if there is-            case future of-                (h : t) ->-                    let {-# INLINE prior' #-}-                        prior' = prior + fromIntegral strLen-                        !diffPos' = diffPos - strLen-                        {-# INLINE past' #-}-                        past' = release (-diffPos') (str : past)-                    in if maxLen < S.length h-                        then error "Overflow in BoyerMoore.lazySearcher"-                        else seek prior' past' h t diffPos' patPos-                []      -> []-        | patPos == patEnd  = checkEnd strPos-        | diffPos < 0       = matcherN diffPos patPos-        | otherwise         = matcherP diffPos patPos-          where-            !strPos  = diffPos + patPos-            !strLen  = S.length str-            !strEnd  = strLen - 1-            !maxDiff = strLen - patLen--            {-# INLINE strAt #-}-            strAt !i = unsafeIndex str i--            -- While comparing the last byte of the pattern, the bad--            -- character-shift is always at least as large as the good--            -- suffix-shift. Eliminating the unnecessary memory reads and-            -- comparison speeds things up noticeably.-            checkEnd !sI  -- index in string to compare to last of pattern-              | strEnd < sI = seek prior past str future (sI - patEnd) patEnd-              | otherwise   =-                case strAt sI of-                  !c | c == pe   ->-                       if sI < patEnd-                        then case sI of-                              0 -> seek prior past str future (-patEnd) preEnd-                              _ -> matcherN (sI - patEnd) preEnd-                        else matcherP (sI - patEnd) preEnd-                     | otherwise -> checkEnd (sI + patEnd + occ c)--            -- Once the last byte has matched, we enter the full matcher-            -- diff is the offset of the window, patI the index of the-            -- pattern byte to compare next.--            -- matcherN is the tight loop that walks backwards from the end-            -- of the pattern checking for matching bytes. The offset is-            -- always negative, so no complete match can occur here.-            -- When a byte matches, we need to check whether we've reached-            -- the front of this chunk, otherwise whether we need the next.-            matcherN !diff !patI =-              case strAt (diff + patI) of-                !c  | c == patAt patI   ->-                        if diff + patI == 0-                            then seek prior past str future diff (patI - 1)-                            else matcherN diff (patI - 1)-                    | otherwise         ->-                        let {-# INLINE badShift #-}-                            badShift = patI + occ c-                            {-# INLINE goodShift #-}-                            goodShift = suff patI-                            !diff' = diff + max badShift goodShift-                        in if maxDiff < diff'-                            then seek prior past str future diff' patEnd-                            else checkEnd (diff' + patEnd)--            -- matcherP is the tight loop for non-negative offsets.-            -- When the pattern is shifted, we must check whether we leave-            -- the current chunk, otherwise we only need to check for a-            -- complete match.-            matcherP !diff !patI =-              case strAt (diff + patI) of-                !c  | c == patAt patI   ->-                      if patI == 0-                        then prior + fromIntegral diff :-                              let !diff' = diff + skip-                              in if maxDiff < diff'-                                then seek prior past str future diff' patEnd-                                else-                                  if skip == patLen-                                    then-                                      checkEnd (diff' + patEnd)-                                    else-                                      afterMatch diff' patEnd-                        else matcherP diff (patI - 1)-                    | otherwise         ->-                        let {-# INLINE badShift #-}-                            badShift = patI + occ c-                            {-# INLINE goodShift #-}-                            goodShift = suff patI-                            !diff' = diff + max badShift goodShift-                        in if maxDiff < diff'-                            then seek prior past str future diff' patEnd-                            else checkEnd (diff' + patEnd)--            -- After a full match, we know how long a prefix of the pattern-            -- still matches. Do not re-compare the prefix to prevent O(m*n)-            -- behaviour for periodic patterns.-            -- This breaks down at chunk boundaries, but except for long-            -- patterns with a short period, that shouldn't matter much.-            afterMatch !diff !patI =-              case strAt (diff + patI) of-                !c  | c == patAt patI ->-                      if patI == kept-                        then prior + fromIntegral diff :-                            let !diff' = diff + skip-                            in if maxDiff < diff'-                                then seek prior past str future diff' patEnd-                                else afterMatch diff' patEnd-                        else afterMatch diff (patI - 1)-                    | patI == patEnd  ->-                        checkEnd (diff + (2*patEnd) + occ c)-                    | otherwise       ->-                        let {-# INLINE badShift #-}-                            badShift = patI + occ c-                            {-# INLINE goodShift #-}-                            goodShift = suff patI-                            !diff' = diff + max badShift goodShift-                        in if maxDiff < diff'-                            then seek prior past str future diff' patEnd-                            else checkEnd (diff' + patEnd)- ------------------------------------------------------------------------------ --                            Breaking Functions                            -- ------------------------------------------------------------------------------@@ -782,119 +448,6 @@                         []      -> (str, S.empty)                         (i:_)   -> S.splitAt i str ---- Ugh! Code duplication ahead!--- But we want to get the first component lazily, so it's no good to find--- the first index (if any) and then split.--- Therefore bite the bullet and copy most of the code of lazySearcher.--- No need for afterMatch here, fortunately.-lazyBreak ::S.ByteString -> [S.ByteString] -> ([S.ByteString], [S.ByteString])-lazyBreak !pat-  | S.null pat  = \lst -> ([],lst)-  | S.length pat == 1 =-    let !w = S.head pat-        go [] = ([], [])-        go (!str : rest) =-            case S.elemIndices w str of-                []    -> let (pre, post) = go rest in (str : pre, post)-                (i:_) -> if i == 0-                            then ([], str : rest)-                            else ([S.take i str], S.drop i str : rest)-    in go-lazyBreak pat = breaker-  where-    !patLen = S.length pat-    !patEnd = patLen - 1-    !occT   = occurs pat-    !suffT  = suffShifts pat-    !maxLen = maxBound - patLen-    !pe     = patAt patEnd--    {-# INLINE patAt #-}-    patAt !i = unsafeIndex pat i--    {-# INLINE occ #-}-    occ !w = unsafeAt occT (fromIntegral w)--    {-# INLINE suff #-}-    suff !i = unsafeAt suffT i--    breaker lst =-      case lst of-        []    -> ([],[])-        (h:t) ->-          if maxLen < S.length h-            then error "Overflow in BoyerMoore.lazyBreak"-            else seek [] h t 0 patEnd--    seek :: [S.ByteString] -> S.ByteString -> [S.ByteString]-                -> Int -> Int -> ([S.ByteString], [S.ByteString])-    seek !past !str future !offset !patPos-      | strPos < 0 =-        case past of-          [] -> error "not enough past!"-          (h : t) -> seek t h (str : future) (offset + S.length h) patPos-      | strEnd < strPos =-        case future of-          []      -> (foldr (flip (.) . (:)) id past [str], [])-          (h : t) ->-            let !off' = offset - strLen-                (past', !discharge) = keep (-off') (str : past)-            in if maxLen < S.length h-                then error "Overflow in BoyerMoore.lazyBreak (future)"-                else let (pre,post) = seek past' h t off' patPos-                     in (foldr (flip (.) . (:)) id discharge pre, post)-      | patPos == patEnd = checkEnd strPos-      | offset < 0 = matcherN offset patPos-      | otherwise  = matcherP offset patPos-      where-        {-# INLINE strAt #-}-        strAt !i = unsafeIndex str i--        !strLen = S.length str-        !strEnd = strLen - 1-        !maxOff = strLen - patLen-        !strPos = offset + patPos--        checkEnd !sI-          | strEnd < sI = seek past str future (sI - patEnd) patEnd-          | otherwise   =-            case strAt sI of-              !c  | c == pe   ->-                    if sI < patEnd-                      then (if sI == 0-                              then seek past str future (-patEnd) (patEnd - 1)-                              else matcherN (sI - patEnd) (patEnd - 1))-                      else matcherP (sI - patEnd) (patEnd - 1)-                  | otherwise -> checkEnd (sI + patEnd + occ c)--        matcherN !off !patI =-          case strAt (off + patI) of-            !c  | c == patAt patI ->-                  if off + patI == 0-                    then seek past str future off (patI - 1)-                    else matcherN off (patI - 1)-                | otherwise ->-                    let !off' = off + max (suff patI) (patI + occ c)-                    in if maxOff < off'-                        then seek past str future off' patEnd-                        else checkEnd (off' + patEnd)--        matcherP !off !patI =-          case strAt (off + patI) of-            !c  | c == patAt patI ->-                  if patI == 0-                    then let !pre = if off == 0 then [] else [S.take off str]-                             !post = S.drop off str-                         in (foldr (flip (.) . (:)) id past pre, post:future)-                    else matcherP off (patI - 1)-                | otherwise ->-                    let !off' = off + max (suff patI) (patI + occ c)-                    in if maxOff < off'-                        then seek past str future off' patEnd-                        else checkEnd (off' + patEnd)-- ------------------------------------------------------------------------------ --                            Splitting Functions                           -- ------------------------------------------------------------------------------@@ -954,58 +507,6 @@             []            -> [str]             (i:_) -> S.take i str : splitter (S.drop (i + patLen) str) --- non-empty pattern-lazySplitKeepFront :: S.ByteString -> [S.ByteString] -> [[S.ByteString]]-lazySplitKeepFront pat = splitter'-  where-    !patLen = S.length pat-    breaker = lazyBreak pat-    splitter' strs = case splitter strs of-                        ([]:rest) -> rest-                        other -> other-    splitter [] = []-    splitter strs =-      case breaker strs of-        (pre, mtch) ->-           pre : case mtch of-                    [] -> []-                    _  -> case lsplit patLen mtch of-                            (pt, rst) ->-                              if null rst-                                then [pt]-                                else let (h : t) = splitter rst-                                     in (pt ++ h) : t---- non-empty pattern-lazySplitKeepEnd :: S.ByteString -> [S.ByteString] -> [[S.ByteString]]-lazySplitKeepEnd pat = splitter-  where-    !patLen = S.length pat-    breaker = lazyBreak pat-    splitter [] = []-    splitter strs =-      case breaker strs of-        (pre, mtch) ->-            let (h : t) = if null mtch-                            then [[]]-                            else case lsplit patLen mtch of-                                    (pt, rst) -> pt : splitter rst-            in (pre ++ h) : t--lazySplitDrop :: S.ByteString -> [S.ByteString] -> [[S.ByteString]]-lazySplitDrop pat = splitter-  where-    !patLen = S.length pat-    breaker = lazyBreak pat-    splitter [] = []-    splitter strs = splitter' strs-    splitter' [] = [[]]-    splitter' strs = case breaker strs of-                        (pre,mtch) ->-                            pre : case mtch of-                                    [] -> []-                                    _  -> splitter' (ldrop patLen mtch)- ------------------------------------------------------------------------------ --                            Replacing Functions                           -- ------------------------------------------------------------------------------@@ -1029,349 +530,3 @@                 | i == 0    -> sub $ replacer (S.drop patLen str)                 | otherwise ->                   S.take i str : sub (replacer (S.drop (i + patLen) str))--{---These would be really nice.-Unfortunately they're too slow, so instead, there's another instance of-almost the same code as in lazySearcher below.---- variant of below-lazyFRepl :: S.ByteString -> ([S.ByteString] -> [S.ByteString])-                -> [S.ByteString] -> [S.ByteString]-lazyFRepl pat = repl-  where-    !patLen = S.length pat-    breaker = lazyBreak pat-    repl sub = replacer-      where-        replacer [] = []-        replacer strs =-          let (pre, mtch) = breaker strs-          in pre ++ case mtch of-                      [] -> []-                      _  -> sub (replacer (ldrop patLen mtch))---- This is nice and short. I really hope it's performing well!-lazyBRepl :: S.ByteString -> S.ByteString -> [S.ByteString] -> [S.ByteString]-lazyBRepl pat !sub = replacer-  where-    !patLen = S.length pat-    breaker = lazyBreak pat-    replacer [] = []-    replacer strs = let (pre, mtch) = breaker strs-                    in pre ++ case mtch of-                                [] -> []-                                _  -> sub : replacer (ldrop patLen mtch)--}---- Yet more code duplication.------ Benchmark it against an implementation using lazyBreak and,--- unless it's significantly faster, NUKE IT!!------ Sigh, it is significantly faster. 10 - 25 %.--- I could live with the 10, but 25 is too much.------ Hmm, maybe an implementation via--- replace pat sub = L.intercalate sub . split pat--- would be competitive now.--- TODO: test speed and space usage.------ replacing loop for lazy ByteStrings as list of chunks,--- called only for non-empty patterns-lazyRepl :: S.ByteString -> ([S.ByteString] -> [S.ByteString])-            -> [S.ByteString] -> [S.ByteString]-lazyRepl pat = replacer- where-  !patLen = S.length pat-  !patEnd = patLen - 1-  !occT   = occurs pat-  !suffT  = suffShifts pat-  !maxLen = maxBound - patLen-  !pe     = patAt patEnd--  {-# INLINE patAt #-}-  patAt !i = unsafeIndex pat i--  {-# INLINE occ #-}-  occ !w = unsafeAt occT (fromIntegral w)--  {-# INLINE suff #-}-  suff !i = unsafeAt suffT i--  replacer sub lst =-      case lst of-        []    -> []-        (h:t) ->-          if maxLen < S.length h-            then error "Overflow in BoyerMoore.lazyRepl"-            else seek [] h t 0 patEnd-   where-        chop _ [] = []-        chop !k (!str : rest)-          | k < s     =-            if maxLen < (s - k)-                then error "Overflow in BoyerMoore.lazyRepl (chop)"-                else seek [] (S.drop k str) rest 0 patEnd-          | otherwise = chop (k-s) rest-            where-              !s = S.length str--        seek :: [S.ByteString] -> S.ByteString -> [S.ByteString]-                                    -> Int -> Int -> [S.ByteString]-        seek !past !str fut !offset !patPos-          | strPos < 0 =-            case past of-              [] -> error "not enough past!"-              (h : t) -> seek t h (str : fut) (offset + S.length h) patPos-          | strEnd < strPos =-            case fut of-              []      -> foldr (flip (.) . (:)) id past [str]-              (h : t) ->-                let !off' = offset - strLen-                    (past', !discharge) = keep (-off') (str : past)-                in if maxLen < S.length h-                    then error "Overflow in BoyerMoore.lazyRepl (future)"-                    else foldr (flip (.) . (:)) id discharge $-                                            seek past' h t off' patPos-          | patPos == patEnd = checkEnd strPos-          | offset < 0 = matcherN offset patPos-          | otherwise  = matcherP offset patPos-            where-              {-# INLINE strAt #-}-              strAt !i = unsafeIndex str i--              !strLen = S.length str-              !strEnd = strLen - 1-              !maxOff = strLen - patLen-              !strPos = offset + patPos--              checkEnd !sI-                | strEnd < sI = seek past str fut (sI - patEnd) patEnd-                | otherwise   =-                  case strAt sI of-                    !c  | c == pe   ->-                          if sI < patEnd-                            then (if sI == 0-                              then seek past str fut (-patEnd) (patEnd - 1)-                              else matcherN (sI - patEnd) (patEnd - 1))-                          else matcherP (sI - patEnd) (patEnd - 1)-                        | otherwise -> checkEnd (sI + patEnd + occ c)--              matcherN !off !patI =-                case strAt (off + patI) of-                  !c  | c == patAt patI ->-                        if off + patI == 0-                          then seek past str fut off (patI - 1)-                          else matcherN off (patI - 1)-                      | otherwise ->-                        let !off' = off + max (suff patI) (patI + occ c)-                        in if maxOff < off'-                            then seek past str fut off' patEnd-                            else checkEnd (off' + patEnd)--              matcherP !off !patI =-                case strAt (off + patI) of-                  !c  | c == patAt patI ->-                        if patI == 0-                          then foldr (flip (.) . (:)) id past $-                            let pre = if off == 0-                                        then id-                                        else (S.take off str :)-                            in pre . sub $-                                let !p = off + patLen-                                in if p < strLen-                                    then seek [] (S.drop p str) fut 0 patEnd-                                    else chop (p - strLen) fut-                        else matcherP off (patI - 1)-                      | otherwise ->-                        let !off' = off + max (suff patI) (patI + occ c)-                        in if maxOff < off'-                            then seek past str fut off' patEnd-                            else checkEnd (off' + patEnd)-----------------------------------------------------------------------------------                              Preprocessing                               -----------------------------------------------------------------------------------{- Table of last occurrences of bytes in the pattern.--For each byte we record the (negated) position of its last-occurrence in the pattern except at the last position.--Thus, if byte b gives a mismatch at pattern position patPos,-we know that we can shift the window right by at least--patPos - (last occurrence of b in init pat)--or, since we negated the positions,--patPos + (occurs pat)--If the byte doesn't occur in the pattern, we can shift the window-so that the start of the pattern is aligned with the byte after this,-hence the default value of 1.--Complexity: O(patLen + size of alphabet)---}-{- Precondition: non-empty pattern--This invariant is guaranteed by not exporting occurs,-inside this module, we don't call it for empty patterns.---}-{-# INLINE occurs #-}-occurs :: S.ByteString -> UArray Int Int-occurs pat = runSTUArray (do-    let !patEnd = S.length pat - 1-        {-# INLINE patAt #-}-        patAt :: Int -> Int-        patAt i = fromIntegral (unsafeIndex pat i)-    ar <- newArray (0, 255) 1-    let loop !i-            | i == patEnd   = return ar-            | otherwise     = do-                unsafeWrite ar (patAt i) (-i)-                loop (i + 1)-    loop 0)--{- Table of suffix-shifts.--When a mismatch occurs at pattern position patPos, assumed to be not the-last position in the pattern, the suffix u of length (patEnd - patPos)-has been successfully matched.-Let c be the byte in the pattern at position patPos.--If the sub-pattern u also occurs in the pattern somewhere *not* preceded-by c, let uPos be the position of the last byte in u for the last of-all such occurrences. Then there can be no match if the window is shifted-less than (patEnd - uPos) places, because either the part of the string-which matched the suffix u is not aligned with an occurrence of u in the-pattern, or it is aligned with an occurrence of u which is preceded by-the same byte c as the originally matched suffix.--If the complete sub-pattern u does not occur again in the pattern, or all-of its occurrences are preceded by the byte c, then we can align the-pattern with the string so that a suffix v of u matches a prefix of the-pattern. If v is chosen maximal, no smaller shift can give a match, so-we can shift by at least (patLen - length v).--If a complete match is encountered, we can shift by at least the same-amount as if the first byte of the pattern was a mismatch, no complete-match is possible between these positions.--For non-periodic patterns, only very short suffixes will usually occur-again in the pattern, so if a longer suffix has been matched before a-mismatch, the window can then be shifted entirely past the partial-match, so that part of the string will not be re-compared.-For periodic patterns, the suffix shifts will be shorter in general,-leading to an O(strLen * patLen) worst-case performance.--To compute the suffix-shifts, we use an array containing the lengths of-the longest common suffixes of the entire pattern and its prefix ending-with position pos.---}-{- Precondition: non-empty pattern -}-{-# INLINE suffShifts #-}-suffShifts :: S.ByteString -> UArray Int Int-suffShifts pat = runSTUArray (do-    let !patLen = S.length pat-        !patEnd = patLen - 1-        !suff   = suffLengths pat-    ar <- newArray (0,patEnd) patLen-    let preShift !idx !j-            | idx < 0   = return ()-            | suff `unsafeAt` idx == idx + 1 = do-                let !shf = patEnd - idx-                    fillToShf !i-                        | i == shf  = return ()-                        | otherwise = do-                            unsafeWrite ar i shf-                            fillToShf (i + 1)-                fillToShf j-                preShift (idx - 1) shf-            | otherwise = preShift (idx - 1) j-        sufShift !idx-            | idx == patEnd = return ar-            | otherwise     = do-                unsafeWrite ar (patEnd - unsafeAt suff idx) (patEnd - idx)-                sufShift (idx + 1)-    preShift (patEnd - 1) 0-    sufShift 0)--{- Table of suffix-lengths.--The value of this array at place i is the length of the longest common-suffix of the entire pattern and the prefix of the pattern ending at-position i.--Usually, most of the entries will be 0. Only if the byte at position i-is the same as the last byte of the pattern can the value be positive.-In any case the value at index patEnd is patLen (since the pattern is-identical to itself) and 0 <= value at i <= (i + 1).--To keep this part of preprocessing linear in the length of the pattern,-the implementation must be non-obvious (the obvious algorithm for this-is quadratic).--When the index under consideration is inside a previously identified-common suffix, we align that suffix with the end of the pattern and-check whether the suffix ending at the position corresponding to idx-is shorter than the part of the suffix up to idx. If that is the case,-the length of the suffix ending at idx is that of the suffix at the-corresponding position. Otherwise extend the suffix as far as possible.-If the index under consideration is not inside a previously identified-common suffix, compare with the last byte of the pattern. If that gives-a suffix of length > 1, for the next index we're in the previous-situation, otherwise we're back in the same situation for the next-index.---}-{- Precondition: non-empty pattern -}-{-# INLINE suffLengths #-}-suffLengths :: S.ByteString -> UArray Int Int-suffLengths pat = runSTUArray (do-    let !patLen = S.length pat-        !patEnd = patLen - 1-        !preEnd = patEnd - 1-        {-# INLINE patAt #-}-        patAt i = unsafeIndex pat i-        -- last byte for comparisons-        !pe     = patAt patEnd-        -- find index preceding the longest suffix-        dec !diff !j-            | j < 0 || patAt j /= patAt (j + diff) = j-            | otherwise = dec diff (j - 1)-    ar <- newArray_ (0, patEnd)-    unsafeWrite ar patEnd patLen-    let noSuff !i-            | i < 0     = return ar-            | patAt i == pe = do-                let !diff  = patEnd - i-                    !nextI = i - 1-                    !prevI = dec diff nextI-                if prevI == nextI-                    then unsafeWrite ar i 1 >> noSuff nextI-                    else do unsafeWrite ar i (i - prevI)-                            suffLoop prevI preEnd nextI-            | otherwise = do-                unsafeWrite ar i 0-                noSuff (i - 1)-        suffLoop !pre !end !idx-            | idx < 0   = return ar-            | pre < idx =-              if patAt idx /= pe-                then unsafeWrite ar idx 0 >> suffLoop pre (end - 1) (idx - 1)-                else do-                    prevS <- unsafeRead ar end-                    if pre + prevS < idx-                        then do unsafeWrite ar idx prevS-                                suffLoop pre (end - 1) (idx - 1)-                        else do let !prI = dec (patEnd - idx) pre-                                unsafeWrite ar idx (idx - prI)-                                suffLoop prI preEnd (idx - 1)-            | otherwise = noSuff idx-    noSuff preEnd)
Data/ByteString/Search/Internal/Utils.hs view
@@ -14,6 +14,8 @@  module Data.ByteString.Search.Internal.Utils ( kmpBorders                                              , automaton+                                             , occurs+                                             , suffShifts                                              , ldrop                                              , ltake                                              , lsplit@@ -88,6 +90,191 @@                     else unsafeWrite ar i j'                 bordLoop (i+1) j'     bordLoop 1 (-1))++------------------------------------------------------------------------------+--                        Boyer-Moore Preprocessing                         --+------------------------------------------------------------------------------++{- Table of last occurrences of bytes in the pattern.++For each byte we record the (negated) position of its last+occurrence in the pattern except at the last position.++Thus, if byte b gives a mismatch at pattern position patPos,+we know that we can shift the window right by at least++patPos - (last occurrence of b in init pat)++or, since we negated the positions,++patPos + (occurs pat)++If the byte doesn't occur in the pattern, we can shift the window+so that the start of the pattern is aligned with the byte after this,+hence the default value of 1.++Complexity: O(patLen + size of alphabet)++-}+{- Precondition: non-empty pattern++This invariant is guaranteed by not exporting occurs,+inside this module, we don't call it for empty patterns.++-}+{-# INLINE occurs #-}+occurs :: S.ByteString -> UArray Int Int+occurs pat = runSTUArray (do+    let !patEnd = S.length pat - 1+        {-# INLINE patAt #-}+        patAt :: Int -> Int+        patAt i = fromIntegral (unsafeIndex pat i)+    ar <- newArray (0, 255) 1+    let loop !i+            | i == patEnd   = return ar+            | otherwise     = do+                unsafeWrite ar (patAt i) (-i)+                loop (i + 1)+    loop 0)++{- Table of suffix-shifts.++When a mismatch occurs at pattern position patPos, assumed to be not the+last position in the pattern, the suffix u of length (patEnd - patPos)+has been successfully matched.+Let c be the byte in the pattern at position patPos.++If the sub-pattern u also occurs in the pattern somewhere *not* preceded+by c, let uPos be the position of the last byte in u for the last of+all such occurrences. Then there can be no match if the window is shifted+less than (patEnd - uPos) places, because either the part of the string+which matched the suffix u is not aligned with an occurrence of u in the+pattern, or it is aligned with an occurrence of u which is preceded by+the same byte c as the originally matched suffix.++If the complete sub-pattern u does not occur again in the pattern, or all+of its occurrences are preceded by the byte c, then we can align the+pattern with the string so that a suffix v of u matches a prefix of the+pattern. If v is chosen maximal, no smaller shift can give a match, so+we can shift by at least (patLen - length v).++If a complete match is encountered, we can shift by at least the same+amount as if the first byte of the pattern was a mismatch, no complete+match is possible between these positions.++For non-periodic patterns, only very short suffixes will usually occur+again in the pattern, so if a longer suffix has been matched before a+mismatch, the window can then be shifted entirely past the partial+match, so that part of the string will not be re-compared.+For periodic patterns, the suffix shifts will be shorter in general,+leading to an O(strLen * patLen) worst-case performance.++To compute the suffix-shifts, we use an array containing the lengths of+the longest common suffixes of the entire pattern and its prefix ending+with position pos.++-}+{- Precondition: non-empty pattern -}+{-# INLINE suffShifts #-}+suffShifts :: S.ByteString -> UArray Int Int+suffShifts pat = runSTUArray (do+    let !patLen = S.length pat+        !patEnd = patLen - 1+        !suff   = suffLengths pat+    ar <- newArray (0,patEnd) patLen+    let preShift !idx !j+            | idx < 0   = return ()+            | suff `unsafeAt` idx == idx + 1 = do+                let !shf = patEnd - idx+                    fillToShf !i+                        | i == shf  = return ()+                        | otherwise = do+                            unsafeWrite ar i shf+                            fillToShf (i + 1)+                fillToShf j+                preShift (idx - 1) shf+            | otherwise = preShift (idx - 1) j+        sufShift !idx+            | idx == patEnd = return ar+            | otherwise     = do+                unsafeWrite ar (patEnd - unsafeAt suff idx) (patEnd - idx)+                sufShift (idx + 1)+    preShift (patEnd - 1) 0+    sufShift 0)++{- Table of suffix-lengths.++The value of this array at place i is the length of the longest common+suffix of the entire pattern and the prefix of the pattern ending at+position i.++Usually, most of the entries will be 0. Only if the byte at position i+is the same as the last byte of the pattern can the value be positive.+In any case the value at index patEnd is patLen (since the pattern is+identical to itself) and 0 <= value at i <= (i + 1).++To keep this part of preprocessing linear in the length of the pattern,+the implementation must be non-obvious (the obvious algorithm for this+is quadratic).++When the index under consideration is inside a previously identified+common suffix, we align that suffix with the end of the pattern and+check whether the suffix ending at the position corresponding to idx+is shorter than the part of the suffix up to idx. If that is the case,+the length of the suffix ending at idx is that of the suffix at the+corresponding position. Otherwise extend the suffix as far as possible.+If the index under consideration is not inside a previously identified+common suffix, compare with the last byte of the pattern. If that gives+a suffix of length > 1, for the next index we're in the previous+situation, otherwise we're back in the same situation for the next+index.++-}+{- Precondition: non-empty pattern -}+{-# INLINE suffLengths #-}+suffLengths :: S.ByteString -> UArray Int Int+suffLengths pat = runSTUArray (do+    let !patLen = S.length pat+        !patEnd = patLen - 1+        !preEnd = patEnd - 1+        {-# INLINE patAt #-}+        patAt i = unsafeIndex pat i+        -- last byte for comparisons+        !pe     = patAt patEnd+        -- find index preceding the longest suffix+        dec !diff !j+            | j < 0 || patAt j /= patAt (j + diff) = j+            | otherwise = dec diff (j - 1)+    ar <- newArray_ (0, patEnd)+    unsafeWrite ar patEnd patLen+    let noSuff !i+            | i < 0     = return ar+            | patAt i == pe = do+                let !diff  = patEnd - i+                    !nextI = i - 1+                    !prevI = dec diff nextI+                if prevI == nextI+                    then unsafeWrite ar i 1 >> noSuff nextI+                    else do unsafeWrite ar i (i - prevI)+                            suffLoop prevI preEnd nextI+            | otherwise = do+                unsafeWrite ar i 0+                noSuff (i - 1)+        suffLoop !pre !end !idx+            | idx < 0   = return ar+            | pre < idx =+              if patAt idx /= pe+                then unsafeWrite ar idx 0 >> suffLoop pre (end - 1) (idx - 1)+                else do+                    prevS <- unsafeRead ar end+                    if pre + prevS < idx+                        then do unsafeWrite ar idx prevS+                                suffLoop pre (end - 1) (idx - 1)+                        else do let !prI = dec (patEnd - idx) pre+                                unsafeWrite ar idx (idx - prI)+                                suffLoop prI preEnd (idx - 1)+            | otherwise = noSuff idx+    noSuff preEnd)  ------------------------------------------------------------------------------ --                             Helper Functions                             --
stringsearch.cabal view
@@ -7,7 +7,7 @@ -- The package version. See the Haskell package versioning policy -- (http://www.haskell.org/haskellwiki/Package_versioning_policy) for -- standards guiding when and how versions should be incremented.-Version:             0.3.3+Version:             0.3.4  -- A short (one-line) description of the package. Synopsis:            Fast searching, splitting and replacing of ByteStrings@@ -38,7 +38,7 @@ Maintainer:          daniel.is.fischer@googlemail.com  -- A copyright notice.-Copyright:           (c) 2007-2010+Copyright:           (c) 2007-2011                      Daniel Fischer, Chris Kuklewicz, Justin Bailey  Category:            Text, Search@@ -49,8 +49,8 @@ -- a README. Extra-source-files:  CHANGES -Tested-with:         GHC == 6.8.3, GHC == 6.10.1, GHC == 6.10.3, GHC == 6.12.1,-                     GHC == 6.12.2, GHC == 6.12.3+Tested-with:         GHC == 6.8.3, GHC == 6.12.1, GHC == 6.12.2,+                     GHC == 6.12.3, GHC == 7.0.3  -- Constraint on the version of Cabal needed to build this package. Cabal-version:       >=1.2@@ -89,13 +89,17 @@       Build-depends: base >= 2 && < 3    Extensions:        BangPatterns-  ghc-options:       -O2 -Wall-  ghc-prof-options:  -auto-all+  if flag(base4)+    ghc-options:     -O2 -fspec-constr-count=4 -Wall+  else+    ghc-options:     -O2 -Wall+  ghc-prof-options:  -auto    -- Modules not exported by this package.   Other-modules:     Data.ByteString.Search.Internal.BoyerMoore                      Data.ByteString.Search.Internal.KnuthMorrisPratt                      Data.ByteString.Search.Internal.Utils+                     Data.ByteString.Lazy.Search.Internal.BoyerMoore    -- Extra tools (e.g. alex, hsc2hs, ...) needed to build the source.   -- Build-tools: