diff --git a/ghcide/src/Development/IDE/Plugin/CodeAction.hs b/ghcide/src/Development/IDE/Plugin/CodeAction.hs index 3ee947af84..8d93479b66 100644 --- a/ghcide/src/Development/IDE/Plugin/CodeAction.hs +++ b/ghcide/src/Development/IDE/Plugin/CodeAction.hs @@ -158,7 +158,6 @@ suggestAction packageExports ideOptions parsedModule text df annSource tcM har d ++ suggestNewImport packageExports pm diag ++ suggestDeleteUnusedBinding pm text diag ++ suggestExportUnusedTopBinding text pm diag - ++ suggestDisableWarning pm text diag | Just pm <- [parsedModule] ] ++ suggestFillHole diag -- Lowest priority @@ -257,15 +256,6 @@ isUnusedImportedId maybe True (not . any (\(_, IdentifierDetails {..}) -> identInfo == S.singleton Use)) refs | otherwise = False -suggestDisableWarning :: ParsedModule -> Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])] -suggestDisableWarning pm contents Diagnostic{..} - | Just (InR (T.stripPrefix "-W" -> Just w)) <- _code = - pure - ( "Disable \"" <> w <> "\" warnings" - , [TextEdit (endOfModuleHeader pm contents) $ "{-# OPTIONS_GHC -Wno-" <> w <> " #-}\n"] - ) - | otherwise = [] - suggestRemoveRedundantImport :: ParsedModule -> Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])] suggestRemoveRedundantImport ParsedModule{pm_parsed_source = L _ HsModule{hsmodImports}} contents Diagnostic{_range=_range,..} -- The qualified import of ‘many’ from module ‘Control.Applicative’ is redundant @@ -1452,16 +1442,3 @@ renderImportStyle :: ImportStyle -> T.Text renderImportStyle (ImportTopLevel x) = x renderImportStyle (ImportViaParent x p) = p <> "(" <> x <> ")" --- | Find the first non-blank line before the first of (module name / imports / declarations). --- Useful for inserting pragmas. -endOfModuleHeader :: ParsedModule -> Maybe T.Text -> Range -endOfModuleHeader pm contents = - let mod = unLoc $ pm_parsed_source pm - modNameLoc = getLoc <$> hsmodName mod - firstImportLoc = getLoc <$> listToMaybe (hsmodImports mod) - firstDeclLoc = getLoc <$> listToMaybe (hsmodDecls mod) - line = fromMaybe 0 $ firstNonBlankBefore . _line . _start =<< srcSpanToRange =<< - modNameLoc <|> firstImportLoc <|> firstDeclLoc - firstNonBlankBefore n = (n -) . fromMaybe 0 . findIndex (not . T.null) . reverse . take n . T.lines <$> contents - loc = Position line 0 - in Range loc loc diff --git a/ghcide/test/exe/Main.hs b/ghcide/test/exe/Main.hs index 4c15476bf8..0cfb5c7e56 100644 --- a/ghcide/test/exe/Main.hs +++ b/ghcide/test/exe/Main.hs @@ -81,7 +81,6 @@ import Development.IDE.Plugin.Test (TestRequest (BlockSeconds, GetInterfaceFiles import Control.Monad.Extra (whenJust) import qualified Language.LSP.Types.Lens as L import Control.Lens ((^.)) -import Data.Functor import Data.Tuple.Extra waitForProgressBegin :: Session () @@ -706,7 +705,6 @@ codeActionTests = testGroup "code actions" , suggestImportTests , suggestHideShadowTests , suggestImportDisambiguationTests - , disableWarningTests , fixConstructorImportTests , importRenameActionTests , fillTypedHoleTests @@ -913,8 +911,9 @@ removeImportTests = testGroup "remove import actions" ] docB <- createDoc "ModuleB.hs" "haskell" contentB _ <- waitForDiagnostics - action <- assertJust "Code action not found" . firstJust (caWithTitle "Remove import") - =<< getCodeActions docB (Range (Position 2 0) (Position 2 5)) + [InR action@CodeAction { _title = actionTitle }, _] + <- getCodeActions docB (Range (Position 2 0) (Position 2 5)) + liftIO $ "Remove import" @=? actionTitle executeCodeAction action contentAfterAction <- documentContents docB let expectedContentAfterAction = T.unlines @@ -938,8 +937,9 @@ removeImportTests = testGroup "remove import actions" ] docB <- createDoc "ModuleB.hs" "haskell" contentB _ <- waitForDiagnostics - action <- assertJust "Code action not found" . firstJust (caWithTitle "Remove import") - =<< getCodeActions docB (Range (Position 2 0) (Position 2 5)) + [InR action@CodeAction { _title = actionTitle }, _] + <- getCodeActions docB (Range (Position 2 0) (Position 2 5)) + liftIO $ "Remove import" @=? actionTitle executeCodeAction action contentAfterAction <- documentContents docB let expectedContentAfterAction = T.unlines @@ -966,8 +966,9 @@ removeImportTests = testGroup "remove import actions" ] docB <- createDoc "ModuleB.hs" "haskell" contentB _ <- waitForDiagnostics - action <- assertJust "Code action not found" . firstJust (caWithTitle "Remove stuffA, stuffC from import") - =<< getCodeActions docB (Range (Position 2 0) (Position 2 5)) + [InR action@CodeAction { _title = actionTitle }, _] + <- getCodeActions docB (Range (Position 2 0) (Position 2 5)) + liftIO $ "Remove stuffA, stuffC from import" @=? actionTitle executeCodeAction action contentAfterAction <- documentContents docB let expectedContentAfterAction = T.unlines @@ -994,8 +995,9 @@ removeImportTests = testGroup "remove import actions" ] docB <- createDoc "ModuleB.hs" "haskell" contentB _ <- waitForDiagnostics - action <- assertJust "Code action not found" . firstJust (caWithTitle "Remove !!, from import") - =<< getCodeActions docB (Range (Position 2 0) (Position 2 5)) + [InR action@CodeAction { _title = actionTitle }, _] + <- getCodeActions docB (Range (Position 2 0) (Position 2 5)) + liftIO $ "Remove !!, from import" @=? actionTitle executeCodeAction action contentAfterAction <- documentContents docB let expectedContentAfterAction = T.unlines @@ -1021,8 +1023,9 @@ removeImportTests = testGroup "remove import actions" ] docB <- createDoc "ModuleB.hs" "haskell" contentB _ <- waitForDiagnostics - action <- assertJust "Code action not found" . firstJust (caWithTitle "Remove A from import") - =<< getCodeActions docB (Range (Position 2 0) (Position 2 5)) + [InR action@CodeAction { _title = actionTitle }, _] + <- getCodeActions docB (Range (Position 2 0) (Position 2 5)) + liftIO $ "Remove A from import" @=? actionTitle executeCodeAction action contentAfterAction <- documentContents docB let expectedContentAfterAction = T.unlines @@ -1047,8 +1050,9 @@ removeImportTests = testGroup "remove import actions" ] docB <- createDoc "ModuleB.hs" "haskell" contentB _ <- waitForDiagnostics - action <- assertJust "Code action not found" . firstJust (caWithTitle "Remove A, E, F from import") - =<< getCodeActions docB (Range (Position 2 0) (Position 2 5)) + [InR action@CodeAction { _title = actionTitle }, _] + <- getCodeActions docB (Range (Position 2 0) (Position 2 5)) + liftIO $ "Remove A, E, F from import" @=? actionTitle executeCodeAction action contentAfterAction <- documentContents docB let expectedContentAfterAction = T.unlines @@ -1070,8 +1074,9 @@ removeImportTests = testGroup "remove import actions" ] docB <- createDoc "ModuleB.hs" "haskell" contentB _ <- waitForDiagnostics - action <- assertJust "Code action not found" . firstJust (caWithTitle "Remove import") - =<< getCodeActions docB (Range (Position 2 0) (Position 2 5)) + [InR action@CodeAction { _title = actionTitle }, _] + <- getCodeActions docB (Range (Position 2 0) (Position 2 5)) + liftIO $ "Remove import" @=? actionTitle executeCodeAction action contentAfterAction <- documentContents docB let expectedContentAfterAction = T.unlines @@ -1094,8 +1099,9 @@ removeImportTests = testGroup "remove import actions" ] doc <- createDoc "ModuleC.hs" "haskell" content _ <- waitForDiagnostics - action <- assertJust "Code action not found" . firstJust (caWithTitle "Remove all redundant imports") - =<< getCodeActions doc (Range (Position 2 0) (Position 2 5)) + [_, _, _, _, InR action@CodeAction { _title = actionTitle }] + <- getCodeActions doc (Range (Position 2 0) (Position 2 5)) + liftIO $ "Remove all redundant imports" @=? actionTitle executeCodeAction action contentAfterAction <- documentContents doc let expectedContentAfterAction = T.unlines @@ -1111,10 +1117,6 @@ removeImportTests = testGroup "remove import actions" ] liftIO $ expectedContentAfterAction @=? contentAfterAction ] - where - caWithTitle t = \case - InR a@CodeAction{_title} -> guard (_title == t) >> Just a - _ -> Nothing extendImportTests :: TestTree extendImportTests = testGroup "extend import actions" @@ -1784,57 +1786,6 @@ suggestHideShadowTests = , "(++) = id" ] -disableWarningTests :: TestTree -disableWarningTests = - testGroup "disable warnings" $ - [ - ( "missing-signatures" - , T.unlines - [ "{-# OPTIONS_GHC -Wall #-}" - , "main = putStrLn \"hello\"" - ] - , T.unlines - [ "{-# OPTIONS_GHC -Wall #-}" - , "{-# OPTIONS_GHC -Wno-missing-signatures #-}" - , "main = putStrLn \"hello\"" - ] - ) - , - ( "unused-imports" - , T.unlines - [ "{-# OPTIONS_GHC -Wall #-}" - , "" - , "" - , "module M where" - , "" - , "import Data.Functor" - ] - , T.unlines - [ "{-# OPTIONS_GHC -Wall #-}" - , "{-# OPTIONS_GHC -Wno-unused-imports #-}" - , "" - , "" - , "module M where" - , "" - , "import Data.Functor" - ] - ) - ] - <&> \(warning, initialContent, expectedContent) -> testSession (T.unpack warning) $ do - doc <- createDoc "Module.hs" "haskell" initialContent - _ <- waitForDiagnostics - codeActs <- mapMaybe caResultToCodeAct <$> getCodeActions doc (Range (Position 0 0) (Position 0 0)) - case find (\CodeAction{_title} -> _title == "Disable \"" <> warning <> "\" warnings") codeActs of - Nothing -> liftIO $ assertFailure "No code action with expected title" - Just action -> do - executeCodeAction action - contentAfterAction <- documentContents doc - liftIO $ expectedContent @=? contentAfterAction - where - caResultToCodeAct = \case - InL _ -> Nothing - InR c -> Just c - insertNewDefinitionTests :: TestTree insertNewDefinitionTests = testGroup "insert new definition actions" [ testSession "insert new function definition" $ do @@ -2586,12 +2537,7 @@ removeRedundantConstraintsTests = let doc <- createDoc "Testing.hs" "haskell" code _ <- waitForDiagnostics actionsOrCommands <- getCodeActions doc (Range (Position 4 0) (Position 4 maxBound)) - liftIO $ assertBool "Found some actions (other than \"disable warnings\")" - $ all isDisableWarningAction actionsOrCommands - where - isDisableWarningAction = \case - InR CodeAction{_title} -> "Disable" `T.isPrefixOf` _title && "warnings" `T.isSuffixOf` _title - _ -> False + liftIO $ assertBool "Found some actions" (null actionsOrCommands) in testGroup "remove redundant function constraints" [ check @@ -4786,9 +4732,7 @@ asyncTests = testGroup "async" void waitForDiagnostics actions <- getCodeActions doc (Range (Position 1 0) (Position 1 0)) liftIO $ [ _title | InR CodeAction{_title} <- actions] @=? - [ "add signature: foo :: a -> a" - , "Disable \"missing-signatures\" warnings" - ] + [ "add signature: foo :: a -> a" ] , testSession "request" $ do -- Execute a custom request that will block for 1000 seconds void $ sendRequest (SCustomMethod "test") $ toJSON $ BlockSeconds 1000 @@ -4800,9 +4744,7 @@ asyncTests = testGroup "async" void waitForDiagnostics actions <- getCodeActions doc (Range (Position 0 0) (Position 0 0)) liftIO $ [ _title | InR CodeAction{_title} <- actions] @=? - [ "add signature: foo :: a -> a" - , "Disable \"missing-signatures\" warnings" - ] + [ "add signature: foo :: a -> a" ] ] diff --git a/plugins/default/src/Ide/Plugin/Pragmas.hs b/plugins/default/src/Ide/Plugin/Pragmas.hs index bef200645a..75c540d2d0 100644 --- a/plugins/default/src/Ide/Plugin/Pragmas.hs +++ b/plugins/default/src/Ide/Plugin/Pragmas.hs @@ -1,30 +1,28 @@ {-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ViewPatterns #-} -- | Provides code actions to add missing pragmas (whenever GHC suggests to) -module Ide.Plugin.Pragmas - ( - descriptor - ) where - -import Control.Lens hiding (List) -import qualified Data.HashMap.Strict as H -import Data.Maybe (catMaybes) -import qualified Data.Text as T -import Development.IDE as D +module Ide.Plugin.Pragmas (descriptor) where + +import Control.Applicative ((<|>)) +import Control.Lens hiding (List) +import Control.Monad (join) +import Control.Monad.IO.Class +import qualified Data.HashMap.Strict as H +import Data.List.Extra (nubOrdOn) +import Data.Maybe (catMaybes, listToMaybe) +import qualified Data.Text as T +import Development.IDE as D +import Development.IDE.GHC.Compat import Ide.Types +import qualified Language.LSP.Server as LSP import Language.LSP.Types -import qualified Language.LSP.Types as J -import qualified Language.LSP.Types.Lens as J - -import Control.Monad (join) -import Development.IDE.GHC.Compat -import qualified Language.LSP.Server as LSP -import qualified Language.LSP.VFS as VFS -import qualified Text.Fuzzy as Fuzzy -import Data.List.Extra (nubOrd) -import Control.Monad.IO.Class +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 -- --------------------------------------------------------------------- @@ -36,55 +34,68 @@ descriptor plId = (defaultPluginDescriptor plId) -- --------------------------------------------------------------------- +-- | Title and pragma +type PragmaEdit = (T.Text, Pragma) + +data Pragma = LangExt T.Text | OptGHC T.Text + deriving (Show, Eq, Ord) + +codeActionProvider :: PluginMethodHandler IdeState TextDocumentCodeAction +codeActionProvider state _plId (CodeActionParams _ _ docId _ (J.CodeActionContext (J.List diags) _monly)) = do + let mFile = docId ^. J.uri & uriToFilePath <&> toNormalizedFilePath' + uri = docId ^. J.uri + pm <- liftIO $ fmap join $ runAction "Pragmas.GetParsedModule" state $ getParsedModule `traverse` mFile + let dflags = ms_hspp_opts . pm_mod_summary <$> pm + insertRange = maybe (Range (Position 0 0) (Position 0 0)) endOfModuleHeader pm + pedits = nubOrdOn snd . concat $ suggest dflags <$> diags + return $ Right $ List $ pragmaEditToAction uri insertRange <$> pedits + -- | Add a Pragma to the given URI at the top of the file. --- Pragma is added to the first line of the Uri. -- It is assumed that the pragma name is a valid pragma, -- thus, not validated. -mkPragmaEdit :: Uri -> T.Text -> WorkspaceEdit -mkPragmaEdit uri pragmaName = res where - pos = J.Position 0 0 - textEdits = J.List - [J.TextEdit (J.Range pos pos) - ("{-# LANGUAGE " <> pragmaName <> " #-}\n") - ] - res = J.WorkspaceEdit - (Just $ H.singleton uri textEdits) - Nothing +pragmaEditToAction :: Uri -> Range -> PragmaEdit -> (Command |? CodeAction) +pragmaEditToAction uri range (title, p) = + InR $ J.CodeAction title (Just J.CodeActionQuickFix) (Just (J.List [])) Nothing Nothing (Just edit) Nothing + where + render (OptGHC x) = "{-# OPTIONS_GHC -Wno-" <> x <> " #-}\n" + render (LangExt x) = "{-# LANGUAGE " <> x <> " #-}\n" + textEdits = J.List [J.TextEdit range $ render p] + edit = + J.WorkspaceEdit + (Just $ H.singleton uri textEdits) + Nothing + +suggest :: Maybe DynFlags -> Diagnostic -> [PragmaEdit] +suggest dflags diag = + suggestAddPragma dflags diag + ++ suggestDisableWarning diag -- --------------------------------------------------------------------- --- | 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'. -codeActionProvider :: PluginMethodHandler IdeState TextDocumentCodeAction -codeActionProvider state _plId (CodeActionParams _ _ docId _ (J.CodeActionContext (J.List diags) _monly)) = liftIO $ do - let mFile = docId ^. J.uri & uriToFilePath <&> toNormalizedFilePath' - pm <- fmap join $ runAction "addPragma" state $ getParsedModule `traverse` mFile - let dflags = ms_hspp_opts . pm_mod_summary <$> pm - -- Get all potential Pragmas for all diagnostics. - pragmas = nubOrd $ concatMap (\d -> genPragma dflags (d ^. J.message)) diags - cmds <- mapM mkCodeAction pragmas - return $ Right $ List cmds - where - mkCodeAction pragmaName = do - let - codeAction = InR $ J.CodeAction title (Just J.CodeActionQuickFix) (Just (J.List [])) Nothing Nothing (Just edit) Nothing - title = "Add \"" <> pragmaName <> "\"" - edit = mkPragmaEdit (docId ^. J.uri) pragmaName - return codeAction - - genPragma mDynflags target = - [ r | r <- findPragma target, r `notElem` disabled] - where - disabled - | Just dynFlags <- mDynflags - -- GHC does not export 'OnOff', so we have to view it as string - = catMaybes $ T.stripPrefix "Off " . T.pack . prettyPrint <$> extensions dynFlags - | otherwise - -- When the module failed to parse, we don't have access to its - -- dynFlags. In that case, simply don't disable any pragmas. - = [] + +suggestDisableWarning :: Diagnostic -> [PragmaEdit] +suggestDisableWarning Diagnostic {_code} + | Just (InR (T.stripPrefix "-W" -> Just w)) <- _code = + pure ("Disable \"" <> w <> "\" warnings", OptGHC w) + | otherwise = [] -- --------------------------------------------------------------------- +-- | 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 + where + genPragma target = + [("Add \"" <> r <> "\"", LangExt r) | r <- findPragma target, r `notElem` disabled] + disabled + | Just dynFlags <- mDynflags = + -- GHC does not export 'OnOff', so we have to view it as string + catMaybes $ T.stripPrefix "Off " . T.pack . prettyPrint <$> extensions dynFlags + | otherwise = + -- When the module failed to parse, we don't have access to its + -- dynFlags. In that case, simply don't disable any pragmas. + [] + -- | Find all Pragmas are an infix of the search term. findPragma :: T.Text -> [T.Text] findPragma str = concatMap check possiblePragmas @@ -103,8 +114,6 @@ findPragma str = concatMap check possiblePragmas , "Strict" /= name ] --- --------------------------------------------------------------------- - -- | All language pragmas, including the No- variants allPragmas :: [T.Text] allPragmas = @@ -164,3 +173,17 @@ completion _ide _ complParams = do _xdata = Nothing } _ -> return $ List [] + +-- --------------------------------------------------------------------- + +-- | Find the first non-blank line before the first of (module name / imports / declarations). +-- Useful for inserting pragmas. +endOfModuleHeader :: ParsedModule -> Range +endOfModuleHeader pm = + let mod = unLoc $ pm_parsed_source pm + modNameLoc = getLoc <$> hsmodName mod + firstImportLoc = getLoc <$> listToMaybe (hsmodImports mod) + firstDeclLoc = getLoc <$> listToMaybe (hsmodDecls mod) + line = maybe 0 (_line . _start) (modNameLoc <|> firstImportLoc <|> firstDeclLoc >>= srcSpanToRange) + loc = Position line 0 + in Range loc loc diff --git a/test/functional/Class.hs b/test/functional/Class.hs index 0a0a2d0d4d..4ab13b6511 100644 --- a/test/functional/Class.hs +++ b/test/functional/Class.hs @@ -1,26 +1,25 @@ -{-# LANGUAGE LambdaCase #-} --- {-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeOperators #-} module Class ( tests ) where +import Control.Applicative.Combinators import Control.Lens hiding ((<.>)) -import Control.Monad.IO.Class (MonadIO(liftIO)) +import Control.Monad.IO.Class (MonadIO (liftIO)) import qualified Data.ByteString.Lazy as BS import qualified Data.Text.Encoding as T import Language.LSP.Test -import Language.LSP.Types hiding (_title, _command) -import qualified Language.LSP.Types.Lens as J +import Language.LSP.Types hiding (_command, _title) +import qualified Language.LSP.Types.Lens as J import System.FilePath import Test.Hls.Util import Test.Tasty import Test.Tasty.Golden import Test.Tasty.HUnit -import Control.Applicative.Combinators tests :: TestTree tests = testGroup diff --git a/test/functional/FunctionalCodeAction.hs b/test/functional/FunctionalCodeAction.hs index a150c274c6..116843390a 100644 --- a/test/functional/FunctionalCodeAction.hs +++ b/test/functional/FunctionalCodeAction.hs @@ -1,31 +1,35 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} module FunctionalCodeAction (tests) where import Control.Applicative.Combinators -import Control.Lens hiding (List) +import Control.Lens hiding (List) import Control.Monad import Control.Monad.IO.Class import Data.Aeson import Data.Default -import qualified Data.HashMap.Strict as HM +import qualified Data.HashMap.Strict as HM import Data.List import Data.Maybe -import qualified Data.Text as T +import qualified Data.Text as T import Ide.Plugin.Config -import Language.LSP.Test as Test +import Language.LSP.Test as Test import Language.LSP.Types -import qualified Language.LSP.Types.Lens as L import qualified Language.LSP.Types.Capabilities as C +import qualified Language.LSP.Types.Lens as L import Test.Hls.Util import Test.Hspec.Expectations +import System.FilePath (()) +import System.IO.Extra (withTempDir) import Test.Tasty -import Test.Tasty.ExpectedFailure (ignoreTestBecause, expectFailBecause) +import Test.Tasty.ExpectedFailure (expectFailBecause, + ignoreTestBecause) import Test.Tasty.HUnit -import System.FilePath (()) {-# ANN module ("HLint: ignore Reduce duplication"::String) #-} @@ -34,6 +38,7 @@ tests = testGroup "code actions" [ hlintTests , importTests , missingPragmaTests + , disableWarningTests , packageTests , redundantImportTests , renameTests @@ -376,7 +381,7 @@ redundantImportTests = testGroup "redundant import code actions" [ , testCase "doesn't touch other imports" $ runSession hlsCommand noLiteralCaps "test/testdata/redundantImportTest/" $ do doc <- openDoc "src/MultipleImports.hs" "haskell" _ <- waitForDiagnosticsFromSource doc "typecheck" - _ : InL cmd : _ <- getAllCodeActions doc + InL cmd : _ <- getAllCodeActions doc executeCommand cmd _ <- anyRequest contents <- documentContents doc @@ -513,8 +518,14 @@ missingPragmaTests = testGroup "missing pragma warning code actions" [ contents <- documentContents doc let expected = +-- TODO: Why CPP??? +#if __GLASGOW_HASKELL__ < 810 + [ "{-# LANGUAGE ScopedTypeVariables #-}" + , "{-# LANGUAGE TypeApplications #-}" +#else [ "{-# LANGUAGE TypeApplications #-}" , "{-# LANGUAGE ScopedTypeVariables #-}" +#endif , "module TypeApplications where" , "" , "foo :: forall a. a -> a" @@ -554,6 +565,57 @@ missingPragmaTests = testGroup "missing pragma warning code actions" [ liftIO $ T.lines contents @?= expected ] +disableWarningTests :: TestTree +disableWarningTests = + testGroup "disable warnings" $ + [ + ( "missing-signatures" + , T.unlines + [ "{-# OPTIONS_GHC -Wall #-}" + , "main = putStrLn \"hello\"" + ] + , T.unlines + [ "{-# OPTIONS_GHC -Wall #-}" + , "{-# OPTIONS_GHC -Wno-missing-signatures #-}" + , "main = putStrLn \"hello\"" + ] + ) + , + ( "unused-imports" + , T.unlines + [ "{-# OPTIONS_GHC -Wall #-}" + , "" + , "" + , "module M where" + , "" + , "import Data.Functor" + ] + , T.unlines + [ "{-# OPTIONS_GHC -Wall #-}" + , "" + , "" + , "{-# OPTIONS_GHC -Wno-unused-imports #-}" + , "module M where" + , "" + , "import Data.Functor" + ] + ) + ] + <&> \(warning, initialContent, expectedContent) -> testSession (T.unpack warning) $ do + doc <- createDoc "Module.hs" "haskell" initialContent + _ <- waitForDiagnostics + codeActs <- mapMaybe caResultToCodeAct <$> getCodeActions doc (Range (Position 0 0) (Position 0 0)) + case find (\CodeAction{_title} -> _title == "Disable \"" <> warning <> "\" warnings") codeActs of + Nothing -> liftIO $ assertFailure "No code action with expected title" + Just action -> do + executeCodeAction action + contentAfterAction <- documentContents doc + liftIO $ expectedContent @=? contentAfterAction + where + caResultToCodeAct = \case + InL _ -> Nothing + InR c -> Just c + unusedTermTests :: TestTree unusedTermTests = testGroup "unused term code actions" [ ignoreTestBecause "no support for prefixing unused names with _" $ testCase "Prefixes with '_'" $ @@ -610,3 +672,7 @@ noLiteralCaps = def { C._textDocument = Just textDocumentCaps } where textDocumentCaps = def { C._codeAction = Just codeActionCaps } codeActionCaps = CodeActionClientCapabilities (Just True) Nothing Nothing + +testSession :: String -> Session () -> TestTree +testSession name s = testCase name $ withTempDir $ \dir -> + runSession hlsCommand fullCaps dir s