diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,20 @@ +Copyright (c) 2015 Joomy Korkut + +Permission is hereby granted, free of charge, to any person obtaining +a copy of this software and associated documentation files (the +"Software"), to deal in the Software without restriction, including +without limitation the rights to use, copy, modify, merge, publish, +distribute, sublicense, and/or sell copies of the Software, and to +permit persons to whom the Software is furnished to do so, subject to +the following conditions: + +The above copyright notice and this permission notice shall be included +in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. +IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY +CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, +TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE +SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/fuzzy.cabal b/fuzzy.cabal new file mode 100644 --- /dev/null +++ b/fuzzy.cabal @@ -0,0 +1,27 @@ +name: fuzzy +version: 0.1.0.0 +synopsis: Filters a list based on a fuzzy string search. +homepage: http://github.com/joom/fuzzy +license: MIT +license-file: LICENSE +author: Joomy Korkut +maintainer: joomy@cattheory.com +category: Text +build-type: Simple +cabal-version: >=1.10 + +library + exposed-modules: Text.Fuzzy + build-depends: base >=4.8 && <5, + monoid-subclasses > 0.4 + hs-source-dirs: src + default-language: Haskell2010 + +test-suite tests + type: exitcode-stdio-1.0 + hs-source-dirs: tests + main-is: tests.hs + build-depends: base, + fuzzy, + HUnit >= 1.2.5.0 + default-language: Haskell2010 diff --git a/src/Text/Fuzzy.hs b/src/Text/Fuzzy.hs new file mode 100644 --- /dev/null +++ b/src/Text/Fuzzy.hs @@ -0,0 +1,105 @@ +{-# LANGUAGE FlexibleContexts #-} + +-- | Fuzzy string search in Haskell. +-- Uses 'TextualMonoid' to be able to run on different types of strings. +module Text.Fuzzy where + +import Prelude hiding (filter) +import qualified Prelude as P + +import Data.Char (toLower) +import Data.List (sortOn) +import Data.Maybe (isJust, mapMaybe) +import Data.Monoid (mempty, (<>)) +import Data.Ord +import Data.String + +import qualified Data.Monoid.Textual as T + +-- | Included in the return type of @'match'@ and @'filter'@. +-- Contains the original value given, the rendered string +-- and the matching score. +data (T.TextualMonoid s) => Fuzzy t s = + Fuzzy { original :: t + , rendered :: s + , score :: Int + } deriving (Show, Eq) + +-- | Returns the rendered output and the +-- matching score for a pattern and a text. +-- Two examples are given below: +-- +-- >>> match "fnt" "infinite" "" "" id True +-- Just ("infinite",3) +-- +-- >>> match "hsk" ("Haskell",1995) "<" ">" fst False +-- Just ("aell",5) +-- +match :: (T.TextualMonoid s) + => s -- ^ Pattern. + -> t -- ^ The value containing the text to search in. + -> s -- ^ The text to add before each match. + -> s -- ^ The text to add after each match. + -> (t -> s) -- ^ The function to extract the text from the container. + -> Bool -- ^ Case sensitivity. + -> Maybe (Fuzzy t s) -- ^ The original value, rendered string and score. +match pattern t pre post extract caseSensitive = + if null pat then Just (Fuzzy t result totalScore) else Nothing + where + null :: (T.TextualMonoid s) => s -> Bool + null = not . T.any (const True) + + s = extract t + (s', pattern') = let f = T.map toLower in + if caseSensitive then (s, pattern) else (f s, f pattern) + + (totalScore, currScore, result, pat) = + T.foldl' + undefined + (\(tot, cur, res, pat) c -> + case T.splitCharacterPrefix pat of + Nothing -> (tot, 0, res <> T.singleton c, pat) + Just (x, xs) -> + if x == 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') s' + +-- | The function to filter a list of values by fuzzy search on the text extracted from them. +-- +-- >>> filter "ML" [("Standard ML", 1990),("OCaml",1996),("Scala",2003)] "<" ">" fst False +-- [Fuzzy {original = ("Standard ML",1990), rendered = "standard ", score = 4},Fuzzy {original = ("OCaml",1996), rendered = "oca", score = 4}] +filter :: (T.TextualMonoid s) + => s -- ^ Pattern. + -> [t] -- ^ The list of values containing the text to search in. + -> s -- ^ The text to add before each match. + -> s -- ^ The text to add after each match. + -> (t -> s) -- ^ The function to extract the text from the container. + -> Bool -- ^ Case sensitivity. + -> [Fuzzy t s] -- ^ The list of results, sorted, highest score first. +filter pattern ts pre post extract caseSen = + sortOn (Down . score) + (mapMaybe (\t -> match pattern t pre post extract caseSen) ts) + +-- | Return all elements of the list that have a fuzzy +-- match against the pattern. Runs with default settings where +-- nothing is added around the matches, as case insensitive. +-- +-- >>> simpleFilter "vm" ["vim", "emacs", "virtual machine"] +-- ["vim","virtual machine"] +simpleFilter :: (T.TextualMonoid s) + => s -- ^ Pattern to look for. + -> [s] -- ^ List of texts to check. + -> [s] -- ^ The ones that match. +simpleFilter pattern xs = + map original $ filter pattern xs mempty mempty id False + +-- | Returns false if the pattern and the text do not match at all. +-- Returns true otherwise. +-- +-- >>> test "brd" "bread" +-- True +test :: (T.TextualMonoid s) + => s -> s -> Bool +test p s = isJust (match p s mempty mempty id False) diff --git a/tests/tests.hs b/tests/tests.hs new file mode 100644 --- /dev/null +++ b/tests/tests.hs @@ -0,0 +1,61 @@ +module Main where + +import qualified Text.Fuzzy as F +import Test.HUnit + +from :: [Assertion] -> Test +from xs = TestList (map TestCase xs) + +tests :: Test +tests = TestList + [ + TestLabel "test" $ TestList [ + TestLabel "should return true when fuzzy match" $ from [ + F.test "back" "imaback" @?= True + , F.test "back" "bakck" @?= True + , F.test "shig" "osh kosh modkhigow" @?= True + , F.test "" "osh kosh modkhigow" @?= True + ] + , TestLabel "should return false when no fuzzy match" $ from [ + F.test "back" "abck" @?= False + , F.test "okmgk" "osh kosh modkhigow" @?= False + ] + ] + , TestLabel "match" $ TestList [ + TestLabel "should return a greater score for consecutive matches of pattern" $ from [ + (>) (F.score <$> F.match "abcd" "zabcd" "" "" id False) + (F.score <$> F.match "abcd" "azbcd" "" "" id False) + @?= True + ] + , TestLabel "should return the string as is if no pre/post and case sensitive" $ from [ + F.rendered <$> F.match "ab" "ZaZbZ" "" "" id True @?= Just "ZaZbZ" + ] + , TestLabel "should return Nothing on no match" $ from [ + F.match "ZEBRA!" "ZaZbZ" "" "" id False @?= Nothing + ] + , TestLabel "should be case sensitive is specified" $ from [ + F.match "hask" "Haskell" "" "" id True @?= Nothing + ] + , TestLabel "should be wrap pre and post around matches" $ from [ + F.rendered <$> F.match "brd" "bread" "<" ">" id True @?= Just "ea" + ] + ] + , TestLabel "filter" $ TestList [ + TestLabel "should return list untouched when given empty pattern" $ from [ + map F.original (F.filter "" ["abc", "def"] "" "" id True) @?= ["abc", "def"] + ] + , TestLabel "should return the highest score first" $ from [ + (@?=) (head (F.filter "cb" ["cab", "acb"] "" "" id True) ) + (head (F.filter "cb" ["acb"] "" "" id True)) + ] + ] + ] + +runTests :: IO () +runTests = do + _ <- runTestTT tests + return () + +-- | For now, main will run our tests. +main :: IO () +main = runTests