diff --git a/bench/bench.hs b/bench/bench.hs new file mode 100644 --- /dev/null +++ b/bench/bench.hs @@ -0,0 +1,92 @@ +module Main where + +import Protolude ( + IO, + Int, + Maybe, + Text, + fmap, + identity, + length, + map, + show, + ($), + (.), + (<>), + ) + +import Data.Text qualified as T +import Test.Tasty.Bench (bench, bgroup, defaultMain, nf) +import Text.Fuzzily (CaseSensitivity (HandleCase, IgnoreCase), Fuzzy (..)) +import Text.Fuzzily qualified as Fu + + +-- | Force score and rendered text +run :: CaseSensitivity -> Text -> Text -> Maybe (Int, Text) +run caseSen pat txt = + fmap + (\f -> (score f, rendered f)) + (Fu.match caseSen (T.pack "<", T.pack ">") identity pat txt) + + +-- | Number of matching texts +filterCount :: Text -> [Text] -> Int +filterCount pat = + length . Fu.filter IgnoreCase (T.pack "<", T.pack ">") identity pat + + +longText :: Text +longText = + T.replicate 1000 (T.pack "Lorem ipsum dolor sit amet ") + <> T.pack "Schedule meeting with Alex" + <> T.replicate 1000 (T.pack " consectetur adipiscing elit") + + +manyAs :: Text +manyAs = T.replicate 5000 (T.pack "a") <> T.pack "b" + + +shortTexts :: [Text] +shortTexts = + map + (\i -> T.pack ("Task number " <> show i <> " about some meeting topic")) + [1 .. 10000 :: Int] + + +main :: IO () +main = + defaultMain + [ bgroup + "long text" + [ bench "substring, ignore case" $ + nf (run IgnoreCase (T.pack "meeting")) longText + , bench "substring, handle case" $ + nf (run HandleCase (T.pack "meeting")) longText + , bench "fuzzy" $ nf (run IgnoreCase (T.pack "schmtal")) longText + , bench "no match" $ nf (run IgnoreCase (T.pack "xyzqw")) longText + , bench "single char" $ nf (run IgnoreCase (T.pack "s")) longText + ] + , bgroup + "pathological" + [ bench "ab in a…ab" $ nf (run IgnoreCase (T.pack "ab")) manyAs + , bench "ac in a…ab" $ nf (run IgnoreCase (T.pack "ac")) manyAs + ] + , bgroup + "many short texts" + [ bench "filter substring" $ + nf + (filterCount (T.pack "meeting")) + shortTexts + , bench "filter fuzzy" $ + nf + (filterCount (T.pack "tskmtg")) + shortTexts + ] + , bgroup + "String" + [ bench "substring" $ + nf + (fmap score . Fu.match IgnoreCase ("<", ">") identity "meeting") + (T.unpack longText) + ] + ] diff --git a/fuzzily.cabal b/fuzzily.cabal --- a/fuzzily.cabal +++ b/fuzzily.cabal @@ -1,11 +1,11 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.38.0. +-- This file has been generated from package.yaml by hpack version 0.38.1. -- -- see: https://github.com/sol/hpack name: fuzzily -version: 0.2.1.0 +version: 0.2.2.0 synopsis: Filters a list based on a fuzzy string search description: Fuzzily is a library that filters a list based on a fuzzy string search. Uses 'TextualMonoid' to be able to run on different types of strings. @@ -37,9 +37,11 @@ NoImplicitPrelude ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints -fno-warn-orphans build-depends: - base >=4.18.2 && <5 + array ==0.5.* + , base >=4.18.2 && <5 , monoid-subclasses >=1.2.5 && <1.3 , protolude >=0.3.4 && <0.4 + , text >=2.0 && <2.2 default-language: Haskell2010 test-suite fuzzily-test @@ -58,4 +60,24 @@ , base >=4.18.2 && <5 , fuzzily , protolude >=0.3.4 && <0.4 + , text + default-language: Haskell2010 + +benchmark fuzzily-bench + type: exitcode-stdio-1.0 + main-is: bench.hs + other-modules: + Paths_fuzzily + hs-source-dirs: + bench + default-extensions: + ImportQualifiedPost + NoImplicitPrelude + ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints -fno-warn-orphans -O2 + build-depends: + base >=4.18.2 && <5 + , fuzzily + , protolude >=0.3.4 && <0.4 + , tasty-bench + , text default-language: Haskell2010 diff --git a/src/Text/Fuzzily.hs b/src/Text/Fuzzily.hs --- a/src/Text/Fuzzily.hs +++ b/src/Text/Fuzzily.hs @@ -1,3 +1,6 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE MultiWayIf #-} + {-| Fuzzy string search in Haskell. Uses 'TextualMonoid' to be able to run on different types of strings. @@ -5,30 +8,42 @@ module Text.Fuzzily where import Protolude ( - Bool (True), + Bool (False, True), Char, Down (Down), - Eq ((==)), + Eq ((/=), (==)), Int, Maybe (..), - Monoid (mempty), - Num ((*), (+)), - Ord ((>)), - Semigroup ((<>)), + Monad ((>>=)), + Monoid (mconcat, mempty), + Num ((*), (+), (-)), + Ord ((<), (>=)), + Ordering (GT), Show, + Text, + chr, const, + forM_, identity, isJust, map, mapMaybe, not, + ord, otherwise, + pure, sortOn, toLower, + ($), (.), ) +import Data.Array.Base (unsafeAt, unsafeRead, unsafeWrite) +import Data.Array.ST (newArray, runSTUArray) +import Data.Array.Unboxed (UArray, listArray) +import Data.Char (isAsciiUpper) import Data.Monoid.Textual qualified as T +import Data.Text qualified as Text {-| @@ -55,45 +70,190 @@ not . T.any (const True) +-- | Like 'toLower', but faster for ASCII characters +lowerChar :: Char -> Char +lowerChar c + | isAsciiUpper c = chr (ord c + 32) + | c < '\x80' = c + | otherwise = toLower c + + {-| -Run one-pass algorithm on the given search text. -Returns (rendered, score) if the whole pattern was consumed. +Score of matching the given number of characters, +all consecutive (the maximum possible score). -} -matchOnce - :: (T.TextualMonoid text) - => (Char -> Char) - -- ^ normalisation function - -> (text, text) - -- ^ (pre, post) - -> text - -- ^ pattern - -> text - -- ^ search text - -> Maybe (text, Int) - -- ^ (rendered, score) -matchOnce norm (pre, post) pat txt = do +contiguousScore :: Int -> Int +contiguousScore len = + go len 0 0 + where + go :: Int -> Int -> Int -> Int + go 0 !tot !_ = tot + go k !tot !cur = let cur' = cur * 2 + 1 in go (k - 1) (tot + cur') cur' + + +-- | Whether the pattern is a (not necessarily contiguous) subsequence +isSubsequenceOf :: Text -> Text -> Bool +isSubsequenceOf pat txt = + case Text.uncons pat of + Nothing -> True + Just (p, ps) -> case Text.uncons (Text.dropWhile (/= p) txt) of + Nothing -> False + Just (_, rest) -> isSubsequenceOf ps rest + + +{-| +Find the start of the greedy match with the highest score +(the earliest one on ties) and return its score +and the positions of the matched characters. +The pattern must be non-empty and a subsequence of the text. +Only starts at occurrences of the first pattern character are tried, +as starting anywhere else yields the same result as starting +at the next occurrence. +Once a start fails, all later ones fail too. +-} +bestGreedyMatch :: Text -> Text -> Maybe (Int, [Int]) +bestGreedyMatch pat txt = + -- Building the table only pays off for longer texts + if Text.compareLength txt 128 == GT + then bestGreedyMatchTable pat txt + else bestGreedyMatchScan pat txt + + +{-| +Implementation of 'bestGreedyMatch' that scans +the text from each start position. +Fast for short texts, but O(n²) in the worst case. +-} +bestGreedyMatchScan :: Text -> Text -> Maybe (Int, [Int]) +bestGreedyMatchScan pat txt = do + (p, ps) <- Text.uncons pat let - (tot, _, res, restPat) = - T.foldl_' - ( \(tot_, cur, acc, p) c -> case T.splitCharacterPrefix p of - Nothing -> (tot_, 0, acc <> T.singleton c, p) - Just (x, xs) - | norm x == norm c -> - let cur' = cur * 2 + 1 - in ( tot_ + cur' - , cur' - , acc <> pre <> T.singleton c <> post - , xs - ) - | otherwise -> (tot_, 0, acc <> T.singleton c, p) - ) - (0, 0, mempty, pat) - txt + -- Score of greedily matching the pattern's tail, + -- given the score and run value after matching its head + scoreFrom :: Int -> Int -> Text -> Text -> Maybe Int + scoreFrom !tot !cur pat' txt' = case Text.uncons pat' of + Nothing -> Just tot + Just (x, xs) -> case Text.uncons txt' of + Nothing -> Nothing + Just (c, cs) + | x == c -> let cur' = cur * 2 + 1 in scoreFrom (tot + cur') cur' xs cs + | otherwise -> scoreFrom tot 0 pat' cs - if null restPat then Just (res, tot) else Nothing + positionsFrom :: Int -> Text -> Text -> [Int] + positionsFrom !idx pat' txt' = case (Text.uncons pat', Text.uncons txt') of + (Just (x, xs), Just (c, cs)) + | x == c -> idx : positionsFrom (idx + 1) xs cs + | otherwise -> positionsFrom (idx + 1) pat' cs + _ -> [] + findBest :: Int -> Text -> Maybe (Int, Int) -> Maybe (Int, Int) + findBest !idx txt' best = case Text.uncons txt' of + Nothing -> best + Just (c, cs) + | c /= p -> findBest (idx + 1) cs best + | otherwise -> case scoreFrom 1 1 ps cs of + Nothing -> best + Just sc -> + findBest (idx + 1) cs $ case best of + Just (_, bestSc) | bestSc >= sc -> best + _ -> Just (idx, sc) + (start, sc) <- findBest 0 txt Nothing + pure (sc, positionsFrom start pat (Text.drop start txt)) + + {-| +Implementation of 'bestGreedyMatch' that uses a table +with the next occurrence of each pattern character +at or after each position, so that greedily matching from a start +takes one lookup per pattern character instead of a scan of the text. +O(n * m) for a text of length n and a pattern of length m. +-} +bestGreedyMatchTable :: Text -> Text -> Maybe (Int, [Int]) +bestGreedyMatchTable pat txt = do + let + patLen = Text.length pat + txtLen = Text.length txt + patArr :: UArray Int Char + patArr = listArray (0, patLen - 1) (Text.unpack pat) + txtArr :: UArray Int Char + txtArr = listArray (0, txtLen - 1) (Text.unpack txt) + + -- next ! (j * (txtLen + 1) + i): Position of the next occurrence of + -- the j-th pattern character at or after position i (txtLen if none) + next :: UArray Int Int + next = runSTUArray $ do + table <- newArray (0, patLen * (txtLen + 1) - 1) txtLen + forM_ [txtLen - 1, txtLen - 2 .. 0] $ \i -> + forM_ [0 .. patLen - 1] $ \j -> do + let row = j * (txtLen + 1) + if unsafeAt patArr j == unsafeAt txtArr i + then unsafeWrite table (row + i) i + else unsafeRead table (row + i + 1) >>= unsafeWrite table (row + i) + pure table + nextOf j i = unsafeAt next (j * (txtLen + 1) + i) + + -- Score of the greedy match starting at the given position + -- (which must contain the first pattern character) + scoreFrom :: Int -> Maybe Int + scoreFrom start = go 1 start 1 1 + where + go :: Int -> Int -> Int -> Int -> Maybe Int + go !j !prev !tot !cur + | j == patLen = Just tot + | otherwise = + let pos = nextOf j (prev + 1) + in if pos == txtLen + then Nothing + else + let cur' = if pos == prev + 1 then cur * 2 + 1 else 1 + in go (j + 1) pos (tot + cur') cur' + + positionsFrom :: Int -> [Int] + positionsFrom start = + start : go 1 start + where + go j prev + | j == patLen = [] + | otherwise = let pos = nextOf j (prev + 1) in pos : go (j + 1) pos + + findBest :: Int -> Maybe (Int, Int) -> Maybe (Int, Int) + findBest !start best + | start == txtLen = best + | otherwise = case scoreFrom start of + Nothing -> best + Just sc -> + findBest (nextOf 0 (start + 1)) $ case best of + Just (_, bestSc) | bestSc >= sc -> best + _ -> Just (start, sc) + + (start, sc) <- findBest (nextOf 0 0) Nothing + pure (sc, positionsFrom start) + + +{-| +Render the text, wrapping the characters +at the given (ascending) positions in pre and post. +-} +renderAt :: (T.TextualMonoid text) => (text, text) -> Text -> [Int] -> text +renderAt (pre, post) txt0 positions = + -- Concatenate all chunks at once to avoid copying the rest repeatedly + mconcat (go 0 txt0 positions) + where + go _ txt [] = [T.fromText txt] + go offset txt (pos : rest) = + let + (gap, fromPos) = Text.splitAt (pos - offset) txt + (char, after) = Text.splitAt 1 fromPos + in + T.fromText gap + : pre + : T.fromText char + : post + : go (pos + 1) after rest + + +{-| Returns the rendered output and the matching score for a pattern and a text. Two examples are given below: @@ -113,42 +273,48 @@ }) -} {-# INLINEABLE match #-} -match - :: (T.TextualMonoid text) - => CaseSensitivity - -- ^ Handle or ignore case of search text - -> (text, text) - -- ^ Text to add before and after each match - -> (value -> text) - -- ^ Function to extract the text from the container - -> text - -- ^ Pattern - -> value - -- ^ Value containing the text to search in - -> Maybe (Fuzzy value text) - -- ^ Original value, rendered string, and score +match :: + (T.TextualMonoid text) => + -- | Handle or ignore case of search text + CaseSensitivity -> + -- | Text to add before and after each match + (text, text) -> + -- | Function to extract the text from the container + (value -> text) -> + -- | Pattern + text -> + -- | Value containing the text to search in + value -> + -- | Original value, rendered string, and score + Maybe (Fuzzy value text) match caseSen preAndPost extract pat value = do let - norm = if caseSen == HandleCase then identity else toLower - searchText = extract value - - -- iterate over every suffix while carrying the already-passed prefix - go pref txt best = - case matchOnce norm preAndPost pat txt of - Just (rendSub, sc) -> - let cand = Fuzzy value (pref <> rendSub) sc - best' = chooseBetter cand best - in step best' - Nothing -> step best - where - step b = case T.splitCharacterPrefix txt of - Nothing -> b - Just (c, rest') -> go (pref <> T.singleton c) rest' b + -- Non-character factors are ignored + txt = T.toText (const mempty) (extract value) + norm = if caseSen == HandleCase then identity else Text.map lowerChar + -- Mapping single characters keeps the positions aligned with `txt` + txtNorm = norm txt + patNorm = norm (T.toText (const mempty) pat) + patLen = Text.length patNorm + (beforeSub, fromSub) = Text.breakOn patNorm txtNorm - chooseBetter n Nothing = Just n - chooseBetter n (Just o) = if score n > score o then Just n else Just o + (sc, positions) <- + if + | Text.null patNorm -> Just (0, []) + -- A contiguous match has the highest possible score + -- and `breakOn` finds the earliest one + | not (Text.null fromSub) -> + let start = Text.length beforeSub + in Just (contiguousScore patLen, [start .. start + patLen - 1]) + | not (isSubsequenceOf patNorm txtNorm) -> Nothing + | otherwise -> bestGreedyMatch patNorm txtNorm - go mempty searchText Nothing + Just + Fuzzy + { original = value + , rendered = renderAt preAndPost txt positions + , score = sc + } {-| @@ -169,20 +335,20 @@ ] -} {-# INLINEABLE filter #-} -filter - :: (T.TextualMonoid text) - => CaseSensitivity - -- ^ Handle or ignore case of search text - -> (text, text) - -- ^ Text to add before and after each match - -> (value -> text) - -- ^ Function to extract the text from the container - -> text - -- ^ Pattern - -> [value] - -- ^ List of values containing the text to search in - -> [Fuzzy value text] - -- ^ List of results, sorted, highest score first +filter :: + (T.TextualMonoid text) => + -- | Handle or ignore case of search text + CaseSensitivity -> + -- | Text to add before and after each match + (text, text) -> + -- | Function to extract the text from the container + (value -> text) -> + -- | Pattern + text -> + -- | List of values containing the text to search in + [value] -> + -- | List of results, sorted, highest score first + [Fuzzy value text] filter caseSen (pre, post) extractFunc textPattern texts = sortOn (Down . score) @@ -201,14 +367,14 @@ ["vim","virtual machine"] -} {-# INLINEABLE simpleFilter #-} -simpleFilter - :: (T.TextualMonoid text) - => text - -- ^ Pattern to look for. - -> [text] - -- ^ List of texts to check. - -> [text] - -- ^ The ones that match. +simpleFilter :: + (T.TextualMonoid text) => + -- | Pattern to look for. + text -> + -- | List of texts to check. + [text] -> + -- | The ones that match. + [text] simpleFilter textPattern xs = map original diff --git a/tests/tests.hs b/tests/tests.hs --- a/tests/tests.hs +++ b/tests/tests.hs @@ -3,24 +3,51 @@ import Protolude ( Bool (False, True), Char, + Eq ((/=), (==)), IO, Int, + Integral (div, mod), Maybe (Just, Nothing), - Monad (return), + Monad ((>>=)), + Monoid (mempty), + Num ((*), (+)), + Ord ((<=), (>)), + Text, + drop, + evaluate, fst, head, identity, + iterate, map, + not, + replicateM, + take, + toLower, + when, ($), (<$>), (<>), ) -import Test.HUnit (Assertion, Test (..), runTestTT, (@?=)) +import Data.Text qualified as T +import System.Exit (exitFailure) +import System.Timeout (timeout) +import Test.HUnit ( + Assertion, + Counts (errors, failures), + Test (..), + assertBool, + runTestTT, + (@?=), + ) import Text.Fuzzily as Fu ( CaseSensitivity (HandleCase, IgnoreCase), Fuzzy (Fuzzy, original, rendered, score), + bestGreedyMatchScan, + bestGreedyMatchTable, filter, + isSubsequenceOf, match, simpleFilter, test, @@ -92,7 +119,7 @@ identity "ab" "ZaZbZ" - @?= Just "ZaZbZ" + @?= Just "ZaZbZ" ] , TestLabel "returns Nothing on no match" $ from @@ -123,7 +150,7 @@ identity "brd" "bread" - @?= Just "ea" + @?= Just "ea" ] ] , TestLabel "filter" $ @@ -223,10 +250,130 @@ ] +{-| +Reference implementation of the original (cubic) algorithm +to verify that the optimized one yields identical results. +-} +referenceMatch :: + CaseSensitivity -> (Text, Text) -> Text -> Text -> Maybe (Text, Int) +referenceMatch caseSen (pre, post) pat txt0 = + go mempty txt0 Nothing + where + norm = if caseSen == HandleCase then identity else toLower + matchOnce txt = + let + (tot, _, res, restPat) = + T.foldl' + ( \(tot_, cur, acc, p) c -> case T.uncons p of + Nothing -> (tot_, 0 :: Int, acc <> T.singleton c, p) + Just (x, xs) + | norm x == norm c -> + let cur' = cur * 2 + 1 + in (tot_ + cur', cur', acc <> pre <> T.singleton c <> post, xs) + | True -> (tot_, 0, acc <> T.singleton c, p) + ) + (0, 0, mempty, pat) + txt + in + if T.null restPat then Just (res, tot) else Nothing + go pref txt best = + let + best' = case matchOnce txt of + Just (rendSub, sc) -> case best of + Just (_, bestSc) | sc <= bestSc -> best + _ -> Just (pref <> rendSub, sc) + Nothing -> best + in + case T.uncons txt of + Nothing -> best' + Just (c, rest) -> go (pref <> T.singleton c) rest best' + + +-- | All strings over the given alphabet up to the given length +stringsUpTo :: Int -> [Char] -> [Text] +stringsUpTo n alphabet = + [0 .. n] >>= \k -> T.pack <$> replicateM k alphabet + + +equivalenceTests :: Test +equivalenceTests = + TestLabel "matches the reference implementation" $ + from + [ [ (caseSen, pat, txt) + | let tags = (T.pack "<", T.pack ">") + , caseSen <- [IgnoreCase, HandleCase] + , pat <- stringsUpTo 4 "aBc" + , txt <- stringsUpTo 6 "abC" + , ((\f -> (rendered f, score f)) <$> Fu.match caseSen tags identity pat txt) + /= referenceMatch caseSen tags pat txt + ] + @?= [] + ] + + +-- | Pseudo-random text over the given alphabet (linear congruential generator) +pseudoRandomText :: Int -> Int -> Text -> Text +pseudoRandomText seed len alphabet = + T.pack $ + map + (\x -> T.index alphabet ((x `div` 65536) `mod` T.length alphabet)) + ( take + len + (drop 1 (iterate (\x -> (x * 1103515245 + 12345) `mod` 2147483648) seed)) + ) + + +greedyImplementationTests :: Test +greedyImplementationTests = + TestLabel "scan and table implementations agree" $ + from + [ [ (pat, txt) + | (pat, txt) <- + [(pat, txt) | pat <- stringsUpTo 4 "abc", txt <- stringsUpTo 6 "abc"] + <> [ (pat, pseudoRandomText seed (150 + seed) (T.pack "abcd")) + | seed <- [1 .. 250] + , pat <- stringsUpTo 3 "abcd" + ] + , not (T.null pat) + , Fu.isSubsequenceOf pat txt + , Fu.bestGreedyMatchScan pat txt /= Fu.bestGreedyMatchTable pat txt + ] + @?= [] + ] + + +performanceTests :: Test +performanceTests = + TestLabel "matches long texts quickly" $ + from + [ do + let + longText = + T.replicate 2000 (T.pack "lorem ipsum ") + <> T.pack "xyz" + <> T.replicate 2000 (T.pack " dolor sit") + result <- + timeout 2000000 $ + evaluate $ + (\f -> (score f, T.length (rendered f))) + <$> Fu.match + IgnoreCase + (T.pack "<", T.pack ">") + identity + (T.pack "xyz") + longText + assertBool "match took longer than 2 seconds" $ + result == Just (Just (11, T.length longText + 6)) + ] + + runTests :: IO () runTests = do - _ <- runTestTT $ TestList tests - return () + counts <- + runTestTT $ + TestList + (tests <> [equivalenceTests, greedyImplementationTests, performanceTests]) + when (errors counts + failures counts > 0) exitFailure -- | For now, main will run our tests.