Partial sort of fuzzy filtering results

ghcide/ghcide.cabal

@@ -2,7 +2,7 @@ cabal-version:      2.4
 build-type:         Simple
 category:           Development
 name:               ghcide
-version:            1.4.2.2
+version:            1.4.2.3
 license:            Apache-2.0
 license-file:       LICENSE
 author:             Digital Asset and Ghcide contributors

ghcide/src/Development/IDE/Plugin/Completions/Logic.hs

@@ -544,9 +544,9 @@ getCompletions plId ideOpts CC {allModNamesAsNS, anyQualCompls, unqualCompls, qu
       filtModNameCompls =
         map mkModCompl
           $ mapMaybe (T.stripPrefix enteredQual)
-          $ Fuzzy.simpleFilter chunkSize fullPrefix allModNamesAsNS
+          $ Fuzzy.simpleFilter chunkSize maxC fullPrefix allModNamesAsNS
 
-      filtCompls = map Fuzzy.original $ Fuzzy.filter chunkSize prefixText ctxCompls "" "" label False
+      filtCompls = map Fuzzy.original $ Fuzzy.filter chunkSize maxC prefixText ctxCompls "" "" label False
         where
 
           mcc = case maybe_parsed of
@@ -593,7 +593,7 @@ getCompletions plId ideOpts CC {allModNamesAsNS, anyQualCompls, unqualCompls, qu
 
       filtListWith f list =
         [ f label
-        | label <- Fuzzy.simpleFilter chunkSize fullPrefix list
+        | label <- Fuzzy.simpleFilter chunkSize maxC fullPrefix list
         , enteredQual `T.isPrefixOf` label
         ]
 
@@ -621,8 +621,7 @@ getCompletions plId ideOpts CC {allModNamesAsNS, anyQualCompls, unqualCompls, qu
     -> return []
     | otherwise -> do
         -- assumes that nubOrdBy is stable
-        -- nubOrd is very slow - take 10x the maximum configured
-        let uniqueFiltCompls = nubOrdBy uniqueCompl $ take (maxC*10) filtCompls
+        let uniqueFiltCompls = nubOrdBy uniqueCompl filtCompls
         let compls = map (mkCompl plId ideOpts) uniqueFiltCompls
         return $ filtModNameCompls
               ++ filtKeywordCompls

ghcide/src/Text/Fuzzy/Parallel.hs

@@ -10,39 +10,33 @@ module Text.Fuzzy.Parallel
 import           Control.Monad.ST            (runST)
 import           Control.Parallel.Strategies (Eval, Strategy, evalTraversable,
                                               parTraversable, rseq, using)
-import           Data.Function               (on)
 import           Data.Monoid.Textual         (TextualMonoid)
-import           Data.Ord                    (Down (Down))
 import           Data.Vector                 (Vector, (!))
 import qualified Data.Vector                 as V
 -- need to use a stable sort
 import           Data.Bifunctor              (second)
-import qualified Data.Vector.Algorithms.Tim  as VA
+import           Data.Maybe                  (fromJust)
 import           Prelude                     hiding (filter)
 import           Text.Fuzzy                  (Fuzzy (..), match)
 
 -- | The function to filter a list of values by fuzzy search on the text extracted from them.
---
--- >>> length $ filter 1000 200 "ML" (concat $ replicate 10000 [("Standard ML", 1990),("OCaml",1996),("Scala",2003)]) "<" ">" fst False
--- 200
 filter :: (TextualMonoid s)
        => Int      -- ^ Chunk size. 1000 works well.
+       -> Int      -- ^ Max. number of results wanted
        -> 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 chunkSize pattern ts pre post extract caseSen = runST $ do
-  let v = (V.mapMaybe id
+filter chunkSize maxRes pattern ts pre post extract caseSen = runST $ do
+  let v = V.mapMaybe id
              (V.map (\t -> match pattern t pre post extract caseSen) (V.fromList ts)
              `using`
-             parVectorChunk chunkSize (evalTraversable forceScore)))
-  v' <- V.unsafeThaw v
-  VA.sortBy (compare `on` (Down . score)) v'
-  v'' <- V.unsafeFreeze v'
-  return $ V.toList v''
+             parVectorChunk chunkSize (evalTraversable forceScore))
+      perfectScore = score $ fromJust $ match pattern pattern "" "" id False
+  return $ partialSortByAscScore maxRes perfectScore v
 
 -- | Return all elements of the list that have a fuzzy
 -- match against the pattern. Runs with default settings where
@@ -53,11 +47,12 @@ filter chunkSize pattern ts pre post extract caseSen = runST $ do
 {-# INLINABLE simpleFilter #-}
 simpleFilter :: (TextualMonoid s)
              => Int -- ^ Chunk size. 1000 works well.
+             -> Int -- ^ Max. number of results wanted
              -> s   -- ^ Pattern to look for.
              -> [s] -- ^ List of texts to check.
              -> [s] -- ^ The ones that match.
-simpleFilter chunk pattern xs =
-  map original $ filter chunk pattern xs mempty mempty id False
+simpleFilter chunk maxRes pattern xs =
+  map original $ filter chunk maxRes pattern xs mempty mempty id False
 
 --------------------------------------------------------------------------------
 
@@ -82,10 +77,8 @@ parVectorChunk chunkSize st v =
 -- [[0,1,2],[3,4,5],[6,7,8],[9,10,11],[12]]
 chunkVector :: Int -> Vector a -> [Vector a]
 chunkVector chunkSize v = do
-    let indices = chunkIndices chunkSize (0,l)
-        l = V.length v
-    [V.fromListN (h-l+1) [v ! j | j <- [l .. h]]
-            | (l,h) <- indices]
+    let indices = chunkIndices chunkSize (0,V.length v)
+    [V.slice l (h-l) v | (l,h) <- indices]
 
 -- >>> chunkIndices 3 (0,9)
 -- >>> chunkIndices 3 (0,10)
@@ -103,3 +96,34 @@ pairwise :: [a] -> [(a,a)]
 pairwise []       = []
 pairwise [_]      = []
 pairwise (x:y:xs) = (x,y) : pairwise (y:xs)
+
+-- | A stable partial sort ascending by score. O(N) best case, O(wanted*N) worst case
+partialSortByAscScore :: TextualMonoid s
+            => Int  -- ^ Number of items needed
+            -> Int  -- ^ Value of a perfect score
+            -> Vector (Fuzzy t s)
+            -> [Fuzzy t s]
+partialSortByAscScore wantedCount perfectScore v = loop 0 (SortState minBound perfectScore 0) [] where
+  l = V.length v
+  loop index st@SortState{..} acc
+    | foundCount == wantedCount = reverse acc
+    | index == l
+-- ProgressCancelledException
+    = if bestScoreSeen < scoreWanted
+        then loop 0 st{scoreWanted = bestScoreSeen, bestScoreSeen = minBound} acc
+        else reverse acc
+    | otherwise =
+      case v!index of
+        x | score x == scoreWanted
+          -> loop (index+1) st{foundCount = foundCount+1} (x:acc)
+          | score x < scoreWanted && score x > bestScoreSeen
+          -> loop (index+1) st{bestScoreSeen = score x} acc
+          | otherwise
+          -> loop (index+1) st acc
+
+data SortState a = SortState
+  { bestScoreSeen :: !Int
+  , scoreWanted   :: !Int
+  , foundCount    :: !Int
+  }
+  deriving Show

ghcide/test/exe/Main.hs

@@ -4508,7 +4508,9 @@ otherCompletionTests = [
 
 packageCompletionTests :: [TestTree]
 packageCompletionTests =
-  [ testSessionWait "fromList" $ do
+  [ testSession' "fromList" $ \dir -> do
+        liftIO $ writeFile (dir </> "hie.yaml")
+            "cradle: {direct: {arguments: [-hide-all-packages, -package, base, A]}}"
         doc <- createDoc "A.hs" "haskell" $ T.unlines
             [ "{-# OPTIONS_GHC -Wunused-binds #-}",
                 "module A () where",
@@ -4524,9 +4526,8 @@ packageCompletionTests =
               ]
         liftIO $ take 3 (sort compls') @?=
           map ("Defined in "<>)
-              [ "'Data.IntMap"
-              , "'Data.IntMap.Lazy"
-              , "'Data.IntMap.Strict"
+              [ "'Data.List.NonEmpty"
+              , "'GHC.Exts"
               ]
 
   , testSessionWait "Map" $ do