fuzzily 0.2.1.0 → 0.2.2.0

raw patch · 4 files changed

+528/−101 lines, 4 filesdep +arraydep +tasty-benchdep +textPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: array, tasty-bench, text

API changes (from Hackage documentation)

Files

• bench/bench.hs +92/−0
• fuzzily.cabal +25/−3
• src/Text/Fuzzily.hs +258/−92
• tests/tests.hs +153/−6

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

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

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

@@ -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 "<b><r>ea<d>"+                  @?= Just "<b><r>ea<d>"               ]         ]   , 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.