{-|
Fuzzy string search in Haskell.
Uses 'TextualMonoid' to be able to run on different types of strings.
-}
module Text.Fuzzily where

import Protolude as P (
  Bool (True),
  Down (Down),
  Eq ((==)),
  Int,
  Maybe (..),
  Monoid (mempty),
  Num ((*), (+)),
  Semigroup ((<>)),
  Show,
  const,
  identity,
  isJust,
  map,
  mapMaybe,
  not,
  sortOn,
  toLower,
  (.),
 )

import Data.Monoid.Textual qualified as T


{-|
Included in the return type of `match` and `filter`.
Contains the original value given, the rendered string
and the matching score.
-}
data Fuzzy val prettyText = Fuzzy
  { forall val prettyText. Fuzzy val prettyText -> val
original :: val
  , forall val prettyText. Fuzzy val prettyText -> prettyText
rendered :: prettyText
  , forall val prettyText. Fuzzy val prettyText -> Int
score :: Int
  }
  deriving (Int -> Fuzzy val prettyText -> ShowS
[Fuzzy val prettyText] -> ShowS
Fuzzy val prettyText -> String
(Int -> Fuzzy val prettyText -> ShowS)
-> (Fuzzy val prettyText -> String)
-> ([Fuzzy val prettyText] -> ShowS)
-> Show (Fuzzy val prettyText)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall val prettyText.
(Show val, Show prettyText) =>
Int -> Fuzzy val prettyText -> ShowS
forall val prettyText.
(Show val, Show prettyText) =>
[Fuzzy val prettyText] -> ShowS
forall val prettyText.
(Show val, Show prettyText) =>
Fuzzy val prettyText -> String
$cshowsPrec :: forall val prettyText.
(Show val, Show prettyText) =>
Int -> Fuzzy val prettyText -> ShowS
showsPrec :: Int -> Fuzzy val prettyText -> ShowS
$cshow :: forall val prettyText.
(Show val, Show prettyText) =>
Fuzzy val prettyText -> String
show :: Fuzzy val prettyText -> String
$cshowList :: forall val prettyText.
(Show val, Show prettyText) =>
[Fuzzy val prettyText] -> ShowS
showList :: [Fuzzy val prettyText] -> ShowS
Show, Fuzzy val prettyText -> Fuzzy val prettyText -> Bool
(Fuzzy val prettyText -> Fuzzy val prettyText -> Bool)
-> (Fuzzy val prettyText -> Fuzzy val prettyText -> Bool)
-> Eq (Fuzzy val prettyText)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall val prettyText.
(Eq val, Eq prettyText) =>
Fuzzy val prettyText -> Fuzzy val prettyText -> Bool
$c== :: forall val prettyText.
(Eq val, Eq prettyText) =>
Fuzzy val prettyText -> Fuzzy val prettyText -> Bool
== :: Fuzzy val prettyText -> Fuzzy val prettyText -> Bool
$c/= :: forall val prettyText.
(Eq val, Eq prettyText) =>
Fuzzy val prettyText -> Fuzzy val prettyText -> Bool
/= :: Fuzzy val prettyText -> Fuzzy val prettyText -> Bool
Eq)


data CaseSensitivity
  = IgnoreCase
  | HandleCase
  deriving (Int -> CaseSensitivity -> ShowS
[CaseSensitivity] -> ShowS
CaseSensitivity -> String
(Int -> CaseSensitivity -> ShowS)
-> (CaseSensitivity -> String)
-> ([CaseSensitivity] -> ShowS)
-> Show CaseSensitivity
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> CaseSensitivity -> ShowS
showsPrec :: Int -> CaseSensitivity -> ShowS
$cshow :: CaseSensitivity -> String
show :: CaseSensitivity -> String
$cshowList :: [CaseSensitivity] -> ShowS
showList :: [CaseSensitivity] -> ShowS
Show, CaseSensitivity -> CaseSensitivity -> Bool
(CaseSensitivity -> CaseSensitivity -> Bool)
-> (CaseSensitivity -> CaseSensitivity -> Bool)
-> Eq CaseSensitivity
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: CaseSensitivity -> CaseSensitivity -> Bool
== :: CaseSensitivity -> CaseSensitivity -> Bool
$c/= :: CaseSensitivity -> CaseSensitivity -> Bool
/= :: CaseSensitivity -> CaseSensitivity -> Bool
Eq)


null :: (T.TextualMonoid s) => s -> Bool
null :: forall s. TextualMonoid s => 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)


{-|
Returns the rendered output and the
matching score for a pattern and a text.
Two examples are given below:

>>> match HandleCase ("", "") identity "fnt" "infinite"
Just (Fuzzy
  { original = "infinite"
  , rendered = "infinite"
  , score = 3
  })

>>> match IgnoreCase ("<", ">") fst "hsk" ("Haskell", 1995)
Just (Fuzzy
  { original = ("Haskell", 1995)
  , rendered = "<h>a<s><k>ell"
  , score = 5
  })
-}
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 :: forall text value.
TextualMonoid text =>
CaseSensitivity
-> (text, text)
-> (value -> text)
-> text
-> value
-> Maybe (Fuzzy value text)
match CaseSensitivity
caseSensitivity (text
pre, text
post) value -> text
extractFunc text
pattern value
value =
  let
    searchText :: text
searchText = value -> text
extractFunc value
value
    (text
searchTextNorm, text
patternNorm) =
      let mapToLower :: text -> text
mapToLower = (Char -> Char) -> text -> text
forall t. TextualMonoid t => (Char -> Char) -> t -> t
T.map Char -> Char
toLower
      in  if CaseSensitivity
caseSensitivity CaseSensitivity -> CaseSensitivity -> Bool
forall a. Eq a => a -> a -> Bool
== CaseSensitivity
HandleCase
            then (text
searchText, text
pattern)
            else (text -> text
mapToLower text
searchText, text
pattern)

    (Int
totalScore, Int
_, text
result, text
patternFromFold) =
      ((Int, Int, text, text) -> Char -> (Int, Int, text, text))
-> (Int, Int, text, text) -> text -> (Int, Int, text, text)
forall t a. TextualMonoid t => (a -> Char -> a) -> a -> t -> a
forall a. (a -> Char -> a) -> a -> text -> a
T.foldl_'
        ( \(Int
tot, Int
cur, text
res, text
pat) Char
c ->
            case text -> Maybe (Char, text)
forall t. TextualMonoid t => t -> Maybe (Char, t)
T.splitCharacterPrefix text
pat of
              Maybe (Char, text)
Nothing ->
                ( Int
tot
                , Int
0
                , text
res text -> text -> text
forall a. Semigroup a => a -> a -> a
<> Char -> text
forall t. TextualMonoid t => Char -> t
T.singleton Char
c
                , text
pat
                )
              Just (Char
x, text
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'
                        , text
res text -> text -> text
forall a. Semigroup a => a -> a -> a
<> text
pre text -> text -> text
forall a. Semigroup a => a -> a -> a
<> Char -> text
forall t. TextualMonoid t => Char -> t
T.singleton Char
c text -> text -> text
forall a. Semigroup a => a -> a -> a
<> text
post
                        , text
xs
                        )
                  else
                    ( Int
tot
                    , Int
0
                    , text
res text -> text -> text
forall a. Semigroup a => a -> a -> a
<> Char -> text
forall t. TextualMonoid t => Char -> t
T.singleton Char
c
                    , text
pat
                    )
        )
        (Int
0, Int
0, text
forall a. Monoid a => a
mempty, text
patternNorm)
        text
searchTextNorm
  in
    if text -> Bool
forall s. TextualMonoid s => s -> Bool
null text
patternFromFold
      then Fuzzy value text -> Maybe (Fuzzy value text)
forall a. a -> Maybe a
Just (value -> text -> Int -> Fuzzy value text
forall val prettyText.
val -> prettyText -> Int -> Fuzzy val prettyText
Fuzzy value
value text
result Int
totalScore)
      else Maybe (Fuzzy value text)
forall a. Maybe a
Nothing


{-|
The function to filter a list of values
by fuzzy search on the text extracted from them.

>>> langs = [("Standard ML", 1990), ("OCaml", 1996), ("Scala", 2003)]
>>> filter "ML" langs ("<", ">") fst IgnoreCase
[ Fuzzy
  { original = ("Standard ML", 1990)
  , rendered = "standard <m><l>"
  , score = 4}
, Fuzzy
  { original = ("OCaml", 1996)
  , rendered = "oca<m><l>"
  , score = 4
  }
]
-}
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 :: forall text value.
TextualMonoid text =>
CaseSensitivity
-> (text, text)
-> (value -> text)
-> text
-> [value]
-> [Fuzzy value text]
filter CaseSensitivity
caseSen (text
pre, text
post) value -> text
extractFunc text
pattern [value]
texts =
  (Fuzzy value text -> Down Int)
-> [Fuzzy value text] -> [Fuzzy value text]
forall o a. Ord o => (a -> o) -> [a] -> [a]
sortOn
    (Int -> Down Int
forall a. a -> Down a
Down (Int -> Down Int)
-> (Fuzzy value text -> Int) -> Fuzzy value text -> Down Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Fuzzy value text -> Int
forall val prettyText. Fuzzy val prettyText -> Int
score)
    ( (value -> Maybe (Fuzzy value text))
-> [value] -> [Fuzzy value text]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe
        (CaseSensitivity
-> (text, text)
-> (value -> text)
-> text
-> value
-> Maybe (Fuzzy value text)
forall text value.
TextualMonoid text =>
CaseSensitivity
-> (text, text)
-> (value -> text)
-> text
-> value
-> Maybe (Fuzzy value text)
match CaseSensitivity
caseSen (text
pre, text
post) value -> text
extractFunc text
pattern)
        [value]
texts
    )


{-|
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 text)
  => text
  -- ^ Pattern to look for.
  -> [text]
  -- ^ List of texts to check.
  -> [text]
  -- ^ The ones that match.
simpleFilter :: forall text. TextualMonoid text => text -> [text] -> [text]
simpleFilter text
pattern [text]
xs =
  (Fuzzy text text -> text) -> [Fuzzy text text] -> [text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map
    Fuzzy text text -> text
forall val prettyText. Fuzzy val prettyText -> val
original
    (CaseSensitivity
-> (text, text)
-> (text -> text)
-> text
-> [text]
-> [Fuzzy text text]
forall text value.
TextualMonoid text =>
CaseSensitivity
-> (text, text)
-> (value -> text)
-> text
-> [value]
-> [Fuzzy value text]
filter CaseSensitivity
IgnoreCase (text
forall a. Monoid a => a
mempty, text
forall a. Monoid a => a
mempty) text -> text
forall a. a -> a
identity text
pattern [text]
xs)


{-|
Returns false if the pattern and the text do not match at all.
Returns true otherwise.

>>> test "brd" "bread"
True
-}
test :: (T.TextualMonoid text) => text -> text -> Bool
test :: forall text. TextualMonoid text => text -> text -> Bool
test text
pattern text
text =
  Maybe (Fuzzy text text) -> Bool
forall a. Maybe a -> Bool
isJust (CaseSensitivity
-> (text, text)
-> (text -> text)
-> text
-> text
-> Maybe (Fuzzy text text)
forall text value.
TextualMonoid text =>
CaseSensitivity
-> (text, text)
-> (value -> text)
-> text
-> value
-> Maybe (Fuzzy value text)
match CaseSensitivity
IgnoreCase (text
forall a. Monoid a => a
mempty, text
forall a. Monoid a => a
mempty) text -> text
forall a. a -> a
identity text
pattern text
text)