-----------------------------------------------------------------------------
--
-- Module      : Language.PureScript.Ide.Matcher
-- Description : Matchers for psc-ide commands
-- Copyright   : Christoph Hegemann 2016
-- License     : MIT (http://opensource.org/licenses/MIT)
--
-- Maintainer  : Christoph Hegemann <christoph.hegemann1337@gmail.com>
-- Stability   : experimental
--
-- |
-- Matchers for psc-ide commands
-----------------------------------------------------------------------------

module Language.PureScript.Ide.Matcher
       ( Matcher
       , runMatcher
       -- for tests
       , flexMatcher
       ) where

import           Protolude

import           Control.Monad.Fail (fail)
import           Data.Aeson
import qualified Data.Text                     as T
import qualified Data.Text.Encoding            as TE
import           Language.PureScript.Ide.Types
import           Language.PureScript.Ide.Util
import           Text.EditDistance
import           Text.Regex.TDFA               ((=~))


type ScoredMatch a = (Match a, Double)

newtype Matcher a = Matcher (Endo [Match a]) deriving (NonEmpty (Matcher a) -> Matcher a
Matcher a -> Matcher a -> Matcher a
forall b. Integral b => b -> Matcher a -> Matcher a
forall a. NonEmpty (Matcher a) -> Matcher a
forall a. Matcher a -> Matcher a -> Matcher a
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
forall a b. Integral b => b -> Matcher a -> Matcher a
stimes :: forall b. Integral b => b -> Matcher a -> Matcher a
$cstimes :: forall a b. Integral b => b -> Matcher a -> Matcher a
sconcat :: NonEmpty (Matcher a) -> Matcher a
$csconcat :: forall a. NonEmpty (Matcher a) -> Matcher a
<> :: Matcher a -> Matcher a -> Matcher a
$c<> :: forall a. Matcher a -> Matcher a -> Matcher a
Semigroup, Matcher a
[Matcher a] -> Matcher a
Matcher a -> Matcher a -> Matcher a
forall a. Semigroup (Matcher a)
forall a. Matcher a
forall a.
Semigroup a -> a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
forall a. [Matcher a] -> Matcher a
forall a. Matcher a -> Matcher a -> Matcher a
mconcat :: [Matcher a] -> Matcher a
$cmconcat :: forall a. [Matcher a] -> Matcher a
mappend :: Matcher a -> Matcher a -> Matcher a
$cmappend :: forall a. Matcher a -> Matcher a -> Matcher a
mempty :: Matcher a
$cmempty :: forall a. Matcher a
Monoid)

instance FromJSON (Matcher IdeDeclarationAnn) where
  parseJSON :: Value -> Parser (Matcher IdeDeclarationAnn)
parseJSON = forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"matcher" forall a b. (a -> b) -> a -> b
$ \Object
o -> do
    (Maybe Text
matcher :: Maybe Text) <- Object
o forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"matcher"
    case Maybe Text
matcher of
      Just Text
"flex" -> do
        Object
params <- Object
o forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"params"
        Text -> Matcher IdeDeclarationAnn
flexMatcher forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
params forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"search"
      Just Text
"distance" -> do
        Object
params <- Object
o forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"params"
        Text -> Int -> Matcher IdeDeclarationAnn
distanceMatcher
          forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
params forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"search"
          forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
params forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"maximumDistance"
      Just Text
s -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"Unknown matcher: " forall a. Semigroup a => a -> a -> a
<> forall a b. (Show a, StringConv String b) => a -> b
show Text
s)
      Maybe Text
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Monoid a => a
mempty

-- | Matches any occurrence of the search string with intersections
--
-- The scoring measures how far the matches span the string where
-- closer is better.
-- Examples:
--   flMa matches flexMatcher. Score: 14.28
--   sons matches sortCompletions. Score: 6.25
flexMatcher :: Text -> Matcher IdeDeclarationAnn
flexMatcher :: Text -> Matcher IdeDeclarationAnn
flexMatcher Text
p = forall a. ([Match a] -> [ScoredMatch a]) -> Matcher a
mkMatcher (Text
-> [Match IdeDeclarationAnn] -> [ScoredMatch IdeDeclarationAnn]
flexMatch Text
p)

distanceMatcher :: Text -> Int -> Matcher IdeDeclarationAnn
distanceMatcher :: Text -> Int -> Matcher IdeDeclarationAnn
distanceMatcher Text
q Int
maxDist = forall a. ([Match a] -> [ScoredMatch a]) -> Matcher a
mkMatcher (Text
-> Int
-> [Match IdeDeclarationAnn]
-> [ScoredMatch IdeDeclarationAnn]
distanceMatcher' Text
q Int
maxDist)

distanceMatcher' :: Text -> Int -> [Match IdeDeclarationAnn] -> [ScoredMatch IdeDeclarationAnn]
distanceMatcher' :: Text
-> Int
-> [Match IdeDeclarationAnn]
-> [ScoredMatch IdeDeclarationAnn]
distanceMatcher' Text
q Int
maxDist = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Match IdeDeclarationAnn -> Maybe (ScoredMatch IdeDeclarationAnn)
go
  where
    go :: Match IdeDeclarationAnn -> Maybe (ScoredMatch IdeDeclarationAnn)
go Match IdeDeclarationAnn
m = let d :: Int
d = String -> Int
dist (Text -> String
T.unpack Text
y)
               y :: Text
y = IdeDeclaration -> Text
identifierFromIdeDeclaration (IdeDeclarationAnn -> IdeDeclaration
discardAnn (forall a. Match a -> a
unwrapMatch Match IdeDeclarationAnn
m))
          in if Int
d forall a. Ord a => a -> a -> Bool
<= Int
maxDist
             then forall a. a -> Maybe a
Just (Match IdeDeclarationAnn
m, Double
1 forall a. Fractional a => a -> a -> a
/ forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
d)
             else forall a. Maybe a
Nothing
    dist :: String -> Int
dist = EditCosts -> String -> String -> Int
levenshteinDistance EditCosts
defaultEditCosts (Text -> String
T.unpack Text
q)

mkMatcher :: ([Match a] -> [ScoredMatch a]) -> Matcher a
mkMatcher :: forall a. ([Match a] -> [ScoredMatch a]) -> Matcher a
mkMatcher [Match a] -> [ScoredMatch a]
matcher = forall a. Endo [Match a] -> Matcher a
Matcher forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> a) -> Endo a
Endo  forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [ScoredMatch a] -> [ScoredMatch a]
sortCompletions forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Match a] -> [ScoredMatch a]
matcher

runMatcher :: Matcher a -> [Match a] -> [Match a]
runMatcher :: forall a. Matcher a -> [Match a] -> [Match a]
runMatcher (Matcher Endo [Match a]
m)= forall a. Endo a -> a -> a
appEndo Endo [Match a]
m

sortCompletions :: [ScoredMatch a] -> [ScoredMatch a]
sortCompletions :: forall a. [ScoredMatch a] -> [ScoredMatch a]
sortCompletions = forall o a. Ord o => (a -> o) -> [a] -> [a]
sortOn (forall a. a -> Down a
Down forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd)

flexMatch :: Text -> [Match IdeDeclarationAnn] -> [ScoredMatch IdeDeclarationAnn]
flexMatch :: Text
-> [Match IdeDeclarationAnn] -> [ScoredMatch IdeDeclarationAnn]
flexMatch = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text
-> Match IdeDeclarationAnn -> Maybe (ScoredMatch IdeDeclarationAnn)
flexRate

flexRate :: Text -> Match IdeDeclarationAnn -> Maybe (ScoredMatch IdeDeclarationAnn)
flexRate :: Text
-> Match IdeDeclarationAnn -> Maybe (ScoredMatch IdeDeclarationAnn)
flexRate Text
p Match IdeDeclarationAnn
c = do
  Double
score <- Text -> Text -> Maybe Double
flexScore Text
p (IdeDeclaration -> Text
identifierFromIdeDeclaration (IdeDeclarationAnn -> IdeDeclaration
discardAnn (forall a. Match a -> a
unwrapMatch Match IdeDeclarationAnn
c)))
  forall (m :: * -> *) a. Monad m => a -> m a
return (Match IdeDeclarationAnn
c, Double
score)

-- FlexMatching ala Sublime.
-- Borrowed from: http://cdewaka.com/2013/06/fuzzy-pattern-matching-in-haskell/
--
-- By string =~ pattern we'll get the start of the match and the length of
-- the matches a (start, length) tuple if there's a match.
-- If match fails then it would be (-1,0)
flexScore :: Text -> Text -> Maybe Double
flexScore :: Text -> Text -> Maybe Double
flexScore Text
pat Text
str =
  case Text -> Maybe (Char, Text)
T.uncons Text
pat of
    Maybe (Char, Text)
Nothing -> forall a. Maybe a
Nothing
    Just (Char
first', Text
p) ->
      case Text -> ByteString
TE.encodeUtf8 Text
str forall source source1 target.
(RegexMaker Regex CompOption ExecOption source,
 RegexContext Regex source1 target) =>
source1 -> source -> target
=~ Text -> ByteString
TE.encodeUtf8 Text
pat' :: (Int, Int) of
        (-1,Int
0) -> forall a. Maybe a
Nothing
        (Int
start,Int
len) -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall {a} {a}. (Fractional a, Integral a) => a -> a -> a
calcScore Int
start (Int
start forall a. Num a => a -> a -> a
+ Int
len)
      where
        escapedPattern :: [Text]
        escapedPattern :: [Text]
escapedPattern = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map Char -> Text
escape (Text -> String
T.unpack Text
p)

        -- escape prepends a backslash to "regexy" characters to prevent the
        -- matcher from crashing when trying to build the regex
        escape :: Char -> Text
        escape :: Char -> Text
escape Char
c = if Char
c forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` Text -> String
T.unpack Text
"[\\^$.|?*+(){}"
                   then String -> Text
T.pack [Char
'\\', Char
c]
                   else Char -> Text
T.singleton Char
c
        -- This just interleaves the search pattern with .*
        -- abcd[*] -> a.*b.*c.*d.*[*]
        pat' :: Text
pat' = Char -> Text
escape Char
first' forall a. Semigroup a => a -> a -> a
<> forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (forall a. Semigroup a => a -> a -> a
<> Text
".*") [Text]
escapedPattern
        calcScore :: a -> a -> a
calcScore a
start a
end =
          a
100.0 forall a. Fractional a => a -> a -> a
/ forall a b. (Integral a, Num b) => a -> b
fromIntegral ((a
1 forall a. Num a => a -> a -> a
+ a
start) forall a. Num a => a -> a -> a
* (a
end forall a. Num a => a -> a -> a
- a
start forall a. Num a => a -> a -> a
+ a
1))