diff --git a/hls-pragmas-plugin.cabal b/hls-pragmas-plugin.cabal --- a/hls-pragmas-plugin.cabal +++ b/hls-pragmas-plugin.cabal @@ -1,6 +1,6 @@ cabal-version: 2.4 name: hls-pragmas-plugin -version: 2.0.0.1 +version: 2.1.0.0 synopsis: Pragmas plugin for Haskell Language Server description: Please see the README on GitHub at @@ -30,8 +30,8 @@ , extra , fuzzy , ghc - , ghcide == 2.0.0.1 - , hls-plugin-api == 2.0.0.1 + , ghcide == 2.1.0.0 + , hls-plugin-api == 2.1.0.0 , lens , lsp , text @@ -49,10 +49,11 @@ main-is: Main.hs ghc-options: -threaded -rtsopts -with-rtsopts=-N build-depends: + , aeson , base , filepath , hls-pragmas-plugin - , hls-test-utils == 2.0.0.1 + , hls-test-utils == 2.1.0.0 , lens , lsp-types , text diff --git a/src/Ide/Plugin/Pragmas.hs b/src/Ide/Plugin/Pragmas.hs --- a/src/Ide/Plugin/Pragmas.hs +++ b/src/Ide/Plugin/Pragmas.hs @@ -9,37 +9,58 @@ -- | Provides code actions to add missing pragmas (whenever GHC suggests to) module Ide.Plugin.Pragmas - ( descriptor + ( suggestPragmaDescriptor + , completionDescriptor + , suggestDisableWarningDescriptor -- For testing , validPragmas + , AppearWhere(..) ) where import Control.Lens hiding (List) import Control.Monad.IO.Class (MonadIO (liftIO)) -import qualified Data.HashMap.Strict as H +import Control.Monad.Trans.Class (lift) import Data.List.Extra (nubOrdOn) +import qualified Data.Map as M import Data.Maybe (catMaybes) import qualified Data.Text as T import Development.IDE +import Development.IDE.Core.Compile (sourceParser, + sourceTypecheck) +import Development.IDE.Core.PluginUtils import Development.IDE.GHC.Compat import Development.IDE.Plugin.Completions (ghcideCompletionsPluginPriority) import qualified Development.IDE.Spans.Pragmas as Pragmas +import Ide.Plugin.Error import Ide.Types +import qualified Language.LSP.Protocol.Lens as L +import qualified Language.LSP.Protocol.Message as LSP +import qualified Language.LSP.Protocol.Types as LSP import qualified Language.LSP.Server as LSP -import qualified Language.LSP.Types as J -import qualified Language.LSP.Types.Lens as J import qualified Language.LSP.VFS as VFS import qualified Text.Fuzzy as Fuzzy -- --------------------------------------------------------------------- -descriptor :: PluginId -> PluginDescriptor IdeState -descriptor plId = (defaultPluginDescriptor plId) - { pluginHandlers = mkPluginHandler J.STextDocumentCodeAction codeActionProvider - <> mkPluginHandler J.STextDocumentCompletion completion +suggestPragmaDescriptor :: PluginId -> PluginDescriptor IdeState +suggestPragmaDescriptor plId = (defaultPluginDescriptor plId) + { pluginHandlers = mkPluginHandler LSP.SMethod_TextDocumentCodeAction suggestPragmaProvider + , pluginPriority = defaultPluginPriority + 1000 + } + +completionDescriptor :: PluginId -> PluginDescriptor IdeState +completionDescriptor plId = (defaultPluginDescriptor plId) + { pluginHandlers = mkPluginHandler LSP.SMethod_TextDocumentCompletion completion , pluginPriority = ghcideCompletionsPluginPriority + 1 } +suggestDisableWarningDescriptor :: PluginId -> PluginDescriptor IdeState +suggestDisableWarningDescriptor plId = (defaultPluginDescriptor plId) + { pluginHandlers = mkPluginHandler LSP.SMethod_TextDocumentCodeAction suggestDisableWarningProvider + -- #3636 Suggestions to disable warnings should appear last. + , pluginPriority = 0 + } + -- --------------------------------------------------------------------- -- | Title and pragma type PragmaEdit = (T.Text, Pragma) @@ -47,32 +68,34 @@ data Pragma = LangExt T.Text | OptGHC T.Text deriving (Show, Eq, Ord) -codeActionProvider :: PluginMethodHandler IdeState 'J.TextDocumentCodeAction -codeActionProvider state _plId (J.CodeActionParams _ _ docId _ (J.CodeActionContext (J.List diags) _monly)) - | let J.TextDocumentIdentifier{ _uri = uri } = docId - , Just normalizedFilePath <- J.uriToNormalizedFilePath $ toNormalizedUri uri = do - -- ghc session to get some dynflags even if module isn't parsed - ghcSession <- liftIO $ runAction "Pragmas.GhcSession" state $ useWithStale GhcSession normalizedFilePath - (_, fileContents) <- liftIO $ runAction "Pragmas.GetFileContents" state $ getFileContents normalizedFilePath - parsedModule <- liftIO $ runAction "Pragmas.GetParsedModule" state $ getParsedModule normalizedFilePath - let parsedModuleDynFlags = ms_hspp_opts . pm_mod_summary <$> parsedModule +suggestPragmaProvider :: PluginMethodHandler IdeState 'LSP.Method_TextDocumentCodeAction +suggestPragmaProvider = mkCodeActionProvider suggest - case ghcSession of - Just (hscEnv -> hsc_dflags -> sessionDynFlags, _) -> - let nextPragmaInfo = Pragmas.getNextPragmaInfo sessionDynFlags fileContents - pedits = nubOrdOn snd . concat $ suggest parsedModuleDynFlags <$> diags - in - pure $ Right $ List $ pragmaEditToAction uri nextPragmaInfo <$> pedits - Nothing -> pure $ Right $ List [] - | otherwise = pure $ Right $ List [] +suggestDisableWarningProvider :: PluginMethodHandler IdeState 'LSP.Method_TextDocumentCodeAction +suggestDisableWarningProvider = mkCodeActionProvider $ const suggestDisableWarning +mkCodeActionProvider :: (Maybe DynFlags -> Diagnostic -> [PragmaEdit]) -> PluginMethodHandler IdeState 'LSP.Method_TextDocumentCodeAction +mkCodeActionProvider mkSuggest state _plId + (LSP.CodeActionParams _ _ LSP.TextDocumentIdentifier{ _uri = uri } _ (LSP.CodeActionContext diags _monly _)) = do + normalizedFilePath <- getNormalizedFilePathE uri + -- ghc session to get some dynflags even if module isn't parsed + (hscEnv -> hsc_dflags -> sessionDynFlags, _) <- + runActionE "Pragmas.GhcSession" state $ useWithStaleE GhcSession normalizedFilePath + (_, fileContents) <- liftIO $ runAction "Pragmas.GetFileContents" state $ getFileContents normalizedFilePath + parsedModule <- liftIO $ runAction "Pragmas.GetParsedModule" state $ getParsedModule normalizedFilePath + let parsedModuleDynFlags = ms_hspp_opts . pm_mod_summary <$> parsedModule + nextPragmaInfo = Pragmas.getNextPragmaInfo sessionDynFlags fileContents + pedits = (nubOrdOn snd . concat $ mkSuggest parsedModuleDynFlags <$> diags) + pure $ LSP.InL $ pragmaEditToAction uri nextPragmaInfo <$> pedits + + -- | Add a Pragma to the given URI at the top of the file. -- It is assumed that the pragma name is a valid pragma, -- thus, not validated. -pragmaEditToAction :: Uri -> Pragmas.NextPragmaInfo -> PragmaEdit -> (J.Command J.|? J.CodeAction) +pragmaEditToAction :: Uri -> Pragmas.NextPragmaInfo -> PragmaEdit -> (LSP.Command LSP.|? LSP.CodeAction) pragmaEditToAction uri Pragmas.NextPragmaInfo{ nextPragmaLine, lineSplitTextEdits } (title, p) = - J.InR $ J.CodeAction title (Just J.CodeActionQuickFix) (Just (J.List [])) Nothing Nothing (Just edit) Nothing Nothing + LSP.InR $ LSP.CodeAction title (Just LSP.CodeActionKind_QuickFix) (Just []) Nothing Nothing (Just edit) Nothing Nothing where render (OptGHC x) = "{-# OPTIONS_GHC -Wno-" <> x <> " #-}\n" render (LangExt x) = "{-# LANGUAGE " <> x <> " #-}\n" @@ -82,26 +105,25 @@ -- edits in reverse order than lsp (tried in both coc.nvim and vscode) textEdits = if | Just (Pragmas.LineSplitTextEdits insertTextEdit deleteTextEdit) <- lineSplitTextEdits - , let J.TextEdit{ _range, _newText } = insertTextEdit -> - [J.TextEdit _range (render p <> _newText), deleteTextEdit] - | otherwise -> [J.TextEdit pragmaInsertRange (render p)] + , let LSP.TextEdit{ _range, _newText } = insertTextEdit -> + [LSP.TextEdit _range (render p <> _newText), deleteTextEdit] + | otherwise -> [LSP.TextEdit pragmaInsertRange (render p)] edit = - J.WorkspaceEdit - (Just $ H.singleton uri (J.List textEdits)) + LSP.WorkspaceEdit + (Just $ M.singleton uri textEdits) Nothing Nothing suggest :: Maybe DynFlags -> Diagnostic -> [PragmaEdit] suggest dflags diag = suggestAddPragma dflags diag - ++ suggestDisableWarning diag -- --------------------------------------------------------------------- suggestDisableWarning :: Diagnostic -> [PragmaEdit] suggestDisableWarning Diagnostic {_code} - | Just (J.InR (T.stripPrefix "-W" -> Just w)) <- _code + | Just (LSP.InR (T.stripPrefix "-W" -> Just w)) <- _code , w `notElem` warningBlacklist = pure ("Disable \"" <> w <> "\" warnings", OptGHC w) | otherwise = [] @@ -116,7 +138,8 @@ -- | Offer to add a missing Language Pragma to the top of a file. -- Pragmas are defined by a curated list of known pragmas, see 'possiblePragmas'. suggestAddPragma :: Maybe DynFlags -> Diagnostic -> [PragmaEdit] -suggestAddPragma mDynflags Diagnostic {_message} = genPragma _message +suggestAddPragma mDynflags Diagnostic {_message, _source} + | _source == Just sourceTypecheck || _source == Just sourceParser = genPragma _message where genPragma target = [("Add \"" <> r <> "\"", LangExt r) | r <- findPragma target, r `notElem` disabled] @@ -128,6 +151,7 @@ -- When the module failed to parse, we don't have access to its -- dynFlags. In that case, simply don't disable any pragmas. [] +suggestAddPragma _ _ = [] -- | Find all Pragmas are an infix of the search term. findPragma :: T.Text -> [T.Text] @@ -174,30 +198,48 @@ flags :: [T.Text] flags = map (T.pack . stripLeading '-') $ flagsForCompletion False -completion :: PluginMethodHandler IdeState 'J.TextDocumentCompletion +completion :: PluginMethodHandler IdeState 'LSP.Method_TextDocumentCompletion completion _ide _ complParams = do - let (J.TextDocumentIdentifier uri) = complParams ^. J.textDocument - position = complParams ^. J.position - contents <- LSP.getVirtualFile $ toNormalizedUri uri - fmap (Right . J.InL) $ case (contents, uriToFilePath' uri) of + let (LSP.TextDocumentIdentifier uri) = complParams ^. L.textDocument + position = complParams ^. L.position + contents <- lift $ LSP.getVirtualFile $ toNormalizedUri uri + fmap (LSP.InL) $ case (contents, uriToFilePath' uri) of (Just cnts, Just _path) -> 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. @@ -211,8 +253,8 @@ | "-}" `T.isSuffixOf` line = " #" | "}" `T.isSuffixOf` line = " #-" | otherwise = " #-}" - result Nothing = J.List [] - _ -> return $ J.List [] + result Nothing = [] + _ -> return $ [] ----------------------------------------------------------------------- @@ -249,11 +291,11 @@ , ("INCOHERENT" , "INCOHERENT" , "{-# INCOHERENT #-}" , CanInline) ] -mkPragmaCompl :: T.Text -> T.Text -> T.Text -> J.CompletionItem +mkPragmaCompl :: T.Text -> T.Text -> T.Text -> LSP.CompletionItem mkPragmaCompl insertText label detail = - J.CompletionItem label (Just J.CiKeyword) Nothing (Just detail) - Nothing Nothing Nothing Nothing Nothing (Just insertText) (Just J.Snippet) - Nothing Nothing Nothing Nothing Nothing Nothing + LSP.CompletionItem label Nothing (Just LSP.CompletionItemKind_Keyword) Nothing (Just detail) + Nothing Nothing Nothing Nothing Nothing (Just insertText) (Just LSP.InsertTextFormat_Snippet) + Nothing Nothing Nothing Nothing Nothing Nothing Nothing stripLeading :: Char -> String -> String @@ -263,11 +305,11 @@ | otherwise = s:ss -buildCompletion :: T.Text -> J.CompletionItem +buildCompletion :: T.Text -> LSP.CompletionItem buildCompletion label = - J.CompletionItem label (Just J.CiKeyword) Nothing Nothing + LSP.CompletionItem label Nothing (Just LSP.CompletionItemKind_Keyword) Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing - Nothing Nothing Nothing Nothing Nothing Nothing + Nothing Nothing Nothing Nothing Nothing Nothing Nothing diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -4,20 +4,28 @@ ( main ) where -import Control.Lens ((<&>), (^.)) -import qualified Data.Text as T +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 +import qualified Language.LSP.Protocol.Lens as L import System.FilePath import Test.Hls -import Test.Hls.Util (onlyWorkForGhcVersions) +import Test.Hls.Util (onlyWorkForGhcVersions) main :: IO () main = defaultTestRunner tests -pragmasPlugin :: PluginTestDescriptor () -pragmasPlugin = mkPluginTestDescriptor' descriptor "pragmas" +pragmasSuggestPlugin :: PluginTestDescriptor () +pragmasSuggestPlugin = mkPluginTestDescriptor' suggestPragmaDescriptor "pragmas" +pragmasCompletionPlugin :: PluginTestDescriptor () +pragmasCompletionPlugin = mkPluginTestDescriptor' completionDescriptor "pragmas" + +pragmasDisableWarningPlugin :: PluginTestDescriptor () +pragmasDisableWarningPlugin = mkPluginTestDescriptor' suggestDisableWarningDescriptor "pragmas" + tests :: TestTree tests = testGroup "pragmas" @@ -25,58 +33,65 @@ , codeActionTests' , completionTests , completionSnippetTests + , dontSuggestCompletionTests ] codeActionTests :: TestTree codeActionTests = testGroup "code actions" - [ codeActionTest "Block comment then line comment doesn't split line" "BlockCommentThenLineComment" [("Add \"TupleSections\"", "Contains TupleSections code action")] - , codeActionTest "Block comment then single-line block comment doesn't split line" "BlockCommentThenSingleLineBlockComment" [("Add \"TupleSections\"", "Contains TupleSections code action")] - , codeActionTest "Block comment then multi-line block comment doesn't split line" "BlockCommentThenMultiLineBlockComment" [("Add \"TupleSections\"", "Contains TupleSections code action")] - , codeActionTest "Block comment then line haddock splits line" "BlockCommentThenLineHaddock" [("Add \"TupleSections\"", "Contains TupleSections code action")] - , codeActionTest "Block comment then single-line block haddock splits line" "BlockCommentThenSingleLineBlockHaddock" [("Add \"TupleSections\"", "Contains TupleSections code action")] - , codeActionTest "Block comment then multi-line block haddock splits line" "BlockCommentThenMultiLineBlockHaddock" [("Add \"TupleSections\"", "Contains TupleSections code action")] - , codeActionTest "Pragma then line comment doesn't split line" "PragmaThenLineComment" [("Add \"TupleSections\"", "Contains TupleSections code action")] - , codeActionTest "Pragma then single-line block comment doesn't split line" "PragmaThenSingleLineBlockComment" [("Add \"TupleSections\"", "Contains TupleSections code action")] - , codeActionTest "Pragma then multi-line block comment splits line" "PragmaThenMultiLineBlockComment" [("Add \"TupleSections\"", "Contains TupleSections code action")] - , codeActionTest "Pragma then line haddock splits line" "PragmaThenLineHaddock" [("Add \"TupleSections\"", "Contains TupleSections code action")] - , codeActionTest "Pragma then single-line block haddock splits line" "PragmaThenSingleLineBlockHaddock" [("Add \"TupleSections\"", "Contains TupleSections code action")] - , codeActionTest "Pragma then multi-line block haddock splits line" "PragmaThenMultiLineBlockHaddock" [("Add \"TupleSections\"", "Contains TupleSections code action")] - , codeActionTest "Pragma then single-line block haddock single-line block comment splits line" "PragmaThenSingleLineBlockHaddockSingleLineBlockComment" [("Add \"TupleSections\"", "Contains TupleSections code action")] - , codeActionTest "Block comment then single-line block haddock single-line block comment splits line" "BlockCommentThenSingleLineBlockHaddockSingleLineBlockComment" [("Add \"TupleSections\"", "Contains TupleSections code action")] - , codeActionTest "Pragma then line haddock then newline line comment splits line" "PragmaThenLineHaddockNewlineLineComment" [("Add \"TupleSections\"", "Contains TupleSections code action")] - , codeActionTest "does not add pragma after OPTIONS_GHC pragma located after a declaration" "OptionsGhcAfterDecl" [("Add \"TupleSections\"", "Contains TupleSections code action")] - , codeActionTest "adds LANGUAGE with no other pragmas at start ignoring later INLINE pragma" "AddPragmaIgnoreInline" [("Add \"TupleSections\"", "Contains TupleSections code action")] - , codeActionTest "adds LANGUAGE before Doc comments after interchanging pragmas" "BeforeDocInterchanging" [("Add \"NamedFieldPuns\"", "Contains NamedFieldPuns code action")] - , codeActionTest "Add language after altering OPTIONS_GHC and Language" "AddLanguagePragmaAfterInterchaningOptsGhcAndLangs" [("Add \"TupleSections\"", "Contains TupleSections code action")] - , codeActionTest "Add language after pragmas with non standard space between prefix and name" "AddPragmaWithNonStandardSpacingInPrecedingPragmas" [("Add \"TupleSections\"", "Contains TupleSections code action")] - , codeActionTest "adds LANGUAGE after OptGHC at start ignoring later INLINE pragma" "AddPragmaAfterOptsGhcIgnoreInline" [("Add \"TupleSections\"", "Contains TupleSections code action")] - , codeActionTest "adds LANGUAGE ignore later Ann pragma" "AddPragmaIgnoreLaterAnnPragma" [("Add \"BangPatterns\"", "Contains BangPatterns code action")] - , codeActionTest "adds LANGUAGE after interchanging pragmas ignoring later Ann pragma" "AddLanguageAfterInterchaningIgnoringLaterAnn" [("Add \"BangPatterns\"", "Contains BangPatterns code action")] - , codeActionTest "adds LANGUAGE after OptGHC preceded by another language pragma" "AddLanguageAfterLanguageThenOptsGhc" [("Add \"NamedFieldPuns\"", "Contains NamedFieldPuns code action")] - , codeActionTest "adds LANGUAGE pragma after shebang and last language pragma" "AfterShebangAndPragma" [("Add \"NamedFieldPuns\"", "Contains NamedFieldPuns code action")] - , codeActionTest "adds above module keyword on first line" "ModuleOnFirstLine" [("Add \"TupleSections\"", "Contains TupleSections code action")] - , codeActionTest "adds LANGUAGE pragma after GHC_OPTIONS" "AfterGhcOptions" [("Add \"TupleSections\"", "Contains TupleSections code action")] - , codeActionTest "adds LANGUAGE pragma after shebang and GHC_OPTIONS" "AfterShebangAndOpts" [("Add \"TupleSections\"", "Contains TupleSections code action")] - , codeActionTest "adds LANGUAGE pragma after shebang, GHC_OPTIONS and language pragma" "AfterShebangAndOptionsAndPragma" [("Add \"TupleSections\"", "Contains TupleSections code action")] - , codeActionTest "adds LANGUAGE pragma after all others ignoring later INLINE pragma" "AfterShebangAndOptionsAndPragmasIgnoreInline" [("Add \"TupleSections\"", "Contains TupleSections code action")] - , codeActionTest "adds LANGUAGE pragma after all others ignoring multiple later INLINE pragma" "AfterAllWithMultipleInlines" [("Add \"TupleSections\"", "Contains TupleSections code action")] - , codeActionTest "adds LANGUAGE pragma correctly ignoring later INLINE pragma" "AddLanguagePragma" [("Add \"TupleSections\"", "Contains TupleSections code action")] - , codeActionTest "adds TypeApplications pragma" "TypeApplications" [("Add \"TypeApplications\"", "Contains TypeApplications code action")] - , codeActionTest "after shebang" "AfterShebang" [("Add \"NamedFieldPuns\"", "Contains NamedFieldPuns code action")] - , codeActionTest "append to existing pragmas" "AppendToExisting" [("Add \"NamedFieldPuns\"", "Contains NamedFieldPuns code action")] - , codeActionTest "before doc comments" "BeforeDocComment" [("Add \"NamedFieldPuns\"", "Contains NamedFieldPuns code action")] - , codeActionTest "before doc comments" "MissingSignatures" [("Disable \"missing-signatures\" warnings", "Contains missing-signatures code action")] - , codeActionTest "before doc comments" "UnusedImports" [("Disable \"unused-imports\" warnings", "Contains unused-imports code action")] - , codeActionTest "adds TypeSynonymInstances pragma" "NeedsPragmas" [("Add \"TypeSynonymInstances\"", "Contains TypeSynonymInstances code action"), ("Add \"FlexibleInstances\"", "Contains FlexibleInstances code action")] + [ codeActionTestWithPragmasSuggest "Block comment then line comment doesn't split line" "BlockCommentThenLineComment" [("Add \"TupleSections\"", "Contains TupleSections code action")] + , codeActionTestWithPragmasSuggest "Block comment then single-line block comment doesn't split line" "BlockCommentThenSingleLineBlockComment" [("Add \"TupleSections\"", "Contains TupleSections code action")] + , codeActionTestWithPragmasSuggest "Block comment then multi-line block comment doesn't split line" "BlockCommentThenMultiLineBlockComment" [("Add \"TupleSections\"", "Contains TupleSections code action")] + , codeActionTestWithPragmasSuggest "Block comment then line haddock splits line" "BlockCommentThenLineHaddock" [("Add \"TupleSections\"", "Contains TupleSections code action")] + , codeActionTestWithPragmasSuggest "Block comment then single-line block haddock splits line" "BlockCommentThenSingleLineBlockHaddock" [("Add \"TupleSections\"", "Contains TupleSections code action")] + , codeActionTestWithPragmasSuggest "Block comment then multi-line block haddock splits line" "BlockCommentThenMultiLineBlockHaddock" [("Add \"TupleSections\"", "Contains TupleSections code action")] + , codeActionTestWithPragmasSuggest "Pragma then line comment doesn't split line" "PragmaThenLineComment" [("Add \"TupleSections\"", "Contains TupleSections code action")] + , codeActionTestWithPragmasSuggest "Pragma then single-line block comment doesn't split line" "PragmaThenSingleLineBlockComment" [("Add \"TupleSections\"", "Contains TupleSections code action")] + , codeActionTestWithPragmasSuggest "Pragma then multi-line block comment splits line" "PragmaThenMultiLineBlockComment" [("Add \"TupleSections\"", "Contains TupleSections code action")] + , codeActionTestWithPragmasSuggest "Pragma then line haddock splits line" "PragmaThenLineHaddock" [("Add \"TupleSections\"", "Contains TupleSections code action")] + , codeActionTestWithPragmasSuggest "Pragma then single-line block haddock splits line" "PragmaThenSingleLineBlockHaddock" [("Add \"TupleSections\"", "Contains TupleSections code action")] + , codeActionTestWithPragmasSuggest "Pragma then multi-line block haddock splits line" "PragmaThenMultiLineBlockHaddock" [("Add \"TupleSections\"", "Contains TupleSections code action")] + , codeActionTestWithPragmasSuggest "Pragma then single-line block haddock single-line block comment splits line" "PragmaThenSingleLineBlockHaddockSingleLineBlockComment" [("Add \"TupleSections\"", "Contains TupleSections code action")] + , codeActionTestWithPragmasSuggest "Block comment then single-line block haddock single-line block comment splits line" "BlockCommentThenSingleLineBlockHaddockSingleLineBlockComment" [("Add \"TupleSections\"", "Contains TupleSections code action")] + , codeActionTestWithPragmasSuggest "Pragma then line haddock then newline line comment splits line" "PragmaThenLineHaddockNewlineLineComment" [("Add \"TupleSections\"", "Contains TupleSections code action")] + , codeActionTestWithPragmasSuggest "does not add pragma after OPTIONS_GHC pragma located after a declaration" "OptionsGhcAfterDecl" [("Add \"TupleSections\"", "Contains TupleSections code action")] + , codeActionTestWithPragmasSuggest "adds LANGUAGE with no other pragmas at start ignoring later INLINE pragma" "AddPragmaIgnoreInline" [("Add \"TupleSections\"", "Contains TupleSections code action")] + , codeActionTestWithPragmasSuggest "adds LANGUAGE before Doc comments after interchanging pragmas" "BeforeDocInterchanging" [("Add \"NamedFieldPuns\"", "Contains NamedFieldPuns code action")] + , codeActionTestWithPragmasSuggest "Add language after altering OPTIONS_GHC and Language" "AddLanguagePragmaAfterInterchaningOptsGhcAndLangs" [("Add \"TupleSections\"", "Contains TupleSections code action")] + , codeActionTestWithPragmasSuggest "Add language after pragmas with non standard space between prefix and name" "AddPragmaWithNonStandardSpacingInPrecedingPragmas" [("Add \"TupleSections\"", "Contains TupleSections code action")] + , codeActionTestWithPragmasSuggest "adds LANGUAGE after OptGHC at start ignoring later INLINE pragma" "AddPragmaAfterOptsGhcIgnoreInline" [("Add \"TupleSections\"", "Contains TupleSections code action")] + , codeActionTestWithPragmasSuggest "adds LANGUAGE ignore later Ann pragma" "AddPragmaIgnoreLaterAnnPragma" [("Add \"BangPatterns\"", "Contains BangPatterns code action")] + , codeActionTestWithPragmasSuggest "adds LANGUAGE after interchanging pragmas ignoring later Ann pragma" "AddLanguageAfterInterchaningIgnoringLaterAnn" [("Add \"BangPatterns\"", "Contains BangPatterns code action")] + , codeActionTestWithPragmasSuggest "adds LANGUAGE after OptGHC preceded by another language pragma" "AddLanguageAfterLanguageThenOptsGhc" [("Add \"NamedFieldPuns\"", "Contains NamedFieldPuns code action")] + , codeActionTestWithPragmasSuggest "adds LANGUAGE pragma after shebang and last language pragma" "AfterShebangAndPragma" [("Add \"NamedFieldPuns\"", "Contains NamedFieldPuns code action")] + , codeActionTestWithPragmasSuggest "adds above module keyword on first line" "ModuleOnFirstLine" [("Add \"TupleSections\"", "Contains TupleSections code action")] + , codeActionTestWithPragmasSuggest "adds LANGUAGE pragma after GHC_OPTIONS" "AfterGhcOptions" [("Add \"TupleSections\"", "Contains TupleSections code action")] + , codeActionTestWithPragmasSuggest "adds LANGUAGE pragma after shebang and GHC_OPTIONS" "AfterShebangAndOpts" [("Add \"TupleSections\"", "Contains TupleSections code action")] + , codeActionTestWithPragmasSuggest "adds LANGUAGE pragma after shebang, GHC_OPTIONS and language pragma" "AfterShebangAndOptionsAndPragma" [("Add \"TupleSections\"", "Contains TupleSections code action")] + , codeActionTestWithPragmasSuggest "adds LANGUAGE pragma after all others ignoring later INLINE pragma" "AfterShebangAndOptionsAndPragmasIgnoreInline" [("Add \"TupleSections\"", "Contains TupleSections code action")] + , codeActionTestWithPragmasSuggest "adds LANGUAGE pragma after all others ignoring multiple later INLINE pragma" "AfterAllWithMultipleInlines" [("Add \"TupleSections\"", "Contains TupleSections code action")] + , codeActionTestWithPragmasSuggest "adds LANGUAGE pragma correctly ignoring later INLINE pragma" "AddLanguagePragma" [("Add \"TupleSections\"", "Contains TupleSections code action")] + , codeActionTestWithPragmasSuggest "adds TypeApplications pragma" "TypeApplications" [("Add \"TypeApplications\"", "Contains TypeApplications code action")] + , codeActionTestWithPragmasSuggest "after shebang" "AfterShebang" [("Add \"NamedFieldPuns\"", "Contains NamedFieldPuns code action")] + , codeActionTestWithPragmasSuggest "append to existing pragmas" "AppendToExisting" [("Add \"NamedFieldPuns\"", "Contains NamedFieldPuns code action")] + , codeActionTestWithPragmasSuggest "before doc comments" "BeforeDocComment" [("Add \"NamedFieldPuns\"", "Contains NamedFieldPuns code action")] + , codeActionTestWithPragmasSuggest "adds TypeSynonymInstances pragma" "NeedsPragmas" [("Add \"TypeSynonymInstances\"", "Contains TypeSynonymInstances code action"), ("Add \"FlexibleInstances\"", "Contains FlexibleInstances code action")] + , codeActionTestWithDisableWarning "before doc comments" "MissingSignatures" [("Disable \"missing-signatures\" warnings", "Contains missing-signatures code action")] + , codeActionTestWithDisableWarning "before doc comments" "UnusedImports" [("Disable \"unused-imports\" warnings", "Contains unused-imports code action")] ] ghc94regression :: String ghc94regression = "to be reported" -codeActionTest :: String -> FilePath -> [(T.Text, String)] -> TestTree -codeActionTest testComment fp actions = - goldenWithPragmas testComment fp $ \doc -> do +codeActionTestWithPragmasSuggest :: String -> FilePath -> [(T.Text, String)] -> TestTree +codeActionTestWithPragmasSuggest = codeActionTestWith pragmasSuggestPlugin + +codeActionTestWithDisableWarning :: String -> FilePath -> [(T.Text, String)] -> TestTree +codeActionTestWithDisableWarning = codeActionTestWith pragmasDisableWarningPlugin + +codeActionTestWith :: PluginTestDescriptor () -> String -> FilePath -> [(T.Text, String)] -> TestTree +codeActionTestWith descriptor testComment fp actions = + goldenWithPragmas descriptor testComment fp $ \doc -> do _ <- waitForDiagnosticsFrom doc cas <- map fromAction <$> getAllCodeActions doc mapM_ (\(action, contains) -> go action contains cas) actions @@ -91,7 +106,7 @@ codeActionTests' = testGroup "additional code actions" [ - goldenWithPragmas "no duplication" "NamedFieldPuns" $ \doc -> do + goldenWithPragmas pragmasSuggestPlugin "no duplication" "NamedFieldPuns" $ \doc -> do _ <- waitForDiagnosticsFrom doc cas <- map fromAction <$> getCodeActions doc (Range (Position 8 9) (Position 8 9)) ca <- liftIO $ case cas of @@ -99,7 +114,7 @@ _ -> assertFailure $ "Expected one code action, but got: " <> show cas liftIO $ (ca ^. L.title == "Add \"NamedFieldPuns\"") @? "NamedFieldPuns code action" executeCodeAction ca - , goldenWithPragmas "doesn't suggest disabling type errors" "DeferredTypeErrors" $ \doc -> do + , goldenWithPragmas pragmasSuggestPlugin "doesn't suggest disabling type errors" "DeferredTypeErrors" $ \doc -> do _ <- waitForDiagnosticsFrom doc cas <- map fromAction <$> getAllCodeActions doc liftIO $ "Disable \"deferred-type-errors\" warnings" `notElem` map (^. L.title) cas @? "Doesn't contain deferred-type-errors code action" @@ -109,11 +124,11 @@ completionTests :: TestTree completionTests = testGroup "completions" - [ completionTest "completes pragmas" "Completion.hs" "" "LANGUAGE" (Just Snippet) (Just "LANGUAGE ${1:extension} #-}") (Just "{-# LANGUAGE #-}") [0, 4, 0, 34, 0, 4] - , completionTest "completes pragmas with existing closing pragma bracket" "Completion.hs" "" "LANGUAGE" (Just Snippet) (Just "LANGUAGE ${1:extension}") (Just "{-# LANGUAGE #-}") [0, 4, 0, 31, 0, 4] - , completionTest "completes pragmas with existing closing comment bracket" "Completion.hs" "" "LANGUAGE" (Just Snippet) (Just "LANGUAGE ${1:extension} #") (Just "{-# LANGUAGE #-}") [0, 4, 0, 32, 0, 4] - , completionTest "completes pragmas with existing closing bracket" "Completion.hs" "" "LANGUAGE" (Just Snippet) (Just "LANGUAGE ${1:extension} #-") (Just "{-# LANGUAGE #-}") [0, 4, 0, 33, 0, 4] - , completionTest "completes options pragma" "Completion.hs" "OPTIONS" "OPTIONS_GHC" (Just Snippet) (Just "OPTIONS_GHC -${1:option} #-}") (Just "{-# OPTIONS_GHC #-}") [0, 4, 0, 34, 0, 4] + [ completionTest "completes pragmas" "Completion.hs" "" "LANGUAGE" (Just InsertTextFormat_Snippet) (Just "LANGUAGE ${1:extension} #-}") (Just "{-# LANGUAGE #-}") [0, 4, 0, 34, 0, 4] + , completionTest "completes pragmas with existing closing pragma bracket" "Completion.hs" "" "LANGUAGE" (Just InsertTextFormat_Snippet) (Just "LANGUAGE ${1:extension}") (Just "{-# LANGUAGE #-}") [0, 4, 0, 31, 0, 4] + , completionTest "completes pragmas with existing closing comment bracket" "Completion.hs" "" "LANGUAGE" (Just InsertTextFormat_Snippet) (Just "LANGUAGE ${1:extension} #") (Just "{-# LANGUAGE #-}") [0, 4, 0, 32, 0, 4] + , completionTest "completes pragmas with existing closing bracket" "Completion.hs" "" "LANGUAGE" (Just InsertTextFormat_Snippet) (Just "LANGUAGE ${1:extension} #-") (Just "{-# LANGUAGE #-}") [0, 4, 0, 33, 0, 4] + , completionTest "completes options pragma" "Completion.hs" "OPTIONS" "OPTIONS_GHC" (Just InsertTextFormat_Snippet) (Just "OPTIONS_GHC -${1:option} #-}") (Just "{-# OPTIONS_GHC #-}") [0, 4, 0, 34, 0, 4] , completionTest "completes ghc options pragma values" "Completion.hs" "{-# OPTIONS_GHC -Wno-red #-}\n" "Wno-redundant-constraints" Nothing Nothing Nothing [0, 0, 0, 0, 0, 24] , completionTest "completes language extensions" "Completion.hs" "" "OverloadedStrings" Nothing Nothing Nothing [0, 24, 0, 31, 0, 24] , completionTest "completes language extensions case insensitive" "Completion.hs" "lAnGuaGe Overloaded" "OverloadedStrings" Nothing Nothing Nothing [0, 4, 0, 34, 0, 24] @@ -127,31 +142,82 @@ 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) + "Completion.hs" input label (Just InsertTextFormat_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] = - testCase testComment $ runSessionWithServer pragmasPlugin testDataDir $ do +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.kind @?= Just CiKeyword - item ^. L.insertTextFormat @?= textFormat - item ^. L.insertText @?= insertText + item ^. L.label @?= expectedLabel + item ^. L.kind @?= Just CompletionItemKind_Keyword + item ^. L.insertTextFormat @?= expectedFormat + item ^. L.insertText @?= expectedInsertText item ^. L.detail @?= detail -goldenWithPragmas :: TestName -> FilePath -> (TextDocumentIdentifier -> Session ()) -> TestTree -goldenWithPragmas title path = goldenWithHaskellDoc pragmasPlugin title testDataDir path "expected" "hs" +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" testDataDir :: FilePath testDataDir = "test" "testdata"