Inline Fuzzy.match to apply [1] and to be case-sensitive on first match

[1] - joom/fuzzy#4

Author: pepeiborra

ghcide/src/Text/Fuzzy/Parallel.hs

@@ -5,7 +5,6 @@ module Text.Fuzzy.Parallel
     Scored(..),
     -- reexports
     Fuzzy,
-    match
 ) where
 
 import           Control.Monad.ST            (runST)
@@ -16,12 +15,58 @@ import           Data.Vector                 (Vector, (!))
 import qualified Data.Vector                 as V
 -- need to use a stable sort
 import           Data.Bifunctor              (second)
-import           Data.Maybe                  (fromJust)
+import           Data.Char                   (toLower)
+import           Data.Maybe                  (fromMaybe)
+import qualified Data.Monoid.Textual         as T
 import           Prelude                     hiding (filter)
-import           Text.Fuzzy                  (Fuzzy (..), match)
+import           Text.Fuzzy                  (Fuzzy (..))
 
 data Scored a = Scored {score_ :: !Int, original:: !a}
-  deriving Functor
+  deriving (Functor,Show)
+
+-- | 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 in lowercase except for first character
+      -> 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.
+      -> Maybe (Fuzzy t s) -- ^ The original value, rendered string and score.
+match pattern t pre post extract =
+    if null pat then Just (Fuzzy t result totalScore) else Nothing
+  where
+    null :: (T.TextualMonoid s) => s -> Bool
+    null = not . T.any (const True)
+
+    s = extract t
+    (totalScore, _currScore, result, pat, _) =
+      T.foldl'
+        undefined
+        (\(tot, cur, res, pat, isFirst) c ->
+            case T.splitCharacterPrefix pat of
+              Nothing -> (tot, 0, res <> T.singleton c, pat, isFirst)
+              Just (x, xs) ->
+                -- the case of the first character has to match
+                -- otherwise use lower case since the pattern is assumed lower
+                let !c' = if isFirst then c else toLower c in
+                if x == c' then
+                  let cur' = cur * 2 + 1 in
+                  (tot + cur', cur', res <> pre <> T.singleton c <> post, xs, False)
+                else (tot, 0, res <> T.singleton c, pat, isFirst)
+        ) ( 0
+          , 1 -- matching at the start gives a bonus (cur = 1)
+          , mempty, pattern, True) s
 
 -- | The function to filter a list of values by fuzzy search on the text extracted from them.
 filter :: (TextualMonoid s)
@@ -32,15 +77,20 @@ filter :: (TextualMonoid s)
        -> 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.
        -> [Scored t] -- ^ The list of results, sorted, highest score first.
-filter chunkSize maxRes pattern ts pre post extract caseSen = runST $ do
+filter chunkSize maxRes pattern ts pre post extract = runST $ do
   let v = V.mapMaybe id
-             (V.map (\t -> match pattern t pre post extract caseSen) (V.fromList ts)
+             (V.map (\t -> match pattern' t pre post extract) (V.fromList ts)
              `using`
              parVectorChunk chunkSize (evalTraversable forceScore))
-      perfectScore = score $ fromJust $ match pattern pattern "" "" id False
+      perfectScore = score $ fromMaybe (error $ T.toString undefined pattern) $
+        match pattern' pattern' "" "" id
   return $ partialSortByAscScore maxRes perfectScore v
+  where
+      -- Preserve case for the first character, make all others lowercase
+      pattern' = case T.splitCharacterPrefix pattern of
+          Just (c, rest) -> T.singleton c <> T.map toLower rest
+          _              -> pattern
 
 -- | Return all elements of the list that have a fuzzy
 -- match against the pattern. Runs with default settings where
@@ -56,7 +106,7 @@ simpleFilter :: (TextualMonoid s)
              -> [s] -- ^ List of texts to check.
              -> [Scored s] -- ^ The ones that match.
 simpleFilter chunk maxRes pattern xs =
-  filter chunk maxRes pattern xs mempty mempty id False
+  filter chunk maxRes pattern xs mempty mempty id
 
 --------------------------------------------------------------------------------
 

ghcide/test/exe/Main.hs

@@ -4189,15 +4189,13 @@ topLevelCompletionTests = [
         "variable"
         ["bar = xx", "-- | haddock", "xxx :: ()", "xxx = ()", "-- | haddock", "data Xxx = XxxCon"]
         (Position 0 8)
-        [("xxx", CiFunction, "xxx", True, True, Nothing),
-         ("XxxCon", CiConstructor, "XxxCon", False, True, Nothing)
+        [("xxx", CiFunction, "xxx", True, True, Nothing)
         ],
     completionTest
         "constructor"
         ["bar = xx", "-- | haddock", "xxx :: ()", "xxx = ()", "-- | haddock", "data Xxx = XxxCon"]
         (Position 0 8)
-        [("xxx", CiFunction, "xxx", True, True, Nothing),
-         ("XxxCon", CiConstructor, "XxxCon", False, True, Nothing)
+        [("xxx", CiFunction, "xxx", True, True, Nothing)
         ],
     completionTest
         "class method"
@@ -4311,10 +4309,9 @@ nonLocalCompletionTests =
       [("head", CiFunction, "head ${1:([a])}", True, True, Nothing)],
     completionTest
       "constructor"
-      ["module A where", "f = Tru"]
-      (Position 1 7)
-      [ ("True", CiConstructor, "True ", True, True, Nothing),
-        ("truncate", CiFunction, "truncate ${1:a}", True, True, Nothing)
+      ["{-# OPTIONS_GHC -Wall #-}", "module A where", "f = True"]
+      (Position 2 8)
+      [ ("True", CiConstructor, "True ", True, True, Nothing)
       ],
     completionTest
       "type"
@@ -4331,8 +4328,8 @@ nonLocalCompletionTests =
       ],
     completionTest
       "duplicate import"
-      ["module A where", "import Data.List", "import Data.List", "f = perm"]
-      (Position 3 8)
+      ["module A where", "import Data.List", "import Data.List", "f = permu"]
+      (Position 3 9)
       [ ("permutations", CiFunction, "permutations ${1:([a])}", False, False, Nothing)
       ],
     completionTest