{-# 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 { Fuzzy t s -> t
original :: t
        , Fuzzy t s -> s
rendered :: s
        , Fuzzy t s -> Int
score    :: Int
        } deriving (Int -> Fuzzy t s -> ShowS
[Fuzzy t s] -> ShowS
Fuzzy t s -> String
(Int -> Fuzzy t s -> ShowS)
-> (Fuzzy t s -> String)
-> ([Fuzzy t s] -> ShowS)
-> Show (Fuzzy t s)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall t s.
(TextualMonoid s, Show t, Show s) =>
Int -> Fuzzy t s -> ShowS
forall t s.
(TextualMonoid s, Show t, Show s) =>
[Fuzzy t s] -> ShowS
forall t s.
(TextualMonoid s, Show t, Show s) =>
Fuzzy t s -> String
showList :: [Fuzzy t s] -> ShowS
$cshowList :: forall t s.
(TextualMonoid s, Show t, Show s) =>
[Fuzzy t s] -> ShowS
show :: Fuzzy t s -> String
$cshow :: forall t s.
(TextualMonoid s, Show t, Show s) =>
Fuzzy t s -> String
showsPrec :: Int -> Fuzzy t s -> ShowS
$cshowsPrec :: forall t s.
(TextualMonoid s, Show t, Show s) =>
Int -> Fuzzy t s -> ShowS
Show, Fuzzy t s -> Fuzzy t s -> Bool
(Fuzzy t s -> Fuzzy t s -> Bool)
-> (Fuzzy t s -> Fuzzy t s -> Bool) -> Eq (Fuzzy t s)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall t s.
(TextualMonoid s, Eq t, Eq s) =>
Fuzzy t s -> Fuzzy t s -> Bool
/= :: Fuzzy t s -> Fuzzy t s -> Bool
$c/= :: forall t s.
(TextualMonoid s, Eq t, Eq s) =>
Fuzzy t s -> Fuzzy t s -> Bool
== :: Fuzzy t s -> Fuzzy t s -> Bool
$c== :: forall t s.
(TextualMonoid s, Eq t, Eq s) =>
Fuzzy t s -> Fuzzy t s -> Bool
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 ("<h>a<s><k>ell",5)
--
{-# INLINABLE match #-}
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 :: s -> t -> s -> s -> (t -> s) -> Bool -> Maybe (Fuzzy t s)
match s
pattern t
t s
pre s
post t -> s
extract Bool
caseSensitive =
    if s -> Bool
forall s. TextualMonoid s => s -> Bool
null s
pat then Fuzzy t s -> Maybe (Fuzzy t s)
forall a. a -> Maybe a
Just (t -> s -> Int -> Fuzzy t s
forall t s. t -> s -> Int -> Fuzzy t s
Fuzzy t
t s
result Int
totalScore) else Maybe (Fuzzy t s)
forall a. Maybe a
Nothing
  where
    null :: (T.TextualMonoid s) => s -> Bool
    null :: s -> Bool
null = Bool -> Bool
not (Bool -> Bool) -> (s -> Bool) -> s -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> s -> Bool
forall t. TextualMonoid t => (Char -> Bool) -> t -> Bool
T.any (Bool -> Char -> Bool
forall a b. a -> b -> a
const Bool
True)

    s :: s
s = t -> s
extract t
t
    (s
s', s
pattern') = let f :: s -> s
f = (Char -> Char) -> s -> s
forall t. TextualMonoid t => (Char -> Char) -> t -> t
T.map Char -> Char
toLower in
                     if Bool
caseSensitive then (s
s, s
pattern) else (s -> s
f s
s, s -> s
f s
pattern)

    (Int
totalScore, Int
currScore, s
result, s
pat) =
      ((Int, Int, s, s) -> s -> (Int, Int, s, s))
-> ((Int, Int, s, s) -> Char -> (Int, Int, s, s))
-> (Int, Int, s, s)
-> s
-> (Int, Int, s, s)
forall t a.
TextualMonoid t =>
(a -> t -> a) -> (a -> Char -> a) -> a -> t -> a
T.foldl'
        (Int, Int, s, s) -> s -> (Int, Int, s, s)
forall a. HasCallStack => a
undefined
        (\(Int
tot, Int
cur, s
res, s
pat) Char
c ->
            case s -> Maybe (Char, s)
forall t. TextualMonoid t => t -> Maybe (Char, t)
T.splitCharacterPrefix s
pat of
              Maybe (Char, s)
Nothing -> (Int
tot, Int
0, s
res s -> s -> s
forall a. Semigroup a => a -> a -> a
<> Char -> s
forall t. TextualMonoid t => Char -> t
T.singleton Char
c, s
pat)
              Just (Char
x, s
xs) ->
                if Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
c then
                  let cur' :: Int
cur' = Int
cur Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
2 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 in
                  (Int
tot Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
cur', Int
cur', s
res s -> s -> s
forall a. Semigroup a => a -> a -> a
<> s
pre s -> s -> s
forall a. Semigroup a => a -> a -> a
<> Char -> s
forall t. TextualMonoid t => Char -> t
T.singleton Char
c s -> s -> s
forall a. Semigroup a => a -> a -> a
<> s
post, s
xs)
                else (Int
tot, Int
0, s
res s -> s -> s
forall a. Semigroup a => a -> a -> a
<> Char -> s
forall t. TextualMonoid t => Char -> t
T.singleton Char
c, s
pat)
        ) (Int
0, Int
0, s
forall a. Monoid a => a
mempty, s
pattern') s
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 <m><l>", score = 4},Fuzzy {original = ("OCaml",1996), rendered = "oca<m><l>", score = 4}]
{-# INLINABLE filter #-}
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 :: s -> [t] -> s -> s -> (t -> s) -> Bool -> [Fuzzy t s]
filter s
pattern [t]
ts s
pre s
post t -> s
extract Bool
caseSen =
  (Fuzzy t s -> Down Int) -> [Fuzzy t s] -> [Fuzzy t s]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (Int -> Down Int
forall a. a -> Down a
Down (Int -> Down Int) -> (Fuzzy t s -> Int) -> Fuzzy t s -> Down Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Fuzzy t s -> Int
forall t s. TextualMonoid s => Fuzzy t s -> Int
score)
         ((t -> Maybe (Fuzzy t s)) -> [t] -> [Fuzzy t s]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (\t
t -> s -> t -> s -> s -> (t -> s) -> Bool -> Maybe (Fuzzy t s)
forall s t.
TextualMonoid s =>
s -> t -> s -> s -> (t -> s) -> Bool -> Maybe (Fuzzy t s)
match s
pattern t
t s
pre s
post t -> s
extract Bool
caseSen) [t]
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"]
{-# INLINABLE simpleFilter #-}
simpleFilter :: (T.TextualMonoid s)
             => s   -- ^ Pattern to look for.
             -> [s] -- ^ List of texts to check.
             -> [s] -- ^ The ones that match.
simpleFilter :: s -> [s] -> [s]
simpleFilter s
pattern [s]
xs =
  (Fuzzy s s -> s) -> [Fuzzy s s] -> [s]
forall a b. (a -> b) -> [a] -> [b]
map Fuzzy s s -> s
forall t s. TextualMonoid s => Fuzzy t s -> t
original ([Fuzzy s s] -> [s]) -> [Fuzzy s s] -> [s]
forall a b. (a -> b) -> a -> b
$ s -> [s] -> s -> s -> (s -> s) -> Bool -> [Fuzzy s s]
forall s t.
TextualMonoid s =>
s -> [t] -> s -> s -> (t -> s) -> Bool -> [Fuzzy t s]
filter s
pattern [s]
xs s
forall a. Monoid a => a
mempty s
forall a. Monoid a => a
mempty s -> s
forall a. a -> a
id Bool
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 :: s -> s -> Bool
test s
p s
s = Maybe (Fuzzy s s) -> Bool
forall a. Maybe a -> Bool
isJust (s -> s -> s -> s -> (s -> s) -> Bool -> Maybe (Fuzzy s s)
forall s t.
TextualMonoid s =>
s -> t -> s -> s -> (t -> s) -> Bool -> Maybe (Fuzzy t s)
match s
p s
s s
forall a. Monoid a => a
mempty s
forall a. Monoid a => a
mempty s -> s
forall a. a -> a
id Bool
False)