hls-pragmas-plugin: Reduce noisy completions (#3647)

* hls-pragmas-plugin: Reduce noisy completions * hls-pragmas-plugin: Simply completion and add comments * Fix typo in hls-pragma-plugin comment --------- Co-authored-by: fendor <[email protected]> Co-authored-by: mergify[bot] <37929162+mergify[bot]@users.noreply.github.com>
haskell · Jun 14, 2023 · 7882822 · 7882822
1 parent 139dcf5
commit 7882822
Show file tree

Hide file tree

Showing 3 changed files with 92 additions and 22 deletions.
diff --git a/plugins/hls-pragmas-plugin/hls-pragmas-plugin.cabal b/plugins/hls-pragmas-plugin/hls-pragmas-plugin.cabal
@@ -49,6 +49,7 @@ test-suite tests
   main-is:          Main.hs
   ghc-options:      -threaded -rtsopts -with-rtsopts=-N
   build-depends:
+    , aeson
     , base
     , filepath
     , hls-pragmas-plugin

diff --git a/plugins/hls-pragmas-plugin/src/Ide/Plugin/Pragmas.hs b/plugins/hls-pragmas-plugin/src/Ide/Plugin/Pragmas.hs
@@ -14,6 +14,7 @@ module Ide.Plugin.Pragmas
   , suggestDisableWarningDescriptor
   -- For testing
   , validPragmas
+  , AppearWhere(..)
   ) where
 
 import           Control.Lens                       hiding (List)
@@ -200,23 +201,41 @@ completion _ide _ complParams = do
     contents <- LSP.getVirtualFile $ toNormalizedUri uri
     fmap (Right . J.InL) $ case (contents, uriToFilePath' uri) of
         (Just cnts, Just _path) ->
-            result <$> VFS.getCompletionPrefix position cnts
+            J.List . result <$> VFS.getCompletionPrefix position cnts
             where
                 result (Just pfix)
                     | "{-# language" `T.isPrefixOf` line
-                    = J.List $ map buildCompletion
+                    = map buildCompletion
                         (Fuzzy.simpleFilter (VFS.prefixText pfix) allPragmas)
                     | "{-# options_ghc" `T.isPrefixOf` line
-                    = J.List $ map buildCompletion
+                    = map buildCompletion
                         (Fuzzy.simpleFilter (VFS.prefixText pfix) flags)
                     | "{-#" `T.isPrefixOf` line
-                    = J.List $ [ mkPragmaCompl (a <> suffix) b c
-                                | (a, b, c, w) <- validPragmas, w == NewLine ]
+                    = [ mkPragmaCompl (a <> suffix) b c
+                      | (a, b, c, w) <- validPragmas, w == NewLine
+                      ]
+                    | -- Do not suggest any pragmas any of these conditions:
+                      -- 1. Current line is a an import
+                      -- 2. There is a module name right before the current word.
+                      --    Something like `Text.la` shouldn't suggest adding the
+                      --    'LANGUAGE' pragma.
+                      -- 3. The user has not typed anything yet.
+                      "import" `T.isPrefixOf` line || not (T.null module_) || T.null word
+                    = []
                     | otherwise
-                    = J.List $ [ mkPragmaCompl (prefix <> a <> suffix) b c
-                                | (a, b, c, _) <- validPragmas, Fuzzy.test word b]
+                    = [ mkPragmaCompl (prefix <> pragmaTemplate <> suffix) matcher detail
+                      | (pragmaTemplate, matcher, detail, appearWhere) <- validPragmas
+                      , -- Only suggest a pragma that needs its own line if the whole line
+                        -- fuzzily matches the pragma
+                        (appearWhere == NewLine && Fuzzy.test line matcher ) ||
+                        -- Only suggest a pragma that appears in the middle of a line when
+                        -- the current word is not the only thing in the line and the
+                        -- current word fuzzily matches the pragma
+                        (appearWhere == CanInline && line /= word && Fuzzy.test word matcher)
+                      ]
                     where
                         line = T.toLower $ VFS.fullLine pfix
+                        module_ = VFS.prefixModule pfix
                         word = VFS.prefixText pfix
                         -- Not completely correct, may fail if more than one "{-#" exist
                         -- , we can ignore it since it rarely happen.
@@ -230,9 +249,8 @@ completion _ide _ complParams = do
                             | "-}"   `T.isSuffixOf` line = " #"
                             | "}"    `T.isSuffixOf` line = " #-"
                             | otherwise                 = " #-}"
-                result Nothing = J.List []
+                result Nothing = []
         _ -> return $ J.List []
-
 -----------------------------------------------------------------------
 
 -- | Pragma where exist
@@ -287,6 +305,3 @@ buildCompletion label =
   J.CompletionItem label (Just J.CiKeyword) Nothing Nothing
     Nothing Nothing Nothing Nothing Nothing Nothing Nothing
     Nothing Nothing Nothing Nothing Nothing Nothing
-
-
-
diff --git a/plugins/hls-pragmas-plugin/test/Main.hs b/plugins/hls-pragmas-plugin/test/Main.hs
@@ -5,6 +5,8 @@ module Main
   ) where
 
 import           Control.Lens            ((<&>), (^.))
+import           Data.Aeson
+import           Data.Foldable
 import qualified Data.Text               as T
 import           Ide.Plugin.Pragmas
 import qualified Language.LSP.Types.Lens as L
@@ -31,6 +33,7 @@ tests =
   , codeActionTests'
   , completionTests
   , completionSnippetTests
+  , dontSuggestCompletionTests
   ]
 
 codeActionTests :: TestTree
@@ -139,29 +142,80 @@ completionSnippetTests :: TestTree
 completionSnippetTests =
   testGroup "expand snippet to pragma" $
     validPragmas <&>
-      (\(insertText, label, detail, _) ->
-        let input = T.toLower $ T.init label
+      (\(insertText, label, detail, appearWhere) ->
+        let inputPrefix =
+              case appearWhere of
+                NewLine   -> ""
+                CanInline -> "something "
+            input = inputPrefix <> (T.toLower $ T.init label)
         in completionTest (T.unpack label)
             "Completion.hs" input label (Just Snippet)
             (Just $ "{-# " <> insertText <> " #-}") (Just detail)
             [0, 0, 0, 34, 0, fromIntegral $ T.length input])
 
-completionTest :: String -> String -> T.Text -> T.Text -> Maybe InsertTextFormat -> Maybe T.Text -> Maybe T.Text -> [UInt] -> TestTree
-completionTest testComment fileName te' label textFormat insertText detail [a, b, c, d, x, y] =
+dontSuggestCompletionTests :: TestTree
+dontSuggestCompletionTests =
+  testGroup "do not suggest pragmas" $
+  let replaceFuncBody newBody = Just $ mkEdit (8,6) (8,8) newBody
+      writeInEmptyLine txt = Just $ mkEdit (3,0) (3,0) txt
+      generalTests = [ provideNoCompletionsTest "in imports" "Completion.hs" (Just $ mkEdit (3,0) (3,0) "import WA") (Position 3 8)
+                     , provideNoCompletionsTest "when no word has been typed" "Completion.hs" Nothing (Position 3 0)
+                     , provideNoCompletionsTest "when expecting auto complete on modules" "Completion.hs" (Just $ mkEdit (8,6) (8,8) "Data.Maybe.WA") (Position 8 19)
+                     ]
+      individualPragmaTests = validPragmas <&> \(insertText,label,detail,appearWhere) ->
+          let completionPrompt = T.toLower $ T.init label
+              promptLen = fromIntegral (T.length completionPrompt)
+          in case appearWhere of
+              CanInline ->
+                  provideNoUndesiredCompletionsTest ("at new line: " <> T.unpack label) "Completion.hs" (Just label) (writeInEmptyLine completionPrompt) (Position 3 0)
+              NewLine ->
+                  provideNoUndesiredCompletionsTest ("inline: " <> T.unpack label) "Completion.hs" (Just label) (replaceFuncBody completionPrompt) (Position 8 (6 + promptLen))
+    in generalTests ++ individualPragmaTests
+
+mkEdit :: (UInt,UInt) -> (UInt,UInt) -> T.Text -> TextEdit
+mkEdit (startLine, startCol) (endLine, endCol) newText =
+    TextEdit (Range (Position startLine startCol) (Position endLine endCol)) newText
+
+completionTest :: String -> FilePath -> T.Text -> T.Text -> Maybe InsertTextFormat -> Maybe T.Text -> Maybe T.Text -> [UInt] -> TestTree
+completionTest testComment fileName replacementText expectedLabel expectedFormat expectedInsertText detail [delFromLine, delFromCol, delToLine, delToCol, completeAtLine, completeAtCol] =
   testCase testComment $ runSessionWithServer pragmasCompletionPlugin testDataDir $ do
     doc <- openDoc fileName "haskell"
     _ <- waitForDiagnostics
-    let te = TextEdit (Range (Position a b) (Position c d)) te'
+    let te = TextEdit (Range (Position delFromLine delFromCol) (Position delToLine delToCol)) replacementText
     _ <- applyEdit doc te
-    compls <- getCompletions doc (Position x y)
-    item <- getCompletionByLabel label compls
+    compls <- getCompletions doc (Position completeAtLine completeAtCol)
+    item <- getCompletionByLabel expectedLabel compls
     liftIO $ do
-      item ^. L.label @?= label
+      item ^. L.label @?= expectedLabel
       item ^. L.kind @?= Just CiKeyword
-      item ^. L.insertTextFormat @?= textFormat
-      item ^. L.insertText @?= insertText
+      item ^. L.insertTextFormat @?= expectedFormat
+      item ^. L.insertText @?= expectedInsertText
       item ^. L.detail @?= detail
 
+provideNoCompletionsTest :: String -> FilePath -> Maybe TextEdit -> Position -> TestTree
+provideNoCompletionsTest testComment fileName mTextEdit pos =
+  provideNoUndesiredCompletionsTest testComment fileName Nothing mTextEdit pos
+
+provideNoUndesiredCompletionsTest :: String -> FilePath -> Maybe T.Text -> Maybe TextEdit -> Position -> TestTree
+provideNoUndesiredCompletionsTest testComment fileName mUndesiredLabel mTextEdit pos =
+  testCase testComment $ runSessionWithServer pragmasCompletionPlugin testDataDir $ do
+    doc <- openDoc fileName "haskell"
+    _ <- waitForDiagnostics
+    _ <- sendConfigurationChanged disableGhcideCompletions
+    mapM_ (applyEdit doc) mTextEdit
+    compls <- getCompletions doc pos
+    liftIO $ case mUndesiredLabel of
+        Nothing -> compls @?= []
+        Just undesiredLabel -> do
+            case find (\c -> c ^. L.label == undesiredLabel) compls of
+                Just c -> assertFailure $
+                    "Did not expect a completion with label=" <> T.unpack undesiredLabel
+                    <> ", got completion: "<> show c
+                Nothing -> pure ()
+
+disableGhcideCompletions :: Value
+disableGhcideCompletions = object [ "haskell" .= object ["plugin" .= object [ "ghcide-completions" .= object ["globalOn" .= False]]] ]
+
 goldenWithPragmas :: PluginTestDescriptor () -> TestName -> FilePath -> (TextDocumentIdentifier -> Session ()) -> TestTree
 goldenWithPragmas descriptor title path = goldenWithHaskellDoc descriptor title testDataDir path "expected" "hs"