#600 Code action to ignore hlint hints module wide

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

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

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"
+

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

plugins/hls-hlint-plugin/test/testdata/UnrecognizedPragmasOff.hs

@@ -0,0 +1,3 @@
+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
+module UnrecognizedPragmasOff where
+foo x = id x

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

plugins/hls-hlint-plugin/test/testdata/UnrecognizedPragmasOn.hs

@@ -0,0 +1,3 @@
+{-# OPTIONS_GHC -Wunrecognised-pragmas #-}
+module UnrecognizedPragmasOn where
+foo x = id x