From 974d591e7223ee1f4fb0a9007f1ad11ad2606a4f Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Sun, 11 Jun 2023 14:01:51 +0200 Subject: [PATCH 1/3] hls-pragmas-plugin: Reduce noisy completions --- .../hls-pragmas-plugin.cabal | 1 + .../src/Ide/Plugin/Pragmas.hs | 30 +++++--- plugins/hls-pragmas-plugin/test/Main.hs | 74 ++++++++++++++++--- 3 files changed, 83 insertions(+), 22 deletions(-) diff --git a/plugins/hls-pragmas-plugin/hls-pragmas-plugin.cabal b/plugins/hls-pragmas-plugin/hls-pragmas-plugin.cabal index b5ed8e0b70..947b1f808c 100644 --- 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 index c26d9cbc79..930c4e0b03 100644 --- a/plugins/hls-pragmas-plugin/src/Ide/Plugin/Pragmas.hs +++ b/plugins/hls-pragmas-plugin/src/Ide/Plugin/Pragmas.hs @@ -12,6 +12,7 @@ module Ide.Plugin.Pragmas ( descriptor -- For testing , validPragmas + , AppearWhere(..) ) where import Control.Lens hiding (List) @@ -181,23 +182,32 @@ 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 + ] + | "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 + , Fuzzy.test word matcher + , (appearWhere == NewLine && line == word) + || (appearWhere == CanInline && line /= word) + || (T.elem ' ' matcher && appearWhere == NewLine && Fuzzy.test line 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. @@ -211,9 +221,8 @@ completion _ide _ complParams = do | "-}" `T.isSuffixOf` line = " #" | "}" `T.isSuffixOf` line = " #-" | otherwise = " #-}" - result Nothing = J.List [] + result Nothing = [] _ -> return $ J.List [] - ----------------------------------------------------------------------- -- | Pragma where exist @@ -268,6 +277,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 index 4285062f05..5636e55778 100644 --- 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 @@ -25,6 +27,7 @@ tests = , codeActionTests' , completionTests , completionSnippetTests + , dontSuggestCompletionTests ] codeActionTests :: TestTree @@ -127,29 +130,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 pragmasPlugin 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 pragmasPlugin 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 :: TestName -> FilePath -> (TextDocumentIdentifier -> Session ()) -> TestTree goldenWithPragmas title path = goldenWithHaskellDoc pragmasPlugin title testDataDir path "expected" "hs" From 90f38f0138b48c967c774317834044588db70f76 Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Mon, 12 Jun 2023 10:48:16 +0200 Subject: [PATCH 2/3] hls-pragmas-plugin: Simply completion and add comments --- .../src/Ide/Plugin/Pragmas.hs | 19 ++++++++++++++----- 1 file changed, 14 insertions(+), 5 deletions(-) diff --git a/plugins/hls-pragmas-plugin/src/Ide/Plugin/Pragmas.hs b/plugins/hls-pragmas-plugin/src/Ide/Plugin/Pragmas.hs index 930c4e0b03..665e566d7f 100644 --- a/plugins/hls-pragmas-plugin/src/Ide/Plugin/Pragmas.hs +++ b/plugins/hls-pragmas-plugin/src/Ide/Plugin/Pragmas.hs @@ -195,15 +195,24 @@ completion _ide _ complParams = do = [ mkPragmaCompl (a <> suffix) b c | (a, b, c, w) <- validPragmas, w == NewLine ] - | "import" `T.isPrefixOf` line || not (T.null module_) || T.null word + | -- 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 = [ mkPragmaCompl (prefix <> pragmaTemplate <> suffix) matcher detail | (pragmaTemplate, matcher, detail, appearWhere) <- validPragmas - , Fuzzy.test word matcher - , (appearWhere == NewLine && line == word) - || (appearWhere == CanInline && line /= word) - || (T.elem ' ' matcher && appearWhere == NewLine && Fuzzy.test line matcher) + , -- Only suggest a pragma that need 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 From bb0433cc2e625e3ecf0e3864f203ced576a9d13b Mon Sep 17 00:00:00 2001 From: fendor Date: Mon, 12 Jun 2023 13:43:03 +0200 Subject: [PATCH 3/3] Fix typo in hls-pragma-plugin comment --- plugins/hls-pragmas-plugin/src/Ide/Plugin/Pragmas.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/plugins/hls-pragmas-plugin/src/Ide/Plugin/Pragmas.hs b/plugins/hls-pragmas-plugin/src/Ide/Plugin/Pragmas.hs index 665e566d7f..e95723ea78 100644 --- a/plugins/hls-pragmas-plugin/src/Ide/Plugin/Pragmas.hs +++ b/plugins/hls-pragmas-plugin/src/Ide/Plugin/Pragmas.hs @@ -206,7 +206,7 @@ completion _ide _ complParams = do | otherwise = [ mkPragmaCompl (prefix <> pragmaTemplate <> suffix) matcher detail | (pragmaTemplate, matcher, detail, appearWhere) <- validPragmas - , -- Only suggest a pragma that need its own line if the whole line + , -- 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