diff --git a/alfred-margaret.cabal b/alfred-margaret.cabal --- a/alfred-margaret.cabal +++ b/alfred-margaret.cabal @@ -1,5 +1,5 @@ name: alfred-margaret -version: 1.0.0.0 +version: 1.1.1.0 synopsis: Fast Aho-Corasick string searching description: An efficient implementation of the Aho-Corasick string searching algorithm. @@ -7,45 +7,71 @@ license: BSD3 license-file: LICENSE author: The Alfred-Margaret authors -maintainer: Ruud van Asseldonk -copyright: 2019 Channable +maintainer: Ruud van Asseldonk , Fabian Thorand +copyright: 2020 Channable category: Data, Text build-type: Simple extra-source-files: README.md cabal-version: >=1.10 tested-with: - -- Stackage LTS 11.22. - GHC == 8.2.2 - -- Stackage LTS 12.14. - , GHC == 8.4.3 - -- Stackage LTS 12.26. - , GHC == 8.4.4 -- Stackage LTS 13.10. - , GHC == 8.6.3 + GHC == 8.6.3 + -- Stackage LTS 16.18. + , GHC == 8.8.4 source-repository head type: git location: https://github.com/channable/alfred-margaret +Flag aeson + Description: Enable aeson support + Manual: False + Default: True + +-- Compile this package with LLVM, rather than with the default code generator. +-- LLVM produces about 20% faster code. +Flag llvm + Description: Compile with LLVM + Manual: True + -- Defaulting to false makes the package buildable by Hackage, + -- allowing the documentation to be generated for us. + Default: False + library hs-source-dirs: src exposed-modules: Data.Text.AhoCorasick.Automaton - , Data.Text.AhoCorasick.Searcher , Data.Text.AhoCorasick.Replacer + , Data.Text.AhoCorasick.Searcher + , Data.Text.AhoCorasick.Splitter + , Data.Text.BoyerMoore.Automaton + , Data.Text.BoyerMoore.Replacer + , Data.Text.BoyerMoore.Searcher + , Data.Text.Utf16 build-depends: base >= 4.7 && < 5 - , containers >= 0.6.2 && < 0.7 - , deepseq >= 1.4.4 && < 1.5 - , hashable >= 1.3.0 && < 1.4 - , text >= 1.2.4 && < 1.3 - , primitive >= 0.7.1 && < 0.8 - , vector >= 0.12.1 && < 0.13 - ghc-options: -Wall -Wincomplete-record-updates -Wincomplete-uni-patterns + , containers >= 0.6 && < 0.7 + , deepseq >= 1.4 && < 1.5 + , hashable >= 1.2.7 && < 1.4 + , primitive >= 0.6.4 && < 0.8 + , text >= 1.2.3 && < 1.3 + , unordered-containers >= 0.2.9 && < 0.3 + , vector >= 0.12 && < 0.13 + ghc-options: -Wall -Wincomplete-record-updates -Wincomplete-uni-patterns -O2 default-language: Haskell2010 + if flag(aeson) { + build-depends: aeson >= 1.4.2 && < 1.6 + cpp-options: -DHAS_AESON + } + if flag(llvm) { + ghc-options: -fllvm -optlo=-O3 -optlo=-tailcallelim + } test-suite test-suite type: exitcode-stdio-1.0 - main-is: AhoCorasickSpec.hs + main-is: Main.hs + other-modules: Data.Text.AhoCorasickSpec + , Data.Text.BoyerMooreSpec + , Data.Text.Orphans hs-source-dirs: tests ghc-options: -Wall -Wincomplete-record-updates -Wno-orphans build-depends: base >= 4.7 && < 5 diff --git a/src/Data/Text/AhoCorasick/Automaton.hs b/src/Data/Text/AhoCorasick/Automaton.hs --- a/src/Data/Text/AhoCorasick/Automaton.hs +++ b/src/Data/Text/AhoCorasick/Automaton.hs @@ -4,17 +4,11 @@ -- Licensed under the 3-clause BSD license, see the LICENSE file in the -- repository root. --- Compile this module with LLVM, rather than with the default code generator. --- LLVM produces about 20% faster code. --- We pass -fignore-asserts to improve performance: we ran this code with --- asserts enabled in production for two months, and in this time, the asserts --- have not been violated. -{-# OPTIONS_GHC -fllvm -O2 -optlo=-O3 -optlo=-tailcallelim -fignore-asserts #-} {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE ScopedTypeVariables #-} -- | An efficient implementation of the Aho-Corasick string matching algorithm. @@ -41,53 +35,47 @@ , runLower , debugBuildDot , CaseSensitivity (..) - , CodeUnit , CodeUnitIndex (..) , Match (..) , Next (..) - , lengthUtf16 - , lowerUtf16 - , unpackUtf16 - , unsafeCutUtf16 - , unsafeSliceUtf16 ) where import Prelude hiding (length) import Control.DeepSeq (NFData) -import Control.Exception (assert) import Data.Bits ((.&.), (.|.), shiftL, shiftR) import Data.Foldable (foldl') import Data.Hashable (Hashable) import Data.IntMap.Strict (IntMap) import Data.Text.Internal (Text (..)) -import Data.Word (Word16, Word64) +import Data.Word (Word64) import GHC.Generics (Generic) -import Data.Primitive.ByteArray (ByteArray (..)) -import qualified Data.Char as Char +#if defined(HAS_AESON) +import Data.Aeson (FromJSON, ToJSON) +#endif + import qualified Data.IntMap.Strict as IntMap import qualified Data.List as List -import qualified Data.Text.Array as TextArray -import qualified Data.Text.Unsafe as TextUnsafe import qualified Data.Vector as Vector import qualified Data.Vector.Unboxed as UVector -import qualified Data.Vector.Primitive as PVector +import Data.Text.Utf16 (CodeUnit, CodeUnitIndex (..), indexTextArray, lowerCodeUnit) + data CaseSensitivity = CaseSensitive | IgnoreCase deriving stock (Eq, Generic, Show) +#if defined(HAS_AESON) + deriving anyclass (Hashable, NFData, FromJSON, ToJSON) +#else deriving anyclass (Hashable, NFData) +#endif -- | A numbered state in the Aho-Corasick automaton. type State = Int --- | A code unit is a 16-bit integer from which UTF-16 encoded text is built up. --- The `Text` type is represented as a UTF-16 string. -type CodeUnit = Word16 - -- | A transition is a pair of (code unit, next state). The code unit is 16 bits, -- and the state index is 32 bits. We pack these together as a manually unlifted -- tuple, because an unboxed Vector of tuples is a tuple of vectors, but we want @@ -107,16 +95,6 @@ -- type Transition = Word64 --- | An index into the raw UTF-16 data of a `Text`. This is not the code point --- index as conventionally accepted by `Text`, so we wrap it to avoid confusing --- the two. Incorrect index manipulation can lead to surrogate pairs being --- sliced, so manipulate indices with care. This type is also used for lengths. -newtype CodeUnitIndex = CodeUnitIndex - { codeUnitIndex :: Int - } - deriving stock (Eq, Generic, Show) - deriving newtype (Hashable, Ord, Num, Bounded, NFData) - data Match v = Match { matchPos :: {-# UNPACK #-} !CodeUnitIndex -- ^ The code unit index past the last code unit of the match. Note that this @@ -451,7 +429,7 @@ consumeInput :: Int -> Int -> a -> State -> a consumeInput !offset !remaining !acc !state = let - inputCodeUnit = fromIntegral $ TextArray.unsafeIndex u16data offset + inputCodeUnit = fromIntegral $ indexTextArray u16data offset -- NOTE: Although doing this match here entangles the automaton a bit -- with case sensitivity, doing so is faster than passing in a function -- that transforms each code unit. @@ -548,112 +526,3 @@ {-# INLINE runLower #-} runLower :: forall a v. a -> (a -> Match v -> Next a) -> AcMachine v -> Text -> a runLower = runWithCase IgnoreCase - --- | Return a Text as a list of UTF-16 code units. -unpackUtf16 :: Text -> [CodeUnit] -unpackUtf16 (Text u16data offset length) = - let - go _ 0 = [] - go i n = TextArray.unsafeIndex u16data i : go (i + 1) (n - 1) - in - go offset length - --- | Return whether the code unit at the given index starts a surrogate pair. --- Such a code unit must be followed by a high surrogate in valid UTF-16. --- Returns false on out of bounds indices. -{-# INLINE isLowSurrogate #-} -isLowSurrogate :: Int -> Text -> Bool -isLowSurrogate !i (Text !u16data !offset !len) = - let - w = TextArray.unsafeIndex u16data (offset + i) - in - i >= 0 && i < len && w >= 0xd800 && w <= 0xdbff - --- | Return whether the code unit at the given index ends a surrogate pair. --- Such a code unit must be preceded by a low surrogate in valid UTF-16. --- Returns false on out of bounds indices. -{-# INLINE isHighSurrogate #-} -isHighSurrogate :: Int -> Text -> Bool -isHighSurrogate !i (Text !u16data !offset !len) = - let - w = TextArray.unsafeIndex u16data (offset + i) - in - i >= 0 && i < len && w >= 0xdc00 && w <= 0xdfff - --- | Extract a substring from a text, at a code unit offset and length. --- This is similar to `Text.take length . Text.drop begin`, except that the --- begin and length are in code *units*, not code points, so we can slice the --- UTF-16 array, and we don't have to walk the entire text to take surrogate --- pairs into account. It is the responsibility of the user to not slice --- surrogate pairs, and to ensure that the length is within bounds, hence this --- function is unsafe. -{-# INLINE unsafeSliceUtf16 #-} -unsafeSliceUtf16 :: CodeUnitIndex -> CodeUnitIndex -> Text -> Text -unsafeSliceUtf16 (CodeUnitIndex !begin) (CodeUnitIndex !length) !text - = assert (begin + length <= TextUnsafe.lengthWord16 text) - $ assert (not $ isHighSurrogate begin text) - $ assert (not $ isLowSurrogate (begin + length - 1) text) - $ TextUnsafe.takeWord16 length $ TextUnsafe.dropWord16 begin text - --- | The complement of `unsafeSliceUtf16`: removes the slice, and returns the --- part before and after. See `unsafeSliceUtf16` for details. -{-# INLINE unsafeCutUtf16 #-} -unsafeCutUtf16 :: CodeUnitIndex -> CodeUnitIndex -> Text -> (Text, Text) -unsafeCutUtf16 (CodeUnitIndex !begin) (CodeUnitIndex !length) !text - = assert (begin + length <= TextUnsafe.lengthWord16 text) - $ assert (not $ isHighSurrogate begin text) - $ assert (not $ isLowSurrogate (begin + length - 1) text) - ( TextUnsafe.takeWord16 begin text - , TextUnsafe.dropWord16 (begin + length) text - ) - --- | Return the length of the text, in number of code units. -{-# INLINE lengthUtf16 #-} -lengthUtf16 :: Text -> CodeUnitIndex -lengthUtf16 = CodeUnitIndex . TextUnsafe.lengthWord16 - --- | Apply a function to each code unit of a text. -mapUtf16 :: (CodeUnit -> CodeUnit) -> Text -> Text -mapUtf16 f (Text u16data offset length) = - let - get !i = f $ TextArray.unsafeIndex u16data (offset + i) - !(PVector.Vector !offset' !length' !(ByteArray !u16data')) = - PVector.generate length get - in - Text (TextArray.Array u16data') offset' length' - --- | Lowercase each individual code unit of a text without changing their index. --- This is not a proper case folding, but it does ensure that indices into the --- lowercased string correspond to indices into the original string. --- --- Differences from `Text.toLower` include code points in the BMP that lowercase --- to multiple code points, and code points outside of the BMP. --- --- For example, "İ" (U+0130), which `toLower` converts to "i" (U+0069, U+0307), --- is converted into U+0069 only by `lowerUtf16`. --- Also, "𑢢" (U+118A2), a code point from the Warang City writing system in the --- Supplementary Multilingual Plane, introduced in 2014 to Unicode 7. It would --- be lowercased to U+118C2 by `toLower`, but it is left untouched by --- `lowerUtf16`. -lowerUtf16 :: Text -> Text -lowerUtf16 = mapUtf16 lowerCodeUnit - -{-# INLINE lowerCodeUnit #-} -lowerCodeUnit :: CodeUnit -> CodeUnit -lowerCodeUnit cu = - if cu >= 0xd800 && cu < 0xe000 - -- This code unit is part of a surrogate pair. Don't touch those, because - -- we don't have all information required to decode the code point. Note - -- that alphabets that need to be encoded as surrogate pairs are mostly - -- archaic and obscure; all of the languages used by our customers have - -- alphabets in the Basic Multilingual Plane, which does not need surrogate - -- pairs. Note that the BMP is not just ascii or extended ascii. See also - -- https://codepoints.net/basic_multilingual_plane. - then cu - -- The code unit is a code point on its own (not part of a surrogate pair), - -- lowercase the code point. These code points, which are all in the BMP, - -- have the important property that lowercasing them is again a code point - -- in the BMP, so the output can be encoded in exactly one code unit, just - -- like the input. This property was verified by exhaustive testing; see - -- also the test in AhoCorasickSpec.hs. - else fromIntegral $ Char.ord $ Char.toLower $ Char.chr $ fromIntegral cu diff --git a/src/Data/Text/AhoCorasick/Replacer.hs b/src/Data/Text/AhoCorasick/Replacer.hs --- a/src/Data/Text/AhoCorasick/Replacer.hs +++ b/src/Data/Text/AhoCorasick/Replacer.hs @@ -4,9 +4,8 @@ -- Licensed under the 3-clause BSD license, see the LICENSE file in the -- repository root. --- See Automaton.hs for why these GHC flags are here. -{-# OPTIONS_GHC -fllvm -O2 -optlo=-O3 -optlo=-tailcallelim -fno-ignore-asserts #-} {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingStrategies #-} @@ -31,6 +30,10 @@ import Data.Text (Text) import GHC.Generics (Generic) +#if defined(HAS_AESON) +import qualified Data.Aeson as AE +#endif + import qualified Data.Text as Text import Data.Text.AhoCorasick.Automaton (CaseSensitivity (..), CodeUnitIndex) @@ -38,6 +41,7 @@ import qualified Data.Text.AhoCorasick.Automaton as Aho import qualified Data.Text.AhoCorasick.Searcher as Searcher +import qualified Data.Text.Utf16 as Utf16 -- | Descriptive type alias for strings to search for. type Needle = Text @@ -54,7 +58,12 @@ { needlePriority :: {-# UNPACK #-} !Priority , needleLength :: {-# UNPACK #-} !CodeUnitIndex , needleReplacement :: !Replacement - } deriving (Eq, Generic, Hashable, NFData, Show) + } +#if defined(HAS_AESON) + deriving (Eq, Generic, Hashable, NFData, Show, AE.FromJSON, AE.ToJSON) +#else + deriving (Eq, Generic, Hashable, NFData, Show) +#endif -- | A state machine used for efficient replacements with many different needles. data Replacer = Replacer @@ -62,7 +71,11 @@ , replacerSearcher :: Searcher Payload } deriving stock (Show, Eq, Generic) - deriving anyclass (Hashable, NFData) +#if defined(HAS_AESON) + deriving (Hashable, NFData, AE.FromJSON, AE.ToJSON) +#else + deriving (Hashable, NFData) +#endif -- | Build an Aho-Corasick automaton that can be used for performing fast -- sequential replaces. @@ -76,17 +89,17 @@ build :: CaseSensitivity -> [(Needle, Replacement)] -> Replacer build caseSensitivity replaces = Replacer caseSensitivity searcher where - searcher = Searcher.buildWithValues $ zipWith mapNeedle [0..] replaces + searcher = Searcher.buildWithValues caseSensitivity $ zipWith mapNeedle [0..] replaces mapNeedle i (needle, replacement) = let needle' = case caseSensitivity of CaseSensitive -> needle - IgnoreCase -> Aho.lowerUtf16 needle + IgnoreCase -> Utf16.lowerUtf16 needle in -- Note that we negate i: earlier needles have a higher priority. We -- could avoid it and define larger integers to be lower priority, but -- that made the terminology in this module very confusing. - (needle', Payload (-i) (Aho.lengthUtf16 needle') replacement) + (needle', Payload (-i) (Utf16.lengthUtf16 needle') replacement) -- | Return the composition `replacer2` after `replacer1`, if they have the same -- case sensitivity. If the case sensitivity differs, Nothing is returned. @@ -100,7 +113,7 @@ renumber i (needle, Payload _ len replacement) = (needle, Payload (-i) len replacement) needles1 = Searcher.needles searcher1 needles2 = Searcher.needles searcher2 - searcher = Searcher.buildWithValues $ zipWith renumber [0..] (needles1 ++ needles2) + searcher = Searcher.buildWithValues case1 $ zipWith renumber [0..] (needles1 ++ needles2) in Just $ Replacer case1 searcher @@ -126,16 +139,16 @@ go !_offset [] remainder = [remainder] go !offset ((Match pos len replacement) : ms) remainder = let - (prefix, suffix) = Aho.unsafeCutUtf16 (pos - offset) len remainder + (prefix, suffix) = Utf16.unsafeCutUtf16 (pos - offset) len remainder in prefix : replacement : go (pos + len) ms suffix -- | Compute the length of the string resulting from applying the replacements. replacementLength :: [Match] -> Text -> CodeUnitIndex -replacementLength matches initial = go matches (Aho.lengthUtf16 initial) +replacementLength matches initial = go matches (Utf16.lengthUtf16 initial) where go [] !acc = acc - go (Match _ matchLen repl : rest) !acc = go rest (acc - matchLen + Aho.lengthUtf16 repl) + go (Match _ matchLen repl : rest) !acc = go rest (acc - matchLen + Utf16.lengthUtf16 repl) -- | Given a list of matches sorted on start position, remove matches that start -- within an earlier match. diff --git a/src/Data/Text/AhoCorasick/Searcher.hs b/src/Data/Text/AhoCorasick/Searcher.hs --- a/src/Data/Text/AhoCorasick/Searcher.hs +++ b/src/Data/Text/AhoCorasick/Searcher.hs @@ -4,15 +4,11 @@ -- Licensed under the 3-clause BSD license, see the LICENSE file in the -- repository root. --- See AhoCorasick.Automaton for more info about these GHC flags. --- TL;DR: They make things faster, and we need the flags here because the --- functions from that module may be inlined into this module. -{-# OPTIONS_GHC -fllvm -O2 -optlo=-O3 -optlo=-tailcallelim -fno-ignore-asserts #-} - {-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} module Data.Text.AhoCorasick.Searcher ( Searcher @@ -21,8 +17,9 @@ , needles , numNeedles , automaton + , caseSensitivity , containsAny - , containsAnyIgnoreCase + , setSearcherCaseSensitivity ) where @@ -32,7 +29,15 @@ import Data.Text (Text) import GHC.Generics (Generic) +#if defined(HAS_AESON) +import Data.Aeson ((.:), (.=)) +import qualified Data.Aeson as AE +#endif + +import Data.Text.AhoCorasick.Automaton (CaseSensitivity (..)) + import qualified Data.Text.AhoCorasick.Automaton as Aho +import qualified Data.Text.Utf16 as Utf16 -- | A set of needles with associated values, and an Aho-Corasick automaton to -- efficiently find those needles. @@ -50,21 +55,35 @@ -- -- We also use Hashed to cache the hash of the needles. data Searcher v = Searcher - { searcherNeedles :: Hashed [(Text, v)] + { searcherCaseSensitive :: CaseSensitivity + , searcherNeedles :: Hashed [(Text, v)] , searcherNumNeedles :: Int , searcherAutomaton :: Aho.AcMachine v } deriving (Generic) +#if defined(HAS_AESON) +instance AE.ToJSON v => AE.ToJSON (Searcher v) where + toJSON s = AE.object + [ "needles" .= needles s + , "caseSensitivity" .= caseSensitivity s + ] + +instance (Hashable v, AE.FromJSON v) => AE.FromJSON (Searcher v) where + parseJSON = AE.withObject "Searcher" $ \o -> buildWithValues <$> o .: "caseSensitivity" <*> o .: "needles" +#endif + instance Show (Searcher v) where show _ = "Searcher _ _ _" instance Hashable v => Hashable (Searcher v) where hashWithSalt salt searcher = hashWithSalt salt $ searcherNeedles searcher + {-# INLINE hashWithSalt #-} instance Eq v => Eq (Searcher v) where -- Since we store the length of the needle list anyway, -- we can use it to early out if there is a length mismatch. - Searcher xs nx _ == Searcher ys ny _ = (nx, xs) == (ny, ys) + Searcher cx xs nx _ == Searcher cy ys ny _ = (nx, xs, cx) == (ny, ys, cy) + {-# INLINE (==) #-} instance NFData v => NFData (Searcher v) @@ -75,17 +94,27 @@ -- reassign priorities, rather than concatenating the needle lists as-is and -- possibly having duplicate priorities in the resulting searcher. instance Semigroup (Searcher ()) where - x <> y = buildWithValues (needles x <> needles y) + x <> y + | caseSensitivity x == caseSensitivity y + = buildWithValues (searcherCaseSensitive x) (needles x <> needles y) + | otherwise = error "Combining searchers of different case sensitivity" + {-# INLINE (<>) #-} -build :: [Text] -> Searcher () -build = buildWithValues . fmap (\x -> (x, ())) +-- | Builds the Searcher for a list of needles +-- The caller is responsible that the needles are lower case in case the IgnoreCase +-- is used for case sensitivity +build :: CaseSensitivity -> [Text] -> Searcher () +build case_ = buildWithValues case_ . fmap (\x -> (x, ())) -buildWithValues :: Hashable v => [(Text, v)] -> Searcher v -buildWithValues ns = +-- | The caller is responsible that the needles are lower case in case the IgnoreCase +-- is used for case sensitivity +buildWithValues :: Hashable v => CaseSensitivity -> [(Text, v)] -> Searcher v +{-# INLINABLE buildWithValues #-} +buildWithValues case_ ns = let - unpack (text, value) = (Aho.unpackUtf16 text, value) + unpack (text, value) = (Utf16.unpackUtf16 text, value) in - Searcher (hashed ns) (length ns) $ Aho.build $ fmap unpack ns + Searcher case_ (hashed ns) (length ns) $ Aho.build $ fmap unpack ns needles :: Searcher v -> [(Text, v)] needles = unhashed . searcherNeedles @@ -96,8 +125,19 @@ automaton :: Searcher v -> Aho.AcMachine v automaton = searcherAutomaton +caseSensitivity :: Searcher v -> CaseSensitivity +caseSensitivity = searcherCaseSensitive + +-- | Updates the case sensitivity of the searcher. Does not change the +-- capitilization of the needles. The caller should be certain that if IgnoreCase +-- is passed, the needles are already lower case. +setSearcherCaseSensitivity :: CaseSensitivity -> Searcher v -> Searcher v +setSearcherCaseSensitivity case_ searcher = searcher{ + searcherCaseSensitive = case_ + } + -- | Return whether the haystack contains any of the needles. --- Is case sensitive. +-- Case sensitivity depends on the properties of the searcher -- This function is marked noinline as an inlining boundary. Aho.runText is -- marked inline, so this function will be optimized to report only whether -- there is a match, and not construct a list of matches. We don't want this @@ -111,16 +151,6 @@ let -- On the first match, return True immediately. f _acc _match = Aho.Done True - in - Aho.runText False f (automaton searcher) text - --- | Return whether the haystack contains any of the needles. --- Is case insensitive. The needles in the searcher should be lowercase. -{-# NOINLINE containsAnyIgnoreCase #-} -containsAnyIgnoreCase :: Searcher () -> Text -> Bool -containsAnyIgnoreCase !searcher !text = - let - -- On the first match, return True immediately. - f _acc _match = Aho.Done True - in - Aho.runLower False f (automaton searcher) text + in case caseSensitivity searcher of + CaseSensitive -> Aho.runText False f (automaton searcher) text + IgnoreCase -> Aho.runLower False f (automaton searcher) text diff --git a/src/Data/Text/AhoCorasick/Splitter.hs b/src/Data/Text/AhoCorasick/Splitter.hs new file mode 100644 --- /dev/null +++ b/src/Data/Text/AhoCorasick/Splitter.hs @@ -0,0 +1,189 @@ +-- Alfred-Margaret: Fast Aho-Corasick string searching +-- Copyright 2019 Channable +-- +-- Licensed under the 3-clause BSD license, see the LICENSE file in the +-- repository root. + +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} + +-- | Splitting strings using Aho–Corasick. +module Data.Text.AhoCorasick.Splitter + ( Splitter + , build + , automaton + , separator + , split + , splitIgnoreCase + , splitReverse + , splitReverseIgnoreCase + ) where + +import Control.DeepSeq (NFData (..)) +import Data.Function (on) +import Data.Hashable (Hashable (..)) +import Data.List.NonEmpty (NonEmpty ((:|))) +import Data.Text (Text) + +#if defined(HAS_AESON) +import qualified Data.Aeson as AE +#endif + +import qualified Data.List.NonEmpty as NonEmpty + +import Data.Text.AhoCorasick.Automaton (AcMachine) + +import qualified Data.Text.AhoCorasick.Automaton as Aho +import qualified Data.Text.Utf16 as Utf16 + +-------------------------------------------------------------------------------- +-- Splitter + +-- | Build a splitter once, then use it many times! +data Splitter = + Splitter + { splitterAutomaton :: AcMachine () -- INVARIANT: Exactly one needle. + , splitterSeparator :: Text -- INVARIANT: Equivalent to needle. + } + +#if defined(HAS_AESON) +instance AE.ToJSON Splitter where + toJSON = AE.toJSON . separator + +instance AE.FromJSON Splitter where + parseJSON v = build <$> AE.parseJSON v +#endif + +-- | Construct a splitter with a single separator. +{-# INLINE build #-} +build :: Text -> Splitter +build sep = + let !auto = Aho.build [(Utf16.unpackUtf16 sep, ())] in + Splitter auto sep + +-- | Get the automaton that would be used for finding separators. +{-# INLINE automaton #-} +automaton :: Splitter -> AcMachine () +automaton = splitterAutomaton + +-- | What is the separator we are splitting on? +{-# INLINE separator #-} +separator :: Splitter -> Text +separator = splitterSeparator + +-- | Split the given string into strings separated by the separator. +-- +-- If the order of the results is not important, use the faster function +-- 'splitReverse' instead. +{-# INLINE split #-} +split :: Splitter -> Text -> NonEmpty Text +split = (NonEmpty.reverse .) . splitReverse + +-- | Split the given string into strings separated by the separator. +-- +-- If the order of the results is not important, use the faster function +-- 'splitReverseIgnoreCase' instead. +-- +-- The separator is matched case-insensitively, but the splitter must have been +-- constructed with a lowercase needle. +{-# INLINE splitIgnoreCase #-} +splitIgnoreCase :: Splitter -> Text -> NonEmpty Text +splitIgnoreCase = (NonEmpty.reverse .) . splitReverseIgnoreCase + +-- | Like 'split', but return the substrings in reverse order. +{-# INLINE splitReverse #-} +splitReverse :: Splitter -> Text -> NonEmpty Text +splitReverse s t = + finalizeAccum $ + Aho.runText + (zeroAccum (separator s) t) + stepAccum + (automaton s) + t + +-- | Like 'splitIgnoreCase', but return the substrings in reverse order. +{-# INLINE splitReverseIgnoreCase #-} +splitReverseIgnoreCase :: Splitter -> Text -> NonEmpty Text +splitReverseIgnoreCase s t = + finalizeAccum $ + Aho.runLower + (zeroAccum (separator s) t) + stepAccum + (automaton s) + t + +-------------------------------------------------------------------------------- +-- Fold + +-- | The accumulator is used as state when processing the matches from left to +-- right. While the matches are fed to us ordered by end offset, all matches +-- have the same length because there is only one needle. +data Accum = + Accum + { _accumSepLen :: !Aho.CodeUnitIndex -- ^ Length of separator. + , _accumHaystack :: !Text -- ^ Haystack to slice off of. + , accumResult :: ![Text] -- ^ Match-separated strings. + , accumPrevEnd :: !Aho.CodeUnitIndex -- ^ Offset at end of last match. + } + +-- | Finalizing the accumulator does more than just 'accumResult', hence this +-- is a separate function. +{-# INLINE finalizeAccum #-} +finalizeAccum :: Accum -> NonEmpty Text +finalizeAccum (Accum _ hay res prevEnd) = + -- Once we have processed all the matches, there is still the substring after + -- the final match. This substring is always included in the result, even + -- when there were no matches. Hence we can return a non-empty list. + let !str = Utf16.unsafeSliceUtf16 prevEnd (Utf16.lengthUtf16 hay - prevEnd) hay in + str :| res + +-- | The initial accumulator begins at the begin of the haystack. +{-# INLINE zeroAccum #-} +zeroAccum :: Text -> Text -> Accum +zeroAccum sep hay = Accum (Utf16.lengthUtf16 sep) hay [] 0 + +-- | Step the accumulator using the next match. Overlapping matches will be +-- ignored. Overlapping matches may occur when the separator has a non-empty +-- prefix that is also a suffix. +{-# INLINE stepAccum #-} +stepAccum :: Accum -> Aho.Match v -> Aho.Next Accum +stepAccum acc@(Accum sepLen hay res prevEnd) (Aho.Match sepEnd _) + + -- When the match begins before the current offset, it overlaps a match that + -- we processed before, and so we ignore it. + | sepEnd - sepLen < prevEnd = + Aho.Step acc + + -- The match is behind the current offset, so we slice the haystack until the + -- begin of the match and include that as a result. + | otherwise = + let !str = Utf16.unsafeSliceUtf16 prevEnd (sepEnd - sepLen - prevEnd) hay in + Aho.Step acc { accumResult = str : res, accumPrevEnd = sepEnd } + +-------------------------------------------------------------------------------- +-- Instances + +instance Eq Splitter where + {-# INLINE (==) #-} + (==) = (==) `on` separator + +instance Ord Splitter where + {-# INLINE compare #-} + compare = compare `on` separator + +instance Hashable Splitter where + {-# INLINE hashWithSalt #-} + hashWithSalt salt searcher = + salt `hashWithSalt` separator searcher + +instance NFData Splitter where + {-# INLINE rnf #-} + rnf (Splitter searcher sepLength) = + rnf searcher `seq` + rnf sepLength + +instance Show Splitter where + showsPrec p splitter = + showParen (p > 10) $ + showString "build " . + showsPrec 11 (separator splitter) diff --git a/src/Data/Text/BoyerMoore/Automaton.hs b/src/Data/Text/BoyerMoore/Automaton.hs new file mode 100644 --- /dev/null +++ b/src/Data/Text/BoyerMoore/Automaton.hs @@ -0,0 +1,372 @@ +-- Alfred-Margaret: Fast Aho-Corasick string searching +-- Copyright 2019 Channable +-- +-- Licensed under the 3-clause BSD license, see the LICENSE file in the +-- repository root. + +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | An efficient implementation of the Boyer-Moore string search algorithm. +-- http://www-igm.univ-mlv.fr/~lecroq/string/node14.html#SECTION00140 +-- https://en.wikipedia.org/wiki/Boyer%E2%80%93Moore_string-search_algorithm +-- +-- This module contains a almost 1:1 translation from the C example code in the +-- wikipedia article. +-- +-- The algorithm here can be potentially improved by including the Galil rule +-- (https://en.wikipedia.org/wiki/Boyer%E2%80%93Moore_string-search_algorithm#The_Galil_rule) +module Data.Text.BoyerMoore.Automaton + ( + Automaton + , CaseSensitivity (..) + , buildAutomaton + , runText + , runLower + , patternLength + , patternText + + , CodeUnitIndex (..) + , Next (..) + ) + where + +import Prelude hiding (length) + +import Control.DeepSeq (NFData) +import Control.Monad (when) +import Control.Monad.ST (runST) +import Data.Hashable (Hashable (..), Hashed, hashed, unhashed) +import Data.Text.Internal (Text (..)) +import GHC.Generics (Generic) + +#if defined(HAS_AESON) +import qualified Data.Aeson as AE +#endif +import qualified Data.HashMap.Strict as HashMap +import qualified Data.Vector.Unboxed as UVector +import qualified Data.Vector.Unboxed.Mutable as UMVector + +import Data.Text.AhoCorasick.Automaton (CaseSensitivity (..), Next (..)) +import Data.Text.Utf16 (CodeUnit, CodeUnitIndex (..), lengthUtf16, lowerCodeUnit, lengthUtf16, unsafeIndexUtf16) + +-- | A Boyer-Moore automaton is based on lookup-tables that allow skipping through the haystack. +-- This allows for sub-linear matching in some cases, as we do not have to look at every input +-- character. +-- +-- NOTE: Unlike the AcMachine, a Boyer-Moore automaton only returns non-overlapping matches. +-- This means that a Boyer-Moore automaton is not a 100% drop-in replacement for Aho-Corasick. +-- +-- Returning overlapping matches would degrade the performance to /O(nm)/ in pathological cases like +-- finding @aaaa@ in @aaaaa....aaaaaa@ as for each match it would scan back the whole /m/ characters +-- of the pattern. +data Automaton = Automaton + { automatonPattern :: Hashed Text + , automatonSuffixTable :: SuffixTable + , automatonBadCharTable :: BadCharTable + } + deriving stock (Generic, Show) + deriving anyclass (NFData) + +instance Hashable Automaton where + hashWithSalt salt (Automaton pattern _ _) = hashWithSalt salt pattern + +instance Eq Automaton where + (Automaton pat1 _ _) == (Automaton pat2 _ _) = pat1 == pat2 + +#if defined(HAS_AESON) +instance AE.FromJSON Automaton where + parseJSON v = buildAutomaton <$> AE.parseJSON v + +instance AE.ToJSON Automaton where + toJSON = AE.toJSON . unhashed . automatonPattern +#endif + +buildAutomaton :: Text -> Automaton +buildAutomaton pattern = Automaton (hashed pattern) (buildSuffixTable pattern) (buildBadCharTable pattern) + +runWithCase + :: forall a + . CaseSensitivity + -> a + -> (a -> CodeUnitIndex -> Next a) + -> Automaton + -> Text + -> a +{-# INLINE runWithCase #-} +runWithCase caseSensitivity seed f automaton text + | patLen == 0 = seed + | otherwise = go seed (patLen - 1) + where + Automaton patternHashed suffixTable badCharTable = automaton + pattern = unhashed patternHashed + patLen = lengthUtf16 pattern + stringLen = lengthUtf16 text + + inputCasedAt = case caseSensitivity of + CaseSensitive -> indexCodePoint text + IgnoreCase -> lowerCodeUnit . indexCodePoint text + + go result haystackIndex + | haystackIndex < stringLen = matchLoop result haystackIndex (patLen - 1) + | otherwise = result + {-# INLINE go #-} + + -- Compare the needle back-to-front with the haystack + matchLoop result haystackIndex needleIndex + | needleIndex >= 0 && inputCasedAt haystackIndex == indexCodePoint pattern needleIndex = + -- Characters match, try the pair before + matchLoop result (haystackIndex - 1) (needleIndex - 1) + -- We found a match (all needle characters matched) + | needleIndex < 0 = + case f result (haystackIndex + 1) of + Done final -> final + -- `haystackIndex` now points to the character just before the match starts + -- Adding `patLen` once points to the last character of the match, + -- Adding `patLen` once more points to the earliest character where + -- we can find a non-overlapping match. + Step intermediate -> go intermediate (haystackIndex + 2 * patLen) + -- We know it's not a match, the characters differ at the current position + | otherwise = + let + -- The bad character table tells us how far we can advance to the right so that the + -- character at the current position in the input string, where matching failed, + -- is lined up with it's rightmost occurrence in the needle. + -- Note: we could end up left of were we started, essentially never making progress, + -- if we were to use this rule alone. + badCharSkip = badCharLookup badCharTable (inputCasedAt haystackIndex) + suffixSkip = suffixLookup suffixTable needleIndex + skip = max badCharSkip suffixSkip + in + go result (haystackIndex + skip) + +-- | Finds all matches in the text, calling the match callback with the *first* +-- matched character of each match of the pattern. +-- +-- NOTE: This is unlike Aho-Corasick, which reports the index of the character +-- right after a match. +-- +-- NOTE: To get full advantage of inlining this function, you probably want to +-- compile the compiling module with -fllvm and the same optimization flags as +-- this module. +{-# INLINE runText #-} +runText :: forall a. a -> (a -> CodeUnitIndex -> Next a) -> Automaton -> Text -> a +runText = runWithCase CaseSensitive + +-- | Finds all matches in the lowercased text. This function lowercases the text +-- on the fly to avoid allocating a second lowercased text array. Lowercasing is +-- applied to individual code units, so the indexes into the lowercased text can +-- be used to index into the original text. It is still the responsibility of +-- the caller to lowercase the needles. Needles that contain uppercase code +-- points will not match. +-- +-- NOTE: To get full advantage of inlining this function, you probably want to +-- compile the compiling module with -fllvm and the same optimization flags as +-- this module. +{-# INLINE runLower #-} +runLower :: forall a. a -> (a -> CodeUnitIndex -> Next a) -> Automaton -> Text -> a +runLower = runWithCase IgnoreCase + +-- | Length of the matched pattern measured in Utf16 code units. +patternLength :: Automaton -> CodeUnitIndex +patternLength = lengthUtf16 . patternText + +-- | Return the pattern that was used to construct the automaton. +patternText :: Automaton -> Text +patternText (Automaton pattern _ _) = unhashed pattern + +-- | The suffix table tells us for each character of the pattern how many characters we can +-- jump ahead if the match fails at that point. +newtype SuffixTable = SuffixTable (UVector.Vector Int) + deriving stock (Generic, Show) + deriving anyclass (NFData) + +-- | Lookup an entry in the suffix table. +suffixLookup :: SuffixTable -> CodeUnitIndex -> CodeUnitIndex +{-# INLINE suffixLookup #-} +suffixLookup (SuffixTable table) = CodeUnitIndex . indexTable table . codeUnitIndex + +buildSuffixTable :: Text -> SuffixTable +buildSuffixTable pattern = runST $ do + let patLen = lengthUtf16 pattern + + table <- UMVector.new $ codeUnitIndex patLen + + let + -- Case 1: For each position of the pattern we record the shift that would align the pattern so + -- that it starts at the longest suffix that is at the same time a prefix, if a mismatch would + -- happen at that position. + -- + -- Suppose the length of the pattern is n, a mismatch occurs at position i in the pattern and j + -- in the haystack, then we know that pattern[i+1..n] == haystack[j+1..j+n-i]. That is, we know + -- that the part of the haystack that we already matched is a suffix of the pattern. + -- If the pattern happens to have a prefix that is equal to or a shorter suffix of that matched + -- suffix, we can shift the pattern to the right so that the pattern starts at the longest + -- suffix that we have seen that conincides with a prefix of the pattern. + -- + -- Consider the pattern `ababa`. Then we get + -- + -- p: 0 1 2 3 4 + -- Pattern: a b a b a + -- lastPrefixIndex: 2 2 4 4 5 + -- table: 6 5 6 5 5 + init1 lastPrefixIndex p + | p >= 0 = do + let + prefixIndex + | isPrefix pattern (p + 1) = p + 1 + | otherwise = lastPrefixIndex + UMVector.write table (codeUnitIndex p) (codeUnitIndex $ prefixIndex + patLen - 1 - p) + init1 prefixIndex (p - 1) + | otherwise = pure () + + -- Case 2: We also have to account for the fact that the matching suffix of the pattern might + -- occur again somewhere within the pattern. In that case, we may not shift as far as if it was + -- a prefix. That is why the `init2` loop is run after `init1`, potentially overwriting some + -- entries with smaller shifts. + init2 p + | p < patLen - 1 = do + let + suffixLen = suffixLength pattern p + when (indexCodePoint pattern (p - suffixLen) /= indexCodePoint pattern (patLen - 1 - suffixLen)) $ + UMVector.write table (codeUnitIndex $ patLen - 1 - suffixLen) (codeUnitIndex $ patLen - 1 - p + suffixLen) + init2 (p + 1) + | otherwise = pure () + + init1 (patLen - 1) (patLen - 1) + init2 0 + + SuffixTable <$> UVector.unsafeFreeze table + + +-- | The bad char table tells us how far we may skip ahead when encountering a certain character +-- in the input string. For example, if there's a character that is not contained in the pattern at +-- all, we can skip ahead until after that character. +data BadCharTable = BadCharTable + { badCharTableAscii :: {-# UNPACK #-} !(UVector.Vector Int) + -- ^ The element type should be CodeUnitIndex, but there's no unboxed vector for that type, and + -- defining it would be a lot of boilerplate. + , badCharTableNonAscii :: !(HashMap.HashMap CodeUnit CodeUnitIndex) + , badCharTablePatternLen :: CodeUnitIndex + } + deriving stock (Generic, Show) + deriving anyclass (NFData) + +-- | Number of entries in the fixed-size lookup-table of the bad char table. +asciiCount :: Int +{-# INLINE asciiCount #-} +asciiCount = 128 + +-- | Lookup an entry in the bad char table. +badCharLookup :: BadCharTable -> CodeUnit -> CodeUnitIndex +{-# INLINE badCharLookup #-} +badCharLookup (BadCharTable asciiTable nonAsciis patLen) char + | intChar < asciiCount = CodeUnitIndex $ indexTable asciiTable intChar + | otherwise = HashMap.lookupDefault patLen char nonAsciis + where + intChar = fromIntegral char + +-- | True if the suffix of the @pattern@ starting from @pos@ is a prefix of the pattern +-- For example, @isPrefix \"aabbaa\" 4 == True@. +isPrefix :: Text -> CodeUnitIndex -> Bool +isPrefix pattern pos = go 0 + where + suffixLen = lengthUtf16 pattern - pos + go i + | i < suffixLen = + if indexCodePoint pattern i == indexCodePoint pattern (pos + i) + then go (i + 1) + else False + | otherwise = True + +-- | Length of the longest suffix of the pattern ending on @pos@. +-- For example, @suffixLength \"abaacbbaac\" 4 == 4@, because the substring \"baac\" ends at position +-- 4 and is at the same time the longest suffix that does so, having length 4. +suffixLength :: Text -> CodeUnitIndex -> CodeUnitIndex +suffixLength pattern pos = go 0 + where + patLen = lengthUtf16 pattern + go i + | indexCodePoint pattern (pos - i) == indexCodePoint pattern (patLen - 1 - i) && i < pos = go (i + 1) + | otherwise = i + +buildBadCharTable :: Text -> BadCharTable +buildBadCharTable pattern = runST $ do + let patLen = lengthUtf16 pattern + + -- Initialize table with the maximum skip distance, which is the length of the pattern. + -- This applies to all characters that are not part of the pattern. + asciiTable <- UMVector.replicate asciiCount $ codeUnitIndex patLen + + let + -- Fill the bad character table based on the rightmost occurrence of a character in the pattern. + -- Note that there is also a variant of Boyer-Moore that records all positions (see Wikipedia, + -- but that requires even more storage space). + -- Also note that we exclude the last character of the pattern when building the table. + -- This is because + -- + -- 1. If the last character does not occur anywhere else in the pattern and we encounter it + -- during a mismatch, we can advance the pattern to just after that character: + -- + -- Haystack: aaadcdabcdbb + -- Pattern: abcd + -- + -- In the above example, we would match `d` and `c`, but then fail because `d` != `b`. + -- Since `d` only occurs at the very last position of the pattern, we can shift to + -- + -- Haystack: aaadcdabcdbb + -- Pattern: abcd + -- + -- 2. If it does occur anywhere else in the pattern, we can only shift as far as it's necessary + -- to align it with the haystack: + -- + -- Haystack: aaadddabcdbb + -- Pattern: adcd + -- + -- We match `d`, and then there is a mismatch `d` != `c`, which allows us to shift only up to: + + -- Haystack: aaadddabcdbb + -- Pattern: adcd + fillTable !i !nonAsciis + -- for(i = 0; i < patLen - 1; i++) { + | i < patLen - 1 = do + let patChar = indexCodePoint pattern i + if fromIntegral patChar < asciiCount + then do + UMVector.write asciiTable (fromIntegral patChar) (codeUnitIndex $ patLen - 1 - i) + fillTable (i + 1) nonAsciis + else + fillTable (i + 1) (HashMap.insert patChar (patLen - 1 - i) nonAsciis) + -- } + | otherwise = pure nonAsciis + + nonAsciis <- fillTable 0 HashMap.empty + + asciiTableFrozen <- UVector.unsafeFreeze asciiTable + + pure BadCharTable + { badCharTableAscii = asciiTableFrozen + , badCharTableNonAscii = nonAsciis + , badCharTablePatternLen = patLen + } + + +-- Helper functions for easily toggling the safety of this module + +-- | Read from a lookup table at the specified index. +indexTable :: UVector.Unbox a => UVector.Vector a -> Int -> a +{-# INLINE indexTable #-} +indexTable = (UVector.!) -- UVector.unsafeIndex + + +-- | Read from a lookup table at the specified index. +indexCodePoint :: Text -> CodeUnitIndex -> CodeUnit +{-# INLINE indexCodePoint #-} +indexCodePoint text index + | index < 0 || index >= lengthUtf16 text = error $ "Index out of bounds " ++ show index + | otherwise = unsafeIndexUtf16 text index diff --git a/src/Data/Text/BoyerMoore/Replacer.hs b/src/Data/Text/BoyerMoore/Replacer.hs new file mode 100644 --- /dev/null +++ b/src/Data/Text/BoyerMoore/Replacer.hs @@ -0,0 +1,98 @@ +-- Alfred-Margaret: Fast Aho-Corasick string searching +-- Copyright 2019 Channable +-- +-- Licensed under the 3-clause BSD license, see the LICENSE file in the +-- repository root. + +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleInstances #-} + +module Data.Text.BoyerMoore.Replacer + ( -- Replacer + replaceSingleLimited + ) + where + +import Data.Text (Text) +import Data.Text.BoyerMoore.Automaton (CodeUnitIndex, Automaton) + +import qualified Data.Text as Text + +import Data.Text.BoyerMoore.Automaton (CaseSensitivity (..)) + +import qualified Data.Text.BoyerMoore.Automaton as BoyerMoore +import qualified Data.Text.Utf16 as Utf16 + +-- | Replace all occurrences matched by the Boyer-Moore automaton +-- with the given replacement text in some haystack. +replaceSingleLimited + :: CaseSensitivity + -- ^ In case of 'IgnoreCase', the automaton must have been created with a lower-case needle + -> Automaton -- ^ Matches the needles + -> Text -- ^ Replacement string + -> Text -- ^ Haystack + -> CodeUnitIndex -- ^ Maximum number of code units in the returned text + -> Maybe Text +replaceSingleLimited caseSensitivity needle replacement haystack maxLength + | needleLength == 0 = Just $ if haystackLength == 0 then replacement else haystack + | otherwise = finish $ case caseSensitivity of + CaseSensitive -> BoyerMoore.runText initial foundMatch needle haystack + IgnoreCase -> BoyerMoore.runLower initial foundMatch needle haystack + where + needleLength = BoyerMoore.patternLength needle + haystackLength = Utf16.lengthUtf16 haystack + replacementLength = Utf16.lengthUtf16 replacement + + initial = ReplaceState + { rsChunks = [] + , rsPreviousMatchEnd = 0 + , rsLength = 0 + } + + foundMatch rs matchStart = + let + matchEnd = matchStart + needleLength + + -- Slice the part of the haystack between the end of the previous match + -- and the start of the current match + haystackPartLength = matchStart - rsPreviousMatchEnd rs + haystackPart = Utf16.unsafeSliceUtf16 (rsPreviousMatchEnd rs) haystackPartLength haystack + + -- Add the preceding part of the haystack and the replacement in reverse + -- order to the chunk list (all chunks will be reversed at once in the final step). + newChunks = replacement : haystackPart : rsChunks rs + newLength = replacementLength + haystackPartLength + rsLength rs + + newState = ReplaceState + { rsChunks = newChunks + , rsPreviousMatchEnd = matchEnd + , rsLength = newLength + } + in + if newLength > maxLength + then BoyerMoore.Done newState + else BoyerMoore.Step newState + + finish rs = + let + -- Slice the remaining part of the haystack from the end of the last match + -- to the end of the haystack. + haystackPartLength = haystackLength - rsPreviousMatchEnd rs + finalChunks + = Utf16.unsafeSliceUtf16 (rsPreviousMatchEnd rs) haystackPartLength haystack + : rsChunks rs + finalLength = rsLength rs + haystackPartLength + in + if finalLength > maxLength + then Nothing + else Just $ Text.concat $ reverse finalChunks + +-- | Internal accumulator state for performing a replace while stepping an automaton +data ReplaceState = ReplaceState + { rsChunks :: [Text] + -- ^ Chunks of the final text, in reverse order so that we can efficiently prepend + , rsPreviousMatchEnd :: !CodeUnitIndex + -- ^ Index one past the end of the last match. + , rsLength :: !CodeUnitIndex + -- ^ Length of the newly build string so far, measured in CodeUnits + } diff --git a/src/Data/Text/BoyerMoore/Searcher.hs b/src/Data/Text/BoyerMoore/Searcher.hs new file mode 100644 --- /dev/null +++ b/src/Data/Text/BoyerMoore/Searcher.hs @@ -0,0 +1,125 @@ +-- Alfred-Margaret: Fast Aho-Corasick string searching +-- Copyright 2019 Channable +-- +-- Licensed under the 3-clause BSD license, see the LICENSE file in the +-- repository root. + +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} + +module Data.Text.BoyerMoore.Searcher + ( Searcher + , build + , buildWithValues + , needles + , numNeedles + , automata + , caseSensitivity + , containsAny + , setSearcherCaseSensitivity + ) + where + + +import Control.DeepSeq (NFData) +import Data.Bifunctor (first) +import Data.Hashable (Hashable (hashWithSalt), Hashed, hashed, unhashed) +import Data.Text (Text) +import GHC.Generics (Generic) + +import Data.Text.BoyerMoore.Automaton (Automaton, CaseSensitivity (..)) + +import qualified Data.Text.BoyerMoore.Automaton as BoyerMoore + +-- | A set of needles with associated values, and Boyer-Moore automata to +-- efficiently find those needles. +-- +-- INVARIANT: searcherAutomaton = BoyerMoore.buildAutomaton . searcherNeedles +-- To enforce this invariant, the fields are not exposed from this module. +-- There is a separate constructor function. +-- +-- The purpose of this wrapper is to have a type that is Hashable and Eq, so we +-- can derive those for the types that embed the searcher, whithout +-- requiring the automaton itself to be Hashable or Eq, which would be both +-- wasteful and tedious. Because the automaton is fully determined by the +-- needles and associated values, it is sufficient to implement Eq and Hashable +-- in terms of the needles only. +-- +-- We also use Hashed to cache the hash of the needles. +data Searcher v = Searcher + { searcherCaseSensitive :: CaseSensitivity + , searcherNeedles :: Hashed [(Text, v)] + , searcherNumNeedles :: Int + , searcherAutomata :: [(Automaton, v)] + } deriving (Generic) + +instance Show (Searcher v) where + show _ = "Searcher _ _ _" + +instance Hashable v => Hashable (Searcher v) where + hashWithSalt salt searcher = hashWithSalt salt $ searcherNeedles searcher + {-# INLINE hashWithSalt #-} + +instance Eq v => Eq (Searcher v) where + Searcher cx xs nx _ == Searcher cy ys ny _ = (cx, nx, xs) == (cy, ny, ys) + {-# INLINE (==) #-} + +instance NFData v => NFData (Searcher v) + +-- | Builds the Searcher for a list of needles +-- The caller is responsible that the needles are lower case in case the IgnoreCase +-- is used for case sensitivity +build :: CaseSensitivity -> [Text] -> Searcher () +{-# INLINABLE build #-} +build case_ = buildWithValues case_ . flip zip (repeat ()) + +-- | The caller is responsible that the needles are lower case in case the IgnoreCase +-- is used for case sensitivity +buildWithValues :: Hashable v => CaseSensitivity -> [(Text, v)] -> Searcher v +{-# INLINABLE buildWithValues #-} +buildWithValues case_ ns = + Searcher case_ (hashed ns) (length ns) $ map (first BoyerMoore.buildAutomaton) ns + +needles :: Searcher v -> [(Text, v)] +needles = unhashed . searcherNeedles + +automata :: Searcher v -> [(Automaton, v)] +automata = searcherAutomata + +numNeedles :: Searcher v -> Int +numNeedles = searcherNumNeedles + +caseSensitivity :: Searcher v -> CaseSensitivity +caseSensitivity = searcherCaseSensitive + +-- | Updates the case sensitivity of the searcher. Does not change the +-- capitilization of the needles. The caller should be certain that if IgnoreCase +-- is passed, the needles are already lower case. +setSearcherCaseSensitivity :: CaseSensitivity -> Searcher v -> Searcher v +setSearcherCaseSensitivity case_ searcher = searcher{ + searcherCaseSensitive = case_ + } + + +-- | Return whether the haystack contains any of the needles. +-- Case sensitivity depends on the properties of the searcher +-- This function is marked noinline as an inlining boundary. BoyerMoore.runText is +-- marked inline, so this function will be optimized to report only whether +-- there is a match, and not construct a list of matches. We don't want this +-- function be inline, to make sure that the conditions of the caller don't +-- affect how this function is optimized. There is little to gain from +-- additional inlining. The pragma is not an optimization in itself, rather it +-- is a defence against fragile optimizer decisions. +{-# NOINLINE containsAny #-} +containsAny :: Searcher () -> Text -> Bool +containsAny !searcher !text = + let + -- On the first match, return True immediately. + f _acc _match = BoyerMoore.Done True + in + case caseSensitivity searcher of + CaseSensitive -> + any (\(automaton, ()) -> BoyerMoore.runText False f automaton text) (automata searcher) + IgnoreCase -> + any (\(automaton, ()) -> BoyerMoore.runLower False f automaton text) (automata searcher) diff --git a/src/Data/Text/Utf16.hs b/src/Data/Text/Utf16.hs new file mode 100644 --- /dev/null +++ b/src/Data/Text/Utf16.hs @@ -0,0 +1,230 @@ +-- Alfred-Margaret: Fast Aho-Corasick string searching +-- Copyright 2019 Channable +-- +-- Licensed under the 3-clause BSD license, see the LICENSE file in the +-- repository root. + +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +-- | This module provides functions that allow treating Text values as series of Utf16 codepoints +-- instead of characters. +module Data.Text.Utf16 + ( CodeUnit + , CodeUnitIndex (..) + , lengthUtf16 + , lowerUtf16 + , lowerCodeUnit + , upperUtf16 + , upperCodeUnit + , isCaseInvariant + , unpackUtf16 + , unsafeCutUtf16 + , unsafeSliceUtf16 + , unsafeIndexUtf16 + , indexTextArray + ) where + +import Prelude hiding (length) + +import Control.DeepSeq (NFData) +import Control.Exception (assert) +import Data.Hashable (Hashable) +import Data.Primitive.ByteArray (ByteArray (..), sizeofByteArray) +import Data.Text.Internal (Text (..)) +import Data.Word (Word16) +import GHC.Generics (Generic) + +#if defined(HAS_AESON) +import qualified Data.Aeson as AE +#endif + +import qualified Data.Char as Char +import qualified Data.Text as Text +import qualified Data.Text.Array as TextArray +import qualified Data.Text.Unsafe as TextUnsafe +import qualified Data.Vector.Primitive as PVector + +-- | A code unit is a 16-bit integer from which UTF-16 encoded text is built up. +-- The `Text` type is represented as a UTF-16 string. +type CodeUnit = Word16 + +-- | An index into the raw UTF-16 data of a `Text`. This is not the code point +-- index as conventionally accepted by `Text`, so we wrap it to avoid confusing +-- the two. Incorrect index manipulation can lead to surrogate pairs being +-- sliced, so manipulate indices with care. This type is also used for lengths. +newtype CodeUnitIndex = CodeUnitIndex + { codeUnitIndex :: Int + } + deriving stock (Eq, Ord, Show, Generic, Bounded) +#if defined(HAS_AESON) + deriving newtype (Hashable, Num, NFData, AE.FromJSON, AE.ToJSON) +#else + deriving newtype (Hashable, Num, NFData) +#endif + + +-- | Return a Text as a list of UTF-16 code units. +{-# INLINABLE unpackUtf16 #-} +unpackUtf16 :: Text -> [CodeUnit] +unpackUtf16 (Text u16data offset length) = + let + go _ 0 = [] + go i n = indexTextArray u16data i : go (i + 1) (n - 1) + in + go offset length + +-- | Return whether the code unit at the given index starts a surrogate pair. +-- Such a code unit must be followed by a low surrogate in valid UTF-16. +-- Returns false on out of bounds indices. +{-# INLINE isHighSurrogate #-} +isHighSurrogate :: Int -> Text -> Bool +isHighSurrogate !i (Text !u16data !offset !len) = + let + w = indexTextArray u16data (offset + i) + in + i >= 0 && i < len && w >= 0xd800 && w <= 0xdbff + +-- | Return whether the code unit at the given index ends a surrogate pair. +-- Such a code unit must be preceded by a high surrogate in valid UTF-16. +-- Returns false on out of bounds indices. +{-# INLINE isLowSurrogate #-} +isLowSurrogate :: Int -> Text -> Bool +isLowSurrogate !i (Text !u16data !offset !len) = + let + w = indexTextArray u16data (offset + i) + in + i >= 0 && i < len && w >= 0xdc00 && w <= 0xdfff + +-- | Extract a substring from a text, at a code unit offset and length. +-- This is similar to `Text.take length . Text.drop begin`, except that the +-- begin and length are in code *units*, not code points, so we can slice the +-- UTF-16 array, and we don't have to walk the entire text to take surrogate +-- pairs into account. It is the responsibility of the user to not slice +-- surrogate pairs, and to ensure that the length is within bounds, hence this +-- function is unsafe. +{-# INLINE unsafeSliceUtf16 #-} +unsafeSliceUtf16 :: CodeUnitIndex -> CodeUnitIndex -> Text -> Text +unsafeSliceUtf16 (CodeUnitIndex !begin) (CodeUnitIndex !length) !text + = assert (begin + length <= TextUnsafe.lengthWord16 text) + $ assert (not $ isLowSurrogate begin text) + $ assert (not $ isHighSurrogate (begin + length - 1) text) + $ TextUnsafe.takeWord16 length $ TextUnsafe.dropWord16 begin text + +-- | The complement of `unsafeSliceUtf16`: removes the slice, and returns the +-- part before and after. See `unsafeSliceUtf16` for details. +{-# INLINE unsafeCutUtf16 #-} +unsafeCutUtf16 :: CodeUnitIndex -> CodeUnitIndex -> Text -> (Text, Text) +unsafeCutUtf16 (CodeUnitIndex !begin) (CodeUnitIndex !length) !text + = assert (begin + length <= TextUnsafe.lengthWord16 text) + $ assert (not $ isLowSurrogate begin text) + $ assert (not $ isHighSurrogate (begin + length - 1) text) + ( TextUnsafe.takeWord16 begin text + , TextUnsafe.dropWord16 (begin + length) text + ) + +-- | Return the length of the text, in number of code units. +{-# INLINE lengthUtf16 #-} +lengthUtf16 :: Text -> CodeUnitIndex +lengthUtf16 = CodeUnitIndex . TextUnsafe.lengthWord16 + +-- | Return the code unit (not character) with the given index. +-- Note: The boudns are not checked. +unsafeIndexUtf16 :: Text -> CodeUnitIndex -> CodeUnit +{-# INLINE unsafeIndexUtf16 #-} +unsafeIndexUtf16 (Text arr off _) (CodeUnitIndex pos) = indexTextArray arr (pos + off) + +-- | Apply a function to each code unit of a text. +{-# INLINABLE mapUtf16 #-} +mapUtf16 :: (CodeUnit -> CodeUnit) -> Text -> Text +mapUtf16 f (Text u16data offset length) = + let + get !i = f $ indexTextArray u16data (offset + i) + !(PVector.Vector !offset' !length' !(ByteArray !u16data')) = + PVector.generate length get + in + Text (TextArray.Array u16data') offset' length' + +-- | Lowercase each individual code unit of a text without changing their index. +-- This is not a proper case folding, but it does ensure that indices into the +-- lowercased string correspond to indices into the original string. +-- +-- Differences from `Text.toLower` include code points in the BMP that lowercase +-- to multiple code points, and code points outside of the BMP. +-- +-- For example, "İ" (U+0130), which `toLower` converts to "i" (U+0069, U+0307), +-- is converted into U+0069 only by `lowerUtf16`. +-- Also, "𑢢" (U+118A2), a code point from the Warang City writing system in the +-- Supplementary Multilingual Plane, introduced in 2014 to Unicode 7. It would +-- be lowercased to U+118C2 by `toLower`, but it is left untouched by +-- `lowerUtf16`. +{-# INLINE lowerUtf16 #-} +lowerUtf16 :: Text -> Text +lowerUtf16 = mapUtf16 lowerCodeUnit + +-- | Convert CodeUnits that represent a character on their own (i.e. that are not part of a +-- surrogate pair) to their lower case representation. +-- +-- This function has a special code path for ASCII characters, because Char.toLower +-- is **incredibly** slow. It's implemented there if you want to see for yourself: +-- (https://github.com/ghc/ghc/blob/ghc-8.6.3-release/libraries/base/cbits/WCsubst.c#L4732) +-- (It does a binary search on 1276 casing rules) +{-# INLINE lowerCodeUnit #-} +lowerCodeUnit :: CodeUnit -> CodeUnit +lowerCodeUnit cu + -- ASCII letters A..Z and a..z are two contiguous blocks. + -- Converting to lower case amounts to adding a fixed offset. + | fromIntegral cu >= Char.ord 'A' && fromIntegral cu <= Char.ord 'Z' + = cu + fromIntegral (Char.ord 'a' - Char.ord 'A') + + -- Everything else in ASCII is invariant under toLower. + -- The a..z range is already lower case, and all non-letter characters are case-invariant. + | cu <= 127 = cu + + -- This code unit is part of a surrogate pair. Don't touch those, because + -- we don't have all information required to decode the code point. Note + -- that alphabets that need to be encoded as surrogate pairs are mostly + -- archaic and obscure; all of the languages used by our customers have + -- alphabets in the Basic Multilingual Plane, which does not need surrogate + -- pairs. Note that the BMP is not just ascii or extended ascii. See also + -- https://codepoints.net/basic_multilingual_plane. + | cu >= 0xd800 && cu < 0xe000 = cu + + -- The code unit is a code point on its own (not part of a surrogate pair), + -- lowercase the code point. These code points, which are all in the BMP, + -- have the important property that lowercasing them is again a code point + -- in the BMP, so the output can be encoded in exactly one code unit, just + -- like the input. This property was verified by exhaustive testing; see + -- also the test in AhoCorasickSpec.hs. + | otherwise = fromIntegral $ Char.ord $ Char.toLower $ Char.chr $ fromIntegral cu + +{-# INLINE upperUtf16 #-} +upperUtf16 :: Text -> Text +upperUtf16 = mapUtf16 upperCodeUnit + +{-# INLINE upperCodeUnit #-} +upperCodeUnit :: CodeUnit -> CodeUnit +upperCodeUnit cu + -- Analogous implementation to lowerCodeUnit + | fromIntegral cu >= Char.ord 'a' && fromIntegral cu <= Char.ord 'z' + = cu - fromIntegral (Char.ord 'a' - Char.ord 'A') + | cu <= 127 = cu + | cu >= 0xd800 && cu < 0xe000 = cu + | otherwise = fromIntegral $ Char.ord $ Char.toUpper $ Char.chr $ fromIntegral cu + +-- | Return whether text is the same lowercase as uppercase, such that this +-- function will not return true when Aho–Corasick would differentiate when +-- doing case-insensitive matching. +{-# INLINE isCaseInvariant #-} +isCaseInvariant :: Text -> Bool +isCaseInvariant = Text.all (\c -> Char.toLower c == Char.toUpper c) + +{-# INLINE indexTextArray #-} +indexTextArray :: TextArray.Array -> Int -> CodeUnit +indexTextArray array@(TextArray.Array byteArray) index + = assert (2 * index < sizeofByteArray (ByteArray byteArray)) + $ assert (0 <= index) + $ TextArray.unsafeIndex array index diff --git a/tests/AhoCorasickSpec.hs b/tests/AhoCorasickSpec.hs deleted file mode 100644 --- a/tests/AhoCorasickSpec.hs +++ /dev/null @@ -1,369 +0,0 @@ --- Alfred-Margaret: Fast Aho-Corasick string searching --- Copyright 2019 Channable --- --- Licensed under the 3-clause BSD license, see the LICENSE file in the --- repository root. - -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE OverloadedStrings #-} - -module Main where - -import Control.DeepSeq (rnf) -import Control.Monad (forM_, unless) -import Data.Foldable (foldl') -import Data.Text (Text) -import Data.Word (Word16) -import GHC.Stack (HasCallStack) -import Prelude hiding (replicate) -import Test.Hspec (Spec, Expectation, describe, it, shouldBe, hspec) -import Test.Hspec.Expectations (shouldMatchList, shouldSatisfy) -import Test.Hspec.QuickCheck (modifyMaxSuccess, modifyMaxSize, prop) -import Test.QuickCheck (Arbitrary (arbitrary, shrink), forAll, forAllShrink, (==>)) -import Test.QuickCheck.Gen (Gen) -import Test.QuickCheck.Instances () - -import qualified Data.Char as Char -import qualified Data.Text as Text -import qualified Data.Text.Internal.Search as TextSearch -import qualified Data.Text.Unsafe as TextUnsafe -import qualified Test.QuickCheck as QuickCheck -import qualified Test.QuickCheck.Gen as Gen - -import Data.Text.AhoCorasick.Automaton (CaseSensitivity (..)) - -import qualified Data.Text.AhoCorasick.Automaton as Aho -import qualified Data.Text.AhoCorasick.Replacer as Replacer - -instance Arbitrary CaseSensitivity where - arbitrary = Gen.elements [CaseSensitive, IgnoreCase] - --- | Test that for a single needle which equals the haystack, we find a single --- match. Does not apply to the empty needle. -needleIsHaystackMatches :: HasCallStack => Text -> Expectation -needleIsHaystackMatches needle = - let - needleUtf16 = Aho.unpackUtf16 needle - len = Aho.lengthUtf16 needle - prependMatch ms match = Aho.Step (match : ms) - matches = Aho.runText [] prependMatch (Aho.build [(needleUtf16, ())]) needle - in - matches `shouldBe` [Aho.Match len ()] - -ahoMatch :: [(Text, a)] -> Text -> [Aho.Match a] -ahoMatch needles haystack = - let - makeNeedle (text, value) = (Aho.unpackUtf16 text, value) - needlesUtf16 = fmap makeNeedle needles - prependMatch matches match = Aho.Step (match : matches) - in - Aho.runText [] prependMatch (Aho.build needlesUtf16) haystack - --- | Match without a payload, return only the match positions. -matchPositions :: [Text] -> Text -> [Int] -matchPositions needles haystack = - let - withUnit x = (x, ()) - matches = ahoMatch (fmap withUnit needles) haystack - in - fmap (Aho.codeUnitIndex . Aho.matchPos) matches - --- | `matchPositions` implemented naively in terms of Text's functionality, --- which we assume to be correct. -naiveMatchPositions :: [Text] -> Text -> [Int] -naiveMatchPositions needles haystack = - let - prependMatch :: [Int] -> Text -> Int -> Text -> [Int] - prependMatch matches needle offset haystackSlice = - if Text.null haystack - then matches - -- Text.indices returns all non-overlapping occurrences of the needle, - -- but we want the overlapping ones as well. So we only consider the - -- first match, and then search again starting from one past the - -- beginning of the match. - else case TextSearch.indices needle haystackSlice of - [] -> matches - i:_ -> prependMatch (match : matches) needle offset' remainingHaystack - where - -- The match index is the index past the end, not the start index. - match = offset + i + TextUnsafe.lengthWord16 needle - offset' = offset + i + 1 - remainingHaystack = TextUnsafe.dropWord16 (i + 1) haystackSlice - - prependMatches matches needle = prependMatch matches needle 0 haystack - in - foldl' prependMatches [] needles - --- | Generate random needles and haystacks, such that the needles have a --- reasonable probability of occuring in the haystack, which would hardly be the --- case if we just generated random texts for all of them. We do this by first --- generating a set of fragments, and then building the haystack and needles by --- combining these fragments. By doing this, we also get a lot of partial --- matches, where part of a needle does occur in the haystack, but the full --- needle does not, and also needles with a shared prefix or suffix. This should --- fully stress the possible transitions in the automaton. -arbitraryNeedlesHaystack :: Gen ([Text], Text) -arbitraryNeedlesHaystack = do - let - -- Prefer ascii just to have printable test cases, but do include the other - -- generator to cover the entire range of code points. - genChar = Gen.frequency - [ (4, QuickCheck.arbitraryASCIIChar) - , (1, QuickCheck.arbitrary) - ] - genNonEmptyText = do - chars <- Gen.listOf1 genChar - pure $ Text.pack chars - - fragments <- Gen.listOf1 $ Gen.resize 5 genNonEmptyText - let - genFragment = Gen.elements $ filter (not . Text.null) fragments - genSmall = Gen.scale (`div` 3) $ Gen.listOf1 genFragment - genBig = Gen.scale (* 4) $ Gen.listOf1 genFragment - - needles <- Gen.listOf1 (fmap Text.concat genSmall) - haystack <- fmap Text.concat genBig - pure (needles, haystack) - -main :: IO () -main = hspec $ describe "Data.Text.AhoCorasick" spec - -spec :: Spec -spec = do - modifyMaxSuccess (const 200) $ do - describe "build" $ do - prop "does not throw exceptions" $ \ (kv :: [([Word16], Int)]) -> - rnf $ Aho.build kv - - describe "unpackUtf16" $ do - it "unpacks code point U+437b8" $ - -- Note that 0x437b8 lies in the currently unassigned "Plane 5"; the - -- code point does not currently exist, but that should not bother us. - -- Check in Python: '\U000437b8'.encode('utf-16be') - Aho.unpackUtf16 "\x000437b8" `shouldBe` [0xd8cd, 0xdfb8] - - it "unpacks adjacent nulls individually" $ do - Aho.unpackUtf16 "c\NULe" `shouldBe` [99, 0, 101] - Aho.unpackUtf16 "bc\NUL\NULe" `shouldBe` [98, 99, 0, 0, 101] - - describe "runText" $ do - - describe "when given a needle equal to the haystack" $ do - - it "reports a single match for a repeated character" $ - forM_ [1..128] $ \n -> - needleIsHaystackMatches $ Text.replicate n "a" - - it "reports a single match for non-BMP data" $ do - -- Include a few code points outside of the Basic Multilingual Plane, - -- which require multiple code units to encode. - needleIsHaystackMatches "\x000437b8suffix" - needleIsHaystackMatches "aaa\359339aaa\95759aa\899256aa" - - prop "reports a single match for random needles" $ \needle -> - not (Text.null needle) ==> needleIsHaystackMatches needle - - describe "when given a sliced text (with nonzero internal offset)" $ do - - it "still reports offset relative to the text start" $ - -- The match position should be relative to the start of the text "a". - -- Even if this text is represented as a slice of "bbba" internally. - matchPositions ["a"] (Text.dropWhile (== 'b') "bbba") `shouldMatchList` [1] - - describe "when given non-ascii inputs" $ do - - -- We have a special lookup table for transitions from the base state - -- for the first 128 code units, which is always hit for ascii inputs. - -- Also exercise the fallback code path with a different input. - it "reports a match if the first haystack character is > U+7f" $ do - matchPositions ["eclair"] "éclair" `shouldMatchList` [] - matchPositions ["éclair"] "éclair" `shouldMatchList` [6] - matchPositions ["éclair"] "eclair" `shouldMatchList` [] - - it "reports the correct UTF-16 index for surrogate pairs" $ do - -- Note that the index after the match is 2, even though there is - -- only a single code point. U+1d11e is encoded as two code units - -- in UTF-16. - matchPositions ["𝄞"] "𝄞" `shouldMatchList` [2] - - -- A leviating woman in business suit with dark skin tone needs a - -- whopping 5 code points to encode, of which the first two need a - -- surrogate pair in UTF-16, for a total of 7 code units. - -- U+1f574: man in business suit levitating - -- U+1f3ff: emoji modifier Fitzpatrick type-6 - -- U+200d: zero width joiner - -- U+2640: female sign - -- U+fe0f: variation selector-16 - -- A peculiar feature of Unicode emoji, is that the male levivating - -- man in business suit with dark skin tone is a substring of the - -- levivating woman in business suit. And the levivating man in - -- business suit without particular skin tone is a substring of that. - matchPositions - [ "\x1f574\x1f3ff\x200d\x2640\xfe0f" - , "\x1f574\x1f3ff" - , "\x1f574" - ] "\x1f574\x1f3ff\x200d\x2640\xfe0f" `shouldMatchList` [2, 4, 7] - - describe "when given overlapping needles" $ do - - it "finds exactly all matches" $ do - matchPositions ["foobar", "bar"] "foobar" `shouldMatchList` [6, 6] - matchPositions ["foobarbaz", "bar"] "xfoobarbazy" `shouldMatchList` [10, 7] - matchPositions ["foobar", "foo"] "xfoobarbazy" `shouldMatchList` [7, 4] - - it "keeps the value associated with a needle" $ do - (fmap Aho.matchValue $ ahoMatch [("foo", 'A'), ("bar", 'B')] "foobar") - `shouldMatchList` ['A', 'B'] - (fmap Aho.matchValue $ ahoMatch [("foo", 'A'), ("bar", 'B')] "foobaz") - `shouldMatchList` ['A'] - (fmap Aho.matchValue $ ahoMatch [("foo", 'A'), ("bar", 'B')] "foebar") - `shouldMatchList` ['B'] - - it "reports both matches in case of a duplicate needle" $ do - (fmap Aho.matchValue $ ahoMatch [("foo", 'A'), ("foo", 'B')] "foobar") - `shouldMatchList` ['A', 'B'] - - it "finds all quadratic matches" $ - forM_ ["a", "ab", "abc"] $ \baseText -> - forM_ [1..33] $ \n -> - let - replicate k = Text.replicate k baseText - needles = fmap replicate [1..n] - matches = matchPositions needles (replicate n) - in - -- The needle of length 1 matches n times, the needle of length - -- 2 matches n - 1 times, ..., the needle of length n matches - -- once. - length matches `shouldBe` sum [1..n] - - describe "when given partially overlapping needles" $ do - - it "finds exactly all matches" $ do - matchPositions ["ab", "bcd"] "abccd" `shouldMatchList` [2] - matchPositions ["abc","cde"] "abcdde" `shouldMatchList` [3] - matchPositions ["c","c\NULe"] "c\NUL\NULe" `shouldMatchList` [1] - -- The case below is a regression test; it did fail before; it would - -- report a match at position 5 in addition to position 2. - matchPositions ["bc","c\NULe"] "bc\NUL\NULe" `shouldMatchList` [2] - - describe "when given empyt needles" $ do - - it "does not report a match" $ do - matchPositions [""] "" `shouldMatchList` [] - matchPositions [""] "foo" `shouldMatchList` [] - - describe "when given random needles and haystacks" $ do - - prop "reports only infixes of the haystack" $ - QuickCheck.forAllShrink arbitraryNeedlesHaystack shrink $ \ (needles, haystack) -> - let - dup x = (x, x) - matches = ahoMatch (fmap dup needles) haystack - sliceMatch endPos len = Aho.unsafeSliceUtf16 (endPos - len) len haystack - in - -- Discard inputs for which there are no matches, to ensure we get - -- enough coverage for the case where there are matches. - not (null matches) ==> - forM_ matches $ \ (Aho.Match pos needle) -> do - needle `shouldSatisfy` (`Text.isInfixOf` haystack) - sliceMatch pos (Aho.lengthUtf16 needle) `shouldBe` needle - - prop "reports all infixes of the haystack" $ - QuickCheck.forAllShrink arbitraryNeedlesHaystack shrink $ \ (needles, haystack) -> - matchPositions needles haystack `shouldMatchList` naiveMatchPositions needles haystack - - describe "Char.toLower" $ do - - -- We test that Char.toLower maps the BMP onto itself, because this implies - -- that changing casing code unit by code unit does not change the number of - -- code units, which allows us to implement lowercasing in an optimized - -- manner. - it "maps the Basic Multilingual Plane onto itself" $ - let - isSurrogate cu = cu >= 0xd800 && cu < 0xe000 - in - forM_ [0 .. maxBound :: Aho.CodeUnit] $ \cu -> unless (isSurrogate cu) $ - let - lower = Char.ord $ Char.toLower $ Char.chr $ fromIntegral cu - in - lower `shouldSatisfy` not . isSurrogate - - modifyMaxSize (const 10) $ describe "Replacer.run" $ do - let - genHaystack = fmap Text.pack $ Gen.listOf $ Gen.frequency [(40, Gen.elements "abAB"), (1, pure 'İ'), (1, arbitrary)] - genNeedle = fmap Text.pack $ Gen.resize 3 $ Gen.listOf1 $ Gen.elements "abAB" - genReplaces = Gen.listOf $ (,) <$> genNeedle <*> arbitrary - shrinkReplaces = filter (not . any (\(needle, _) -> Text.null needle)) . shrink - - replace needles haystack = Replacer.run (Replacer.build CaseSensitive needles) haystack - replaceIgnoreCase needles haystack = Replacer.run (Replacer.build IgnoreCase needles) haystack - - it "replaces all occurrences" $ do - replace [("A", "B")] "AXAXB" `shouldBe` "BXBXB" - replace [("A", "B"), ("X", "Y")] "AXAXB" `shouldBe` "BYBYB" - replace [("aaa", ""), ("b", "c")] "aaabaaa" `shouldBe` "c" - -- Have a few non-matching needles too. - replace [("A", "B"), ("Q", "r"), ("Z", "")] "AXAXB" `shouldBe` "BXBXB" - - it "replaces only non-overlapping matches" $ do - replace [("aa", "zz"), ("bb", "w")] "aaabbb" `shouldBe` "zzawb" - replace [("aaa", "")] "aaaaa" `shouldBe` "aa" - - it "replaces all occurrences in priority order" $ do - replace [("A", ""), ("BBBB", "bingo")] "BBABB" `shouldBe` "bingo" - replace [("BB", ""), ("BBBB", "bingo")] "BBBB" `shouldBe` "" - - it "replaces needles that contain a surrogate pair" $ - replace [("\x1f574", "levivating man in business suit")] - "the \x1f574" `shouldBe` "the levivating man in business suit" - - it "replaces all occurrences case-insensitively" $ do - replaceIgnoreCase [("A", "B")] "AXAXB" `shouldBe` "BXBXB" - replaceIgnoreCase [("A", "B")] "axaxb" `shouldBe` "BxBxb" - replaceIgnoreCase [("a", "b")] "AXAXB" `shouldBe` "bXbXB" - - replaceIgnoreCase [("A", "B"), ("X", "Y")] "AXAXB" `shouldBe` "BYBYB" - replaceIgnoreCase [("A", "B"), ("X", "Y")] "axaxb" `shouldBe` "BYBYb" - replaceIgnoreCase [("a", "b"), ("x", "y")] "AXAXB" `shouldBe` "bybyB" - - it "matches replacements case-insensitively" $ - replaceIgnoreCase [("foo", "BAR"), ("bar", "BAZ")] "Foo" `shouldBe` "BAZ" - - it "matches replacements case-insensitively for non-ascii characters" $ do - replaceIgnoreCase [("éclair", "lightning")] "Éclair" `shouldBe` "lightning" - -- Note: U+0319 is an uppercase alpha, which looks exactly like A, but it - -- is a different code point. - replaceIgnoreCase [("bèta", "α"), ("\x0391", "alpha")] "BÈTA" `shouldBe` "alpha" - - it "matches surrogate pairs case-insensitively" $ do - -- We can't lowercase a levivating man in business suit, but that should - -- not affect whether we match it or not. - replaceIgnoreCase [("\x1f574", "levivating man in business suit")] - "the \x1f574" `shouldBe` "the levivating man in business suit" - - prop "satisfies (run . compose a b) == (run b (run a))" $ - forAllShrink genHaystack shrink $ \haystack -> - forAll arbitrary $ \case_ -> - forAllShrink genReplaces shrinkReplaces $ \replaces1 -> - forAllShrink genReplaces shrinkReplaces $ \replaces2 -> - let - rm1 = Replacer.build case_ replaces1 - rm2 = Replacer.build case_ replaces2 - Just rm12 = Replacer.compose rm1 rm2 - in - Replacer.run rm2 (Replacer.run rm1 haystack) - `shouldBe` Replacer.run rm12 haystack - - prop "is identity for empty needles" $ \case_ haystack -> - let replacerId = Replacer.build case_ [] - in Replacer.run replacerId haystack `shouldBe` haystack - - prop "is equivalent to sequential Text.replace calls" $ - forAllShrink genHaystack shrink $ \haystack -> - forAllShrink genReplaces shrinkReplaces $ \replaces -> - let - replacer = Replacer.build CaseSensitive replaces - replaceText agg (needle, replacement) = Text.replace needle replacement agg - expected = foldl' replaceText haystack replaces - in - Replacer.run replacer haystack `shouldBe` expected diff --git a/tests/Data/Text/AhoCorasickSpec.hs b/tests/Data/Text/AhoCorasickSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Data/Text/AhoCorasickSpec.hs @@ -0,0 +1,405 @@ +-- Alfred-Margaret: Fast Aho-Corasick string searching +-- Copyright 2019 Channable +-- +-- Licensed under the 3-clause BSD license, see the LICENSE file in the +-- repository root. + +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Data.Text.AhoCorasickSpec (spec) where + +import Control.DeepSeq (rnf) +import Control.Monad (forM_, unless) +import Data.Foldable (foldl') +import Data.List.NonEmpty (NonEmpty ((:|))) +import Data.Word (Word16) +import Test.Hspec (Spec, Expectation, describe, it, parallel, shouldBe) +import Test.Hspec.Expectations (shouldMatchList, shouldSatisfy) +import Test.Hspec.QuickCheck (modifyMaxSuccess, modifyMaxSize, prop) +import Test.QuickCheck (Arbitrary (arbitrary, shrink), forAll, forAllShrink, (==>)) +import Test.QuickCheck.Instances () +import Test.QuickCheck.Gen (Gen) +import GHC.Stack (HasCallStack) +import Data.Text (Text) +import Prelude hiding (replicate) + +import qualified Data.Char as Char +import qualified Data.Text as Text +import qualified Data.Text.Internal.Search as TextSearch +import qualified Data.Text.Unsafe as TextUnsafe +import qualified Test.QuickCheck as QuickCheck +import qualified Test.QuickCheck.Gen as Gen + +import Data.Text.AhoCorasick.Automaton (CaseSensitivity (..)) +import Data.Text.Orphans () + +import qualified Data.Text.AhoCorasick.Automaton as Aho +import qualified Data.Text.AhoCorasick.Replacer as Replacer +import qualified Data.Text.AhoCorasick.Splitter as Splitter +import qualified Data.Text.Utf16 as Utf16 + +-- | Test that for a single needle which equals the haystack, we find a single +-- match. Does not apply to the empty needle. +needleIsHaystackMatches :: HasCallStack => Text -> Expectation +needleIsHaystackMatches needle = + let + needleUtf16 = Utf16.unpackUtf16 needle + len = Utf16.lengthUtf16 needle + prependMatch ms match = Aho.Step (match : ms) + matches = Aho.runText [] prependMatch (Aho.build [(needleUtf16, ())]) needle + in + matches `shouldBe` [Aho.Match len ()] + +ahoMatch :: [(Text, a)] -> Text -> [Aho.Match a] +ahoMatch needles haystack = + let + makeNeedle (text, value) = (Utf16.unpackUtf16 text, value) + needlesUtf16 = fmap makeNeedle needles + prependMatch matches match = Aho.Step (match : matches) + in + Aho.runText [] prependMatch (Aho.build needlesUtf16) haystack + +-- | Match without a payload, return only the match positions. +matchPositions :: [Text] -> Text -> [Int] +matchPositions needles haystack = + let + withUnit x = (x, ()) + matches = ahoMatch (fmap withUnit needles) haystack + in + fmap (Utf16.codeUnitIndex . Aho.matchPos) matches + +-- | `matchPositions` implemented naively in terms of Text's functionality, +-- which we assume to be correct. +naiveMatchPositions :: [Text] -> Text -> [Int] +naiveMatchPositions needles haystack = + let + prependMatch :: [Int] -> Text -> Int -> Text -> [Int] + prependMatch matches needle offset haystackSlice = + if Text.null haystack + then matches + -- Text.indices returns all non-overlapping occurrences of the needle, + -- but we want the overlapping ones as well. So we only consider the + -- first match, and then search again starting from one past the + -- beginning of the match. + else case TextSearch.indices needle haystackSlice of + [] -> matches + i:_ -> prependMatch (match : matches) needle offset' remainingHaystack + where + -- The match index is the index past the end, not the start index. + match = offset + i + TextUnsafe.lengthWord16 needle + offset' = offset + i + 1 + remainingHaystack = TextUnsafe.dropWord16 (i + 1) haystackSlice + + prependMatches matches needle = prependMatch matches needle 0 haystack + in + foldl' prependMatches [] needles + +-- | Generate random needles and haystacks, such that the needles have a +-- reasonable probability of occuring in the haystack, which would hardly be the +-- case if we just generated random texts for all of them. We do this by first +-- generating a set of fragments, and then building the haystack and needles by +-- combining these fragments. By doing this, we also get a lot of partial +-- matches, where part of a needle does occur in the haystack, but the full +-- needle does not, and also needles with a shared prefix or suffix. This should +-- fully stress the possible transitions in the automaton. +arbitraryNeedlesHaystack :: Gen ([Text], Text) +arbitraryNeedlesHaystack = do + let + -- Prefer ascii just to have printable test cases, but do include the other + -- generator to cover the entire range of code points. + genChar = Gen.frequency + [ (4, QuickCheck.arbitraryASCIIChar) + , (1, QuickCheck.arbitrary) + ] + genNonEmptyText = do + chars <- Gen.listOf1 genChar + pure $ Text.pack chars + + fragments <- Gen.listOf1 $ Gen.resize 5 genNonEmptyText + let + genFragment = Gen.elements $ filter (not . Text.null) fragments + genSmall = Gen.scale (`div` 3) $ Gen.listOf1 genFragment + genBig = Gen.scale (* 4) $ Gen.listOf1 genFragment + + needles <- Gen.listOf1 (fmap Text.concat genSmall) + haystack <- fmap Text.concat genBig + pure (needles, haystack) + +spec :: Spec +spec = parallel $ do + modifyMaxSuccess (const 200) $ do + describe "build" $ do + prop "does not throw exceptions" $ \ (kv :: [([Word16], Int)]) -> + rnf $ Aho.build kv + + describe "unpackUtf16" $ do + it "unpacks code point U+437b8" $ + -- Note that 0x437b8 lies in the currently unassigned "Plane 5"; the + -- code point does not currently exist, but that should not bother us. + -- Check in Python: '\U000437b8'.encode('utf-16be') + Utf16.unpackUtf16 "\x000437b8" `shouldBe` [0xd8cd, 0xdfb8] + + it "unpacks adjacent nulls individually" $ do + Utf16.unpackUtf16 "c\NULe" `shouldBe` [99, 0, 101] + Utf16.unpackUtf16 "bc\NUL\NULe" `shouldBe` [98, 99, 0, 0, 101] + + describe "runText" $ do + + describe "when given a needle equal to the haystack" $ do + + it "reports a single match for a repeated character" $ + forM_ [1..128] $ \n -> + needleIsHaystackMatches $ Text.replicate n "a" + + it "reports a single match for non-BMP data" $ do + -- Include a few code points outside of the Basic Multilingual Plane, + -- which require multible code units to encode. + needleIsHaystackMatches "\x000437b8suffix" + needleIsHaystackMatches "aaa\359339aaa\95759aa\899256aa" + + prop "reports a single match for random needles" $ \needle -> + not (Text.null needle) ==> needleIsHaystackMatches needle + + describe "when given a sliced text (with nonzero internal offset)" $ + + it "still reports offset relative to the text start" $ + -- The match position should be relative to the start of the text "a". + -- Even if this text is represented as a slice of "bbba" internally. + matchPositions ["a"] (Text.dropWhile (== 'b') "bbba") `shouldMatchList` [1] + + describe "when given non-ascii inputs" $ do + + -- We have a special lookup table for transitions from the base state + -- for the first 128 code units, which is always hit for ascii inputs. + -- Also exercise the fallback code path with a different input. + it "reports a match if the first haystack character is > U+7f" $ do + matchPositions ["eclair"] "éclair" `shouldMatchList` [] + matchPositions ["éclair"] "éclair" `shouldMatchList` [6] + matchPositions ["éclair"] "eclair" `shouldMatchList` [] + + it "reports the correct UTF-16 index for surrogate pairs" $ do + -- Note that the index after the match is 2, even though there is + -- only a single code point. U+1d11e is encoded as two code units + -- in UTF-16. + matchPositions ["𝄞"] "𝄞" `shouldMatchList` [2] + + -- A levitating woman in business suit with dark skin tone needs a + -- whopping 5 code points to encode, of which the first two need a + -- surrogate pair in UTF-16, for a total of 7 code units. + -- U+1f574: man in business suit levitating + -- U+1f3ff: emoji modifier Fitzpatrick type-6 + -- U+200d: zero width joiner + -- U+2640: female sign + -- U+fe0f: variation selector-16 + -- A peculiar feature of Unicode emoji, is that the male levitating + -- man in business suit with dark skin tone is a substring of the + -- levitating woman in business suit. And the levitating man in + -- business suit without particular skin tone is a substring of that. + matchPositions + [ "\x1f574\x1f3ff\x200d\x2640\xfe0f" + , "\x1f574\x1f3ff" + , "\x1f574" + ] "\x1f574\x1f3ff\x200d\x2640\xfe0f" `shouldMatchList` [2, 4, 7] + + describe "when given overlapping needles" $ do + + it "finds exactly all matches" $ do + matchPositions ["foobar", "bar"] "foobar" `shouldMatchList` [6, 6] + matchPositions ["foobarbaz", "bar"] "xfoobarbazy" `shouldMatchList` [10, 7] + matchPositions ["foobar", "foo"] "xfoobarbazy" `shouldMatchList` [7, 4] + + it "keeps the value associated with a needle" $ do + fmap Aho.matchValue (ahoMatch [("foo", 'A'), ("bar", 'B')] "foobar") + `shouldMatchList` ['A', 'B'] + fmap Aho.matchValue (ahoMatch [("foo", 'A'), ("bar", 'B')] "foobaz") + `shouldMatchList` ['A'] + fmap Aho.matchValue (ahoMatch [("foo", 'A'), ("bar", 'B')] "foebar") + `shouldMatchList` ['B'] + + it "reports both matches in case of a duplicate needle" $ + fmap Aho.matchValue (ahoMatch [("foo", 'A'), ("foo", 'B')] "foobar") + `shouldMatchList` ['A', 'B'] + + it "finds all quadratic matches" $ + forM_ ["a", "ab", "abc"] $ \baseText -> + forM_ [1..33] $ \n -> + let + replicate k = Text.replicate k baseText + needles = fmap replicate [1..n] + matches = matchPositions needles (replicate n) + in + -- The needle of length 1 matches n times, the needle of length + -- 2 matches n - 1 times, ..., the needle of length n matches + -- once. + length matches `shouldBe` sum [1..n] + + describe "when given partially overlapping needles" $ do + + it "finds exactly all matches" $ do + matchPositions ["ab", "bcd"] "abccd" `shouldMatchList` [2] + matchPositions ["abc","cde"] "abcdde" `shouldMatchList` [3] + matchPositions ["c","c\NULe"] "c\NUL\NULe" `shouldMatchList` [1] + -- The case below is a regression test; it did fail before; it would + -- report a match at position 5 in addition to position 2. + matchPositions ["bc","c\NULe"] "bc\NUL\NULe" `shouldMatchList` [2] + + describe "when given empyt needles" $ do + + it "does not report a match" $ do + matchPositions [""] "" `shouldMatchList` [] + matchPositions [""] "foo" `shouldMatchList` [] + + describe "when given random needles and haystacks" $ do + + prop "reports only infixes of the haystack" $ + QuickCheck.forAllShrink arbitraryNeedlesHaystack shrink $ \ (needles, haystack) -> + let + dup x = (x, x) + matches = ahoMatch (fmap dup needles) haystack + sliceMatch endPos len = Utf16.unsafeSliceUtf16 (endPos - len) len haystack + in + -- Discard inputs for which there are no matches, to ensure we get + -- enough coverage for the case where there are matches. + not (null matches) ==> + forM_ matches $ \ (Aho.Match pos needle) -> do + needle `shouldSatisfy` (`Text.isInfixOf` haystack) + sliceMatch pos (Utf16.lengthUtf16 needle) `shouldBe` needle + + prop "reports all infixes of the haystack" $ + QuickCheck.forAllShrink arbitraryNeedlesHaystack shrink $ \ (needles, haystack) -> + matchPositions needles haystack `shouldMatchList` naiveMatchPositions needles haystack + + let + isSurrogate cu = cu >= 0xd800 && cu < 0xe000 + + describe "Char.toLower" $ do + + -- We test that Char.toLower maps the BMP onto itself, because this implies + -- that changing casing code unit by code unit does not change the number of + -- code units, which allows us to implement lowercasing in an optimized + -- manner. + it "maps the Basic Multilingual Plane onto itself" $ + forM_ [0 .. maxBound :: Utf16.CodeUnit] $ \cu -> unless (isSurrogate cu) $ + let + lower = Char.ord $ Char.toLower $ Char.chr $ fromIntegral cu + in + lower `shouldSatisfy` not . isSurrogate + + describe "Utf16.lowerCodeUnit" $ + it "is equivalent to Char.toLower on the BMP" $ + forM_ [0 .. maxBound :: Utf16.CodeUnit] $ \cu -> unless (isSurrogate cu) $ + let + lowerAsChar = fromIntegral . Char.ord . Char.toLower . Char.chr . fromIntegral + in + lowerAsChar cu `shouldBe` Utf16.lowerCodeUnit cu + + describe "Char.toUpper" $ do + + -- We test that Char.toUpper maps the BMP onto itself, because this implies + -- that changing casing code unit by code unit does not change the number of + -- code units, which allows us to implement upppercasing in an optimized + -- manner. + it "maps the Basic Multilingual Plane onto itself" $ + forM_ [0 .. maxBound :: Utf16.CodeUnit] $ \cu -> unless (isSurrogate cu) $ + let + upper = Char.ord $ Char.toUpper $ Char.chr $ fromIntegral cu + in + upper `shouldSatisfy` not . isSurrogate + + describe "Utf16.upperCodeUnit" $ + it "is equivalent to Char.toUpper on the BMP" $ + forM_ [0 .. maxBound :: Utf16.CodeUnit] $ \cu -> unless (isSurrogate cu) $ + let + upperAsChar = fromIntegral . Char.ord . Char.toUpper . Char.chr . fromIntegral + in + upperAsChar cu `shouldBe` Utf16.upperCodeUnit cu + + modifyMaxSize (const 10) $ describe "Replacer.run" $ do + let + genHaystack = fmap Text.pack $ Gen.listOf $ Gen.frequency [(40, Gen.elements "abAB"), (1, pure 'İ'), (1, arbitrary)] + -- needles may not be empty, because empty needles are filtered out in an I.ActionReplaceMultiple + genNeedle = fmap Text.pack $ Gen.resize 3 $ Gen.listOf1 $ Gen.elements "abAB" + genReplaces = Gen.listOf $ (,) <$> genNeedle <*> arbitrary + shrinkReplaces = filter (not . any (\(needle, _) -> Text.null needle)) . shrink + + replace needles haystack = Replacer.run (Replacer.build CaseSensitive needles) haystack + replaceIgnoreCase needles haystack = Replacer.run (Replacer.build IgnoreCase needles) haystack + + it "replaces all occurrences" $ do + replace [("A", "B")] "AXAXB" `shouldBe` "BXBXB" + replace [("A", "B"), ("X", "Y")] "AXAXB" `shouldBe` "BYBYB" + replace [("aaa", ""), ("b", "c")] "aaabaaa" `shouldBe` "c" + -- Have a few non-matching needles too. + replace [("A", "B"), ("Q", "r"), ("Z", "")] "AXAXB" `shouldBe` "BXBXB" + + it "replaces only non-overlapping matches" $ do + replace [("aa", "zz"), ("bb", "w")] "aaabbb" `shouldBe` "zzawb" + replace [("aaa", "")] "aaaaa" `shouldBe` "aa" + + it "replaces all occurrences in priority order" $ do + replace [("A", ""), ("BBBB", "bingo")] "BBABB" `shouldBe` "bingo" + replace [("BB", ""), ("BBBB", "bingo")] "BBBB" `shouldBe` "" + + it "replaces needles that contain a surrogate pair" $ + replace [("\x1f574", "levitating man in business suit")] + "the \x1f574" `shouldBe` "the levitating man in business suit" + + it "replaces all occurrences case-insensitively" $ do + replaceIgnoreCase [("A", "B")] "AXAXB" `shouldBe` "BXBXB" + replaceIgnoreCase [("A", "B")] "axaxb" `shouldBe` "BxBxb" + replaceIgnoreCase [("a", "b")] "AXAXB" `shouldBe` "bXbXB" + + replaceIgnoreCase [("A", "B"), ("X", "Y")] "AXAXB" `shouldBe` "BYBYB" + replaceIgnoreCase [("A", "B"), ("X", "Y")] "axaxb" `shouldBe` "BYBYb" + replaceIgnoreCase [("a", "b"), ("x", "y")] "AXAXB" `shouldBe` "bybyB" + + it "matches replacements case-insensitively" $ + replaceIgnoreCase [("foo", "BAR"), ("bar", "BAZ")] "Foo" `shouldBe` "BAZ" + + it "matches replacements case-insensitively for non-ascii characters" $ do + replaceIgnoreCase [("éclair", "lightning")] "Éclair" `shouldBe` "lightning" + -- Note: U+0319 is an uppercase alpha, which looks exactly like A, but it + -- is a different code point. + replaceIgnoreCase [("bèta", "α"), ("\x0391", "alpha")] "BÈTA" `shouldBe` "alpha" + + it "matches surrogate pairs case-insensitively" $ do + -- We can't lowercase a levivating man in business suit, but that should + -- not affect whether we match it or not. + replaceIgnoreCase [("\x1f574", "levitating man in business suit")] "the \x1f574" + `shouldBe` "the levitating man in business suit" + + prop "satisfies (run . compose a b) == (run b (run a))" $ + forAllShrink genHaystack shrink $ \haystack -> + forAll arbitrary $ \case_ -> + forAllShrink genReplaces shrinkReplaces $ \replaces1 -> + forAllShrink genReplaces shrinkReplaces $ \replaces2 -> + let + rm1 = Replacer.build case_ replaces1 + rm2 = Replacer.build case_ replaces2 + Just rm12 = Replacer.compose rm1 rm2 + in + Replacer.run rm2 (Replacer.run rm1 haystack) + `shouldBe` Replacer.run rm12 haystack + + prop "is identity for empty needles" $ \case_ haystack -> + let replacerId = Replacer.build case_ [] + in Replacer.run replacerId haystack `shouldBe` haystack + + prop "is equivalent to sequential Text.replace calls" $ + forAllShrink genHaystack shrink $ \haystack -> + forAllShrink genReplaces shrinkReplaces $ \replaces -> + let + replacer = Replacer.build CaseSensitive replaces + replaceText agg (needle, replacement) = Text.replace needle replacement agg + expected = foldl' replaceText haystack replaces + in + Replacer.run replacer haystack `shouldBe` expected + + describe "Splitter.split" $ + + it "passes an example" $ + let separator = "bob" in + let splitter = Splitter.build separator in + Splitter.split splitter "C++bobobCOBOLbobScala" + `shouldBe` "C++" :| ["obCOBOL", "Scala"] diff --git a/tests/Data/Text/BoyerMooreSpec.hs b/tests/Data/Text/BoyerMooreSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Data/Text/BoyerMooreSpec.hs @@ -0,0 +1,209 @@ +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Data.Text.BoyerMooreSpec (spec) where + +import Control.DeepSeq (rnf) +import Control.Monad (forM_) +import Data.Foldable (for_) +import Test.Hspec (Spec, Expectation, describe, it, parallel, shouldBe) +import Test.Hspec.Expectations (shouldMatchList, shouldSatisfy) +import Test.Hspec.QuickCheck (modifyMaxSuccess, prop) +import Test.QuickCheck (Arbitrary (arbitrary, shrink), forAll, forAllShrink, (==>)) +import Test.QuickCheck.Instances () +import Test.QuickCheck.Gen (Gen) +import GHC.Stack (HasCallStack) +import Data.Text (Text) +import Prelude hiding (replicate) + +import qualified Data.Text as Text +import qualified Data.Text.Internal.Search as TextSearch +import qualified Data.Text.Unsafe as TextUnsafe +import qualified Test.QuickCheck as QuickCheck +import qualified Test.QuickCheck.Gen as Gen + +import Data.Text.Orphans () +import Data.Text.BoyerMoore.Automaton (CaseSensitivity (..)) + +import qualified Data.Text.AhoCorasick.Replacer as AhoReplacer +import qualified Data.Text.BoyerMoore.Automaton as BoyerMoore +import qualified Data.Text.BoyerMoore.Replacer as Replacer +import qualified Data.Text.Utf16 as Utf16 + +-- | Test that for a single needle which equals the haystack, we find a single +-- match. Does not apply to the empty needle. +needleIsHaystackMatches :: HasCallStack => Text -> Expectation +needleIsHaystackMatches needle = + let + prependMatch ms match = BoyerMoore.Step (Utf16.codeUnitIndex match : ms) + matches = BoyerMoore.runText [] prependMatch (BoyerMoore.buildAutomaton needle) needle + in + matches `shouldBe` [0] + +boyerMatch :: Text -> Text -> [Int] +boyerMatch needle haystack = + let + prependMatch matches match = BoyerMoore.Step (Utf16.codeUnitIndex match : matches) + in + BoyerMoore.runText [] prependMatch (BoyerMoore.buildAutomaton needle) haystack + +-- | Match without a payload, return only the match positions. +matchEndPositions :: Text -> Text -> [Int] +matchEndPositions needle haystack = + let + matches = boyerMatch needle haystack + in + fmap (Utf16.codeUnitIndex (Utf16.lengthUtf16 needle) +) matches + +-- | `matchEndPositions` implemented naively in terms of Text's functionality, +-- which we assume to be correct. +naiveMatchPositions :: Text -> Text -> [Int] +naiveMatchPositions needle haystack = + map toEndPos $ TextSearch.indices needle haystack + where + toEndPos index = TextUnsafe.lengthWord16 needle + index + +-- | Generate random needles and haystacks, such that the needles have a +-- reasonable probability of occuring in the haystack, which would hardly be the +-- case if we just generated random texts for all of them. We do this by first +-- generating a set of fragments, and then building the haystack and needles by +-- combining these fragments. By doing this, we also get a lot of partial +-- matches, where part of a needle does occur in the haystack, but the full +-- needle does not, and also needles with a shared prefix or suffix. This should +-- fully stress the possible transitions in the automaton. +arbitraryNeedleHaystack :: Gen (Text, Text) +arbitraryNeedleHaystack = do + let + -- Prefer ascii just to have printable test cases, but do include the other + -- generator to cover the entire range of code points. + genChar = Gen.frequency + [ (4, QuickCheck.arbitraryASCIIChar) + , (1, QuickCheck.arbitrary) + ] + genNonEmptyText = do + chars <- Gen.listOf1 genChar + pure $ Text.pack chars + + fragments <- Gen.listOf1 $ Gen.resize 5 genNonEmptyText + let + genFragment = Gen.elements $ filter (not . Text.null) fragments + genSmall = Gen.scale (`div` 3) $ Gen.listOf1 genFragment + genBig = Gen.scale (* 4) $ Gen.listOf1 genFragment + + needle <- fmap Text.concat genSmall + haystack <- fmap Text.concat genBig + pure (needle, haystack) + +spec :: Spec +spec = parallel $ modifyMaxSuccess (const 200) $ do + describe "build" $ do + prop "does not throw exceptions" $ \ (pat :: Text) -> + rnf $ BoyerMoore.buildAutomaton pat + + describe "runText" $ do + + describe "when given a needle equal to the haystack" $ do + + it "reports a single match for a repeated character" $ + forM_ [1..128] $ \n -> + needleIsHaystackMatches $ Text.replicate n "a" + + it "reports a single match for non-BMP data" $ do + -- Include a few code points outside of the Basic Multilingual Plane, + -- which require multible code units to encode. + needleIsHaystackMatches "\x000437b8suffix" + needleIsHaystackMatches "aaa\359339aaa\95759aa\899256aa" + + prop "reports a single match for random needles" $ \needle -> + not (Text.null needle) ==> needleIsHaystackMatches needle + + describe "when given a sliced text (with nonzero internal offset)" $ do + + it "still reports offset relative to the text start" $ + -- The match position should be relative to the start of the text "a". + -- Even if this text is represented as a slice of "bbba" internally. + matchEndPositions "a" (Text.dropWhile (== 'b') "bbba") `shouldMatchList` [1] + + describe "when given non-ascii inputs" $ do + + -- We have a special lookup table for bad character shifts for + -- the first 128 code units, which is always hit for ascii inputs. + -- Also exercise the fallback code path with a different input. + it "reports a match if the haystack contains a character > U+7f" $ do + matchEndPositions "eclair" "éclaireclair" `shouldMatchList` [12] + matchEndPositions "éclair" "éclaireclair" `shouldMatchList` [6] + matchEndPositions "éclair" "eclairéclair" `shouldMatchList` [12] + + it "reports the correct UTF-16 index for surrogate pairs" $ do + -- Note that the index after the match is 2, even though there is + -- only a single code point. U+1d11e is encoded as two code units + -- in UTF-16. + matchEndPositions "𝄞" "𝄞" `shouldMatchList` [2] + + -- A leviating woman in business suit with dark skin tone needs a + -- whopping 5 code points to encode, of which the first two need a + -- surrogate pair in UTF-16, for a total of 7 code units. + -- U+1f574: man in business suit levitating + -- U+1f3ff: emoji modifier Fitzpatrick type-6 + -- U+200d: zero width joiner + -- U+2640: female sign + -- U+fe0f: variation selector-16 + -- A peculiar feature of Unicode emoji, is that the male levivating + -- man in business suit with dark skin tone is a substring of the + -- levivating woman in business suit. And the levivating man in + -- business suit without particular skin tone is a substring of that. + let + examples = + [ ("\x1f574\x1f3ff\x200d\x2640\xfe0f", 7) + , ("\x1f574\x1f3ff", 4) + , ("\x1f574", 2) + ] + for_ examples $ \(needle, endPos) -> + matchEndPositions needle "\x1f574\x1f3ff\x200d\x2640\xfe0f" `shouldMatchList` [endPos] + + describe "when given empty needle" $ do + + it "does not report a match" $ do + matchEndPositions "" "" `shouldMatchList` [] + matchEndPositions "" "foo" `shouldMatchList` [] + + describe "kitchen sink" $ do + it "kitchen sinks" $ do + matchEndPositions "\"\SO]JL\"" "aaaaa\"\SO]JL\"" `shouldMatchList` [11] + matchEndPositions "\"X]JL\"" "aaaaa\"X]JL\"" `shouldMatchList` [11] + + describe "when given random needles and haystacks" $ do + + prop "reports only infixes of the haystack" $ + QuickCheck.forAllShrink arbitraryNeedleHaystack shrink $ \ (needle, haystack) -> + let + matches = boyerMatch needle haystack + sliceMatch startPos len = Utf16.unsafeSliceUtf16 startPos len haystack + in + forM_ matches $ \pos -> do + needle `shouldSatisfy` (`Text.isInfixOf` haystack) + sliceMatch (Utf16.CodeUnitIndex pos) (Utf16.lengthUtf16 needle) `shouldBe` needle + + prop "reports all infixes of the haystack" $ + QuickCheck.forAllShrink arbitraryNeedleHaystack shrink $ \ (needle, haystack) -> + matchEndPositions needle haystack `shouldMatchList` naiveMatchPositions needle haystack + + describe "replaceSingleLimited" $ do + + prop "is equivalent to Aho-Corasick replacer with a single needle" $ + forAllShrink arbitraryNeedleHaystack shrink $ \(needle, haystack) -> + forAllShrink arbitrary shrink $ \replacement -> + forAll arbitrary $ \case_ -> + let + expected = AhoReplacer.run (AhoReplacer.build case_ [(needle, replacement)]) haystack + + auto = BoyerMoore.buildAutomaton $ case case_ of + IgnoreCase -> Utf16.lowerUtf16 needle + CaseSensitive -> needle + + actual = Replacer.replaceSingleLimited case_ auto replacement haystack maxBound + in + actual `shouldBe` Just expected + diff --git a/tests/Data/Text/Orphans.hs b/tests/Data/Text/Orphans.hs new file mode 100644 --- /dev/null +++ b/tests/Data/Text/Orphans.hs @@ -0,0 +1,10 @@ +module Data.Text.Orphans where + +import Test.QuickCheck (Arbitrary (..)) + +import qualified Test.QuickCheck.Gen as Gen + +import Data.Text.AhoCorasick.Automaton (CaseSensitivity (..)) + +instance Arbitrary CaseSensitivity where + arbitrary = Gen.elements [CaseSensitive, IgnoreCase] diff --git a/tests/Main.hs b/tests/Main.hs new file mode 100644 --- /dev/null +++ b/tests/Main.hs @@ -0,0 +1,11 @@ +module Main where + +import Test.Hspec (describe, hspec) + +import Data.Text.AhoCorasickSpec as A +import Data.Text.BoyerMooreSpec as B + +main :: IO () +main = hspec $ do + describe "Data.Text.AhoCorasick" A.spec + describe "Data.Text.BoyerMoore" B.spec