alfred-margaret 2.0.0.0 → 2.1.0.0

raw patch · 21 files changed

+1743/−165 lines, 21 filesdep ~basedep ~deepseqdep ~textPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: base, deepseq, text

API changes (from Hackage documentation)

Files

• alfred-margaret.cabal +19/−2
• bench/bm/Main.hs +211/−0
• src/Data/Text/AhoCorasick/Automaton.hs +19/−1
• src/Data/Text/AhoCorasick/Replacer.hs +95/−40
• src/Data/Text/AhoCorasick/Searcher.hs +12/−3
• src/Data/Text/AhoCorasick/Splitter.hs +29/−25
• src/Data/Text/BoyerMoore/Automaton.hs +14/−11
• src/Data/Text/BoyerMoore/Searcher.hs +1/−1
• src/Data/Text/BoyerMooreCI/Automaton.hs +474/−0
• src/Data/Text/BoyerMooreCI/Replacer.hs +89/−0
• src/Data/Text/BoyerMooreCI/Searcher.hs +121/−0
• src/Data/Text/Utf8.hs +145/−23
• src/Data/Text/Utf8/Unlower.hs +87/−0
• src/Data/TypedByteArray.hs +30/−1
• tests/Data/Text/AhoCorasickSpec.hs +24/−1
• tests/Data/Text/BoyerMooreCISpec.hs +195/−0
• tests/Data/Text/BoyerMooreSpec.hs +1/−35
• tests/Data/Text/Orphans.hs +0/−14
• tests/Data/Text/TestInstances.hs +93/−0
• tests/Data/Text/Utf8Spec.hs +76/−2
• tests/Main.hs +8/−6

@@ -1,5 +1,5 @@ name:                alfred-margaret-version:             2.0.0.0+version:             2.1.0.0 synopsis:            Fast Aho-Corasick string searching description:         An efficient implementation of the Aho-Corasick                      string searching algorithm.@@ -44,6 +44,7 @@   hs-source-dirs:      src   exposed-modules:     Data.Text.CaseSensitivity                      , Data.Text.Utf8+                     , Data.Text.Utf8.Unlower                      , Data.Text.AhoCorasick.Automaton                      , Data.Text.AhoCorasick.Replacer                      , Data.Text.AhoCorasick.Searcher@@ -51,6 +52,9 @@                      , Data.Text.BoyerMoore.Automaton                      , Data.Text.BoyerMoore.Replacer                      , Data.Text.BoyerMoore.Searcher+                     , Data.Text.BoyerMooreCI.Automaton+                     , Data.Text.BoyerMooreCI.Replacer+                     , Data.Text.BoyerMooreCI.Searcher                      , Data.TypedByteArray   build-depends:       base             >= 4.7 && < 5@@ -78,8 +82,9 @@   main-is:             Main.hs   other-modules:       Data.Text.AhoCorasickSpec                      , Data.Text.BoyerMooreSpec+                     , Data.Text.BoyerMooreCISpec                      , Data.Text.Utf8Spec-                     , Data.Text.Orphans+                     , Data.Text.TestInstances   hs-source-dirs:      tests   ghc-options:         -Wall -Wincomplete-record-updates -Wno-orphans   build-depends:       base >= 4.7 && < 5@@ -103,6 +108,18 @@                      , vector                      , deepseq                      , criterion+  default-language:    Haskell2010++benchmark bm+  type:                exitcode-stdio-1.0+  main-is:             Main.hs+  hs-source-dirs:      bench/bm+  ghc-options:         -Wall -Wincomplete-record-updates -Wno-orphans+  build-depends:       base >= 4.7 && < 5+                     , alfred-margaret+                     , deepseq+                     , criterion+                     , text   default-language:    Haskell2010  executable dump-automaton

@@ -0,0 +1,211 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE OverloadedStrings #-}++module Main+  ( main+  ) where++import Criterion.Main (bgroup, bench, defaultMain, nf)++import qualified Data.Text as Text+import qualified Data.Text.AhoCorasick.Automaton as Aho+import qualified Data.Text.BoyerMoore.Automaton as BoyerMoore+import qualified Data.Text.BoyerMooreCI.Automaton as BoyerMooreCI+import qualified Data.Text.Utf8 as Utf8++--+-- @+-- stack bench alfred-margaret:bm --ba '--output bm.html'+-- @++main :: IO ()+main = defaultMain+  [+    bgroup "Big needle, large haystack" $+      benchVariants needle1 haystack1++  , bgroup "Big needle, small haystack" $+      benchVariants needle2 haystack2++  , bgroup "Small needle, large haystack" $+      benchVariants needle3 haystack3++  , bgroup "Small needle, small haystack" $+      benchVariants needle4 haystack4++  , bgroup "Cyrillic, medium needle, large haystack" $+      benchVariants needle5 haystack5++  ]+  where+    benchVariants needle haystack =+      [ bench "Count Aho" $ nf (ahoCount needle) haystack+      , bench "Count Aho CI" $ nf (ahociCount needle) haystack+      , bench "Count BoyerMoore" $ nf (bmCount needle) haystack+      , bench "Count BoyerMoore CI" $ nf (bmciCount needle) haystack+      , bench "Count Aho CI multineedle" $ nf (ahocimultiCount needle) haystack+      , bench "Count Text.count" $ nf (Text.count needle) haystack+      -- This naive case insensitive count is really slow. We leave it out+      -- because it throws off the plot scale.+      -- , bench "Count Text.count . lowerUtf8" $ nf (Text.count needle . Utf8.lowerUtf8) haystack+      , bench "Contains Aho" $ nf (ahoContains needle) haystack+      , bench "Contains Aho CI" $ nf (ahociContains needle) haystack+      , bench "Contains BoyerMoore" $ nf (bmContains needle) haystack+      , bench "Contains BoyerMoore CI" $ nf (bmciContains needle) haystack+      , bench "Contains Text.isInfixOf" $ nf (Text.isInfixOf needle) haystack+      ]+++-- | The NOINLINE annotation is used so that the needle doesn't get inlined at compile time. The+-- function does get partially applied with the needle so that the automaton is constructed only+-- once.+ahoCount :: Text.Text -> Text.Text -> Int+{-# NOINLINE ahoCount #-}+ahoCount needle =+  let+    !automaton = Aho.build [(needle, ())]+    onMatch !n _match = Aho.Step (n + 1)+  in+    -- Eta expansion of the haystack variable is necessary for proper inlining of runText+    \haystack -> Aho.runText 0 onMatch automaton haystack++ahoContains :: Text.Text -> Text.Text -> Bool+{-# NOINLINE ahoContains #-}+ahoContains needle =+  let+    !automaton = Aho.build [(needle, ())]+    onMatch _ _match = Aho.Done True+  in+    \haystack -> Aho.runText False onMatch automaton haystack++ahociCount :: Text.Text -> Text.Text -> Int+{-# NOINLINE ahociCount #-}+ahociCount needle =+  let+    !automaton = Aho.build [(needle, ())]+    onMatch !n _match = Aho.Step (n + 1)+  in+    \haystack -> Aho.runLower 0 onMatch automaton haystack+++ahocimultiCount :: Text.Text -> Text.Text -> Int+{-# NOINLINE ahocimultiCount #-}+ahocimultiCount needle =+  let+    !automaton = Aho.build $ map (\n -> (n, ())) $ Aho.needleCasings needle+    onMatch !n _match = Aho.Step (n + 1)+  in+    \haystack -> Aho.runText 0 onMatch automaton haystack++ahociContains :: Text.Text -> Text.Text -> Bool+{-# NOINLINE ahociContains #-}+ahociContains needle =+  let+    !automaton = Aho.build [(needle, ())]+    onMatch _ _match = Aho.Done True+  in+    \haystack -> Aho.runLower False onMatch automaton haystack++bmciCount :: Text.Text -> Text.Text -> Int+{-# NOINLINE bmciCount #-}+bmciCount needle =+  let+    !automaton = BoyerMooreCI.buildAutomaton needle+    onMatch !n _matchStart _matchEnd = BoyerMooreCI.Step (n + 1)+  in+    \haystack -> BoyerMooreCI.runText 0 onMatch automaton haystack++bmciContains :: Text.Text -> Text.Text -> Bool+{-# NOINLINE bmciContains #-}+bmciContains needle =+  let+    !automaton = BoyerMooreCI.buildAutomaton needle+    onMatch _ _matchStart _matchEnd = BoyerMooreCI.Done True+  in+    \haystack -> BoyerMooreCI.runText False onMatch automaton haystack++bmCount :: Text.Text -> Text.Text -> Int+{-# NOINLINE bmCount #-}+bmCount needle =+  let+    !automaton = BoyerMoore.buildAutomaton needle+    onMatch !n _match = BoyerMoore.Step (n + 1)+  in+    \haystack -> BoyerMoore.runText 0 onMatch automaton haystack++bmContains :: Text.Text -> Text.Text -> Bool+{-# NOINLINE bmContains #-}+bmContains needle =+  let+    !automaton = BoyerMoore.buildAutomaton needle+    onMatch _ _match = BoyerMoore.Done True+  in+    \haystack -> BoyerMoore.runText False onMatch automaton haystack+++needle1 :: Text.Text+needle1 = "necessitatibus"++haystack1 :: Text.Text+haystack1 =+  Text.unlines+    [ "Lorem ipsum dolor sit amet. Et sint voluptatibus est vero maxime vel explicabo reprehenderit non molestiae quisquam sit dolores facere qui cumque quibusdam 33 impedit deserunt! Aut libero harum et quis quasi qui cupiditate autem."+    , "Qui quia totam non rerum eveniet sed tempora repellendus ab enim consequatur eum quaerat iste. Sed amet nihil sed voluptate aspernatur ut rerum facilis est officia earum aut molestiae tenetur non autem nulla. Qui deserunt necessitatibus ab accusamus doloremque non sint aspernatur."+    , "Et officia illum non quaerat obcaecati cum accusamus minus rem quae quis sed rerum omnis sed inventore quasi. Qui totam deserunt sit minima ullam sit debitis dolores. Est debitis explicabo ut temporibus corporis nam harum dolore est fuga numquam non exercitationem Quis cum amet fuga."+    , "Aut incidunt provident et sequi nulla est molestias perferendis. Hic exercitationem modi ex optio cumque nam voluptate debitis nam iste consequatur non nihil rerum ut accusantium nihil. Sed ullam maiores nobis dolorem sit galisum maiores eum reprehenderit maxime sed galisum placeat cum molestiae quia id similique velit. Aut quasi autem non illo reiciendis sit ullam tempora."+    , "Ut corporis exercitationem sed dicta autem ut voluptatem dolorem vel dolores dolores. Qui ipsam quisquam sed facere porro rem autem necessitatibus nam beatae quisquam. Quo voluptatem optio hic quod reprehenderit ut nostrum voluptatem."+    , "Et consequuntur quia vel unde laudantium non voluptatum magnam. Ut quam autem rem fugit quia ut assumenda error quam amet in omnis quia ut rerum soluta sed consequatur fuga. Ut blanditiis quia et facilis ratione aut blanditiis dolorum aut itaque excepturi eos iste incidunt qui blanditiis velit et magni autem."+    ]++needle2 :: Text.Text+needle2 = "necessitatibus"++haystack2 :: Text.Text+haystack2 =+  Text.unlines+    [ "Lorem ipsum dolor sit amet. Et sint voluptatibus est vero maxime vel explicabo reprehenderit non molestiae quisquam sit dolores facere qui cumque quibusdam 33 impedit deserunt! Aut libero harum et quis quasi qui cupiditate autem."+    ]++needle3 :: Text.Text+needle3 = "sit"++haystack3 :: Text.Text+haystack3 =+  Text.unlines+    [ "Lorem ipsum dolor sit amet. Et sint voluptatibus est vero maxime vel explicabo reprehenderit non molestiae quisquam sit dolores facere qui cumque quibusdam 33 impedit deserunt! Aut libero harum et quis quasi qui cupiditate autem."+    , "Qui quia totam non rerum eveniet sed tempora repellendus ab enim consequatur eum quaerat iste. Sed amet nihil sed voluptate aspernatur ut rerum facilis est officia earum aut molestiae tenetur non autem nulla. Qui deserunt necessitatibus ab accusamus doloremque non sint aspernatur."+    , "Et officia illum non quaerat obcaecati cum accusamus minus rem quae quis sed rerum omnis sed inventore quasi. Qui totam deserunt sit minima ullam sit debitis dolores. Est debitis explicabo ut temporibus corporis nam harum dolore est fuga numquam non exercitationem Quis cum amet fuga."+    , "Aut incidunt provident et sequi nulla est molestias perferendis. Hic exercitationem modi ex optio cumque nam voluptate debitis nam iste consequatur non nihil rerum ut accusantium nihil. Sed ullam maiores nobis dolorem sit galisum maiores eum reprehenderit maxime sed galisum placeat cum molestiae quia id similique velit. Aut quasi autem non illo reiciendis sit ullam tempora."+    , "Ut corporis exercitationem sed dicta autem ut voluptatem dolorem vel dolores dolores. Qui ipsam quisquam sed facere porro rem autem necessitatibus nam beatae quisquam. Quo voluptatem optio hic quod reprehenderit ut nostrum voluptatem."+    , "Et consequuntur quia vel unde laudantium non voluptatum magnam. Ut quam autem rem fugit quia ut assumenda error quam amet in omnis quia ut rerum soluta sed consequatur fuga. Ut blanditiis quia et facilis ratione aut blanditiis dolorum aut itaque excepturi eos iste incidunt qui blanditiis velit et magni autem."+    ]++needle4 :: Text.Text+needle4 = "sit"++haystack4 :: Text.Text+haystack4 =+  Text.unlines+    [ "Lorem ipsum dolor sit amet. Et sint voluptatibus est vero maxime vel explicabo reprehenderit non molestiae quisquam sit dolores facere qui cumque quibusdam 33 impedit deserunt! Aut libero harum et quis quasi qui cupiditate autem."+    ]++++needle5 :: Text.Text+needle5 = "сусципиантур"++-- Cyrillic lipsum from https://generator.lorem-ipsum.info/_russian+haystack5 :: Text.Text+haystack5 =+  Text.unlines+    [ "Лорем ипсум долор сит амет, ин вис вирис маиорум инсоленс, алиа агам иудицабит цу нец, ут адмодум инцидеринт еффициантур цум. Вих те номинави диспутатиони, не дуо путент дицунт. Дебет репудиандае яуо ан, вих тамяуам репудиандае цонцлусионемяуе но, цу иус регионе урбанитас. Персиус дицерет форенсибус ат цум, еум яуаеяуе аппеллантур еу. Хас вивендо цонсететур те, ад хас меис пхаедрум, репудиаре демоцритум вих еу."+    , "Пер ут нулла минимум цонтентионес, сеа ат мунере алтера медиоцрем. Но вим лабитур цонсететур, нам ут ипсум фацилис феугаит. Не дицат феугиат аппареат нам, дуис адиписцинг ех еам. Ут еуисмод веритус интерпретарис усу. Сед цасе дицунт ехпетендис ех. Ад лудус урбанитас вим."+    , "Перфецто инсоленс ут меи, адмодум ментитум партиендо усу ат. Ин солеат еирмод аперири дуо, еи мазим фацилиси делицата сед. Дицо неглегентур ут хис, еи хис афферт аудире. Ат аццусата глориатур вел."+    , "Персиус омиттам при ад, цонгуе воцент репудиаре усу ет. Ат детрахит салутатус вим. Еа сеа яуис тациматес. Ид фацер дицтас еум, вери дицам еум еу, при ид тантас омиттам. Суавитате персецути еам те, ет яуот омиттантур ест."+    , "Еа тациматес евертитур дуо, меа ин вениам ассентиор. Еос ессе мунди аццусата цу. Ат партем медиоцрем иус, ан мел алии плацерат. Еам еи суммо ерант тинцидунт. Меа еа алиа сцрибентур."+    , "Еи вих малис омиттам сплендиде, ид витае ностер алияуандо еам, те новум репудиаре пер. Вис цу еррор алтерум садипсцинг, ан ерат фацете аудире ест. Меи ат виде ассуеверит. Вис либрис популо ид, ат хис симилияуе репудиандае, нибх салутатус ех сеа."+    , "Сеа пондерум адиписцинг ех, ет нонумы анциллае вих. Цу иллум ессент медиоцрем вис, еу мовет мунди еос, яуо зрил долорем партиендо но. Хис ат диам цоммодо демоцритум, вери цаусае инцидеринт усу ин. Темпорибус диссентиунт вис еа, ех цум цонсул поссим алтерум. Вим ин веро нулла, еиус реяуе ех меа."+    , "Омнес трацтатос цу еос. Пер ехерци модератиус еа. Нец оффендит сусципит ех. Пер ех постеа фацете, те еум еиус игнота легендос. Ат поссе воцибус пер, ин про лаудем сплендиде цотидиеяуе, но адхуц инермис аццоммодаре еос. Ин денияуе малуиссет еам, ин яуис доцтус нец."+    , "Идяуе елояуентиам еу яуи, витае интерессет не вис, хис диссентиет сусципиантур цу. Тибияуе елаборарет еам еа. Оратио вивендум цонсулату ид пер. Еа путант еррорибус сит, цум ад алияуид аццоммодаре. Алтерум делецтус алияуандо еу иус, ан иус поссит персиус тибияуе. Сеа не нумяуам фуиссет, ат виси аудире при. Суас граеце цопиосае дуо ан, но мунди опортере цонвенире яуи."+    , "Мел фугит путант опортере но, цопиосае оффициис еос еа. Вис инвидунт еффициенди ат, те луцилиус сцрибентур хис, вих не поссит вертерем. Дуо омнис дицат вирис еи, ет адхуц цетеро вис. Еа вим утинам инвенире, вих ин еяуидем ассентиор."+    ]

@@ -5,6 +5,7 @@ -- repository root.  {-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -39,6 +40,7 @@     , runLower     , runText     , runWithCase+    , needleCasings     ) where  import Control.DeepSeq (NFData)@@ -58,6 +60,7 @@ import Data.Text.Utf8 (CodePoint, CodeUnitIndex (CodeUnitIndex), Text (..)) import Data.TypedByteArray (Prim, TypedByteArray) +import qualified Data.Text as Text import qualified Data.Text.Utf8 as Utf8 import qualified Data.TypedByteArray as TBA @@ -113,7 +116,7 @@   -- ^ A lookup table for transitions from the root state, an optimization to   -- avoid having to walk all transitions, at the cost of using a bit of   -- additional memory.-  } deriving (Generic)+  } deriving (Generic, Functor)  instance NFData v => NFData (AcMachine v) @@ -544,3 +547,18 @@ {-# INLINE runLower #-} runLower :: forall a v. a -> (a -> Match v -> Next a) -> AcMachine v -> Text -> a runLower = runWithCase IgnoreCase+++-- | Given a lower case text, this gives all the texts that would lowercase to this one+--+--     needleCasings "abc" == ["abc","abC","aBc","aBC","Abc","AbC","ABc","ABC"]+--     needleCasings "ABC" == []+--     needleCasings "ω1" == ["Ω1","ω1","Ω1"]+--+needleCasings :: Text -> [Text]+needleCasings = map Text.pack . loop . Text.unpack+  where+    loop "" = [""]+    loop (c:cs) = (:) <$> Utf8.unlowerCodePoint c <*> loop cs++

@@ -17,10 +17,13 @@     , Payload (..)     , Replacement     , Replacer (..)+    , replacerCaseSensitivity     , build     , compose+    , mapReplacement     , run     , runWithLimit+    , setCaseSensitivity     ) where  import Control.DeepSeq (NFData)@@ -33,13 +36,14 @@ import qualified Data.Aeson as AE #endif -import Data.Text.CaseSensitivity (CaseSensitivity (..))-import Data.Text.Utf8 (CodeUnitIndex, Text) import Data.Text.AhoCorasick.Searcher (Searcher)+import Data.Text.CaseSensitivity (CaseSensitivity (..))+import Data.Text.Utf8 (CodeUnitIndex (..), Text) -import qualified Data.Text.Utf8 as Utf8+import qualified Data.Text as Text import qualified Data.Text.AhoCorasick.Automaton as Aho import qualified Data.Text.AhoCorasick.Searcher as Searcher+import qualified Data.Text.Utf8 as Utf8  -- | Descriptive type alias for strings to search for. type Needle = Text@@ -54,7 +58,14 @@  data Payload = Payload   { needlePriority    :: {-# UNPACK #-} !Priority-  , needleLength      :: {-# UNPACK #-} !CodeUnitIndex+  , needleLengthBytes       :: {-# UNPACK #-} !CodeUnitIndex+    -- ^ Number of bytes is used for case sensitive matching+  , needleLengthCodePoints  :: {-# UNPACK #-} !Int+    -- ^ For case insensitive matches, the byte length does not necessarily match the needle byte+    -- length. Due to our simple case folding the number of codepoints _does_ match, so we put that+    -- in the payload. It's less efficient because we have to scan backwards through the text to+    -- obtain the length of a match.+   , needleReplacement :: !Replacement   } #if defined(HAS_AESON)@@ -65,8 +76,7 @@  -- | A state machine used for efficient replacements with many different needles. data Replacer = Replacer-  { replacerCaseSensitivity :: CaseSensitivity-  , replacerSearcher :: Searcher Payload+  { replacerSearcher :: Searcher Payload   }   deriving stock (Show, Eq, Generic) #if defined(HAS_AESON)@@ -85,36 +95,64 @@ -- We need to revisit this algorithm when we want to implement full Unicode -- support. build :: CaseSensitivity -> [(Needle, Replacement)] -> Replacer-build caseSensitivity replaces = Replacer caseSensitivity searcher+build caseSensitivity replaces = Replacer searcher   where     searcher = Searcher.buildWithValues caseSensitivity $ zipWith mapNeedle [0..] replaces     mapNeedle i (needle, replacement) =-      let-        needle' = case caseSensitivity of-          CaseSensitive -> needle-          IgnoreCase -> Utf8.lowerUtf8 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) (Utf8.lengthUtf8 needle') replacement)+      -- 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.+      let needle' = case Searcher.caseSensitivity searcher of+                      CaseSensitive -> needle+                      IgnoreCase -> Utf8.lowerUtf8 needle+          -- Payload includes byte and code point lengths, so can still be used if we change case+          -- sensitivity later.+          payload = Payload+            { needlePriority = (-i)+            , needleLengthBytes = Utf8.lengthUtf8 needle+            , needleLengthCodePoints = Text.length needle+            , needleReplacement = replacement+            }+      in (needle', payload)  -- | Return the composition `replacer2` after `replacer1`, if they have the same -- case sensitivity. If the case sensitivity differs, Nothing is returned. compose :: Replacer -> Replacer -> Maybe Replacer-compose (Replacer case1 searcher1) (Replacer case2 searcher2)-  | case1 /= case2 = Nothing+compose (Replacer searcher1) (Replacer searcher2)+  | Searcher.caseSensitivity searcher1 /= Searcher.caseSensitivity searcher2 = Nothing   | otherwise =       let         -- Replace the priorities of the second machine, so they all come after         -- the first.-        renumber i (needle, Payload _ len replacement) = (needle, Payload (-i) len replacement)+        renumber i (needle, Payload _ lenb lenc replacement) = (needle, Payload (-i) lenb lenc replacement)         needles1 = Searcher.needles searcher1         needles2 = Searcher.needles searcher2-        searcher = Searcher.buildWithValues case1 $ zipWith renumber [0..] (needles1 ++ needles2)+        cs = Searcher.caseSensitivity searcher1+        searcher = Searcher.buildWithValues cs $ zipWith renumber [0..] (needles1 ++ needles2)       in-        Just $ Replacer case1 searcher+        Just $ Replacer searcher +-- | Modify the replacement of a replacer. It doesn't modify the needles.+mapReplacement :: (Replacement -> Replacement) -> Replacer -> Replacer+mapReplacement f replacer = replacer{+  replacerSearcher = Searcher.mapSearcher+    (\p -> p {needleReplacement = f (needleReplacement p)})+    (replacerSearcher replacer)+}+++replacerCaseSensitivity :: Replacer -> CaseSensitivity+replacerCaseSensitivity (Replacer searcher) = Searcher.caseSensitivity searcher+++-- | Updates the case sensitivity of the replacer. Does not change the+-- capitilization of the needles. The caller should be certain that if IgnoreCase+-- is passed, the needles are already lower case.+setCaseSensitivity :: CaseSensitivity -> Replacer -> Replacer+setCaseSensitivity case_ (Replacer searcher) =+  Replacer (Searcher.setCaseSensitivity case_ searcher)++ -- A match collected while running replacements. It is isomorphic to the Match -- reported by the automaton, but the data is arranged in a more useful way: -- as the start index and length of the match, and the replacement.@@ -159,27 +197,12 @@       then m0 : removeOverlap (m1:ms)       else removeOverlap (m0:ms) --- | When we iterate through all matches, keep track only of the matches with--- the highest priority: those are the ones that we will replace first. If we--- find multiple matches with that priority, remember all of them. If we find a--- match with lower priority, ignore it, because we already have a more--- important match. Also, if the priority is `threshold` or higher, ignore the--- match, so we can exclude matches if we already did a round of replacements--- for that priority. This way we don't have to build a new automaton after--- every round of replacements.-{-# INLINE prependMatch #-}-prependMatch :: Priority -> (Priority, [Match]) -> Aho.Match Payload -> Aho.Next (Priority, [Match])-prependMatch !threshold (!pBest, !matches) (Aho.Match pos (Payload pMatch len replacement))-  | pMatch < threshold && pMatch >  pBest = Aho.Step (pMatch, [Match (pos - len) len replacement])-  | pMatch < threshold && pMatch == pBest = Aho.Step (pMatch, Match (pos - len) len replacement : matches)-  | otherwise = Aho.Step (pBest, matches)- run :: Replacer -> Text -> Text run replacer = fromJust . runWithLimit replacer maxBound  {-# NOINLINE runWithLimit #-} runWithLimit :: Replacer -> CodeUnitIndex -> Text -> Maybe Text-runWithLimit (Replacer case_ searcher) maxLength = go initialThreshold+runWithLimit (Replacer searcher) maxLength = go initialThreshold   where     !automaton = Searcher.automaton searcher @@ -197,9 +220,9 @@     go !threshold haystack =       let         seed = (minBound :: Priority, [])-        matchesWithPriority = case case_ of-          CaseSensitive -> Aho.runText seed (prependMatch threshold) automaton haystack-          IgnoreCase -> Aho.runLower seed (prependMatch threshold) automaton haystack+        matchesWithPriority = case Searcher.caseSensitivity searcher of+          CaseSensitive -> Aho.runText seed (prependMatch threshold haystack) automaton haystack+          IgnoreCase -> Aho.runLower seed (prependMatch threshold haystack) automaton haystack       in         case matchesWithPriority of           -- No match at the given threshold, there is nothing left to do.@@ -217,3 +240,35 @@             | replacementLength matches haystack > maxLength -> Nothing             | p == minPriority -> Just $ replace (removeOverlap $ sort matches) haystack             | otherwise -> go p $ replace (removeOverlap $ sort matches) haystack++    -- When we iterate through all matches, keep track only of the matches with+    -- the highest priority: those are the ones that we will replace first. If we+    -- find multiple matches with that priority, remember all of them. If we find a+    -- match with lower priority, ignore it, because we already have a more+    -- important match. Also, if the priority is `threshold` or higher, ignore the+    -- match, so we can exclude matches if we already did a round of replacements+    -- for that priority. This way we don't have to build a new automaton after+    -- every round of replacements.+    prependMatch+      :: Priority -> Text -> (Priority, [Match]) -> Aho.Match Payload -> Aho.Next (Priority, [Match])+    {-# INLINE prependMatch #-}+    prependMatch !threshold haystack (!pBest, !matches) (Aho.Match pos (Payload pMatch lenb lenc replacement))+      | pMatch < threshold && pMatch >  pBest =+          Aho.Step (pMatch, [makeMatch haystack pos lenb lenc replacement])+      | pMatch < threshold && pMatch == pBest =+          Aho.Step (pMatch, makeMatch haystack pos lenb lenc replacement : matches)+      | otherwise = Aho.Step (pBest, matches)++    -- Pos is the code unit index past the last code unit of the match, we have+    -- to find the first code unit.+    makeMatch :: Text -> CodeUnitIndex -> CodeUnitIndex -> Int -> Replacement -> Match+    {-# INLINE makeMatch #-}+    makeMatch = case Searcher.caseSensitivity searcher of+      -- Case sensitive: length is interpreted as number of bytes+      CaseSensitive -> \_ pos lenb _ replacement ->+        Match (pos - lenb) lenb replacement+      -- Case insensitive: length is interpreted as number of characters+      IgnoreCase -> \haystack pos _ lenc replacement ->+        -- We start at the last byte of the match, and look backwards.+        let start = Utf8.skipCodePointsBackwards haystack (pos-1) (lenc-1) in+        Match start (pos - start) replacement

@@ -20,12 +20,14 @@     , caseSensitivity     , containsAll     , containsAny+    , mapSearcher     , needles     , numNeedles-    , setSearcherCaseSensitivity+    , setCaseSensitivity     ) where  import Control.DeepSeq (NFData)+import Data.Bifunctor (second) import Data.Hashable (Hashable (hashWithSalt), Hashed, hashed, unhashed) import GHC.Generics (Generic) @@ -115,6 +117,13 @@ buildWithValues case_ ns =   Searcher case_ (hashed ns) (length ns) $ Aho.build ns +-- | Modify the values associated with the needles.+mapSearcher :: Hashable b => (a -> b) -> Searcher a -> Searcher b+mapSearcher f searcher = searcher+  { searcherNeedles = hashed $ fmap (second f) $ needles searcher+  , searcherAutomaton = fmap f (searcherAutomaton searcher)+  }+ needles :: Searcher v -> [(Text, v)] needles = unhashed . searcherNeedles @@ -130,8 +139,8 @@ -- | 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{+setCaseSensitivity :: CaseSensitivity -> Searcher v -> Searcher v+setCaseSensitivity case_ searcher = searcher{     searcherCaseSensitive = case_   } 

@@ -30,6 +30,7 @@ #endif  import qualified Data.List.NonEmpty as NonEmpty+import qualified Data.Text as Text  import Data.Text.AhoCorasick.Automaton (AcMachine) @@ -94,23 +95,26 @@ {-# INLINE splitReverse #-} splitReverse :: Splitter -> Text -> NonEmpty Text splitReverse s t =-  finalizeAccum $-    Aho.runText-      (zeroAccum (separator s) t)-      stepAccum-      (automaton s)-      t+  finalizeAccum t $ Aho.runText zeroAccum stepAccum' (automaton s) t+  where+    -- Case sensitive matching: separator length is in bytes.+    sepLength = Utf8.lengthUtf8 (separator s)+    stepAccum' accum (Aho.Match newFragmentStart _) =+      stepAccum t accum (newFragmentStart - sepLength) newFragmentStart + -- | 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+  finalizeAccum t $ Aho.runLower zeroAccum stepAccum' (automaton s) t+  where+    -- Case insensitive matching: separator length is in codepoints.+    sepLength = Text.length (separator s)+    stepAccum' accum (Aho.Match newFragmentStart _) =+      -- We start at the last byte of the separator, and look backwards.+      let sepStart = Utf8.skipCodePointsBackwards t (newFragmentStart-1) (sepLength-1) in+      stepAccum t accum sepStart newFragmentStart  -------------------------------------------------------------------------------- -- Fold@@ -120,17 +124,17 @@ -- 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.+    { accumResult :: ![Text]+      -- ^ Match-separated strings.+    , accumFragmentStart :: !Aho.CodeUnitIndex+      -- ^ First byte of current fragment (that is the non-separator part)     }  -- | 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) =+finalizeAccum :: Text -> Accum -> NonEmpty Text+finalizeAccum hay (Accum 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.@@ -139,26 +143,26 @@  -- | The initial accumulator begins at the begin of the haystack. {-# INLINE zeroAccum #-}-zeroAccum :: Text -> Text -> Accum-zeroAccum sep hay = Accum (Utf8.lengthUtf8 sep) hay [] 0+zeroAccum :: Accum+zeroAccum = Accum { accumResult = [], accumFragmentStart = 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 _)+stepAccum :: Text -> Accum -> Aho.CodeUnitIndex -> Aho.CodeUnitIndex -> Aho.Next Accum+stepAccum hay acc@(Accum res fragmentStart) sepStart newFragmentStart    -- When the match begins before the current offset, it overlaps a match that   -- we processed before, and so we ignore it.-  | sepEnd - sepLen < prevEnd =+  | sepStart < fragmentStart =       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 = Utf8.unsafeSliceUtf8 prevEnd (sepEnd - sepLen - prevEnd) hay in-      Aho.Step acc { accumResult = str : res, accumPrevEnd = sepEnd }+      let !str = Utf8.unsafeSliceUtf8 fragmentStart (sepStart - fragmentStart) hay in+      Aho.Step acc { accumResult = str : res, accumFragmentStart = newFragmentStart }  -------------------------------------------------------------------------------- -- Instances

@@ -36,7 +36,7 @@ import Control.DeepSeq (NFData) import Control.Monad (when) import Control.Monad.ST (runST)-import Data.Hashable (Hashable (..), Hashed, hashed, unhashed)+import Data.Hashable (Hashable (..)) import GHC.Generics (Generic)  #if defined(HAS_AESON)@@ -65,29 +65,33 @@ -- 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+  { automatonPattern :: !Text+  , automatonPatternHash :: !Int  -- ^ Remember our own hash (similar to what 'Hashed' does but our+                                  -- fields are strict).+  , automatonSuffixTable :: !SuffixTable+  , automatonBadCharTable :: !BadCharTable   }   deriving stock (Generic, Show)   deriving anyclass (NFData)  instance Hashable Automaton where-  hashWithSalt salt (Automaton pattern _ _) = hashWithSalt salt pattern+  hashWithSalt salt (Automaton _ patternHash _ _) = hashWithSalt salt patternHash  instance Eq Automaton where-  (Automaton pat1 _ _) == (Automaton pat2 _ _) = pat1 == pat2+  (Automaton pat1 patHash1 _ _) == (Automaton pat2 patHash2 _ _) =+    patHash1 == patHash2 && 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+  toJSON = AE.toJSON . automatonPattern #endif  buildAutomaton :: Text -> Automaton-buildAutomaton pattern = Automaton (hashed pattern) (buildSuffixTable pattern) (buildBadCharTable pattern)+buildAutomaton pattern =+  Automaton pattern (hash pattern) (buildSuffixTable pattern) (buildBadCharTable pattern)  -- | Finds all matches in the text, calling the match callback with the *first* -- matched character of each match of the pattern.@@ -113,9 +117,8 @@   | patLen == 0 = seed   | otherwise = go seed (patLen - 1)   where-    Automaton patternHashed suffixTable badCharTable = automaton     -- Use needle as identifier since pattern is potentially a keyword-    needle = unhashed patternHashed+    Automaton needle _ suffixTable badCharTable = automaton     patLen = Utf8.lengthUtf8 needle     stringLen = Utf8.lengthUtf8 text @@ -160,7 +163,7 @@  -- | Return the pattern that was used to construct the automaton. patternText :: Automaton -> Text-patternText (Automaton pattern _ _) = unhashed pattern+patternText = automatonPattern  -- | 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.

@@ -61,7 +61,7 @@   {-# INLINE hashWithSalt #-}  instance Eq v => Eq (Searcher v) where-  Searcher xs nx _ == Searcher ys ny _ = (xs, nx) == (ys, ny)+  Searcher xs nx _ == Searcher ys ny _ = nx == ny && xs == ys   {-# INLINE (==) #-}  instance NFData v => NFData (Searcher v)

@@ -0,0 +1,474 @@+-- 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 DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE LambdaCase #-}+{-# 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 is case insensitive variant of the algorithm which, unlike the case+-- sensitive variant, has to be aware of the unicode code points that the bytes+-- represent.+--+module Data.Text.BoyerMooreCI.Automaton+    ( Automaton+    , CaseSensitivity (..)+    , CodeUnitIndex (..)+    , Next (..)+    , buildAutomaton+    , patternLength+    , patternText+    , runText++      -- Exposed for testing+    , minimumSkipForCodePoint+    ) where++import Control.DeepSeq (NFData)+import Control.Monad.ST (runST)+import Data.Hashable (Hashable (..))+import Data.Text.Internal (Text (..))+import GHC.Generics (Generic)++#if defined(HAS_AESON)+import qualified Data.Aeson as AE+#endif++import Data.Text.CaseSensitivity (CaseSensitivity (..))+import Data.Text.Utf8 (BackwardsIter (..), CodePoint, CodeUnitIndex (..))+import Data.TypedByteArray (Prim, TypedByteArray)++import qualified Data.Char as Char+import qualified Data.HashMap.Strict as HashMap+import qualified Data.Text as Text+import qualified Data.Text.Utf8 as Utf8+import qualified Data.TypedByteArray as TBA++data Next a+  = Done !a+  | Step !a+++-- | 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 :: !(TypedByteArray CodePoint)+  , automatonPatternHash :: !Int+  , automatonSuffixTable :: !SuffixTable+  , automatonBadCharLookup :: !BadCharLookup+  , automatonMinPatternSkip :: !CodeUnitIndex+  }+  deriving stock (Generic, Show)+  deriving anyclass (NFData)++instance Hashable Automaton where+  hashWithSalt salt = hashWithSalt salt . automatonPatternHash++instance Eq Automaton where+  x == y = automatonPattern x == automatonPattern y++#if defined(HAS_AESON)+instance AE.FromJSON Automaton where+  parseJSON v = buildAutomaton <$> AE.parseJSON v++instance AE.ToJSON Automaton where+  toJSON = AE.toJSON . patternText+#endif++buildAutomaton :: Text -> Automaton+buildAutomaton pattern_ =+  Automaton+    { automatonPattern = patternVec+    , automatonPatternHash = hash pattern_+    , automatonSuffixTable = buildSuffixTable patternVec+    , automatonBadCharLookup = buildBadCharLookup patternVec+    , automatonMinPatternSkip = minimumSkipForVector patternVec+    }+  where+    patternVec = TBA.fromList (Text.unpack pattern_)++-- | Finds all matches in the text, calling the match callback with the first and last byte index of+-- each match of the pattern.+runText  :: forall a+  . a+  -> (a -> CodeUnitIndex -> CodeUnitIndex -> Next a)+  -> Automaton+  -> Text+  -> a+{-# INLINE runText #-}+runText seed f automaton !text+  | TBA.null pattern_ = seed+  | otherwise = alignPattern seed initialHaystackMin (initialHaystackMin + minPatternSkip - 1)+  where+    Automaton pattern_ _ suffixTable badCharTable minPatternSkip = automaton++    -- In the pattern we always count codepoints,+    -- in the haystack we always count code units++    -- Highest index that we're allowed to use in the text+    haystackMax = case text of Text _ offset len -> CodeUnitIndex (offset + len - 1)++    -- How far we can look back in the text data is first limited by the text+    -- offset, and later by what we matched before.+    initialHaystackMin = case text of Text _ offset _ -> CodeUnitIndex offset++    -- This is our _outer_ loop, called when the pattern is moved+    alignPattern+      :: a+      -> CodeUnitIndex  -- Don't read before this point in the haystack+      -> CodeUnitIndex  -- End of pattern is aligned at this point in the haystack+      -> a+    {-# INLINE alignPattern #-}+    alignPattern !result !haystackMin !alignmentEnd+      | alignmentEnd > haystackMax = result+      | otherwise =+          let+            !iter = Utf8.unsafeIndexAnywhereInCodePoint' (case text of Text d _ _ -> d) alignmentEnd+            !patternIndex = TBA.length pattern_ - 1+            -- End of char may be somewhere different than where we started looking+            !alignmentEnd' = backwardsIterEndOfChar iter+          in+            matchLoop result haystackMin alignmentEnd' iter patternIndex++    -- The _inner_ loop, called for every pattern character back to front within a pattern alignment.+    matchLoop+      :: a+      -> CodeUnitIndex  -- haystackMin, don't read before this point in the haystack+      -> CodeUnitIndex  -- (adjusted) alignmentEnd, end of pattern is aligned at this point in the haystack+      -> BackwardsIter+      -> Int            -- index in the pattern+      -> a+    matchLoop !result !haystackMin !alignmentEnd !iter !patternIndex =+      let+        !haystackCodePointLower = Utf8.lowerCodePoint (backwardsIterChar iter)+      in+        case haystackCodePointLower == TBA.unsafeIndex pattern_ patternIndex of++          True | patternIndex == 0 ->+            -- We found a complete match (all pattern characters matched)+            let !from = backwardsIterNext iter + 1 - initialHaystackMin+                !to = alignmentEnd - initialHaystackMin+            in+              case f result from to of+                Done final -> final+                Step intermediate ->+                  let haystackMin' = alignmentEnd + 1  -- Disallow overlapping matches+                      alignmentEnd' = alignmentEnd + minPatternSkip+                  in alignPattern intermediate haystackMin' alignmentEnd'++          -- The pattern may be aligned in such a way that the start is before the start of the+          -- haystack. This _only_ happens when ⱥ and ⱦ characters occur (due to how minPatternSkip+          -- is calculated).+          True | backwardsIterNext iter < haystackMin ->+            alignPattern result haystackMin (alignmentEnd + 1)++          -- We continue by comparing the next character+          True ->+            let+              next = backwardsIterNext iter+              !iter' = Utf8.unsafeIndexEndOfCodePoint' (case text of Text d _ _ -> d) next+            in+              matchLoop result haystackMin alignmentEnd iter' (patternIndex - 1)++          -- Character did _not_ match at current position. Check how far the pattern has to move.+          False ->+            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 pattern.+              !fromBadChar =+                backwardsIterEndOfChar iter + badCharLookup badCharTable haystackCodePointLower++              -- This is always at least 1, ensuring that we make progress+              -- Suffixlookup tells us how far we can move the pattern+              !fromSuffixLookup =+                alignmentEnd + suffixLookup suffixTable patternIndex++              !alignmentEnd' = max fromBadChar fromSuffixLookup++            in+              -- Minimum stays the same+              alignPattern result haystackMin alignmentEnd'++-- | Length of the matched pattern measured in UTF-8 code units (bytes).+patternLength :: Automaton -> CodeUnitIndex+patternLength = Utf8.lengthUtf8 . patternText++-- | Return the pattern that was used to construct the automaton, O(n).+patternText :: Automaton -> Text+patternText = Text.pack . TBA.toList . automatonPattern+++-- | Number of bytes that we can skip in the haystack if we want to skip no more+-- than 1 pattern codepoint.+--+-- It must always be a low (safe) estimate, otherwise the algorithm can miss+-- matches. It must account for any variation of upper/lower case characters+-- that may occur in the haystack. In most cases, this is the same number of+-- bytes as for the given codepoint+--+--     minimumSkipForCodePoint 'a' == 1+--     minimumSkipForCodePoint 'д' == 2+--     minimumSkipForCodePoint 'ⓟ' == 3+--     minimumSkipForCodePoint '🎄' == 4+--+minimumSkipForCodePoint :: CodePoint -> CodeUnitIndex+minimumSkipForCodePoint cp =+  case Char.ord cp of+    c | c < 0x80     -> 1+    c | c < 0x800    -> 2+    -- The letters ⱥ and ⱦ are 3 UTF8 bytes, but have unlowerings Ⱥ and Ⱦ of 2 bytes+    0x2C65           -> 2  -- ⱥ+    0x2C66           -> 2  -- ⱦ+    c | c < 0x10000  -> 3+    _                -> 4+++-- | Number of bytes of the shortest case variation of the given needle. Needles+-- are assumed to be lower case.+--+--     minimumSkipForVector (TBA.fromList "ab..cd") == 6+--     minimumSkipForVector (TBA.fromList "aⱥ💩") == 7+--+minimumSkipForVector :: TypedByteArray CodePoint -> CodeUnitIndex+minimumSkipForVector = TBA.foldr (\cp s -> s + minimumSkipForCodePoint cp) 0+++-- | The suffix table tells us for each codepoint (not byte!) of the pattern how many bytes (not+-- codepoints!) we can jump ahead if the match fails at that point.+newtype SuffixTable = SuffixTable (TypedByteArray CodeUnitIndex)+  deriving stock (Generic)+  deriving anyclass (NFData)++instance Show SuffixTable where+  show (SuffixTable table) = "SuffixTable (TBA.toList " <> show (TBA.toList table) <> ")"++-- | Lookup an entry in the suffix table.+suffixLookup :: SuffixTable -> Int -> CodeUnitIndex+{-# INLINE suffixLookup #-}+suffixLookup (SuffixTable table) = indexTable table++buildSuffixTable :: TypedByteArray CodePoint -> SuffixTable+buildSuffixTable pattern_ = runST $ do+  let+    patLen = TBA.length pattern_+    wholePatternSkip = minimumSkipForVector pattern_++  table <- TBA.newTypedByteArray 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+    -- lastSkipBytes:              5   not touched by init1+    -- lastSkipBytes:           4  5   "a" == "a" so if we get a mismatch here we can skip+    --                                            everything but the length of "a"+    -- lastSkipBytes:        4  4  5   "ab" /= "ba" so keep skip value+    -- lastSkipBytes:     2  4  4  5   "aba" == "aba"+    -- lastSkipBytes:  2  2  4  4  5   "abab" /= "baba"+    init1 lastSkipBytes p+      | p >= 0 = do+        let+          skipBytes = case suffixIsPrefix pattern_ (p + 1) of+                        Nothing -> lastSkipBytes+                        -- Skip the whole pattern _except_ the bytes for the suffix(==prefix)+                        Just nonSkippableBytes -> wholePatternSkip - nonSkippableBytes+        TBA.writeTypedByteArray table p skipBytes+        init1 skipBytes (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 skipBytes+      | p < patLen - 1 = do+          -- If we find a suffix that ends at p, we can skip everything _after_ p.+          let skipBytes' = skipBytes - minimumSkipForCodePoint (TBA.unsafeIndex pattern_ p)+          case substringIsSuffix pattern_ p of+            Nothing -> pure ()+            Just suffixLen -> do+              TBA.writeTypedByteArray table (patLen - 1 - suffixLen) skipBytes'+          init2 (p + 1) skipBytes'+      | otherwise = pure ()++  init1 (wholePatternSkip-1) (patLen - 1)+  init2 0 wholePatternSkip+  TBA.writeTypedByteArray table (patLen - 1) (CodeUnitIndex 1)++  SuffixTable <$> TBA.unsafeFreezeTypedByteArray table++-- | True if the suffix of the @pattern@ starting from @pos@ is a prefix of the pattern+-- For example, @suffixIsPrefix \"aabbaa\" 4 == Just 2@.+suffixIsPrefix :: TypedByteArray CodePoint -> Int -> Maybe CodeUnitIndex+suffixIsPrefix pattern_ pos = go 0 (CodeUnitIndex 0)+  where+    suffixLen = TBA.length pattern_ - pos+    go !i !skipBytes+      | i < suffixLen =+          let prefixChar = TBA.unsafeIndex pattern_ i in+          if prefixChar == TBA.unsafeIndex pattern_ (pos + i)+            then go (i + 1) (skipBytes + minimumSkipForCodePoint prefixChar)+            else Nothing+      | otherwise = Just skipBytes++-- | Length in bytes of the longest suffix of the pattern ending on @pos@.  For+-- example, @substringIsSuffix \"abaacbbaac\" 4 == Just 4@, because the+-- substring \"baac\" ends at position 4 and is at the same time the longest+-- suffix that does so, having a length of 4 characters.+--+-- For a string like "abaacaabcbaac", when we detect at pos=4 that baac==baac,+-- it means that if we get a mismatch before the "baac" suffix, we can skip the+-- "aabcbaac" characters _after_ the "baac" substring. So we can put+-- (minimumSkipForText "aabcbaac") at that point in the suffix table.+--+--   substringIsSuffix (Vector.fromList "ababa") 0 == Nothing  -- a == a, but not a proper substring+--   substringIsSuffix (Vector.fromList "ababa") 1 == Nothing  -- b /= a+--   substringIsSuffix (Vector.fromList "ababa") 2 == Nothing  -- aba == aba, but not a proper substring+--   substringIsSuffix (Vector.fromList "ababa") 3 == Nothing  -- b /= a+--   substringIsSuffix (Vector.fromList "ababa") 4 == Nothing  -- ababa == ababa, but not a proper substring+--   substringIsSuffix (Vector.fromList "baba") 0 == Nothing  -- b /= a+--   substringIsSuffix (Vector.fromList "baba") 1 == Nothing  -- ba == ba, but not a proper substring+--   substringIsSuffix (Vector.fromList "abaacaabcbaac") 4 == Just 4  -- baac == baac+--   substringIsSuffix (Vector.fromList "abaacaabcbaac") 8 == Just 1  -- c == c+--+substringIsSuffix :: TypedByteArray CodePoint -> Int -> Maybe Int+substringIsSuffix pattern_ pos = go 0+  where+    patLen = TBA.length pattern_+    go i | i > pos = Nothing  -- prefix==suffix, so already covered by suffixIsPrefix+         | TBA.unsafeIndex pattern_ (pos - i) == TBA.unsafeIndex pattern_ (patLen - 1 - i) =+             go (i + 1)+         | i == 0 = Nothing  -- Nothing matched+         | otherwise = Just i+++-- | The bad char table tells us how many bytes 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 BadCharLookup = BadCharLookup+  { badCharLookupTable :: {-# UNPACK #-} !(TypedByteArray CodeUnitIndex)+  , badCharLookupMap :: !(HashMap.HashMap CodePoint CodeUnitIndex)+  , badCharLookupDefault :: !CodeUnitIndex+  }+  deriving stock (Generic, Show)+  deriving anyclass (NFData)++-- | Number of entries in the fixed-size lookup-table of the bad char table.+badCharTableSize :: Int+{-# INLINE badCharTableSize #-}+badCharTableSize = 256++-- | Lookup an entry in the bad char table.+badCharLookup :: BadCharLookup -> CodePoint -> CodeUnitIndex+{-# INLINE badCharLookup #-}+badCharLookup (BadCharLookup bclTable bclMap bclDefault) char+  | intChar < badCharTableSize = indexTable bclTable intChar+  | otherwise = HashMap.lookupDefault bclDefault char bclMap+  where+    intChar = fromEnum char++++buildBadCharLookup :: TypedByteArray CodePoint -> BadCharLookup+buildBadCharLookup pattern_ = runST $ do++  let+    defaultSkip = minimumSkipForVector 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.+  table <- (TBA.replicate badCharTableSize defaultSkip)++  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 !badCharMap !skipBytes = \case+      [] -> pure badCharMap+      [_] -> pure badCharMap  -- The last pattern character doesn't count.+      (!patChar : !patChars) ->+        let skipBytes' = skipBytes - minimumSkipForCodePoint patChar in+        if fromEnum patChar < badCharTableSize+        then do+          TBA.writeTypedByteArray table (fromEnum patChar) skipBytes'+          fillTable badCharMap skipBytes' patChars+        else+          let badCharMap' = HashMap.insert patChar skipBytes' badCharMap+          in fillTable badCharMap' skipBytes' patChars++  badCharMap <- fillTable HashMap.empty defaultSkip (TBA.toList pattern_)++  tableFrozen <- TBA.unsafeFreezeTypedByteArray table++  pure BadCharLookup+    { badCharLookupTable = tableFrozen+    , badCharLookupMap = badCharMap+    , badCharLookupDefault = defaultSkip+    }+++-- Helper functions for easily toggling the safety of this module++-- | Read from a lookup table at the specified index.+indexTable :: Prim a => TypedByteArray a -> Int -> a+{-# INLINE indexTable #-}+indexTable = TBA.unsafeIndex

@@ -0,0 +1,89 @@+-- 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.BoyerMooreCI.Replacer+    ( -- Replacer+      replaceSingleLimited+    ) where++import Data.Text.Utf8 (Text)+import Data.Text.BoyerMooreCI.Automaton (Automaton, CodeUnitIndex)++import qualified Data.Text.Utf8 as Text+import qualified Data.Text.Utf8 as Utf8+import qualified Data.Text.BoyerMooreCI.Automaton as BoyerMoore++-- | Replace all occurrences matched by the Boyer-Moore automaton+-- with the given replacement text in some haystack.+-- Performs case-sensitive replacement.+replaceSingleLimited+  :: Automaton -- ^ Matches the needles+  -> Text -- ^ Replacement string+  -> Text -- ^ Haystack+  -> CodeUnitIndex -- ^ Maximum number of code units in the returned text+  -> Maybe Text+replaceSingleLimited needle replacement haystack maxLength+  | needleLength == 0 = Just $ if haystackLength == 0 then replacement else haystack+  | otherwise = finish $ BoyerMoore.runText initial foundMatch needle haystack+  where+    needleLength = BoyerMoore.patternLength needle+    haystackLength = Utf8.lengthUtf8 haystack+    replacementLength = Utf8.lengthUtf8 replacement++    initial = ReplaceState+      { rsChunks = []+      , rsPreviousMatchEnd = 0+      , rsLength = 0+      }++    foundMatch rs matchStart matchEnd =+      let+        -- 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 = Utf8.unsafeSliceUtf8 (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 + 1+          , 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+            = Utf8.unsafeSliceUtf8 (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,121 @@+-- 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.BoyerMooreCI.Searcher+    ( Searcher+    , automata+    , build+    , buildNeedleIdSearcher+    , buildWithValues+    , containsAll+    , containsAny+    , needles+    , numNeedles+    ) where+++import Control.DeepSeq (NFData)+import Data.Bifunctor (first)+import Data.Hashable (Hashable (hashWithSalt), Hashed, hashed, unhashed)+import GHC.Generics (Generic)++import Data.Text.Utf8 (Text)+import Data.Text.BoyerMooreCI.Automaton (Automaton)++import qualified Data.Text.BoyerMooreCI.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+  { 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 xs nx _ == Searcher ys ny _ = nx == ny && xs == ys+  {-# INLINE (==) #-}++instance NFData v => NFData (Searcher v)++-- | Builds the Searcher for a list of needles without values.+-- This is useful for just checking whether the haystack contains the needles.+build :: [Text] -> Searcher ()+{-# INLINABLE build #-}+build = buildWithValues . flip zip (repeat ())++-- | Builds the Searcher for a list of needles.+buildWithValues :: Hashable v => [(Text, v)] -> Searcher v+{-# INLINABLE buildWithValues #-}+buildWithValues ns =+  Searcher (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++-- | Return whether the haystack contains any of the needles.+-- 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 _matchStart _matchEnd = BoyerMoore.Done True+  in+    any (\(automaton, ()) -> BoyerMoore.runText False f automaton text) (automata searcher)+-- | Build a 'Searcher' that returns the needle's index in the needle list when it matches.++buildNeedleIdSearcher :: [Text] -> Searcher Int+buildNeedleIdSearcher !ns =+  buildWithValues $ zip ns [0..]++-- | Like 'containsAny', but checks whether all needles match instead.+-- Use 'buildNeedleIdSearcher' to get an appropriate 'Searcher'.+{-# NOINLINE containsAll #-}+containsAll :: Searcher Int -> Text -> Bool+containsAll !searcher !text =+  let+    -- On the first match, return True immediately.+    f _acc _matchStart _matchEnd = BoyerMoore.Done True+  in+    all (\(automaton, _) -> BoyerMoore.runText False f automaton text) (automata searcher)

@@ -5,11 +5,14 @@ -- repository root.  {-# LANGUAGE BangPatterns #-}+{-# LANGUAGE BinaryLiterals #-} {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MagicHash #-}+{-# LANGUAGE NumericUnderscores #-}+{-# LANGUAGE UnboxedTuples #-}  -- | This module provides functions that allow treating 'Text' values as series of UTF-8 code units -- instead of characters. Any calls to 'Text' in @alfred-margaret@ go through this module.@@ -23,6 +26,7 @@     , isCaseInvariant     , lengthUtf8     , lowerCodePoint+    , unlowerCodePoint     , lowerUtf8     , toLowerAscii     , unicode2utf8@@ -40,6 +44,7 @@     , indexCodeUnit     , unsafeIndexCodePoint     , unsafeIndexCodeUnit+    , skipCodePointsBackwards       -- * Slicing Functions       --       -- $slicingFunctions@@ -52,6 +57,10 @@     , isArrayPinned     , unsafeIndexCodePoint'     , unsafeIndexCodeUnit'+    , BackwardsIter (..)+    , unsafeIndexEndOfCodePoint'+    , unsafeIndexAnywhereInCodePoint'+       -- * General Functions       --       -- $generalFunctions@@ -71,10 +80,11 @@ import Data.Text.Internal (Text (..)) import Data.Word (Word8) import GHC.Generics (Generic)-import Data.Primitive (ByteArray(ByteArray), byteArrayFromList)+import Data.Primitive (ByteArray (ByteArray), Prim, byteArrayFromList) #if defined(HAS_AESON) import Data.Aeson (FromJSON, ToJSON) #endif+import Data.Text.Utf8.Unlower (unlowerCodePoint)  import qualified Data.Char as Char import qualified Data.Text as Text@@ -96,11 +106,11 @@ newtype CodeUnitIndex = CodeUnitIndex     { codeUnitIndex :: Int     }-    deriving stock (Eq, Ord, Show, Generic, Bounded)+    deriving stock (Eq, Ord, Generic, Bounded) #if defined(HAS_AESON)-    deriving newtype (Hashable, Num, NFData, FromJSON, ToJSON)+    deriving newtype (Show, Prim, Hashable, Num, NFData, FromJSON, ToJSON) #else-    deriving newtype (Hashable, Num, NFData)+    deriving newtype (Show, Prim, Hashable, Num, NFData) #endif  {-# INLINABLE unpackUtf8 #-}@@ -142,6 +152,7 @@  -- | Convert a Unicode Code Point 'c' into a list of UTF-8 code units (bytes). unicode2utf8 :: (Ord a, Num a, Bits a) => a -> [a]+{-# INLINE unicode2utf8 #-} unicode2utf8 c     | c < 0x80    = [c]     | c < 0x800   = [0xc0 .|. (c `shiftR` 6), 0x80 .|. (0x3f .&. c)]@@ -152,17 +163,27 @@ fromByteList byteList = Text (TextArray.ByteArray ba#) 0 (length byteList)   where !(ByteArray ba#) = byteArrayFromList byteList --- | 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.+-- | Return whether text has exactly one case variation, 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)+isCaseInvariant = Text.all (\c -> unlowerCodePoint (lowerCodePoint c) == [c])  -- $decoding -- -- Functions that turns code unit sequences into code point sequences. +-- | Decode a single UTF-8 code unit into its code point.+-- The given code unit should have the following format:+--+-- > ┌───────────────┐+-- > │0 x x x x x x x│+-- > └───────────────┘+decode1 :: CodeUnit -> CodePoint+decode1 cu0 =+  Char.chr $ fromIntegral cu0+ -- | Decode 2 UTF-8 code units into their code point. -- The given code units should have the following format: --@@ -214,22 +235,46 @@ -- | Does exactly the same thing as 'unsafeIndexCodePoint'', but on 'Text' values. {-# INLINE unsafeIndexCodePoint #-} unsafeIndexCodePoint :: Text -> CodeUnitIndex -> (CodeUnitIndex, CodePoint)-unsafeIndexCodePoint (Text !u8data !off !_len) (CodeUnitIndex !index) =-  unsafeIndexCodePoint' u8data $ CodeUnitIndex $ off + index+unsafeIndexCodePoint (Text !u8data !off !_len) !index =+  unsafeIndexCodePoint' u8data $ CodeUnitIndex off + index  -- | Get the code unit at the given 'CodeUnitIndex'. -- Performs bounds checking. {-# INLINE indexCodeUnit #-} indexCodeUnit :: Text -> CodeUnitIndex -> CodeUnit-indexCodeUnit !text (CodeUnitIndex !index)-  | index < 0 || index >= codeUnitIndex (lengthUtf8 text) = error $ "Index out of bounds " ++ show index-  | otherwise = unsafeIndexCodeUnit text $ CodeUnitIndex index+indexCodeUnit !text !index+  | index < 0 || index >= lengthUtf8 text = error $ "Index out of bounds " ++ show index+  | otherwise = unsafeIndexCodeUnit text index  {-# INLINE unsafeIndexCodeUnit #-} unsafeIndexCodeUnit :: Text -> CodeUnitIndex -> CodeUnit-unsafeIndexCodeUnit (Text !u8data !off !_len) (CodeUnitIndex !index) =-  unsafeIndexCodeUnit' u8data $ CodeUnitIndex $ off + index+unsafeIndexCodeUnit (Text !u8data !off !_len) !index =+  unsafeIndexCodeUnit' u8data $ CodeUnitIndex off + index +-- | Scan backwards through the text until we've seen the specified number of codepoints. Assumes+-- that the initial CodeUnitIndex is within a codepoint.+{-# INLINE skipCodePointsBackwards #-}+skipCodePointsBackwards :: Text -> CodeUnitIndex -> Int -> CodeUnitIndex+skipCodePointsBackwards (Text !u8data !off !len) !index0 !n0+  | index0 >= CodeUnitIndex len = error "Invalid use of skipCodePointsBackwards"+  | otherwise = loop (index0 + CodeUnitIndex off) n0+  where+    loop index n | atTrailingByte index =+      loop (index-1) n  -- Don't exit before we're at a leading byte+    loop index 0 | index < 0 =+      -- Throw an error if we've read before the array (e.g. when the data was+      -- not valid UTF-8), this one-time check doesn't prevent undefined+      -- behaviour but may help you locate bugs.+      error "Invalid use of skipCodePointsBackwards"+    loop index 0 =+      index - CodeUnitIndex off+    loop index n =+      loop (index-1) (n-1)++    -- Second, third and fourth bytes of a codepoint are always 10xxxxxx, while+    -- the first byte can be 0xxxxxxx or 11yyyyyy.+    atTrailingByte !index = unsafeIndexCodeUnit' u8data index .&. 0b1100_0000 == 0b1000_0000+ -- $slicingFunctions -- -- 'unsafeCutUtf8' and 'unsafeSliceUtf8' are used to retrieve slices of 'Text' values.@@ -289,16 +334,93 @@ -- Returns garbage if there is no valid code point at that position. -- Does not perform bounds checking. -- See 'decode2', 'decode3' and 'decode4' for the expected format of multi-byte code points.-{-# INLINE unsafeIndexCodePoint' #-} unsafeIndexCodePoint' :: TextArray.Array -> CodeUnitIndex -> (CodeUnitIndex, CodePoint)-unsafeIndexCodePoint' !u8data (CodeUnitIndex !idx)-  | cu0 < 0xc0 = (1, Char.chr $ fromIntegral cu0)-  | cu0 < 0xe0 = (2, decode2 cu0 (cuAt 1))-  | cu0 < 0xf0 = (3, decode3 cu0 (cuAt 1) (cuAt 2))-  | otherwise = (4, decode4 cu0 (cuAt 1) (cuAt 2) (cuAt 3))+{-# INLINE unsafeIndexCodePoint' #-}+unsafeIndexCodePoint' !u8data !idx =+  decodeN (cuAt 0) (cuAt 1) (cuAt 2) (cuAt 3)   where-    cuAt !i = unsafeIndexCodeUnit' u8data $ CodeUnitIndex $ idx + i-    !cu0 = cuAt 0+    cuAt !i = unsafeIndexCodeUnit' u8data $ idx + i++decodeN :: CodeUnit -> CodeUnit -> CodeUnit -> CodeUnit -> (CodeUnitIndex, CodePoint)+{-# INLINE decodeN #-}+decodeN cu0 cu1 cu2 cu3+  | cu0 < 0xc0 = (1, decode1 cu0)+  | cu0 < 0xe0 = (2, decode2 cu0 cu1)+  | cu0 < 0xf0 = (3, decode3 cu0 cu1 cu2)+  | otherwise = (4, decode4 cu0 cu1 cu2 cu3)++++-- | Intermediate state when you're iterating backwards through a Utf8 text.+data BackwardsIter = BackwardsIter+  { backwardsIterNext :: {-# UNPACK #-} !CodeUnitIndex+    -- ^ First byte to the left of the codepoint that we're focused on. This can+    -- be used with 'unsafeIndexEndOfCodePoint'' to find the next codepoint.+  , backwardsIterChar :: {-# UNPACK #-} !CodePoint+    -- ^ The codepoint that we're focused on+  , backwardsIterEndOfChar :: {-# UNPACK #-} !CodeUnitIndex+    -- ^ Points to the last byte of the codepoint that we're focused on+  }++-- | Similar to unsafeIndexCodePoint', but assumes that the given index is the+-- end of a utf8 codepoint. It returns the decoded code point and the index+-- _before_ the code point. The resulting index could be passed directly to+-- unsafeIndexEndOfCodePoint' again to decode the _previous_ code point.+unsafeIndexEndOfCodePoint' :: TextArray.Array -> CodeUnitIndex -> BackwardsIter+{-# INLINE unsafeIndexEndOfCodePoint' #-}+unsafeIndexEndOfCodePoint' !u8data !idx =+  let+    cuAt !i = unsafeIndexCodeUnit' u8data $ idx - i+    -- Second, third and fourth bytes of a codepoint are always 10xxxxxx, while+    -- the first byte can be 0xxxxxxx or 11yyyyyy.+    isFirstByte !cu = cu .&. 0b1100_0000 /= 0b1000_0000+    cu0 = cuAt 0+  in+    if isFirstByte cu0+    then BackwardsIter (idx - 1) (decode1 cu0) idx+    else+      let cu1 = cuAt 1 in+      if isFirstByte cu1+      then BackwardsIter (idx - 2) (decode2 cu1 cu0) idx+      else+        let cu2 = cuAt 2 in+        if isFirstByte cu2+        then BackwardsIter (idx - 3) (decode3 cu2 cu1 cu0) idx+        else+          let cu3 = cuAt 3 in+          if isFirstByte cu3+          then BackwardsIter (idx - 4) (decode4 cu3 cu2 cu1 cu0) idx+          else+            error "unsafeIndexEndOfCodePoint' could not find valid UTF8 codepoint"++unsafeIndexAnywhereInCodePoint' :: TextArray.Array -> CodeUnitIndex -> BackwardsIter+{-# INLINE unsafeIndexAnywhereInCodePoint' #-}+unsafeIndexAnywhereInCodePoint' !u8data !idx =+  let+    cuAt !i = unsafeIndexCodeUnit' u8data $ idx + i+    -- Second, third and fourth bytes of a codepoint are always 10xxxxxx, while+    -- the first byte can be 0xxxxxxx or 11yyyyyy.+    isFirstByte !cu = cu .&. 0b1100_0000 /= 0b1000_0000+    cu0 = cuAt 0++    makeBackwardsIter next (l, cp) = BackwardsIter next cp (next + l)+  in+    if isFirstByte cu0+    then makeBackwardsIter (idx - 1) $ decodeN cu0 (cuAt 1) (cuAt 2) (cuAt 3)+    else+      let cu00 = cuAt (-1) in+      if isFirstByte cu00+      then makeBackwardsIter (idx - 2) $ decodeN cu00 cu0 (cuAt 1) (cuAt 2)+      else+        let cu000 = cuAt (-2) in+        if isFirstByte cu000+        then makeBackwardsIter (idx - 3) $ decodeN cu000 cu00 cu0 (cuAt 1)+        else+          let cu0000 = cuAt (-3) in+          if isFirstByte cu0000+          then makeBackwardsIter (idx - 4) $ decodeN cu0000 cu000 cu00 cu0+          else+            error "unsafeIndexAnywhereInCodePoint' could not find valid UTF8 codepoint"  {-# INLINE unsafeIndexCodeUnit' #-} unsafeIndexCodeUnit' :: TextArray.Array -> CodeUnitIndex -> CodeUnit

@@ -0,0 +1,87 @@++module Data.Text.Utf8.Unlower+  (+    unlowerCodePoint++  , printUnlowerings+  ) where++import Control.Monad (forM_)++import qualified Data.Char as Char+import qualified Data.HashMap.Strict as HashMap+import qualified Data.List as List+++-- | Inverse of Char.toLower/Utf8.lowerCodePoint+--+-- Returns all the characters that have the given character as their lower case, for example:+--+--    unlowerCodePoint 'a' == "aA"+--    unlowerCodePoint 'A' == ""+--    unlowerCodePoint '1' == "1"+--    unlowerCodePoint 'i' == "İiI"+--    unlowerCodePoint 'ß' == "ẞß"+--+unlowerCodePoint :: Char -> [Char]+unlowerCodePoint =+  \c -> maybe [c] id $ HashMap.lookup c unlowerings++-- | This map contains all the unlowerings for which the result is not just a singleton with the+-- input character. It's marked NOINLINE to make sure that it only gets constructed once.+unlowerings :: HashMap.HashMap Char [Char]+{-# NOINLINE unlowerings #-}+unlowerings =+  HashMap.filterWithKey isNotId $ List.foldl' (flip addUnlowering) initialMap [minBound..maxBound]+  where+    initialMap = HashMap.fromList $ zip [minBound..maxBound] (repeat [])+    addUnlowering c hm =+      HashMap.insertWith (++) (Char.toLower c) [c] hm+    isNotId lc ucs = ucs /= [lc]+++-- | This function prints all the special cases of unlowerCodePoint where it's not @(pure . id)@:+--+--     SPECIAL: i (105) -> İ (304) i (105) I (73)+--     SPECIAL: k (107) -> K (8490) k (107) K (75)+--     SPECIAL: ß (223) -> ẞ (7838) ß (223)+--     SPECIAL: å (229) -> Å (8491) å (229) Å (197)+--     SPECIAL: dž (454) -> dž (454) Dž (453) DŽ (452)+--     SPECIAL: lj (457) -> lj (457) Lj (456) LJ (455)+--     SPECIAL: nj (460) -> nj (460) Nj (459) NJ (458)+--     SPECIAL: dz (499) -> dz (499) Dz (498) DZ (497)+--     SPECIAL: θ (952) -> ϴ (1012) θ (952) Θ (920)+--     SPECIAL: ω (969) -> Ω (8486) ω (969) Ω (937)+--     [..]+--     Inverse of Char.toUpper: a (97) -> a (97) A (65)+--     Inverse of Char.toUpper: b (98) -> b (98) B (66)+--     Inverse of Char.toUpper: c (99) -> c (99) C (67)+--     [..]+--+printUnlowerings :: IO ()+printUnlowerings = do++  let+    showCP :: Char -> String+    showCP c = case Char.ord c of+      co | co > 68000 -> show co -- Some RTL languages above these code points are annoying to print+      co -> c : " (" <> show co <> ")"++    showCPs :: [Char] -> String+    showCPs cs = List.intercalate " " (map showCP cs)++    isInverse (lc, ucs) = ucs == [lc, Char.toUpper lc] || ucs == [Char.toUpper lc, lc]+    isAlreadyUppercase (_, ucs) = ucs == []+    isSpecial p = not (isInverse p) && not (isAlreadyUppercase p)++    lst :: [(Char, [Char])]+    lst = HashMap.toList unlowerings++  forM_ (filter isSpecial lst) $ \(lc, ucs) -> do+    putStrLn $ "SPECIAL: " <> showCP lc <> " -> " <> showCPs ucs++  forM_ (filter isAlreadyUppercase lst) $ \(lc, _) -> do+    putStrLn $ "Already uppercase (there is no unlowering): " <> showCP lc++  forM_ (filter isInverse lst) $ \(lc, ucs) -> do+    putStrLn $ "Inverse of Char.toUpper: " <> showCP lc <> " -> " <> List.intercalate " " (map showCP ucs)

@@ -12,22 +12,31 @@     , Prim     , TypedByteArray     , fromList+    , toList     , generate     , newTypedByteArray     , unsafeFreezeTypedByteArray     , unsafeIndex     , writeTypedByteArray+    , null+    , length+    , foldr     ) where +import Prelude hiding (foldr, length, null)+ import Control.DeepSeq (NFData (rnf)) import Control.Monad.Primitive (PrimMonad (PrimState)) import Control.Monad.ST (runST) import Data.Primitive (ByteArray (ByteArray), MutableByteArray, Prim, byteArrayFromList,                        indexByteArray, newByteArray, sizeOf, unsafeFreezeByteArray, writeByteArray) +import qualified Data.Primitive as Primitive++ -- | Thin wrapper around 'ByteArray' that makes signatures and indexing nicer to read. newtype TypedByteArray a = TypedByteArray ByteArray-    deriving Show+    deriving (Show, Eq)  -- | Thin wrapper around 'MutableByteArray s' that makes signatures and indexing nicer to read. newtype MutableTypedByteArray a s = MutableTypedByteArray (MutableByteArray s)@@ -43,6 +52,10 @@ fromList :: Prim a => [a] -> TypedByteArray a fromList = TypedByteArray . byteArrayFromList +{-# INLINE toList #-}+toList :: Prim a => TypedByteArray a -> [a]+toList = foldr (:) []+ -- | Element index without bounds checking. {-# INLINE unsafeIndex #-} unsafeIndex :: Prim a => TypedByteArray a -> Int -> a@@ -81,3 +94,19 @@             | otherwise = do                 p i                 go (i + 1)++{-# INLINE null #-}+null :: TypedByteArray a -> Bool+null (TypedByteArray arr) =+  Primitive.sizeofByteArray arr == 0  -- under the assumption that elements are not size 0++{-# INLINE length #-}+length :: forall a. Prim a => TypedByteArray a -> Int+length (TypedByteArray arr) =+  -- This is how foldrByteArray calculates it, so must be good+  Primitive.sizeofByteArray arr `quot` sizeOf (undefined :: a)++{-# INLINE foldr #-}+foldr :: Prim a => (a -> b -> b) -> b -> TypedByteArray a -> b+foldr f a (TypedByteArray arr) = Primitive.foldrByteArray f a arr+

@@ -4,6 +4,8 @@ -- Licensed under the 3-clause BSD license, see the LICENSE file in the -- repository root. +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}+ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-}@@ -22,7 +24,7 @@ import qualified Test.QuickCheck.Gen as Gen  import Data.Text.CaseSensitivity (CaseSensitivity (..))-import Data.Text.Orphans ()+import Data.Text.TestInstances () import Data.Text.Utf8 (Text)  import qualified Data.Text.Utf8 as Text@@ -64,6 +66,7 @@              it "works with characters that are not in ASCII" $ do                 countMatches Aho.IgnoreCase ["groß", "öffnung", "tür"] "Großfräsmaschinenöffnungstür" `shouldBe` 3+                countMatches Aho.IgnoreCase ["groß", "öffnung", "tür"] "GROẞFRÄSMASCHINENÖFFNUNGSTÜR" `shouldBe` 3      modifyMaxSize (const 10) $ describe "Replacer" $ do @@ -118,7 +121,12 @@                 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")] "åÅÅ" `shouldBe` "bbb"+                replaceIgnoreCase [("k", "m")] "KkK" `shouldBe` "mmm"+                replaceIgnoreCase [("dz", "z")] "dzDzDZ" `shouldBe` "zzz"                 replaceIgnoreCase [("bèta", "α"), ("\x0391", "alpha")] "BÈTA" `shouldBe` "alpha"+                replaceIgnoreCase [("ßèta", "sseta")] "ßèta" `shouldBe` "sseta"+                replaceIgnoreCase [("ßèta", "sseta")] "ẞÈTA" `shouldBe` "sseta"              it "matches surrogate pairs case-insensitively" $ do                 -- We can't lowercase a levivating man in business suit, but that should@@ -178,6 +186,11 @@                     let searcher = Searcher.build Aho.CaseSensitive needles                     Searcher.containsAny searcher illiad `shouldBe` expectedResult +            it "works with the the first line of the illiad (ignore case)" $ do+                let illiad = "ἌΝΔΡΑ ΜΟΙ ἜΝΝΕΠΕ, ΜΟΥ͂ΣΑ, ΠΟΛΎΤΡΟΠΟΝ, ὋΣ ΜΆΛΑ ΠΟΛΛᾺ"+                    searcher = Searcher.build Aho.IgnoreCase ["μοι"]+                Searcher.containsAny searcher illiad `shouldBe` True+         describe "containsAll" $ do              prop "never reports true for empty needles" $ \ (haystack :: Text) ->@@ -213,12 +226,22 @@                     splitter = Splitter.build separator                  Splitter.split splitter "C++bobobCOBOLbobScala" `shouldBe` "C++" :| ["obCOBOL", "Scala"]+                Splitter.splitIgnoreCase splitter "C++bobobCOBOLbobScala" `shouldBe` "C++" :| ["obCOBOL", "Scala"]+                Splitter.splitIgnoreCase splitter "C++BOBOBCOBOLBOBSCALA" `shouldBe` "C++" :| ["OBCOBOL", "SCALA"]              it "neatly splits the first line of the illiad" $ do                 let splitter = Splitter.build ", "                  Splitter.split splitter "Ἄνδρα μοι ἔννεπε, Μοῦσα, πολύτροπον, ὃς μάλα πολλὰ" `shouldBe`                     "Ἄνδρα μοι ἔννεπε" :| ["Μοῦσα", "πολύτροπον", "ὃς μάλα πολλὰ"]+                Splitter.splitIgnoreCase splitter "Ἄνδρα μοι ἔννεπε, Μοῦσα, πολύτροπον, ὃς μάλα πολλὰ" `shouldBe`+                    "Ἄνδρα μοι ἔννεπε" :| ["Μοῦσα", "πολύτροπον", "ὃς μάλα πολλὰ"]++            it "splits on case insensitive needles" $ do+                -- The case variations of å have different byte lengths+                let splitter = Splitter.build "å"+                Splitter.splitIgnoreCase splitter "aaåbbÅccÅdd" `shouldBe`+                    "aa" :| ["bb", "cc", "dd"]  -- helpers 

@@ -0,0 +1,195 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE OverloadedStrings #-}++module Data.Text.BoyerMooreCISpec+  ( spec+  ) where+++import Control.Monad (forM_)+import Test.Hspec (Spec, describe, it, shouldBe, parallel)+import Test.Hspec.QuickCheck (modifyMaxSuccess, prop)+import Data.Text (Text)+import Test.QuickCheck (Arbitrary (arbitrary, shrink), forAllShrink)+import Test.QuickCheck.Instances ()++import qualified Data.Char as Char+import qualified Data.Text as Text+import qualified Data.Text.Utf8 as Utf8+import qualified Test.QuickCheck as QuickCheck++import Data.Text.CaseSensitivity (CaseSensitivity (..))+import Data.Text.TestInstances (arbitraryAlphabet, arbitraryFragment, arbitraryNeedleHaystack,+                                arbitraryNeedlesHaystack)++import qualified Data.Text.AhoCorasick.Replacer as AhoReplacer+import qualified Data.Text.BoyerMooreCI.Automaton as BoyerMooreCI+import qualified Data.Text.BoyerMooreCI.Searcher as Searcher+import qualified Data.Text.BoyerMooreCI.Replacer as Replacer+++spec :: Spec+spec = parallel $ modifyMaxSuccess (const 200) $ do++  describe "automaton" $ do++    it "works for some basic examples" $ do+      matchPositions "a" "abca" `shouldBe` [(0,0), (3,3)]+      matchPositions "a" "ABCA" `shouldBe` [(0,0), (3,3)]+      matchPositions "abc" "abca" `shouldBe` [(0,2)]+      matchPositions "abc" "ABCA" `shouldBe` [(0,2)]+      matchPositions "bc" "abca" `shouldBe` [(1,2)]+      matchPositions "bc" "ABCA" `shouldBe` [(1,2)]++    it "does not yield overlapping matches" $ do+      matchPositions "aba" "abababa" `shouldBe` [(0,2), (4,6)]+      matchPositions "aba" "ABaBaBA" `shouldBe` [(0,2), (4,6)]++    it "does not work with uppercase needles" $ do+      matchPositions "A" "aaaa" `shouldBe` []+      matchPositions "A" "AAAA" `shouldBe` []++    it "works with cyrillic characters" $ do+      -- Cyrillic characters are all two bytes.+      -- The match positions are byte indices (not char indices).+      matchPositions "п" "ипсум" `shouldBe` [(2,3)]+      matchPositions "п" "ИПСУМ" `shouldBe` [(2,3)]++      matchPositions "лорем" "Лорем" `shouldBe` [(0,9)]+      matchTexts "лорем" "Лорем" `shouldBe` ["Лорем"]++      matchPositions "лорем" "ЛОРЕМ" `shouldBe` [(0,9)]+      matchTexts "лорем" "ЛОРЕМ" `shouldBe` ["ЛОРЕМ"]++      -- This is an interesting case for badCharLookup, because the mismatch+      -- happens at "с" which is the first character in the needle.+      matchTexts "сит" "итсит" `shouldBe` ["сит"]+      matchTexts "сит" "ИТСИТ" `shouldBe` ["СИТ"]++    it "works with mixed byte lengths" $ do+      -- Space is 1 byte+      matchTexts "сит" "Лор сит амет" `shouldBe` ["сит"]+      matchTexts "сит" "Лорем ипсум долор сит амет" `shouldBe` ["сит"]+      matchTexts "сит" "ЛОРЕМ ИПСУМ ДОЛОР СИТ АМЕТ" `shouldBe` ["СИТ"]++      matchTexts "💩b" "ЛОРЕМab𝄞💩𝄞ДОЛab💩baåÅÅ𝄞𝄞ßẞ" `shouldBe` ["💩b"]+      matchTexts "𝄞" "ЛОРЕМab𝄞💩𝄞ДОЛab💩baåÅÅ𝄞𝄞ßẞ" `shouldBe` ["𝄞","𝄞","𝄞","𝄞"]+      matchTexts "a" "ЛОРЕМab𝄞💩𝄞ДОЛab💩baåÅÅ𝄞𝄞ßẞ" `shouldBe` ["a","a","a"]++    it "works with ⱥ and ⱦ" $ do+      -- The letters ⱥ and ⱦ are 3 UTF8 bytes, but have unlowerings Ⱥ and Ⱦ of 2 bytes+      matchPositions "ⱥⱦⱥⱦⱥⱦ" "ⱥⱦⱥⱦⱥⱦ" `shouldBe` [(0, 17)]+      matchTexts "ⱥⱦⱥⱦⱥⱦ" "ⱥⱦⱥⱦⱥⱦ" `shouldBe` ["ⱥⱦⱥⱦⱥⱦ"]+      matchPositions "ⱥⱦⱥⱦⱥⱦ" "ȺȾȺȾȺȾ" `shouldBe` [(0, 11)]+      matchTexts "ⱥⱦⱥⱦⱥⱦ" "ȺȾȺȾȺȾ" `shouldBe` ["ȺȾȺȾȺȾ"]++      matchPositions "ⱥⱦⱥⱦⱥⱦ" "ȺⱦⱥȾⱥȾ" `shouldBe` [(0, 14)]+      matchTexts "ⱥⱦⱥⱦⱥⱦ" "ȺⱦⱥȾⱥȾ" `shouldBe` ["ȺⱦⱥȾⱥȾ"]++    describe "with a needle equal to the haystack" $ do++      it "reports a single match for a repeated character" $+        forM_ [1..128] $ \n ->+          let needle = Text.replicate n "a" in+          matchPositions needle needle `shouldBe` [(0, Utf8.lengthUtf8 needle-1)]++      prop "reports a single match for any arbitrary text fragment" $+        QuickCheck.forAll (arbitraryAlphabet >>= arbitraryFragment) $ \text ->+          let needle = Utf8.lowerUtf8 text in+          matchPositions needle text `shouldBe` [(0, Utf8.lengthUtf8 text-1)]++    describe "with sliced text (using 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") `shouldBe` [(0, 0)]++    it "matches ß and ẞ" $ do+      matchTexts "groß" "Großfräsmaschinenöffnungstür" `shouldBe` ["Groß"]+      matchTexts "groß" "GROẞFRÄSMASCHINENÖFFNUNGSTÜR" `shouldBe` ["GROẞ"]+      matchTexts "öffnung" "Großfräsmaschinenöffnungstür" `shouldBe` ["öffnung"]+      matchTexts "öffnung" "GROẞFRÄSMASCHINENÖFFNUNGSTÜR" `shouldBe` ["ÖFFNUNG"]+++  describe "minimumSkipForCodePoint" $+    it "should match the reference implementation" $ do+      forM_ [minBound..maxBound] $ \c ->+        BoyerMooreCI.minimumSkipForCodePoint c `shouldBe` refMinimumSkipForCodePoint c+++  describe "Searcher" $ do+    describe "containsAny" $ do++      -- For the edge case where a needle is the empty string,+      -- 'Text.isInfixOf' and 'Searcher.containsAny' are different:+      --+      -- @+      -- Text.isInfixOf "" "abc" == True /= False == Searcher.containsAny (Searcher.build [""]) "abc"+      -- @+      --+      -- However, at this point we probably shouldn't break this property.+      prop "is equivalent to disjunction of Text.isInfixOf calls*" $ do+        QuickCheck.forAllShrink arbitraryNeedlesHaystack shrink $ \(needles, haystack) -> do+          let+            lneedles = map Utf8.lowerUtf8 needles  -- needles must be lowercase+            searcher = Searcher.build lneedles+            test needle =+              not (Text.null needle) && needle `Text.isInfixOf` (Utf8.lowerUtf8 haystack)+          Searcher.containsAny searcher haystack `shouldBe` any test lneedles++    describe "containsAll" $ do+      prop "is equivalent to conjunction of Text.isInfixOf calls*" $ do+        QuickCheck.forAllShrink arbitraryNeedlesHaystack shrink $ \(needles, haystack) -> do+          let+            lneedles = map Utf8.lowerUtf8 needles  -- needles must be lowercase+            searcher = Searcher.buildNeedleIdSearcher lneedles+            test needle =+              not (Text.null needle) && needle `Text.isInfixOf` (Utf8.lowerUtf8 haystack)+          Searcher.containsAll searcher haystack `shouldBe` all test lneedles++  describe "Replacer" $ do+    describe "replaceSingleLimited" $ do++      prop "is equivalent to Aho-Corasick replacer with a single needle" $+        forAllShrink arbitraryNeedleHaystack shrink $ \(needle, haystack) ->+        forAllShrink arbitrary shrink $ \replacement ->+        let+          lneedle = Utf8.lowerUtf8 needle+          expected =+            AhoReplacer.run (AhoReplacer.build IgnoreCase [(lneedle, replacement)]) haystack+          auto = BoyerMooreCI.buildAutomaton lneedle+          actual = Replacer.replaceSingleLimited auto replacement haystack maxBound+        in+          actual `shouldBe` Just expected++-- Reference implementation for BoyerMooreCI.minimumSkipForCodePoint+refMinimumSkipForCodePoint :: Utf8.CodePoint -> Utf8.CodeUnitIndex+refMinimumSkipForCodePoint cp =+  let codePointLength = length . Utf8.unicode2utf8 . Char.ord in+  case Utf8.unlowerCodePoint cp of+    [] ->+      -- Input is upper case, so this is undefined behaviour but we match what the real+      -- implementation does:+      Utf8.CodeUnitIndex $ codePointLength cp+    ucs -> Utf8.CodeUnitIndex $ minimum $ map codePointLength ucs+++-- | Return indices of the first and last byte of every match+matchPositions :: Text -> Text -> [(Utf8.CodeUnitIndex, Utf8.CodeUnitIndex)]+matchPositions needle =+  let+    !automaton = BoyerMooreCI.buildAutomaton needle+    prependMatch matches matchStart matchEnd =+      BoyerMooreCI.Step ((matchStart, matchEnd) : matches)+  in+    \haystack -> reverse $ BoyerMooreCI.runText [] prependMatch automaton haystack++positionText :: Text -> (Utf8.CodeUnitIndex, Utf8.CodeUnitIndex) -> Text+positionText haystack (firstByte, lastByte) =+  let len = lastByte - firstByte + 1  -- length is 1 if firstByte==lastByte+  in Utf8.unsafeSliceUtf8 firstByte len haystack++matchTexts :: Text -> Text -> [Text]+matchTexts needle haystack =+  map (positionText haystack) $ matchPositions needle haystack

@@ -16,15 +16,12 @@ import Test.Hspec.Expectations (shouldMatchList, shouldSatisfy) import Test.Hspec.QuickCheck (modifyMaxSuccess, prop) import Test.QuickCheck (Arbitrary (arbitrary, shrink), forAllShrink, (==>))-import Test.QuickCheck.Gen (Gen) import Test.QuickCheck.Instances () --- import qualified Data.Text.Internal.Search as TextSearch import qualified Test.QuickCheck as QuickCheck-import qualified Test.QuickCheck.Gen as Gen  import Data.Text.CaseSensitivity (CaseSensitivity (..))-import Data.Text.Orphans ()+import Data.Text.TestInstances (arbitraryNeedleHaystack) import Data.Text.Utf8 (Text)  import qualified Data.Text.Utf8 as Text@@ -67,37 +64,6 @@   map toEndPos $ TextSearch.indices needle haystack   where     toEndPos index = Utf8.codeUnitIndex (Utf8.lengthUtf8 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

@@ -1,14 +0,0 @@-module Data.Text.Orphans where--import Test.QuickCheck (Arbitrary (..))--import qualified Test.QuickCheck.Gen as Gen--import Data.Text.CaseSensitivity (CaseSensitivity (..))-import Data.Text.Utf8--instance Arbitrary CaseSensitivity where-  arbitrary = Gen.elements [CaseSensitive, IgnoreCase]--instance Arbitrary CodeUnitIndex where-  arbitrary = fmap CodeUnitIndex arbitrary

@@ -0,0 +1,93 @@+module Data.Text.TestInstances where++import Data.Text.Internal (Text (..))+import Test.QuickCheck (Arbitrary (..), Gen)++import qualified Data.Text as Text+import qualified Data.Text.Array as TextArray+import qualified Test.QuickCheck as QuickCheck+import qualified Test.QuickCheck.Gen as Gen++import Data.Text.CaseSensitivity (CaseSensitivity (..))+import qualified Data.Text.Utf8 as Utf8++++instance Arbitrary CaseSensitivity where+  arbitrary = Gen.elements [CaseSensitive, IgnoreCase]++instance Arbitrary Utf8.CodeUnitIndex where+  arbitrary = fmap Utf8.CodeUnitIndex arbitrary++++-- | Copy the text such that it has an arbitrary offset, but the represented+-- text stays the same.+arbitraryOffset :: Text -> Gen Text+arbitraryOffset (Text sourceData sourceOffset sourceLength) = do+  QuickCheck.Positive destOffset <- arbitrary+  let destData = TextArray.run $ do+        arr <- TextArray.new (destOffset + sourceLength)+        TextArray.copyI sourceLength arr destOffset sourceData sourceOffset+        pure arr+  pure $ Text destData destOffset sourceLength+++-- | 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. This way we also get a lot+-- of partial matches where part of a needle does occur in the haystack, but the+-- full needle does not, as well as needles with a shared prefix or suffix. This+-- should fully stress the possible transitions in the search algorithms.+--+arbitraryNeedleHaystack :: Gen (Text, Text)+arbitraryNeedleHaystack = do+  -- Generate a set of fragments, all within the same arbitrarily chosen alphabet+  alphabet <- arbitraryAlphabet+  fragments <- Gen.listOf1 $ Gen.resize 5 (arbitraryFragment alphabet)+  let+    genSmall = Gen.scale (`div` 3) $ Gen.listOf1 $ Gen.elements fragments+    genBig = Gen.scale (* 4) $ Gen.listOf1 $ Gen.elements fragments+  needle <- arbitraryOffset =<< fmap Text.concat genSmall+  haystack <- arbitraryOffset =<< fmap Text.concat genBig+  pure (needle, haystack)++arbitraryNeedlesHaystack :: Gen ([Text], Text)+arbitraryNeedlesHaystack = do+  -- Generate a set of fragments, all within the same arbitrarily chosen alphabet+  alphabet <- arbitraryAlphabet+  fragments <- Gen.listOf1 $ Gen.resize 5 (arbitraryFragment alphabet)+  let+    genSmall = Gen.scale (`div` 3) $ Gen.listOf1 $ Gen.elements fragments+    genBig = Gen.scale (* 4) $ Gen.listOf1 $ Gen.elements fragments+  needles <- Gen.listOf1 (arbitraryOffset =<< fmap Text.concat genSmall)+  haystack <- arbitraryOffset =<< fmap Text.concat genBig+  pure (needles, haystack)++arbitraryFragment :: [Char] -> Gen Text+arbitraryFragment alphabet =+  arbitraryOffset =<< Text.pack <$> Gen.listOf1 (Gen.elements alphabet)++arbitraryAlphabet :: Gen [Char]+arbitraryAlphabet =+  Gen.oneof [ pure simpleAlphabet+            , pure fancyAlphabet+            , randomAlphabet+            ]++  where++    simpleAlphabet = "abAB12"  -- Some ascii, include numbers so that not everything has upper/lower cases++    fancyAlphabet =+      concat+        [ "яЯ"  -- Cyrillic, two-byte characters+        , "åÅÅ" -- Å '\8491' and Å '\197' both have å '\229' as lower case+        ++ "𝄞💩"  -- Four byte characters \119070 and \128169+        ++ "ßẞ"   -- Note that ẞ '\7838' lower cases to ß '\223', but ß '\223' upper cases to ß '\223'+        ]++    randomAlphabet = sequence $ replicate 8 QuickCheck.arbitrary

@@ -3,14 +3,15 @@  module Data.Text.Utf8Spec where +import Control.Exception (evaluate) import Control.Monad (forM_)-import Test.Hspec (Spec, describe, it, shouldBe, shouldSatisfy)+import Test.Hspec (Spec, anyErrorCall, describe, it, shouldBe, shouldSatisfy, shouldThrow) import Test.Hspec.QuickCheck (prop) import Test.QuickCheck (Gen, choose, forAllShrink, shrink)  import qualified Data.Char as Char -import Data.Text.Orphans ()+import Data.Text.TestInstances ()  import qualified Data.Text.Utf8 as Utf8 @@ -46,6 +47,36 @@         prop "is equivalent to Char.toLower on all of Unicode" $ \c ->             Utf8.lowerCodePoint c `shouldBe` Char.toLower c +    describe "unlowerCodePoint" $ do++      it "should return nothing if it's not a lower case of anything" $ do+        Utf8.unlowerCodePoint 'A' `shouldBe` ""+        Utf8.unlowerCodePoint 'ẞ' `shouldBe` ""++      it "should return itself if it doesn't have any casings" $ do+        Utf8.unlowerCodePoint '1' `shouldBe` "1"++      it "can return multiple values" $ do+        Utf8.unlowerCodePoint 'a' `shouldBe` "aA"+        Utf8.unlowerCodePoint 'ß' `shouldBe` "ẞß"+        Utf8.unlowerCodePoint 'i' `shouldBe` "İiI"++    describe "isCaseInvariant" $ do+      it "holds vacuously for empty texts" $ do+        Utf8.isCaseInvariant "" `shouldBe` True++      it "should be true for characters without upper/lower cases" $ do+        Utf8.isCaseInvariant "." `shouldBe` True+        Utf8.isCaseInvariant ".,;'123" `shouldBe` True+        Utf8.isCaseInvariant "💩" `shouldBe` True++      it "should be false if there are characters with upper/lower cases" $ do+        Utf8.isCaseInvariant "a" `shouldBe` False+        Utf8.isCaseInvariant "A.." `shouldBe` False+        Utf8.isCaseInvariant "ß." `shouldBe` False+        Utf8.isCaseInvariant "ẞ" `shouldBe` False+        Utf8.isCaseInvariant "İ" `shouldBe` False+     describe "dropWhile" $ do          it "handles a simple example well" $ do@@ -80,6 +111,49 @@          prop "Ord Text behaves like Ord String" $ \ (a :: String) (b :: String) -> do             compare (Utf8.pack a) (Utf8.pack b) `shouldBe` compare a b++    describe "skipCodePointsBackwards" $ do+      it "works with ascii" $ do+        Utf8.skipCodePointsBackwards "abcd" 3 0 `shouldBe` 3+        Utf8.skipCodePointsBackwards "abcd" 3 1 `shouldBe` 2+        Utf8.skipCodePointsBackwards "abcd" 3 2 `shouldBe` 1+        Utf8.skipCodePointsBackwards "abcd" 3 3 `shouldBe` 0++      it "moves to start of codepoint if you skip 0" $ do+        Utf8.skipCodePointsBackwards "💩💩" 0 0 `shouldBe` 0+        Utf8.skipCodePointsBackwards "💩💩" 1 0 `shouldBe` 0+        Utf8.skipCodePointsBackwards "💩💩" 2 0 `shouldBe` 0+        Utf8.skipCodePointsBackwards "💩💩" 3 0 `shouldBe` 0+        Utf8.skipCodePointsBackwards "💩💩" 4 0 `shouldBe` 4+        Utf8.skipCodePointsBackwards "💩💩" 5 0 `shouldBe` 4+        Utf8.skipCodePointsBackwards "💩💩" 6 0 `shouldBe` 4+        Utf8.skipCodePointsBackwards "💩💩" 7 0 `shouldBe` 4++      it "can skip 1 multi-byte codepoint" $ do+        Utf8.skipCodePointsBackwards "💩💩" 4 1 `shouldBe` 0+        Utf8.skipCodePointsBackwards "💩💩" 5 1 `shouldBe` 0+        Utf8.skipCodePointsBackwards "💩💩" 6 1 `shouldBe` 0+        Utf8.skipCodePointsBackwards "💩💩" 7 1 `shouldBe` 0++      it "can skip multiple multi-byte codepoint" $ do+        -- a, İ, ẞ and 💩 have byte lengths 1, 2, 3 and 4+        Utf8.skipCodePointsBackwards "aİẞ💩ẞİa" 15 0 `shouldBe` 15  -- stays at a+        Utf8.skipCodePointsBackwards "aİẞ💩ẞİa" 15 1 `shouldBe` 13  -- skips to İ+        Utf8.skipCodePointsBackwards "aİẞ💩ẞİa" 15 2 `shouldBe` 10  -- skips to ẞ+        Utf8.skipCodePointsBackwards "aİẞ💩ẞİa" 15 3 `shouldBe` 6   -- skips to 💩+        Utf8.skipCodePointsBackwards "aİẞ💩ẞİa" 15 4 `shouldBe` 3   -- skips to ẞ+        Utf8.skipCodePointsBackwards "aİẞ💩ẞİa" 15 5 `shouldBe` 1   -- skips to İ+        Utf8.skipCodePointsBackwards "aİẞ💩ẞİa" 15 6 `shouldBe` 0   -- skips to a+        Utf8.skipCodePointsBackwards "aİẞ💩ẞİa" 14 2 `shouldBe` 6  -- from İ to 💩+        Utf8.skipCodePointsBackwards "aİẞ💩ẞİa" 13 2 `shouldBe` 6  -- from İ to 💩+        Utf8.skipCodePointsBackwards "aİẞ💩ẞİa" 10 3 `shouldBe` 1  -- from ẞ to İ+        Utf8.skipCodePointsBackwards "aİẞ💩ẞİa" 9 3 `shouldBe` 0   -- from 💩 to a++      it "throws errors when you read out of bounds" $ do+        evaluate (Utf8.skipCodePointsBackwards "💩💩" 8 0) `shouldThrow` anyErrorCall+        evaluate (Utf8.skipCodePointsBackwards "💩💩" 7 2) `shouldThrow` anyErrorCall++  arbitrarySlicingIndices :: Utf8.Text -> Gen (Utf8.CodeUnitIndex, Utf8.CodeUnitIndex) arbitrarySlicingIndices example = do

@@ -2,12 +2,14 @@  import Test.Hspec (describe, hspec) -import Data.Text.AhoCorasickSpec as U8A-import Data.Text.BoyerMooreSpec as U8B-import Data.Text.Utf8Spec as U8+import Data.Text.AhoCorasickSpec as AhoCorasickSpec+import Data.Text.BoyerMooreSpec as BoyerMooreSpec+import Data.Text.BoyerMooreCISpec as BoyerMooreCISpec+import Data.Text.Utf8Spec as Utf8Spec  main :: IO () main = hspec $ do-  describe "Data.Text.AhoCorasick" U8A.spec-  describe "Data.Text.BoyerMoore" U8B.spec-  describe "Data.Text.Utf8" U8.spec+  describe "Data.Text.AhoCorasick" AhoCorasickSpec.spec+  describe "Data.Text.BoyerMoore" BoyerMooreSpec.spec+  describe "Data.Text.BoyerMooreCI" BoyerMooreCISpec.spec+  describe "Data.Text.Utf8" Utf8Spec.spec