diff --git a/hls-hlint-plugin.cabal b/hls-hlint-plugin.cabal --- a/hls-hlint-plugin.cabal +++ b/hls-hlint-plugin.cabal @@ -1,6 +1,6 @@ cabal-version: 2.4 name: hls-hlint-plugin -version: 2.0.0.1 +version: 2.1.0.0 synopsis: Hlint integration plugin with Haskell Language Server description: Please see the README on GitHub at @@ -30,8 +30,6 @@ manual: True library - if impl(ghc >= 9.5) - buildable: False exposed-modules: Ide.Plugin.Hlint hs-source-dirs: src build-depends: @@ -47,12 +45,13 @@ , extra , filepath , ghc-exactprint >=0.6.3.4 - , ghcide == 2.0.0.1 + , ghcide == 2.1.0.0 , hashable - , hlint < 3.6 - , hls-plugin-api == 2.0.0.1 + , hlint < 3.7 + , hls-plugin-api == 2.1.0.0 , lens , lsp + , mtl , refact , regex-tdfa , stm @@ -78,8 +77,6 @@ TypeOperators test-suite tests - if impl(ghc >= 9.5) - buildable: False type: exitcode-stdio-1.0 default-language: Haskell2010 hs-source-dirs: test @@ -92,7 +89,8 @@ , filepath , hls-hlint-plugin , hls-plugin-api - , hls-test-utils == 2.0.0.1 + , hls-test-utils == 2.1.0.0 , lens , lsp-types + , row-types , text diff --git a/src/Ide/Plugin/Hlint.hs b/src/Ide/Plugin/Hlint.hs --- a/src/Ide/Plugin/Hlint.hs +++ b/src/Ide/Plugin/Hlint.hs @@ -1,23 +1,24 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedLabels #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PackageImports #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StrictData #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ViewPatterns #-} - +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PackageImports #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StrictData #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -Wno-orphans #-} -- On 9.4 we get a new redundant constraint warning, but deleting the @@ -40,16 +41,20 @@ import Control.Concurrent.STM import Control.DeepSeq import Control.Exception -import Control.Lens ((^.)) +import Control.Lens ((?~), (^.)) import Control.Monad -import Control.Monad.IO.Class -import Control.Monad.Trans.Except +import Control.Monad.Error.Class (MonadError (throwError)) +import Control.Monad.IO.Class (MonadIO (liftIO)) +import Control.Monad.Trans.Class (MonadTrans (lift)) +import Control.Monad.Trans.Except (ExceptT (..), + runExceptT) import Data.Aeson.Types (FromJSON (..), ToJSON (..), Value (..)) import qualified Data.ByteString as BS import Data.Hashable import qualified Data.HashMap.Strict as Map +import qualified Data.Map as M import Data.Maybe import qualified Data.Text as T import qualified Data.Text.Encoding as T @@ -57,6 +62,7 @@ import Development.IDE hiding (Error, getExtensions) +import Development.IDE.Core.Compile (sourceParser) import Development.IDE.Core.Rules (defineNoFile, getParsedModuleWithComments) import Development.IDE.Core.Shake (getDiagnostics) @@ -111,24 +117,22 @@ import Language.Haskell.GhclibParserEx.Fixity as GhclibParserEx (applyFixities) import qualified Refact.Fixity as Refact #endif - import Ide.Plugin.Config hiding (Config) +import Ide.Plugin.Error import Ide.Plugin.Properties +import Ide.Plugin.Resolve import Ide.PluginUtils import Ide.Types hiding (Config) import Language.Haskell.HLint as Hlint hiding (Error) -import Language.LSP.Server (ProgressCancellable (Cancellable), - sendRequest, - withIndefiniteProgress) -import Language.LSP.Types hiding - (SemanticTokenAbsolute (length, line), - SemanticTokenRelative (length), - SemanticTokensEdit (_start)) -import qualified Language.LSP.Types as LSP -import qualified Language.LSP.Types.Lens as LSP +import qualified Language.LSP.Protocol.Lens as LSP +import Language.LSP.Protocol.Message +import Language.LSP.Protocol.Types hiding + (Null) +import qualified Language.LSP.Protocol.Types as LSP +import Language.LSP.Server (getVersionedTextDoc) import qualified Development.IDE.Core.Shake as Shake import Development.IDE.Spans.Pragmas (LineSplitTextEdits (LineSplitTextEdits), @@ -144,6 +148,7 @@ import System.Environment (setEnv, unsetEnv) #endif +import Development.IDE.Core.PluginUtils as PluginUtils import Text.Regex.TDFA.Text () -- --------------------------------------------------------------------- @@ -153,7 +158,7 @@ | LogGeneratedIdeas NormalizedFilePath [[Refact.Refactoring Refact.SrcSpan]] | LogGetIdeas NormalizedFilePath | LogUsingExtensions NormalizedFilePath [String] -- Extension is only imported conditionally, so we just stringify them - deriving Show + | forall a. (Pretty a) => LogResolve a instance Pretty Log where pretty = \case @@ -162,6 +167,7 @@ LogGeneratedIdeas fp ideas -> "Generated hlint ideas for for" <+> viaShow fp <> ":" <+> viaShow ideas LogUsingExtensions fp exts -> "Using extensions for " <+> viaShow fp <> ":" <+> pretty exts LogGetIdeas fp -> "Getting hlint ideas for " <+> viaShow fp + LogResolve msg -> pretty msg #ifdef HLINT_ON_GHC_LIB -- Reimplementing this, since the one in Development.IDE.GHC.Compat isn't for ghc-lib @@ -186,13 +192,13 @@ #endif descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState -descriptor recorder plId = (defaultPluginDescriptor plId) +descriptor recorder plId = + let resolveRecorder = cmapWithPrio LogResolve recorder + (pluginCommands, pluginHandlers) = mkCodeActionWithResolveAndCommand resolveRecorder plId codeActionProvider (resolveProvider recorder) + in (defaultPluginDescriptor plId) { pluginRules = rules recorder plId - , pluginCommands = - [ PluginCommand "applyOne" "Apply a single hint" (applyOneCmd recorder) - , PluginCommand "applyAll" "Apply all hints to the file" (applyAllCmd recorder) - ] - , pluginHandlers = mkPluginHandler STextDocumentCodeAction codeActionProvider + , pluginCommands = pluginCommands + , pluginHandlers = pluginHandlers , pluginConfigDescriptor = defaultConfigDescriptor { configHasDiagnostics = True , configCustomConfig = mkCustomConfig properties @@ -243,13 +249,15 @@ ideaToDiagnostic idea = LSP.Diagnostic { _range = srcSpanToRange $ ideaSpan idea - , _severity = Just LSP.DsInfo + , _severity = Just LSP.DiagnosticSeverity_Information -- we are encoding the fact that idea has refactorings in diagnostic code , _code = Just (InR $ T.pack $ codePre ++ ideaHint idea) , _source = Just "hlint" , _message = idea2Message idea , _relatedInformation = Nothing , _tags = Nothing + , _codeDescription = Nothing + , _data_ = Nothing } where codePre = if null $ ideaRefactoring idea then "" else "refact:" @@ -267,12 +275,14 @@ parseErrorToDiagnostic (Hlint.ParseError l msg contents) = LSP.Diagnostic { _range = srcSpanToRange l - , _severity = Just LSP.DsInfo - , _code = Just (InR "parser") + , _severity = Just LSP.DiagnosticSeverity_Information + , _code = Just (InR sourceParser) , _source = Just "hlint" , _message = T.unlines [T.pack msg,T.pack contents] , _relatedInformation = Nothing , _tags = Nothing + , _codeDescription = Nothing + , _data_ = Nothing } -- This one is defined in Development.IDE.GHC.Error but here @@ -390,25 +400,16 @@ 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 pluginId (CodeActionParams _ _ documentId _ context) +codeActionProvider :: PluginMethodHandler IdeState Method_TextDocumentCodeAction +codeActionProvider ideState _pluginId (CodeActionParams _ _ documentId _ context) | let TextDocumentIdentifier uri = documentId , Just docNormalizedFilePath <- uriToNormalizedFilePath (toNormalizedUri uri) - = liftIO $ fmap (Right . LSP.List . map LSP.InR) $ do + = do + verTxtDocId <- lift $ getVersionedTextDoc documentId + liftIO $ fmap (InL . map LSP.InR) $ do allDiagnostics <- atomically $ getDiagnostics ideState + let numHintsInDoc = length [diagnostic | (diagnosticNormalizedFilePath, _, diagnostic) <- allDiagnostics , validCommand diagnostic @@ -418,76 +419,70 @@ [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 [] + let singleHintCodeActions = diags >>= diagnosticToCodeActions verTxtDocId if numHintsInDoc > 1 && numHintsInContext > 0 then do - pure $ singleHintCodeActions ++ [applyAllAction] + pure $ singleHintCodeActions ++ [applyAllAction verTxtDocId] else pure singleHintCodeActions | otherwise - = pure $ Right $ LSP.List [] + = pure $ InL [] where - applyAllAction = - 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 + applyAllAction verTxtDocId = + let args = Just $ toJSON (ApplyHint verTxtDocId Nothing) + in LSP.CodeAction "Apply all hints" (Just LSP.CodeActionKind_QuickFix) Nothing Nothing Nothing Nothing Nothing args -- |Some hints do not have an associated refactoring - validCommand (LSP.Diagnostic _ _ (Just (InR code)) (Just "hlint") _ _ _) = + validCommand (LSP.Diagnostic _ _ (Just (InR code)) _ (Just "hlint") _ _ _ _) = "refact:" `T.isPrefixOf` code validCommand _ = False - LSP.List diags = context ^. LSP.diagnostics + diags = context ^. LSP.diagnostics +resolveProvider :: Recorder (WithPriority Log) -> ResolveFunction IdeState HlintResolveCommands Method_CodeActionResolve +resolveProvider recorder ideState _plId ca uri resolveValue = do + file <- getNormalizedFilePathE uri + case resolveValue of + (ApplyHint verTxtDocId oneHint) -> do + edit <- ExceptT $ liftIO $ applyHint recorder ideState file oneHint verTxtDocId + pure $ ca & LSP.edit ?~ edit + (IgnoreHint verTxtDocId hintTitle ) -> do + edit <- ExceptT $ liftIO $ ignoreHint recorder ideState file verTxtDocId hintTitle + pure $ ca & LSP.edit ?~ edit + -- | Convert a hlint diagnostic 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 +diagnosticToCodeActions :: VersionedTextDocumentIdentifier -> LSP.Diagnostic -> [LSP.CodeAction] +diagnosticToCodeActions verTxtDocId 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 + , let suppressHintArguments = IgnoreHint verTxtDocId hint = catMaybes -- Applying the hint is marked preferred because it addresses the underlying error. -- Disabling the rule isn't, because less often used and configuration can be adapted. [ 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) True) + applyHintArguments = ApplyHint verTxtDocId (Just $ OneHint start hint) -> + Just (mkCodeAction applyHintTitle diagnostic (Just (toJSON applyHintArguments)) True) | otherwise -> Nothing - , Just (mkCodeAction suppressHintTitle diagnostic (Just suppressHintWorkspaceEdit) Nothing False) + , Just (mkCodeAction suppressHintTitle diagnostic (Just (toJSON suppressHintArguments)) False) ] | otherwise = [] -mkCodeAction :: T.Text -> LSP.Diagnostic -> Maybe LSP.WorkspaceEdit -> Maybe LSP.Command -> Bool -> LSP.CodeAction -mkCodeAction title diagnostic workspaceEdit command isPreferred = +mkCodeAction :: T.Text -> LSP.Diagnostic -> Maybe Value -> Bool -> LSP.CodeAction +mkCodeAction title diagnostic data_ isPreferred = LSP.CodeAction { _title = title - , _kind = Just LSP.CodeActionQuickFix - , _diagnostics = Just (LSP.List [diagnostic]) + , _kind = Just LSP.CodeActionKind_QuickFix + , _diagnostics = Just [diagnostic] , _isPreferred = Just isPreferred , _disabled = Nothing - , _edit = workspaceEdit - , _command = command - , _xdata = Nothing + , _edit = Nothing + , _command = Nothing + , _data_ = data_ } mkSuppressHintTextEdits :: DynFlags -> T.Text -> T.Text -> [LSP.TextEdit] @@ -511,60 +506,52 @@ combinedTextEdit : lineSplitTextEditList -- --------------------------------------------------------------------- -applyAllCmd :: Recorder (WithPriority Log) -> CommandFunction IdeState Uri -applyAllCmd recorder ide uri = do - let file = maybe (error $ show uri ++ " is not a file.") - toNormalizedFilePath' - (uriToFilePath' uri) - withIndefiniteProgress "Applying all hints" Cancellable $ do - res <- liftIO $ applyHint recorder ide file Nothing - logWith recorder Debug $ LogApplying file res - case res of - Left err -> pure $ Left (responseError (T.pack $ "hlint:applyAll: " ++ show err)) - Right fs -> do - _ <- sendRequest SWorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing fs) (\_ -> pure ()) - pure $ Right Null +ignoreHint :: Recorder (WithPriority Log) -> IdeState -> NormalizedFilePath -> VersionedTextDocumentIdentifier -> HintTitle -> IO (Either PluginError WorkspaceEdit) +ignoreHint _recorder ideState nfp verTxtDocId ignoreHintTitle = runExceptT $ do + (_, fileContents) <- runActionE "Hlint.GetFileContents" ideState $ useE GetFileContents nfp + (msr, _) <- runActionE "Hlint.GetModSummaryWithoutTimestamps" ideState $ useWithStaleE GetModSummaryWithoutTimestamps nfp + case fileContents of + Just contents -> do + let dynFlags = ms_hspp_opts $ msrModSummary msr + textEdits = mkSuppressHintTextEdits dynFlags contents ignoreHintTitle + workspaceEdit = + LSP.WorkspaceEdit + (Just (M.singleton (verTxtDocId ^. LSP.uri) textEdits)) + Nothing + Nothing + pure workspaceEdit + Nothing -> throwError $ PluginInternalError "Unable to get fileContents" -- --------------------------------------------------------------------- - -data ApplyOneParams = AOP - { file :: Uri - , start_pos :: Position - -- | There can be more than one hint suggested at the same position, so HintTitle is used to distinguish between them. - , hintTitle :: HintTitle - } deriving (Eq,Show,Generic,FromJSON,ToJSON) +data HlintResolveCommands = + ApplyHint + { verTxtDocId :: VersionedTextDocumentIdentifier + -- |If Nothing, apply all hints, otherise only apply + -- the given hint + , oneHint :: Maybe OneHint + } + | IgnoreHint + { verTxtDocId :: VersionedTextDocumentIdentifier + , ignoreHintTitle :: HintTitle + } deriving (Generic, ToJSON, FromJSON) type HintTitle = T.Text -data OneHint = OneHint - { oneHintPos :: Position - , oneHintTitle :: HintTitle - } deriving (Eq, Show) - -applyOneCmd :: Recorder (WithPriority Log) -> CommandFunction IdeState ApplyOneParams -applyOneCmd recorder ide (AOP uri pos title) = do - let oneHint = OneHint pos title - let file = maybe (error $ show uri ++ " is not a file.") toNormalizedFilePath' - (uriToFilePath' uri) - let progTitle = "Applying hint: " <> title - withIndefiniteProgress progTitle Cancellable $ do - res <- liftIO $ applyHint recorder ide file (Just oneHint) - logWith recorder Debug $ LogApplying file res - case res of - Left err -> pure $ Left (responseError (T.pack $ "hlint:applyOne: " ++ show err)) - Right fs -> do - _ <- sendRequest SWorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing fs) (\_ -> pure ()) - pure $ Right Null +data OneHint = + OneHint + { oneHintPos :: Position + , oneHintTitle :: HintTitle + } deriving (Generic, Eq, Show, ToJSON, FromJSON) -applyHint :: Recorder (WithPriority Log) -> IdeState -> NormalizedFilePath -> Maybe OneHint -> IO (Either String WorkspaceEdit) -applyHint recorder ide nfp mhint = +applyHint :: Recorder (WithPriority Log) -> IdeState -> NormalizedFilePath -> Maybe OneHint -> VersionedTextDocumentIdentifier -> IO (Either PluginError WorkspaceEdit) +applyHint recorder ide nfp mhint verTxtDocId = runExceptT $ do let runAction' :: Action a -> IO a runAction' = runAction "applyHint" ide let errorHandlers = [ Handler $ \e -> return (Left (show (e :: IOException))) , Handler $ \e -> return (Left (show (e :: ErrorCall))) ] - ideas <- bimapExceptT showParseError id $ ExceptT $ runAction' $ getIdeas recorder nfp + ideas <- bimapExceptT (PluginInternalError . T.pack . showParseError) id $ ExceptT $ runAction' $ getIdeas recorder nfp let ideas' = maybe ideas (`filterIdeas` ideas) mhint let commands = map ideaRefactoring ideas' logWith recorder Debug $ LogGeneratedIdeas nfp commands @@ -600,7 +587,7 @@ mbParsedModule <- liftIO $ runAction' $ getParsedModuleWithComments nfp res <- case mbParsedModule of - Nothing -> throwE "Apply hint: error parsing the module" + Nothing -> throwError "Apply hint: error parsing the module" Just pm -> do let anns = pm_annotations pm let modu = pm_parsed_source pm @@ -614,11 +601,10 @@ #endif case res of Right appliedFile -> do - let uri = fromNormalizedUri (filePathToUri' nfp) - let wsEdit = diffText' True (uri, oldContent) (T.pack appliedFile) IncludeDeletions + let wsEdit = diffText' True (verTxtDocId, oldContent) (T.pack appliedFile) IncludeDeletions ExceptT $ return (Right wsEdit) Left err -> - throwE err + throwError $ PluginInternalError $ T.pack err where -- | If we are only interested in applying a particular hint then -- let's filter out all the irrelevant ideas diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -1,4 +1,5 @@ {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeOperators #-} @@ -6,20 +7,21 @@ ( main ) where -import Control.Lens ((^.)) -import Control.Monad (when) -import Data.Aeson (Value (..), object, toJSON, (.=)) -import Data.Functor (void) -import Data.List (find) -import qualified Data.Map as Map -import Data.Maybe (fromJust, isJust) -import qualified Data.Text as T -import Ide.Plugin.Config (Config (..), PluginConfig (..)) -import qualified Ide.Plugin.Config as Plugin -import qualified Ide.Plugin.Hlint as HLint -import Ide.Types (PluginId) -import qualified Language.LSP.Types.Lens as L -import System.FilePath (()) +import Control.Lens ((^.)) +import Control.Monad (when) +import Data.Aeson (Value (..), object, toJSON, (.=)) +import Data.Functor (void) +import Data.List (find) +import qualified Data.Map as Map +import Data.Maybe (fromJust, isJust) +import Data.Row ((.+), (.==)) +import qualified Data.Text as T +import Ide.Plugin.Config (Config (..), PluginConfig (..)) +import qualified Ide.Plugin.Config as Plugin +import qualified Ide.Plugin.Hlint as HLint +import Ide.Types (PluginId) +import qualified Language.LSP.Protocol.Lens as L +import System.FilePath (()) import Test.Hls main :: IO () @@ -34,6 +36,7 @@ , configTests , ignoreHintTests , applyHintTests + , resolveTests ] getIgnoreHintText :: T.Text -> T.Text @@ -42,6 +45,22 @@ getApplyHintText :: T.Text -> T.Text getApplyHintText name = "Apply hint \"" <> name <> "\"" +resolveTests :: TestTree +resolveTests = testGroup "hlint resolve tests" + [ + ignoreHintGoldenResolveTest + "Resolve version of: 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" + , applyHintGoldenResolveTest + "Resolve version of: [#2612] Apply hint works when operator fixities go right-to-left" + "RightToLeftFixities" + (Point 6 13) + "Avoid reverse" + ] + + ignoreHintTests :: TestTree ignoreHintTests = testGroup "hlint ignore hint tests" [ @@ -77,7 +96,7 @@ liftIO $ do length diags @?= 2 -- "Eta Reduce" and "Redundant Id" reduceDiag ^. L.range @?= Range (Position 1 0) (Position 1 12) - reduceDiag ^. L.severity @?= Just DsInfo + reduceDiag ^. L.severity @?= Just DiagnosticSeverity_Information reduceDiag ^. L.code @?= Just (InR "refact:Eta reduce") reduceDiag ^. L.source @?= Just "hlint" @@ -123,15 +142,16 @@ doc <- openDoc "Base.hs" "haskell" testHlintDiagnostics doc - let change = TextDocumentContentChangeEvent - (Just (Range (Position 1 8) (Position 1 12))) - Nothing "x" + let change = TextDocumentContentChangeEvent $ InL $ #range .== Range (Position 1 8) (Position 1 12) + .+ #rangeLength .== Nothing + .+ #text .== "x" changeDoc doc [change] expectNoMoreDiagnostics 3 doc "hlint" - let change' = TextDocumentContentChangeEvent - (Just (Range (Position 1 8) (Position 1 12))) - Nothing "id x" + let change' = TextDocumentContentChangeEvent $ InL $ #range .== Range (Position 1 8) (Position 1 12) + .+ #rangeLength .== Nothing + .+ #text .== "id x" + changeDoc doc [change'] testHlintDiagnostics doc @@ -182,11 +202,11 @@ doc <- openDoc "IgnoreAnnHlint.hs" "haskell" expectNoMoreDiagnostics 3 doc "hlint" - , knownBrokenForGhcVersions [GHC92, GHC94] "apply-refact has different behavior on v0.10" $ + , knownBrokenForGhcVersions [GHC92, GHC94, GHC96] "apply-refact has different behavior on v0.10" $ testCase "apply-refact preserve regular comments" $ runHlintSession "" $ do testRefactor "Comments.hs" "Redundant bracket" expectedComments - , onlyRunForGhcVersions [GHC92, GHC94] "only run test for apply-refact-0.10" $ + , onlyRunForGhcVersions [GHC92, GHC94, GHC96] "only run test for apply-refact-0.10" $ testCase "apply-refact preserve regular comments" $ runHlintSession "" $ do testRefactor "Comments.hs" "Redundant bracket" expectedComments' @@ -323,7 +343,7 @@ liftIO $ do length diags' @?= 1 d ^. L.range @?= Range (Position 1 10) (Position 1 21) - d ^. L.severity @?= Just DsInfo + d ^. L.severity @?= Just DiagnosticSeverity_Information ] testDir :: FilePath @@ -331,7 +351,7 @@ runHlintSession :: FilePath -> Session a -> IO a runHlintSession subdir = - failIfSessionTimeout . runSessionWithServer hlintPlugin (testDir subdir) + failIfSessionTimeout . runSessionWithServerAndCaps hlintPlugin codeActionNoResolveCaps (testDir subdir) noHlintDiagnostics :: [Diagnostic] -> Assertion noHlintDiagnostics diags = @@ -419,5 +439,25 @@ setupGoldenHlintTest :: TestName -> FilePath -> (TextDocumentIdentifier -> Session ()) -> TestTree setupGoldenHlintTest testName path = - goldenWithHaskellDoc hlintPlugin testName testDir path "expected" "hs" + goldenWithHaskellAndCaps codeActionNoResolveCaps hlintPlugin testName testDir path "expected" "hs" +ignoreHintGoldenResolveTest :: TestName -> FilePath -> Point -> T.Text -> TestTree +ignoreHintGoldenResolveTest testCaseName goldenFilename point hintName = + goldenResolveTest testCaseName goldenFilename point (getIgnoreHintText hintName) + +applyHintGoldenResolveTest :: TestName -> FilePath -> Point -> T.Text -> TestTree +applyHintGoldenResolveTest testCaseName goldenFilename point hintName = do + goldenResolveTest testCaseName goldenFilename point (getApplyHintText hintName) + +goldenResolveTest :: TestName -> FilePath -> Point -> T.Text -> TestTree +goldenResolveTest testCaseName goldenFilename point hintText = + setupGoldenHlintResolveTest testCaseName goldenFilename $ \document -> do + waitForDiagnosticsFromSource document "hlint" + actions <- getAndResolveCodeActions document $ pointToRange point + case find ((== Just hintText) . getCodeActionTitle) actions of + Just (InR codeAction) -> executeCodeAction codeAction + _ -> liftIO $ assertFailure $ makeCodeActionNotFoundAtString point + +setupGoldenHlintResolveTest :: TestName -> FilePath -> (TextDocumentIdentifier -> Session ()) -> TestTree +setupGoldenHlintResolveTest testName path = + goldenWithHaskellAndCaps codeActionResolveCaps hlintPlugin testName testDir path "expected" "hs"