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 8fcd282f94..3769271107 100644 --- 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 index 8cb957ace1..517e86cfda 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 @@ -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"