{-# LANGUAGE BangPatterns #-} {-# OPTIONS_HADDOCK hide, prune #-} -- | -- Module : Data.ByteString.Search.Internal.Utils -- Copyright : Daniel Fischer -- Licence : BSD3 -- Maintainer : Daniel Fischer <daniel.is.fischer@googlemail.com> -- Stability : Provisional -- Portabiltity : non-portable -- -- Author : Daniel Fischer -- -- Utilities for several searching algorithms. module Data.ByteString.Search.Internal.Utils ( kmpBorders , automaton , occurs , suffShifts , ldrop , ltake , lsplit , release , keep , strictify ) where import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L import Data.ByteString.Unsafe (unsafeIndex) import Data.Array.Base (unsafeRead, unsafeWrite, unsafeAt) import Data.Array.ST import Data.Array.Unboxed import Control.Monad (when) import Data.Bits import Data.Word (Word8) ------------------------------------------------------------------------------ -- Preprocessing -- ------------------------------------------------------------------------------ {-# INLINE automaton #-} automaton :: S.ByteString -> UArray Int Int automaton !pat = runSTUArray (do let !patLen = S.length pat {-# INLINE patAt #-} patAt !i = fromIntegral (unsafeIndex pat i) !bord = kmpBorders pat aut <- newArray (0, (patLen + 1)*256 - 1) 0 unsafeWrite aut (patAt 0) 1 let loop !state = do let !base = state `shiftL` 8 inner j | j < 0 = if state == patLen then return aut else loop (state+1) | otherwise = do let !i = base + patAt j s <- unsafeRead aut i when (s == 0) (unsafeWrite aut i (j+1)) inner (unsafeAt bord j) if state == patLen then inner (unsafeAt bord state) else inner state loop 1) -- kmpBorders calculates the width of the widest borders of the prefixes -- of the pattern which are not extensible to borders of the next -- longer prefix. Most entries will be 0. {-# INLINE kmpBorders #-} kmpBorders :: S.ByteString -> UArray Int Int kmpBorders pat = runSTUArray (do let !patLen = S.length pat {-# INLINE patAt #-} patAt :: Int -> Word8 patAt i = unsafeIndex pat i ar <- newArray_ (0, patLen) unsafeWrite ar 0 (-1) let dec w j | j < 0 || w == patAt j = return $! j+1 | otherwise = unsafeRead ar j >>= dec w bordLoop !i !j | patLen < i = return ar | otherwise = do let !w = patAt (i-1) j' <- dec w j if i < patLen && patAt j' == patAt i then unsafeRead ar j' >>= unsafeWrite ar i 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 -- ------------------------------------------------------------------------------ {-# INLINE strictify #-} strictify :: L.ByteString -> S.ByteString strictify = S.concat . L.toChunks -- drop k bytes from a list of strict ByteStrings {-# INLINE ldrop #-} ldrop :: Int -> [S.ByteString] -> [S.ByteString] ldrop _ [] = [] ldrop k (!h : t) | k < l = S.drop k h : t | otherwise = ldrop (k - l) t where !l = S.length h -- take k bytes from a list of strict ByteStrings {-# INLINE ltake #-} ltake :: Int -> [S.ByteString] -> [S.ByteString] ltake _ [] = [] ltake !k (!h : t) | l < k = h : ltake (k - l) t | otherwise = [S.take k h] where !l = S.length h -- split a list of strict ByteStrings at byte k {-# INLINE lsplit #-} lsplit :: Int -> [S.ByteString] -> ([S.ByteString], [S.ByteString]) lsplit _ [] = ([],[]) lsplit !k (!h : t) = case compare k l of LT -> ([S.take k h], S.drop k h : t) EQ -> ([h], t) GT -> let (u, v) = lsplit (k - l) t in (h : u, v) where !l = S.length h -- release is used to keep the zipper in lazySearcher from remembering -- the leading part of the searched string. The deep parameter is the -- number of characters that the past needs to hold. This ensures -- lazy streaming consumption of the searched string. {-# INLINE release #-} release :: Int -> [S.ByteString] -> [S.ByteString] release !deep _ | deep <= 0 = [] release !deep (!x:xs) = let !rest = release (deep-S.length x) xs in x : rest release _ [] = error "stringsearch.release could not find enough past!" -- keep is like release, only we mustn't forget the part of the past -- we don't need anymore for matching but have to keep it for -- breaking, splitting and replacing. -- The names would be more appropriate the other way round, but that's -- a historical accident, so what? {-# INLINE keep #-} keep :: Int -> [S.ByteString] -> ([S.ByteString],[S.ByteString]) keep !deep xs | deep < 1 = ([],xs) keep deep (!x:xs) = let (!p,d) = keep (deep - S.length x) xs in (x:p,d) keep _ [] = error "Forgot too much"