module Yesod.Goodies.Search
( SearchResult(..)
, Search(..)
, search
, search_
, weightedSearch
, weightedSearch_
, TextSearch(..)
, keywordMatch
) where
import Data.List (sortBy, intersect)
import Data.Ord (comparing)
import Data.Maybe (catMaybes)
import qualified Data.Text as T
data SearchResult a = SearchResult
{ searchRank :: Double
, searchResult :: a
}
class Search a where
preference :: SearchResult a -> SearchResult a -> Ordering
preference _ _ = EQ
match :: T.Text -> a -> Maybe (SearchResult a)
search :: Search a => T.Text -> [a] -> [SearchResult a]
search t = rankResults . catMaybes . map (match t)
search_ :: Search a => T.Text -> [a] -> [a]
search_ t = map searchResult . search t
weightedSearch :: Search a => (a -> Double) -> T.Text -> [a] -> [SearchResult a]
weightedSearch f t = rankResults . map (applyFactor f) . catMaybes . map (match t)
where
applyFactor :: (a -> Double) -> SearchResult a -> SearchResult a
applyFactor f' (SearchResult d v) = SearchResult (d * f' v) v
weightedSearch_ :: Search a => (a -> Double) -> T.Text -> [a] -> [a]
weightedSearch_ f t = map searchResult . weightedSearch f t
rankResults :: Search a => [SearchResult a] -> [SearchResult a]
rankResults = reverse . sortBy (comparing searchRank `andthen` preference)
andthen :: (a -> a -> Ordering) -> (a -> a -> Ordering) -> a -> a -> Ordering
andthen f g a b =
case f a b of
EQ -> g a b
x -> x
class TextSearch a where
toText :: a -> T.Text
keywordMatch :: TextSearch a => T.Text -> a -> Maybe (SearchResult a)
keywordMatch t v = go $ fix (toText v) `intersect` fix t
where
go [] = Nothing
go ms = Just $ SearchResult (fromIntegral $ length ms) v
fix :: T.Text -> [T.Text]
fix = filter (not . T.null)
. map T.strip
. T.words
. T.toCaseFold
. T.filter (`notElem` ",.-")