BoyerMooreSpec.hs

{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Data.Text.BoyerMooreSpec
    ( spec
    ) where

import Control.DeepSeq (rnf)
import Control.Monad (forM_)
import Data.Foldable (for_)
import GHC.Stack (HasCallStack)
import Prelude hiding (replicate)
import Test.Hspec (Expectation, Spec, describe, it, parallel, shouldBe)
import Test.Hspec.Expectations (shouldMatchList, shouldSatisfy)
import Test.Hspec.QuickCheck (modifyMaxSuccess, prop)
import Test.QuickCheck (Arbitrary (arbitrary, shrink), forAllShrink, (==>))
import Test.QuickCheck.Instances ()

import qualified Test.QuickCheck as QuickCheck

import Data.Text.CaseSensitivity (CaseSensitivity (..))
import Data.Text.TestInstances (arbitraryNeedleHaystack)
import Data.Text.Utf8 (Text)

import qualified Data.Text.Utf8 as Text
import qualified Data.Text.Utf8 as TextSearch
import qualified Data.Text.Utf8 as Utf8
import qualified Data.Text.AhoCorasick.Replacer as AhoReplacer
import qualified Data.Text.BoyerMoore.Automaton as BoyerMoore
import qualified Data.Text.BoyerMoore.Replacer as Replacer
import qualified Data.Text.BoyerMoore.Searcher as Searcher

-- | Test that for a single needle which equals the haystack, we find a single
-- match. Does not apply to the empty needle.
needleIsHaystackMatches :: HasCallStack => Text -> Expectation
needleIsHaystackMatches needle =
  let
    prependMatch ms match = BoyerMoore.Step (Utf8.codeUnitIndex match : ms)
    matches = BoyerMoore.runText [] prependMatch (BoyerMoore.buildAutomaton needle) needle
  in
    matches `shouldBe` [0]

boyerMatch :: Text -> Text -> [Int]
boyerMatch needle haystack =
  let
    prependMatch matches match = BoyerMoore.Step (Utf8.codeUnitIndex match : matches)
  in
    BoyerMoore.runText [] prependMatch (BoyerMoore.buildAutomaton needle) haystack

-- | Match without a payload, return only the match positions.
matchEndPositions :: Text -> Text -> [Int]
matchEndPositions needle haystack =
  let
    matches = boyerMatch needle haystack
  in
    fmap (Utf8.codeUnitIndex (Utf8.lengthUtf8 needle) +) matches

-- | `matchEndPositions` implemented naively in terms of Text's functionality,
-- which we assume to be correct.
naiveMatchPositions :: Text -> Text -> [Int]
naiveMatchPositions needle haystack =
  map toEndPos $ TextSearch.indices needle haystack
  where
    toEndPos index = Utf8.codeUnitIndex (Utf8.lengthUtf8 needle) + index

spec :: Spec
spec = parallel $ modifyMaxSuccess (const 200) $ do
  describe "build" $ do
    prop "does not throw exceptions" $ \ (pat :: Text) ->
      rnf $ BoyerMoore.buildAutomaton pat

  describe "runText" $ do

    describe "when given a needle equal to the haystack" $ do

      it "reports a single match for a repeated character" $
        forM_ [1..128] $ \n ->
          needleIsHaystackMatches $ Text.replicate n "a"

      it "reports a single match for non-BMP data" $ do
        -- Include a few code points outside of the Basic Multilingual Plane,
        -- which require multible code units to encode.
        needleIsHaystackMatches "\x000437b8suffix"
        needleIsHaystackMatches "aaa\359339aaa\95759aa\899256aa"

      prop "reports a single match for random needles" $ \needle ->
        not (Text.null needle) ==> needleIsHaystackMatches needle

    describe "when given a sliced text (with nonzero internal offset)" $ do

      it "still reports offset relative to the text start" $
        -- The match position should be relative to the start of the text "a".
        -- Even if this text is represented as a slice of "bbba" internally.
        matchEndPositions "a" (Text.dropWhile (== 'b') "bbba") `shouldMatchList` [1]

    describe "when given non-ascii inputs" $ do

      -- We have a special lookup table for bad character shifts for
      -- the first 128 code units, which is always hit for ascii inputs.
      -- Also exercise the fallback code path with a different input.
      -- The code point é is encoded as two code units in UTF-8.
      -- 0             7          13
      -- │             │           │
      -- ▼             ▼           ▼
      -- ┌───┬─┬─┬─┬─┬─┬─┬─┬─┬─┬─┬─┐
      -- │ é │c│l│a│i│r│e│c│l│a│i│r│ Code Points
      -- ├─┬─┼─┼─┼─┼─┼─┼─┼─┼─┼─┼─┼─┤
      -- │ │ │ │ │ │ │ │ │ │ │ │ │ │ Code Units (Bytes)
      -- └─┴─┴─┴─┴─┴─┴─┴─┴─┴─┴─┴─┴─┘
      it "reports a match if the haystack contains a character > U+7f" $ do
        matchEndPositions "eclair" "éclaireclair" `shouldMatchList` [13]
        matchEndPositions "éclair" "éclaireclair" `shouldMatchList` [7]
        matchEndPositions "éclair" "eclairéclair" `shouldMatchList` [13]

      it "reports the correct code unit index for complex characters" $ do
        -- Note that the index after the match is 4, even though there is
        -- only a single code point. U+1d11e is encoded as four code units:
        -- in UTF-8:
        -- 0       4
        -- │       │
        -- ▼       ▼
        -- ┌───────┐
        -- │   𝄞   │ Code Points
        -- ├─┬─┬─┬─┤
        -- │ │ │ │ │ Code Units (Bytes)
        -- └─┴─┴─┴─┘
        matchEndPositions "𝄞" "𝄞" `shouldMatchList` [4]

        -- A levitating woman in business suit with dark skin tone needs a
        -- whopping 5 code points to encode. The first two need 4 code units each to encode,
        -- the remaining three need 3 code units each for a total of 17 code units:
        -- 0       4       8                17
        -- │       │       │                 │
        -- ▼       ▼       ▼                 ▼
        -- ┌───────┬───────┬─────┬─────┬─────┐
        -- │   1   │   2   │  3  │  4  │  5  │ Code Points
        -- ├─┬─┬─┬─┼─┬─┬─┬─┼─┬─┬─┼─┬─┬─┼─┬─┬─┤
        -- │ │ │ │ │ │ │ │ │ │ │ │ │ │ │ │ │ │ Code Units (Bytes)
        -- └─┴─┴─┴─┴─┴─┴─┴─┴─┴─┴─┴─┴─┴─┴─┴─┴─┘
        -- 1. U+1f574: man in business suit levitating (🕴)
        -- 2. U+1f3ff: emoji modifier Fitzpatrick type-6
        -- 3. U+200d:  zero width joiner
        -- 4. U+2640:  female sign (♀)
        -- 5. U+fe0f:  variation selector-16
        -- A peculiar feature of Unicode emoji, is that the male levivating
        -- man in business suit with dark skin tone is a substring of the
        -- levivating woman in business suit. And the levivating man in
        -- business suit without particular skin tone is a substring of that.
        let
          examples =
            [ ("\x1f574\x1f3ff\x200d\x2640\xfe0f", 17)
            , ("\x1f574\x1f3ff", 8)
            , ("\x1f574", 4)
            ]
        for_ examples $ \(needle, endPos) ->
          matchEndPositions needle "\x1f574\x1f3ff\x200d\x2640\xfe0f" `shouldMatchList` [endPos]

    describe "when given empty needle" $ do

      it "does not report a match" $ do
        matchEndPositions "" "" `shouldMatchList` []
        matchEndPositions "" "foo" `shouldMatchList` []

    describe "kitchen sink" $ do
      it "kitchen sinks" $ do
        matchEndPositions "\"\SO]JL\"" "aaaaa\"\SO]JL\"" `shouldMatchList` [11]
        matchEndPositions "\"X]JL\"" "aaaaa\"X]JL\"" `shouldMatchList` [11]

    describe "when given random needles and haystacks" $ do

      prop "reports only infixes of the haystack" $
        QuickCheck.forAllShrink arbitraryNeedleHaystack shrink $ \ (needle, haystack) ->
          let
            matches = boyerMatch needle haystack
            sliceMatch startPos len = Utf8.unsafeSliceUtf8 startPos len haystack
          in
            forM_ matches $ \pos -> do
              needle `shouldSatisfy` (`Text.isInfixOf` haystack)
              sliceMatch (Utf8.CodeUnitIndex pos) (Utf8.lengthUtf8 needle) `shouldBe` needle

      prop "reports all infixes of the haystack" $
        QuickCheck.forAllShrink arbitraryNeedleHaystack shrink $ \ (needle, haystack) ->
          matchEndPositions needle haystack `shouldMatchList` naiveMatchPositions needle haystack

  describe "replaceSingleLimited" $ do

    prop "is equivalent to Aho-Corasick replacer with a single needle" $
      forAllShrink arbitraryNeedleHaystack shrink $ \(needle, haystack) ->
      forAllShrink arbitrary shrink $ \replacement ->
      let
        expected = AhoReplacer.run (AhoReplacer.build CaseSensitive [(needle, replacement)]) haystack

        auto = BoyerMoore.buildAutomaton needle

        actual = Replacer.replaceSingleLimited auto replacement haystack maxBound
      in
        actual `shouldBe` Just expected

  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*" $ \ (needles :: [Text]) (haystack :: Text) ->
        let
          searcher = Searcher.build needles
          test needle =
            not (Text.null needle) && needle `Text.isInfixOf` haystack
        in
          Searcher.containsAny searcher haystack `shouldBe` any test needles

    describe "containsAll" $ do
      prop "is equivalent to conjunction of Text.isInfixOf calls*" $ \ (needles :: [Text]) (haystack :: Text) ->
        let
          searcher = Searcher.buildNeedleIdSearcher needles
          test needle =
            not (Text.null needle) && needle `Text.isInfixOf` haystack
        in
          Searcher.containsAll searcher haystack `shouldBe` all test needles