hls-pragmas-plugin 2.0.0.1 → 2.1.0.0
raw patch · 3 files changed
+238/−129 lines, 3 filesdep +aesondep ~ghcidedep ~hls-plugin-apidep ~hls-test-utilsPVP ok
version bump matches the API change (PVP)
Dependencies added: aeson
Dependency ranges changed: ghcide, hls-plugin-api, hls-test-utils
API changes (from Hackage documentation)
- Ide.Plugin.Pragmas: descriptor :: PluginId -> PluginDescriptor IdeState
+ Ide.Plugin.Pragmas: CanInline :: AppearWhere
+ Ide.Plugin.Pragmas: NewLine :: AppearWhere
+ Ide.Plugin.Pragmas: completionDescriptor :: PluginId -> PluginDescriptor IdeState
+ Ide.Plugin.Pragmas: data AppearWhere
+ Ide.Plugin.Pragmas: suggestDisableWarningDescriptor :: PluginId -> PluginDescriptor IdeState
+ Ide.Plugin.Pragmas: suggestPragmaDescriptor :: PluginId -> PluginDescriptor IdeState
Files
- hls-pragmas-plugin.cabal +5/−4
- src/Ide/Plugin/Pragmas.hs +97/−55
- test/Main.hs +136/−70
hls-pragmas-plugin.cabal view
@@ -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 <https://github.com/haskell/haskell-language-server#readme>@@ -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
src/Ide/Plugin/Pragmas.hs view
@@ -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
test/Main.hs view
@@ -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"