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.36.0. +-- This file has been generated from package.yaml by hpack version 0.38.0. -- -- see: https://github.com/sol/hpack name: fuzzily -version: 0.2.0.0 +version: 0.2.1.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. diff --git a/src/Text/Fuzzily.hs b/src/Text/Fuzzily.hs --- a/src/Text/Fuzzily.hs +++ b/src/Text/Fuzzily.hs @@ -4,14 +4,16 @@ -} module Text.Fuzzily where -import Protolude as P ( +import Protolude ( Bool (True), + Char, Down (Down), Eq ((==)), Int, Maybe (..), Monoid (mempty), Num ((*), (+)), + Ord ((>)), Semigroup ((<>)), Show, const, @@ -20,6 +22,7 @@ map, mapMaybe, not, + otherwise, sortOn, toLower, (.), @@ -53,6 +56,44 @@ {-| +Run one-pass algorithm on the given search text. +Returns (rendered, score) if the whole pattern was consumed. +-} +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 + 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 + + if null restPat then Just (res, tot) else Nothing + + +{-| Returns the rendered output and the matching score for a pattern and a text. Two examples are given below: @@ -71,7 +112,7 @@ , score = 5 }) -} -{-# INLINABLE match #-} +{-# INLINEABLE match #-} match :: (T.TextualMonoid text) => CaseSensitivity @@ -86,46 +127,28 @@ -- ^ Value containing the text to search in -> Maybe (Fuzzy value text) -- ^ Original value, rendered string, and score -match caseSensitivity (pre, post) extractFunc pattern value = do +match caseSen preAndPost extract pat value = do let - normFunc = if caseSensitivity == HandleCase - then identity - else toLower + norm = if caseSen == HandleCase then identity else toLower + searchText = extract value - searchText = extractFunc 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 - (totalScore, _, result, patternFromFold) = - T.foldl_' - ( \(tot, cur, res, pat) c -> - case T.splitCharacterPrefix pat of - Nothing -> - ( tot - , 0 - , res <> T.singleton c - , pat - ) - Just (x, xs) -> - if normFunc x == normFunc c - then - let cur' = cur * 2 + 1 - in ( tot + cur' - , cur' - , res <> pre <> T.singleton c <> post - , xs - ) - else - ( tot - , 0 - , res <> T.singleton c - , pat - ) - ) - (0, 0, mempty, pattern) - searchText + chooseBetter n Nothing = Just n + chooseBetter n (Just o) = if score n > score o then Just n else Just o - if null patternFromFold - then Just (Fuzzy value result totalScore) - else Nothing + go mempty searchText Nothing {-| @@ -145,7 +168,7 @@ } ] -} -{-# INLINABLE filter #-} +{-# INLINEABLE filter #-} filter :: (T.TextualMonoid text) => CaseSensitivity @@ -160,11 +183,11 @@ -- ^ List of values containing the text to search in -> [Fuzzy value text] -- ^ List of results, sorted, highest score first -filter caseSen (pre, post) extractFunc pattern texts = +filter caseSen (pre, post) extractFunc textPattern texts = sortOn (Down . score) ( mapMaybe - (match caseSen (pre, post) extractFunc pattern) + (match caseSen (pre, post) extractFunc textPattern) texts ) @@ -177,7 +200,7 @@ >>> simpleFilter "vm" ["vim", "emacs", "virtual machine"] ["vim","virtual machine"] -} -{-# INLINABLE simpleFilter #-} +{-# INLINEABLE simpleFilter #-} simpleFilter :: (T.TextualMonoid text) => text @@ -186,10 +209,10 @@ -- ^ List of texts to check. -> [text] -- ^ The ones that match. -simpleFilter pattern xs = +simpleFilter textPattern xs = map original - (filter IgnoreCase (mempty, mempty) identity pattern xs) + (filter IgnoreCase (mempty, mempty) identity textPattern xs) {-| @@ -200,5 +223,5 @@ True -} test :: (T.TextualMonoid text) => text -> text -> Bool -test pattern text = - isJust (match IgnoreCase (mempty, mempty) identity pattern text) +test textPattern text = + isJust (match IgnoreCase (mempty, mempty) identity textPattern text) diff --git a/tests/tests.hs b/tests/tests.hs --- a/tests/tests.hs +++ b/tests/tests.hs @@ -7,13 +7,13 @@ Int, Maybe (Just, Nothing), Monad (return), - Ord ((>)), fst, head, identity, map, ($), (<$>), + (<>), ) import Test.HUnit (Assertion, Test (..), runTestTT, (@?=)) @@ -31,172 +31,201 @@ from xs = TestList (map TestCase xs) -tests :: Test +tests :: [Test] tests = - TestList - [ TestLabel "test" $ - TestList - [ TestLabel "returns true when fuzzy match" $ - from - [ Fu.test "back" "imaback" @?= True - , Fu.test "back" "bakck" @?= True - , Fu.test "shig" "osh kosh modkhigow" @?= True - , Fu.test "" "osh kosh modkhigow" @?= True - ] - , TestLabel "should return false when no fuzzy match" $ - from - [ Fu.test "back" "abck" @?= False - , Fu.test "okmgk" "osh kosh modkhigow" @?= False - ] - ] - , TestLabel "match" $ - TestList - [ TestLabel - "returns a greater score for consecutive matches of pattern" - $ from - [ (>) - (Fu.score <$> Fu.match IgnoreCase ("", "") identity "abcd" "zabcd") - (Fu.score <$> Fu.match IgnoreCase ("", "") identity "abcd" "azbcd") - @?= True + [ TestLabel "test" $ + TestList + [ TestLabel "returns true when fuzzy match" $ + from + [ Fu.test "back" "imaback" @?= True + , Fu.test "back" "bakck" @?= True + , Fu.test "shig" "osh kosh modkhigow" @?= True + , Fu.test "" "osh kosh modkhigow" @?= True + ] + , TestLabel "should return false when no fuzzy match" $ + from + [ Fu.test "back" "abck" @?= False + , Fu.test "okmgk" "osh kosh modkhigow" @?= False + ] + ] + , TestLabel "match" $ + TestList + [ TestLabel + "returns a greater score for continuous matches of pattern" + $ from + $ let + scoreContinuousMatch = + Fu.score + <$> Fu.match IgnoreCase ("", "") identity "abcd" "zabcd" + scoreSplitMatch = + Fu.score + <$> Fu.match IgnoreCase ("", "") identity "abcd" "azbcd" + in + [ scoreContinuousMatch @?= Just 26 + , scoreSplitMatch @?= Just 12 ] - , TestLabel - "returns the string as is if no pre/post and case sensitive" - $ from - [ Fu.rendered + , TestLabel + "returns the longest continuous match, even if it's at the end" + $ from + $ let + actual = + Fu.rendered <$> Fu.match - HandleCase - ("", "") + IgnoreCase + ("<", ">") identity - "ab" - "ZaZbZ" - @?= Just "ZaZbZ" - ] - , TestLabel "returns Nothing on no match" $ - from - [ Fu.match - IgnoreCase + "abcd" + "This is a sizeable text with a final matching word: abcd" + expected = + Just $ + "This is a sizeable text" + <> " with a final matching word: " + in + [actual @?= expected] + , TestLabel + "returns the string as is if no pre/post and case sensitive" + $ from + [ Fu.rendered + <$> Fu.match + HandleCase ("", "") identity - "ZEBRA!" + "ab" "ZaZbZ" - @?= Nothing - ] - , TestLabel "is case sensitive if specified" $ - from - [ Fu.match + @?= Just "ZaZbZ" + ] + , TestLabel "returns Nothing on no match" $ + from + [ Fu.match + IgnoreCase + ("", "") + identity + "ZEBRA!" + "ZaZbZ" + @?= Nothing + ] + , TestLabel "is case sensitive if specified" $ + from + [ Fu.match + HandleCase + ("", "") + identity + "hask" + "Haskell" + @?= Nothing + ] + , TestLabel "wraps pre and post around matches" $ + from + [ Fu.rendered + <$> Fu.match HandleCase - ("", "") + ("<", ">") identity - "hask" - "Haskell" - @?= Nothing - ] - , TestLabel "wraps pre and post around matches" $ - from - [ Fu.rendered - <$> Fu.match + "brd" + "bread" + @?= Just "ea" + ] + ] + , TestLabel "filter" $ + TestList + [ TestLabel "returns list untouched when given empty pattern" $ + from + [ ( Fu.original + `map` Fu.filter HandleCase - ("<", ">") + ("", "") identity - "brd" - "bread" - @?= Just "ea" - ] - ] - , TestLabel "filter" $ - TestList - [ TestLabel "returns list untouched when given empty pattern" $ - from - [ ( Fu.original - `map` ( Fu.filter - HandleCase - ("", "") - identity - "" - ["abc", "def"] - ) - ) - @?= ["abc", "def"] - ] - , TestLabel "returns the highest score first" $ - from - [ (@?=) - (head (Fu.filter HandleCase ("", "") identity "cb" ["cab", "acb"])) - (head (Fu.filter HandleCase ("", "") identity "cb" ["acb"])) - ] - , TestLabel "keeps original casing when filtering case insensitive" $ - from - [ ( Fu.original - `map` ( Fu.filter - IgnoreCase - ("", "") - identity - "abc" - ["aBc"] - ) - ) - @?= ["aBc"] - ] - ] - , TestLabel "README examples" $ - TestList - [ TestLabel "hsk" $ - from - [ ( match - IgnoreCase - ("<", ">") - fst - "hsk" - ("Haskell", 1995 :: Int) + "" + ["abc", "def"] + ) + @?= ["abc", "def"] + ] + , TestLabel "returns the highest score first" $ + from + [ (@?=) + ( head $ + Fu.filter + HandleCase + ("", "") + identity + "cb" + ["cab", "acb"] ) - @?= Just - ( Fuzzy - { original = ("Haskell", 1995) - , rendered = "aell" - , score = 5 - } - ) - ] - , TestLabel "langs" $ - from - [ let - langs :: [([Char], Int)] - langs = - [ ("Standard ML", 1990) - , ("OCaml", 1996) - , ("Scala", 2003) - ] - result = filter IgnoreCase ("<", ">") fst "ML" langs - expected = - [ Fuzzy - { original = ("Standard ML", 1990) - , rendered = "Standard " - , score = 4 - } - , Fuzzy - { original = ("OCaml", 1996) - , rendered = "OCa" - , score = 4 - } - ] - in - result @?= expected - ] - , TestLabel "simple filter" $ - from - [ simpleFilter "vm" ["vim", "emacs", "virtual machine"] - @?= ["vim", "virtual machine"] - ] - , TestLabel "test" $ - from - [test "brd" "bread" @?= True] - ] - ] + (head $ Fu.filter HandleCase ("", "") identity "cb" ["acb"]) + ] + , TestLabel "keeps original casing when filtering case insensitive" $ + from + [ ( Fu.original + `map` ( Fu.filter + IgnoreCase + ("", "") + identity + "abc" + ["aBc"] + ) + ) + @?= ["aBc"] + ] + ] + , TestLabel "README examples" $ + TestList + [ TestLabel "hsk" $ + from + [ ( match + IgnoreCase + ("<", ">") + fst + "hsk" + ("Haskell", 1995 :: Int) + ) + @?= Just + ( Fuzzy + { original = ("Haskell", 1995) + , rendered = "aell" + , score = 5 + } + ) + ] + , TestLabel "langs" $ + from + [ let + langs :: [([Char], Int)] + langs = + [ ("Standard ML", 1990) + , ("OCaml", 1996) + , ("Scala", 2003) + ] + result = filter IgnoreCase ("<", ">") fst "ML" langs + expected = + [ Fuzzy + { original = ("Standard ML", 1990) + , rendered = "Standard " + , score = 4 + } + , Fuzzy + { original = ("OCaml", 1996) + , rendered = "OCa" + , score = 4 + } + ] + in + result @?= expected + ] + , TestLabel "simple filter" $ + from + [ simpleFilter "vm" ["vim", "emacs", "virtual machine"] + @?= ["vim", "virtual machine"] + ] + , TestLabel "test" $ + from + [test "brd" "bread" @?= True] + ] + ] runTests :: IO () runTests = do - _ <- runTestTT tests + _ <- runTestTT $ TestList tests return ()