content: {-# LANGUAGE GeneralizedNewtypeDeriving #-}
  {-# LANGUAGE ScopedTypeVariables        #-}
  module PureScript.Ide.Matcher (Matcher, flexMatcher, runMatcher) where
  
  import           Control.Monad
  import           Data.Aeson
  import           Data.Function        (on)
  import           Data.List            (sortBy)
  import           Data.Maybe           (mapMaybe)
  import           Data.Monoid
  import           Data.Text (Text)
  import qualified Data.Text as T
  import qualified Data.Text.Encoding   as TE
  import           PureScript.Ide.Types
  import           Text.Regex.TDFA      ((=~))
  import           Text.EditDistance
  
  
  type ScoredCompletion = (Completion, Double)
  
  newtype Matcher = Matcher (Endo [Completion]) deriving(Monoid)
  
  instance FromJSON Matcher where
    parseJSON = withObject "matcher" $ \o -> do
      (matcher :: Maybe String) <- o .:? "matcher"
      case matcher of
        Just "flex" -> do
          params <- o .: "params"
          search <- params .: "search"
          pure $ flexMatcher search
        Just "distance" -> do
          params <- o .: "params"
          search <- params .: "search"
          maxDist <- params .: "maximumDistance"
          pure $ distanceMatcher search maxDist
        Just _ -> mzero
        Nothing -> return mempty
  
  -- | Matches any occurence 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
  flexMatcher pattern = mkMatcher (flexMatch pattern)
  
  distanceMatcher :: Text -> Int -> Matcher
  distanceMatcher q maxDist = mkMatcher (distanceMatcher' q maxDist)
  
  distanceMatcher' :: Text -> Int -> [Completion] -> [ScoredCompletion]
  distanceMatcher' q maxDist = mapMaybe go
    where
      go c@(Completion (_, y, _)) = let d = dist (T.unpack y)
                                    in if d <= maxDist
                                       then Just (c, 1 / fromIntegral d)
                                       else Nothing
      dist = levenshteinDistance defaultEditCosts (T.unpack q)
  
  mkMatcher :: ([Completion] -> [ScoredCompletion]) -> Matcher
  mkMatcher matcher = Matcher . Endo  $ fmap fst . sortCompletions . matcher
  
  runMatcher :: Matcher -> [Completion] -> [Completion]
  runMatcher (Matcher m)= appEndo m
  
  sortCompletions :: [ScoredCompletion] -> [ScoredCompletion]
  sortCompletions = sortBy (flip compare `on` snd)
  
  flexMatch :: Text -> [Completion] -> [ScoredCompletion]
  flexMatch pattern = mapMaybe (flexRate pattern)
  
  flexRate :: Text -> Completion -> Maybe ScoredCompletion
  flexRate pattern c@(Completion (_,ident,_)) = do
      score <- flexScore pattern ident
      return (c, 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 matchas a (start, length) tuple if there's a match.
  -- If match fails then it would be (-1,0)
  flexScore :: Text -> DeclIdent -> Maybe Double
  flexScore "" _ = Nothing
  flexScore pat str =
      case TE.encodeUtf8 str =~ TE.encodeUtf8 pat' :: (Int, Int) of
          (-1,0) -> Nothing
          (start,len) -> Just $ calcScore start (start + len)
    where
      Just (first,pattern) = T.uncons pat
      -- This just interleaves the search string with .*
      -- abcd -> a.*b.*c.*d
      pat' = first `T.cons` T.concatMap (T.snoc ".*") pattern
      calcScore start end =
          100.0 / fromIntegral ((1 + start) * (end - start + 1))
  