alfred-margaret 1.0.0.0 → 1.1.1.0

raw patch · 14 files changed

+1791/−573 lines, 14 filesdep +aesondep +unordered-containersdep ~containersdep ~deepseqdep ~hashable

Dependencies added: aeson, unordered-containers

Dependency ranges changed: containers, deepseq, hashable, primitive, text, vector

Files

• alfred-margaret.cabal +45/−19
• src/Data/Text/AhoCorasick/Automaton.hs +13/−144
• src/Data/Text/AhoCorasick/Replacer.hs +24/−11
• src/Data/Text/AhoCorasick/Searcher.hs +60/−30
• src/Data/Text/AhoCorasick/Splitter.hs +189/−0
• src/Data/Text/BoyerMoore/Automaton.hs +372/−0
• src/Data/Text/BoyerMoore/Replacer.hs +98/−0
• src/Data/Text/BoyerMoore/Searcher.hs +125/−0
• src/Data/Text/Utf16.hs +230/−0
• tests/AhoCorasickSpec.hs +0/−369
• tests/Data/Text/AhoCorasickSpec.hs +405/−0
• tests/Data/Text/BoyerMooreSpec.hs +209/−0
• tests/Data/Text/Orphans.hs +10/−0
• tests/Main.hs +11/−0

@@ -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 <ruud@channable.com>-copyright:           2019 Channable+maintainer:          Ruud van Asseldonk <ruud@channable.com>, Fabian Thorand <fabian@channable.com>+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

@@ -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

@@ -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.

@@ -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

@@ -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)

@@ -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

@@ -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+  }

@@ -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)

@@ -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

@@ -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

@@ -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"]

@@ -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+

@@ -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]

@@ -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