diff --git a/ghcide/src/Development/IDE/Spans/Pragmas.hs b/ghcide/src/Development/IDE/Spans/Pragmas.hs index 81de0a00c2..132e1e460b 100644 --- a/ghcide/src/Development/IDE/Spans/Pragmas.hs +++ b/ghcide/src/Development/IDE/Spans/Pragmas.hs @@ -388,7 +388,7 @@ mkLexerPState dynFlags stringBuffer = <*> gopt Opt_Haddock <*> gopt Opt_KeepRawTokenStream <*> const False - finalPState = mkPStatePure (mkLexerParserFlags dynFlags) stringBuffer startRealSrcLoc + finalPState = mkPStatePure (mkLexerParserFlags finalDynFlags) stringBuffer startRealSrcLoc #else pState = mkPState finalDynFlags stringBuffer startRealSrcLoc PState{ options = pStateOptions } = pState diff --git a/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs b/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs index 9f4dd42820..339323c563 100644 --- a/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs +++ b/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs @@ -13,6 +13,9 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -Wno-orphans #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RecordWildCards #-} #ifdef HLINT_ON_GHC_LIB #define MIN_GHC_API_VERSION(x,y,z) MIN_VERSION_ghc_lib(x,y,z) @@ -23,7 +26,6 @@ module Ide.Plugin.Hlint ( descriptor - --, provider ) where import Control.Arrow ((&&&)) import Control.Concurrent.STM @@ -105,6 +107,15 @@ import qualified Language.LSP.Types.Lens as LSP import GHC.Generics (Generic) import Text.Regex.TDFA.Text () +import Development.IDE.GHC.Compat.Core (WarningFlag (Opt_WarnUnrecognisedPragmas), + wopt) +import Development.IDE.Spans.Pragmas (LineSplitTextEdits (LineSplitTextEdits), + NextPragmaInfo (NextPragmaInfo), + getNextPragmaInfo, + lineSplitDeleteTextEdit, + lineSplitInsertTextEdit, + lineSplitTextEdits, + nextPragmaLine) import System.Environment (setEnv, unsetEnv) -- --------------------------------------------------------------------- @@ -303,39 +314,57 @@ getHlintConfig pId = Config <$> usePropertyAction #flags pId properties +runHlintAction + :: (Eq k, Hashable k, Show k, Show (RuleResult k), Typeable k, Typeable (RuleResult k), NFData k, NFData (RuleResult k)) + => IdeState + -> NormalizedFilePath -> String -> k -> IO (Maybe (RuleResult k)) +runHlintAction ideState normalizedFilePath desc rule = runAction desc ideState $ use rule normalizedFilePath + +runGetFileContentsAction :: IdeState -> NormalizedFilePath -> IO (Maybe (FileVersion, Maybe T.Text)) +runGetFileContentsAction ideState normalizedFilePath = runHlintAction ideState normalizedFilePath "Hlint.GetFileContents" GetFileContents + +runGetModSummaryAction :: IdeState -> NormalizedFilePath -> IO (Maybe ModSummaryResult) +runGetModSummaryAction ideState normalizedFilePath = runHlintAction ideState normalizedFilePath "Hlint.GetModSummary" GetModSummary + -- --------------------------------------------------------------------- codeActionProvider :: PluginMethodHandler IdeState TextDocumentCodeAction -codeActionProvider ideState plId (CodeActionParams _ _ docId _ context) = Right . LSP.List . map InR <$> liftIO getCodeActions - where - - getCodeActions = do - allDiags <- atomically $ getDiagnostics ideState - let docNfp = toNormalizedFilePath' <$> uriToFilePath' (docId ^. LSP.uri) - numHintsInDoc = length - [d | (nfp, _, d) <- allDiags - , validCommand d - , Just nfp == docNfp - ] - numHintsInContext = length - [d | d <- diags - , validCommand d - ] - -- We only want to show the applyAll code action if there is more than 1 - -- hint in the current document and if code action range contains at - -- least one hint - if numHintsInDoc > 1 && numHintsInContext > 0 then do - pure $ applyAllAction:applyOneActions - else - pure applyOneActions +codeActionProvider ideState pluginId (CodeActionParams _ _ documentId _ context) + | let TextDocumentIdentifier uri = documentId + , Just docNormalizedFilePath <- uriToNormalizedFilePath (toNormalizedUri uri) + = liftIO $ fmap (Right . LSP.List . map LSP.InR) $ do + allDiagnostics <- atomically $ getDiagnostics ideState + let numHintsInDoc = length + [diagnostic | (diagnosticNormalizedFilePath, _, diagnostic) <- allDiagnostics + , validCommand diagnostic + , diagnosticNormalizedFilePath == docNormalizedFilePath + ] + let numHintsInContext = length + [diagnostic | diagnostic <- diags + , validCommand diagnostic + ] + file <- runGetFileContentsAction ideState docNormalizedFilePath + singleHintCodeActions <- + if | Just (_, source) <- file -> do + modSummaryResult <- runGetModSummaryAction ideState docNormalizedFilePath + pure if | Just modSummaryResult <- modSummaryResult + , Just source <- source + , let dynFlags = ms_hspp_opts $ msrModSummary modSummaryResult -> + diags >>= diagnosticToCodeActions dynFlags source pluginId documentId + | otherwise -> [] + | otherwise -> pure [] + if numHintsInDoc > 1 && numHintsInContext > 0 then do + pure $ singleHintCodeActions ++ [applyAllAction] + else + pure singleHintCodeActions + | otherwise + = pure $ Right $ LSP.List [] + where applyAllAction = - let args = Just [toJSON (docId ^. LSP.uri)] - cmd = mkLspCommand plId "applyAll" "Apply all hints" args + let args = Just [toJSON (documentId ^. LSP.uri)] + cmd = mkLspCommand pluginId "applyAll" "Apply all hints" args in LSP.CodeAction "Apply all hints" (Just LSP.CodeActionQuickFix) Nothing Nothing Nothing Nothing (Just cmd) Nothing - applyOneActions :: [LSP.CodeAction] - applyOneActions = mapMaybe mkHlintAction (filter validCommand diags) - -- |Some hints do not have an associated refactoring validCommand (LSP.Diagnostic _ _ (Just (InR code)) (Just "hlint") _ _ _) = "refact:" `T.isPrefixOf` code @@ -344,18 +373,64 @@ codeActionProvider ideState plId (CodeActionParams _ _ docId _ context) = Right LSP.List diags = context ^. LSP.diagnostics - mkHlintAction :: LSP.Diagnostic -> Maybe LSP.CodeAction - mkHlintAction diag@(LSP.Diagnostic (LSP.Range start _) _s (Just (InR code)) (Just "hlint") _ _ _) = - Just . codeAction $ mkLspCommand plId "applyOne" title (Just args) - where - codeAction cmd = LSP.CodeAction title (Just LSP.CodeActionQuickFix) (Just (LSP.List [diag])) Nothing Nothing Nothing (Just cmd) Nothing - -- we have to recover the original ideaHint removing the prefix - ideaHint = T.replace "refact:" "" code - title = "Apply hint: " <> ideaHint - -- need 'file', 'start_pos' and hint title (to distinguish between alternative suggestions at the same location) - args = [toJSON (AOP (docId ^. LSP.uri) start ideaHint)] - mkHlintAction (LSP.Diagnostic _r _s _c _source _m _ _) = Nothing - +-- | Convert a hlint diagonistic into an apply and an ignore code action +-- if applicable +diagnosticToCodeActions :: DynFlags -> T.Text -> PluginId -> TextDocumentIdentifier -> LSP.Diagnostic -> [LSP.CodeAction] +diagnosticToCodeActions dynFlags fileContents pluginId documentId diagnostic + | LSP.Diagnostic{ _source = Just "hlint", _code = Just (InR code), _range = LSP.Range start _ } <- diagnostic + , let TextDocumentIdentifier uri = documentId + , let isHintApplicable = "refact:" `T.isPrefixOf` code + , let hint = T.replace "refact:" "" code + , let suppressHintTitle = "Ignore hint \"" <> hint <> "\" in this module" + , let suppressHintTextEdits = mkSuppressHintTextEdits dynFlags fileContents hint + , let suppressHintWorkspaceEdit = + LSP.WorkspaceEdit + (Just (Map.singleton uri (List suppressHintTextEdits))) + Nothing + Nothing + = catMaybes + [ if | isHintApplicable + , let applyHintTitle = "Apply hint \"" <> hint <> "\"" + applyHintArguments = [toJSON (AOP (documentId ^. LSP.uri) start hint)] + applyHintCommand = mkLspCommand pluginId "applyOne" applyHintTitle (Just applyHintArguments) -> + Just (mkCodeAction applyHintTitle diagnostic Nothing (Just applyHintCommand)) + | otherwise -> Nothing + , Just (mkCodeAction suppressHintTitle diagnostic (Just suppressHintWorkspaceEdit) Nothing) + ] + | otherwise = [] + +mkCodeAction :: T.Text -> LSP.Diagnostic -> Maybe LSP.WorkspaceEdit -> Maybe LSP.Command -> LSP.CodeAction +mkCodeAction title diagnostic workspaceEdit command = + LSP.CodeAction + { _title = title + , _kind = Just LSP.CodeActionQuickFix + , _diagnostics = Just (LSP.List [diagnostic]) + , _isPreferred = Nothing + , _disabled = Nothing + , _edit = workspaceEdit + , _command = command + , _xdata = Nothing + } + +mkSuppressHintTextEdits :: DynFlags -> T.Text -> T.Text -> [LSP.TextEdit] +mkSuppressHintTextEdits dynFlags fileContents hint = + let + NextPragmaInfo{ nextPragmaLine, lineSplitTextEdits } = getNextPragmaInfo dynFlags (Just fileContents) + nextPragmaLinePosition = Position nextPragmaLine 0 + nextPragmaRange = Range nextPragmaLinePosition nextPragmaLinePosition + wnoUnrecognisedPragmasText = + if wopt Opt_WarnUnrecognisedPragmas dynFlags + then Just "{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}\n" + else Nothing + hlintIgnoreText = Just ("{-# HLINT ignore \"" <> hint <> "\" #-}\n") + -- we combine the texts into a single text because lsp-test currently + -- applies text edits backwards and I want the options pragma to + -- appear above the hlint pragma in the tests + combinedText = mconcat $ catMaybes [wnoUnrecognisedPragmasText, hlintIgnoreText] + combinedTextEdit = LSP.TextEdit nextPragmaRange combinedText + lineSplitTextEditList = maybe [] (\LineSplitTextEdits{..} -> [lineSplitInsertTextEdit, lineSplitDeleteTextEdit]) lineSplitTextEdits + in + combinedTextEdit : lineSplitTextEditList -- --------------------------------------------------------------------- applyAllCmd :: CommandFunction IdeState Uri diff --git a/plugins/hls-hlint-plugin/test/Main.hs b/plugins/hls-hlint-plugin/test/Main.hs index 844fc599ef..59ec44e004 100644 --- a/plugins/hls-hlint-plugin/test/Main.hs +++ b/plugins/hls-hlint-plugin/test/Main.hs @@ -1,4 +1,7 @@ +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeOperators #-} module Main ( main ) where @@ -27,8 +30,27 @@ tests :: TestTree tests = testGroup "hlint" [ suggestionsTests , configTests + , ignoreHintTests ] +getIgnoreHintText :: T.Text -> T.Text +getIgnoreHintText name = "Ignore hint \"" <> name <> "\" in this module" + +ignoreHintTests :: TestTree +ignoreHintTests = testGroup "hlint ignore hint tests" + [ + ignoreGoldenTest + "Ignore hint in this module inserts -Wno-unrecognised-pragmas and hlint ignore pragma if warn unrecognized pragmas is off" + "UnrecognizedPragmasOff" + (Point 3 8) + "Eta reduce" + , ignoreGoldenTest + "Ignore hint in this module inserts only hlint ignore pragma if warn unrecognized pragmas is on" + "UnrecognizedPragmasOn" + (Point 3 9) + "Eta reduce" + ] + suggestionsTests :: TestTree suggestionsTests = testGroup "hlint suggestions" [ @@ -45,13 +67,19 @@ suggestionsTests = cas <- map fromAction <$> getAllCodeActions doc + let redundantIdHintName = "Redundant id" + let etaReduceHintName = "Eta reduce" let applyAll = find (\ca -> "Apply all hints" `T.isSuffixOf` (ca ^. L.title)) cas - let redId = find (\ca -> "Redundant id" `T.isSuffixOf` (ca ^. L.title)) cas - let redEta = find (\ca -> "Eta reduce" `T.isSuffixOf` (ca ^. L.title)) cas + let redId = find (\ca -> redundantIdHintName `T.isInfixOf` (ca ^. L.title)) cas + let redEta = find (\ca -> etaReduceHintName `T.isInfixOf` (ca ^. L.title)) cas + let ignoreRedundantIdInThisModule = find (\ca -> getIgnoreHintText redundantIdHintName == (ca ^.L.title)) cas + let ignoreEtaReduceThisModule = find (\ca -> getIgnoreHintText etaReduceHintName == (ca ^.L.title)) cas - liftIO $ isJust applyAll @? "There is 'Apply all hints' code action" - liftIO $ isJust redId @? "There is 'Redundant id' code action" - liftIO $ isJust redEta @? "There is 'Eta reduce' code action" + liftIO $ isJust applyAll @? "There is Apply all hints code action" + liftIO $ isJust redId @? "There is Redundant id code action" + liftIO $ isJust redEta @? "There is Eta reduce code action" + liftIO $ isJust ignoreRedundantIdInThisModule @? "There is ignore Redundant id code action" + liftIO $ isJust ignoreEtaReduceThisModule @? "There is ignore Eta reduce code action" executeCodeAction (fromJust redId) @@ -185,7 +213,7 @@ suggestionsTests = testHlintDiagnostics doc cas <- map fromAction <$> getAllCodeActions doc - let ca = find (\ca -> caTitle `T.isSuffixOf` (ca ^. L.title)) cas + let ca = find (\ca -> caTitle `T.isInfixOf` (ca ^. L.title)) cas liftIO $ isJust ca @? ("There is '" ++ T.unpack caTitle ++"' code action") executeCodeAction (fromJust ca) @@ -284,9 +312,12 @@ configTests = testGroup "hlint plugin config" [ d ^. L.severity @?= Just DsInfo ] +testDir :: FilePath +testDir = "test/testdata" + runHlintSession :: FilePath -> Session a -> IO a runHlintSession subdir = - failIfSessionTimeout . runSessionWithServer hlintPlugin ("test/testdata" subdir) + failIfSessionTimeout . runSessionWithServer hlintPlugin (testDir subdir) noHlintDiagnostics :: [Diagnostic] -> Assertion noHlintDiagnostics diags = @@ -326,3 +357,46 @@ knownBrokenForHlintOnGhcLib = knownBrokenForGhcVersions [GHC88, GHC86] knownBrokenForHlintOnRawGhc :: String -> TestTree -> TestTree knownBrokenForHlintOnRawGhc = knownBrokenForGhcVersions [GHC810, GHC90] + +-- 1's based +data Point = Point { + line :: !Int, + column :: !Int +} + +makePoint line column + | line >= 1 && column >= 1 = Point line column + | otherwise = error "Line or column is less than 1." + +pointToRange :: Point -> Range +pointToRange Point {..} + | line <- subtract 1 line + , column <- subtract 1 column = + Range (Position line column) (Position line $ column + 1) + +getCodeActionTitle :: (Command |? CodeAction) -> Maybe T.Text +getCodeActionTitle commandOrCodeAction + | InR CodeAction {_title} <- commandOrCodeAction = Just _title + | otherwise = Nothing + +makeCodeActionNotFoundAtString :: Point -> String +makeCodeActionNotFoundAtString Point {..} = + "CodeAction not found at line: " <> show line <> ", column: " <> show column + +makeCodeActionFoundAtString :: Point -> String +makeCodeActionFoundAtString Point {..} = + "CodeAction found at line: " <> show line <> ", column: " <> show column + +ignoreGoldenTest :: TestName -> FilePath -> Point -> T.Text -> TestTree +ignoreGoldenTest testCaseName goldenFilename point hintName = + setupGoldenHlintTest testCaseName goldenFilename $ \document -> do + waitForDiagnosticsFromSource document "hlint" + actions <- getCodeActions document $ pointToRange point + case find ((== Just (getIgnoreHintText hintName)) . getCodeActionTitle) actions of + Just (InR codeAction) -> executeCodeAction codeAction + _ -> liftIO $ assertFailure $ makeCodeActionNotFoundAtString point + +setupGoldenHlintTest :: TestName -> FilePath -> (TextDocumentIdentifier -> Session ()) -> TestTree +setupGoldenHlintTest testName path = + goldenWithHaskellDoc hlintPlugin testName testDir path "expected" "hs" + diff --git a/plugins/hls-hlint-plugin/test/testdata/UnrecognizedPragmasOff.expected.hs b/plugins/hls-hlint-plugin/test/testdata/UnrecognizedPragmasOff.expected.hs new file mode 100644 index 0000000000..31d9aed946 --- /dev/null +++ b/plugins/hls-hlint-plugin/test/testdata/UnrecognizedPragmasOff.expected.hs @@ -0,0 +1,4 @@ +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} +{-# HLINT ignore "Eta reduce" #-} +module UnrecognizedPragmasOff where +foo x = id x diff --git a/plugins/hls-hlint-plugin/test/testdata/UnrecognizedPragmasOff.hs b/plugins/hls-hlint-plugin/test/testdata/UnrecognizedPragmasOff.hs new file mode 100644 index 0000000000..2611c9a7f7 --- /dev/null +++ b/plugins/hls-hlint-plugin/test/testdata/UnrecognizedPragmasOff.hs @@ -0,0 +1,3 @@ +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} +module UnrecognizedPragmasOff where +foo x = id x diff --git a/plugins/hls-hlint-plugin/test/testdata/UnrecognizedPragmasOn.expected.hs b/plugins/hls-hlint-plugin/test/testdata/UnrecognizedPragmasOn.expected.hs new file mode 100644 index 0000000000..564503ca40 --- /dev/null +++ b/plugins/hls-hlint-plugin/test/testdata/UnrecognizedPragmasOn.expected.hs @@ -0,0 +1,5 @@ +{-# OPTIONS_GHC -Wunrecognised-pragmas #-} +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} +{-# HLINT ignore "Eta reduce" #-} +module UnrecognizedPragmasOn where +foo x = id x diff --git a/plugins/hls-hlint-plugin/test/testdata/UnrecognizedPragmasOn.hs b/plugins/hls-hlint-plugin/test/testdata/UnrecognizedPragmasOn.hs new file mode 100644 index 0000000000..bac66497ba --- /dev/null +++ b/plugins/hls-hlint-plugin/test/testdata/UnrecognizedPragmasOn.hs @@ -0,0 +1,3 @@ +{-# OPTIONS_GHC -Wunrecognised-pragmas #-} +module UnrecognizedPragmasOn where +foo x = id x