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: 1.0.2.1 +version: 1.0.3.0 synopsis: Hlint integration plugin with Haskell Language Server description: Please see the README on GitHub at @@ -36,7 +36,7 @@ manual: False description: Hlint-3.3 doesn't support versions ghc-lib < 9.0.1 nor ghc <= 8.6, so we can use hlint-3.2 for backwards compat - This flag can be removed when all dependencies support ghc-lib-9.0.1 and we drop support for ghc-8.6 + This flag can be removed when all dependencies support ghc-lib-9.0.* and we drop support for ghc-8.6 library exposed-modules: Ide.Plugin.Hlint @@ -55,18 +55,23 @@ , extra , filepath , ghc-exactprint >=0.6.3.4 - , ghcide ^>=1.5.0 + , ghcide ^>=1.6 , hashable , hlint - , hls-plugin-api >=1.1 && <1.3 + , hls-plugin-api ^>=1.3 , hslogger , lens , lsp , regex-tdfa + , stm , temporary , text , transformers , unordered-containers + -- can be removed if https://github.com/ndmitchell/hlint/pull/1325#issue-1077062712 is merged + -- and https://github.com/haskell/haskell-language-server/pull/2464#issue-1077133441 is updated + -- accordingly + , ghc-lib-parser-ex if (flag(hlint33)) -- This mirrors the logic in hlint.cabal for hlint-3.3 @@ -122,7 +127,7 @@ , filepath , hls-hlint-plugin , hls-plugin-api - , hls-test-utils >=1.0 && <1.2 + , hls-test-utils ^>=1.2 , lens , lsp-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 @@ -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,9 +26,9 @@ module Ide.Plugin.Hlint ( descriptor - --, provider ) where import Control.Arrow ((&&&)) +import Control.Concurrent.STM import Control.DeepSeq import Control.Exception import Control.Lens ((^.)) @@ -35,12 +38,13 @@ import Data.Aeson.Types (FromJSON (..), ToJSON (..), Value (..)) +import qualified Data.ByteString as BS import Data.Default import qualified Data.HashMap.Strict as Map import Data.Hashable import Data.Maybe import qualified Data.Text as T -import qualified Data.Text.IO as T +import qualified Data.Text.Encoding as T import Data.Typeable import Development.IDE hiding (Error) @@ -48,15 +52,17 @@ getParsedModuleWithComments, usePropertyAction) import Development.IDE.Core.Shake (getDiagnostics) -import Refact.Apply +import qualified Refact.Apply as Refact #ifdef HLINT_ON_GHC_LIB import Data.List (nub) -import Development.IDE.GHC.Compat.Core (BufSpan, +import Development.IDE.GHC.Compat (BufSpan, DynFlags, + WarningFlag (Opt_WarnUnrecognisedPragmas), extensionFlags, ms_hspp_opts, - topDir) + topDir, + wopt) import qualified Development.IDE.GHC.Compat.Util as EnumSet import "ghc-lib" GHC hiding (DynFlags (..), @@ -76,11 +82,14 @@ withFile) import System.IO.Temp #else -import Development.IDE.GHC.Compat.Core hiding +import Development.IDE.GHC.Compat hiding (setEnv) +import GHC.Generics (Associativity (LeftAssociative, NotAssociative, RightAssociative)) import Language.Haskell.GHC.ExactPrint.Delta (deltaOptions) import Language.Haskell.GHC.ExactPrint.Parsers (postParseTransform) import Language.Haskell.GHC.ExactPrint.Types (Rigidity (..)) +import Language.Haskell.GhclibParserEx.Fixity as GhclibParserEx (applyFixities) +import qualified Refact.Fixity as Refact #endif import Ide.Logger @@ -101,11 +110,17 @@ import qualified Language.LSP.Types as LSP import qualified Language.LSP.Types.Lens as LSP +import Development.IDE.Spans.Pragmas (LineSplitTextEdits (LineSplitTextEdits), + NextPragmaInfo (NextPragmaInfo), + getNextPragmaInfo, + lineSplitDeleteTextEdit, + lineSplitInsertTextEdit, + lineSplitTextEdits, + nextPragmaLine) import GHC.Generics (Generic) -import Text.Regex.TDFA.Text () - import System.Environment (setEnv, unsetEnv) +import Text.Regex.TDFA.Text () -- --------------------------------------------------------------------- #ifdef HLINT_ON_GHC_LIB @@ -153,9 +168,8 @@ rules plugin = do define $ \GetHlintDiagnostics file -> do config <- getClientConfigAction def - let pluginConfig = configForPlugin config plugin - let hlintOn' = hlintOn config && plcGlobalOn pluginConfig && plcDiagnosticsOn pluginConfig - ideas <- if hlintOn' then getIdeas file else return (Right []) + let hlintOn = pluginEnabledConfig plcDiagnosticsOn plugin config + ideas <- if hlintOn then getIdeas file else return (Right []) return (diagnostics file ideas, Just ()) defineNoFile $ \GetHlintSettings -> do @@ -215,11 +229,11 @@ srcSpanToRange :: SrcSpan -> LSP.Range srcSpanToRange (RealSrcSpan span _) = Range { _start = LSP.Position { - _line = srcSpanStartLine span - 1 - , _character = srcSpanStartCol span - 1} + _line = fromIntegral $ srcSpanStartLine span - 1 + , _character = fromIntegral $ srcSpanStartCol span - 1} , _end = LSP.Position { - _line = srcSpanEndLine span - 1 - , _character = srcSpanEndCol span - 1} + _line = fromIntegral $ srcSpanEndLine span - 1 + , _character = fromIntegral $ srcSpanEndCol span - 1} } srcSpanToRange (UnhelpfulSpan _) = noRange @@ -239,9 +253,23 @@ moduleEx _flags = do mbpm <- getParsedModuleWithComments nfp return $ createModule <$> mbpm - where createModule pm = Right (createModuleEx anns modu) + where + createModule pm = Right (createModuleEx anns (applyParseFlagsFixities modu)) where anns = pm_annotations pm modu = pm_parsed_source pm + + applyParseFlagsFixities :: ParsedSource -> ParsedSource + applyParseFlagsFixities modul = GhclibParserEx.applyFixities (parseFlagsToFixities _flags) modul + + parseFlagsToFixities :: ParseFlags -> [(String, Fixity)] + parseFlagsToFixities = map toFixity . Hlint.fixities + + toFixity :: FixityInfo -> (String, Fixity) + toFixity (name, dir, i) = (name, Fixity NoSourceText i $ f dir) + where + f LeftAssociative = InfixL + f RightAssociative = InfixR + f NotAssociative = InfixN #else moduleEx flags = do mbpm <- getParsedModuleWithComments nfp @@ -302,39 +330,57 @@ 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 <- 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 @@ -343,18 +389,64 @@ 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 (fromIntegral 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 @@ -418,7 +510,7 @@ liftIO $ logm $ "applyHint:apply=" ++ show commands let fp = fromNormalizedFilePath nfp (_, mbOldContent) <- liftIO $ runAction' $ getFileContents nfp - oldContent <- maybe (liftIO $ T.readFile fp) return mbOldContent + oldContent <- maybe (liftIO $ fmap T.decodeUtf8 $ BS.readFile fp) return mbOldContent modsum <- liftIO $ runAction' $ use_ GetModSummary nfp let dflags = ms_hspp_opts $ msrModSummary modsum -- Setting a environment variable with the libdir used by ghc-exactprint. @@ -449,9 +541,9 @@ (pflags, _, _) <- runAction' $ useNoFile_ GetHlintSettings exts <- runAction' $ getExtensions pflags nfp -- We have to reparse extensions to remove the invalid ones - let (enabled, disabled, _invalid) = parseExtensions $ map show exts + let (enabled, disabled, _invalid) = Refact.parseExtensions $ map show exts let refactExts = map show $ enabled ++ disabled - (Right <$> withRuntimeLibdir (applyRefactorings position commands temp refactExts)) + (Right <$> withRuntimeLibdir (Refact.applyRefactorings position commands temp refactExts)) `catches` errorHandlers #else mbParsedModule <- liftIO $ runAction' $ getParsedModuleWithComments nfp @@ -464,8 +556,9 @@ -- apply-refact uses RigidLayout let rigidLayout = deltaOptions RigidLayout (anns', modu') <- - ExceptT $ return $ postParseTransform (Right (anns, [], dflags, modu)) rigidLayout - liftIO $ (Right <$> withRuntimeLibdir (applyRefactorings' position commands anns' modu')) + ExceptT $ mapM (uncurry Refact.applyFixities) + $ postParseTransform (Right (anns, [], dflags, modu)) rigidLayout + liftIO $ (Right <$> withRuntimeLibdir (Refact.applyRefactorings' position commands anns' modu')) `catches` errorHandlers #endif case res of @@ -483,7 +576,7 @@ filterIdeas (OneHint (Position l c) title) ideas = let title' = T.unpack title ideaPos = (srcSpanStartLine &&& srcSpanStartCol) . toRealSrcSpan . ideaSpan - in filter (\i -> ideaHint i == title' && ideaPos i == (l+1, c+1)) ideas + in filter (\i -> ideaHint i == title' && ideaPos i == (fromIntegral $ l+1, fromIntegral $ c+1)) ideas toRealSrcSpan (RealSrcSpan real _) = real toRealSrcSpan (UnhelpfulSpan x) = error $ "No real source span: " ++ show x diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -1,16 +1,20 @@ +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeOperators #-} module Main ( 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 (..), - hlintOn) +import Ide.Plugin.Config (Config (..), PluginConfig (..)) import qualified Ide.Plugin.Config as Plugin import qualified Ide.Plugin.Hlint as HLint import qualified Language.LSP.Types.Lens as L @@ -27,8 +31,41 @@ tests = testGroup "hlint" [ suggestionsTests , configTests + , ignoreHintTests + , applyHintTests ] +getIgnoreHintText :: T.Text -> T.Text +getIgnoreHintText name = "Ignore hint \"" <> name <> "\" in this module" + +getApplyHintText :: T.Text -> T.Text +getApplyHintText name = "Apply hint \"" <> name <> "\"" + +ignoreHintTests :: TestTree +ignoreHintTests = testGroup "hlint ignore hint tests" + [ + ignoreHintGoldenTest + "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" + , ignoreHintGoldenTest + "Ignore hint in this module inserts only hlint ignore pragma if warn unrecognized pragmas is on" + "UnrecognizedPragmasOn" + (Point 3 9) + "Eta reduce" + ] + +applyHintTests :: TestTree +applyHintTests = testGroup "hlint apply hint tests" + [ + applyHintGoldenTest + "[#2612] Apply hint works when operator fixities go right-to-left" + "RightToLeftFixities" + (Point 6 13) + "Avoid reverse" + ] + suggestionsTests :: TestTree suggestionsTests = testGroup "hlint suggestions" [ @@ -45,13 +82,19 @@ 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) @@ -71,6 +114,10 @@ contents <- skipManyTill anyMessage $ getDocumentEdit doc liftIO $ contents @?= "main = undefined\nfoo = id\n" + , testCase ".hlint.yaml fixity rules are applied" $ runHlintSession "fixity" $ do + doc <- openDoc "FixityUse.hs" "haskell" + expectNoMoreDiagnostics 3 doc "hlint" + , testCase "changing document contents updates hlint diagnostics" $ runHlintSession "" $ do doc <- openDoc "Base.hs" "haskell" testHlintDiagnostics doc @@ -185,7 +232,7 @@ 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) @@ -219,40 +266,24 @@ , "a = id @Int 1" ] + configTests :: TestTree configTests = testGroup "hlint plugin config" [ - testCase "changing hlintOn configuration enables or disables hlint diagnostics" $ runHlintSession "" $ do - let config = def { hlintOn = True } - sendConfigurationChanged (toJSON config) - - doc <- openDoc "Base.hs" "haskell" - testHlintDiagnostics doc - - let config' = def { hlintOn = False } - sendConfigurationChanged (toJSON config') - - diags' <- waitForDiagnosticsFrom doc - - liftIO $ noHlintDiagnostics diags' - - , testCase "changing hlint plugin configuration enables or disables hlint diagnostics" $ runHlintSession "" $ do - let config = def { hlintOn = True } - sendConfigurationChanged (toJSON config) + testCase "changing hlint plugin configuration enables or disables hlint diagnostics" $ runHlintSession "" $ do + enableHlint doc <- openDoc "Base.hs" "haskell" testHlintDiagnostics doc - let config' = pluginGlobalOn config "hlint" False - sendConfigurationChanged (toJSON config') + disableHlint diags' <- waitForDiagnosticsFrom doc liftIO $ noHlintDiagnostics diags' , testCase "adding hlint flags to plugin configuration removes hlint diagnostics" $ runHlintSession "" $ do - let config = def { hlintOn = True } - sendConfigurationChanged (toJSON config) + enableHlint doc <- openDoc "Base.hs" "haskell" testHlintDiagnostics doc @@ -265,8 +296,7 @@ liftIO $ noHlintDiagnostics diags' , testCase "adding hlint flags to plugin configuration adds hlint diagnostics" $ runHlintSession "" $ do - let config = def { hlintOn = True } - sendConfigurationChanged (toJSON config) + enableHlint doc <- openDoc "Generalise.hs" "haskell" @@ -284,9 +314,12 @@ 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 = @@ -306,14 +339,19 @@ hlintConfigWithFlags :: [T.Text] -> Config hlintConfigWithFlags flags = def - { hlintOn = True - , Plugin.plugins = Map.fromList [("hlint", - def { Plugin.plcConfig = unObject $ object ["flags" .= flags] } + { Plugin.plugins = Map.fromList [("hlint", + def { Plugin.plcGlobalOn = True, Plugin.plcConfig = unObject $ object ["flags" .= flags] } )] } where unObject (Object obj) = obj unObject _ = undefined +enableHlint :: Session () +enableHlint = sendConfigurationChanged $ toJSON $ def { Plugin.plugins = Map.fromList [ ("hlint", def { Plugin.plcGlobalOn = True }) ] } + +disableHlint :: Session () +disableHlint = sendConfigurationChanged $ toJSON $ def { Plugin.plugins = Map.fromList [ ("hlint", def { Plugin.plcGlobalOn = False }) ] } + -- We have two main code paths in the plugin depending on how hlint interacts with ghc: -- * One when hlint uses ghc-lib (all ghc versions but the last version supported by hlint) -- * Another one when hlint uses directly ghc (only one version, which not have to be the last version supported by ghcide) @@ -326,3 +364,57 @@ 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 <- fromIntegral $ subtract 1 line + , column <- fromIntegral $ 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 + +ignoreHintGoldenTest :: TestName -> FilePath -> Point -> T.Text -> TestTree +ignoreHintGoldenTest testCaseName goldenFilename point hintName = + goldenTest testCaseName goldenFilename point (getIgnoreHintText hintName) + +applyHintGoldenTest :: TestName -> FilePath -> Point -> T.Text -> TestTree +applyHintGoldenTest testCaseName goldenFilename point hintName = do + goldenTest testCaseName goldenFilename point (getApplyHintText hintName) + +goldenTest :: TestName -> FilePath -> Point -> T.Text -> TestTree +goldenTest testCaseName goldenFilename point hintText = + setupGoldenHlintTest testCaseName goldenFilename $ \document -> do + waitForDiagnosticsFromSource document "hlint" + actions <- getCodeActions document $ pointToRange point + case find ((== Just hintText) . getCodeActionTitle) actions of + Just (InR codeAction) -> do + executeCodeAction codeAction + when (isJust (codeAction ^. L.command)) $ + void $ skipManyTill anyMessage $ getDocumentEdit document + _ -> liftIO $ assertFailure $ makeCodeActionNotFoundAtString point + +setupGoldenHlintTest :: TestName -> FilePath -> (TextDocumentIdentifier -> Session ()) -> TestTree +setupGoldenHlintTest testName path = + goldenWithHaskellDoc hlintPlugin testName testDir path "expected" "hs" + diff --git a/test/testdata/RightToLeftFixities.expected.hs b/test/testdata/RightToLeftFixities.expected.hs new file mode 100644 --- /dev/null +++ b/test/testdata/RightToLeftFixities.expected.hs @@ -0,0 +1,6 @@ +module RightToLeftFixities where +import Data.List (sortOn) +import Control.Arrow ((&&&)) +import Data.Ord (Down(Down)) +functionB :: [String] -> [(Char,Int)] +functionB = sortOn (Down . snd) . map (head &&& length) . id diff --git a/test/testdata/RightToLeftFixities.hs b/test/testdata/RightToLeftFixities.hs new file mode 100644 --- /dev/null +++ b/test/testdata/RightToLeftFixities.hs @@ -0,0 +1,6 @@ +module RightToLeftFixities where +import Data.List (sortOn) +import Control.Arrow ((&&&)) +import Data.Ord (Down(Down)) +functionB :: [String] -> [(Char,Int)] +functionB = reverse . sortOn snd . map (head &&& length) . id diff --git a/test/testdata/UnrecognizedPragmasOff.expected.hs b/test/testdata/UnrecognizedPragmasOff.expected.hs new file mode 100644 --- /dev/null +++ b/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/test/testdata/UnrecognizedPragmasOff.hs b/test/testdata/UnrecognizedPragmasOff.hs new file mode 100644 --- /dev/null +++ b/test/testdata/UnrecognizedPragmasOff.hs @@ -0,0 +1,3 @@ +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} +module UnrecognizedPragmasOff where +foo x = id x diff --git a/test/testdata/UnrecognizedPragmasOn.expected.hs b/test/testdata/UnrecognizedPragmasOn.expected.hs new file mode 100644 --- /dev/null +++ b/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/test/testdata/UnrecognizedPragmasOn.hs b/test/testdata/UnrecognizedPragmasOn.hs new file mode 100644 --- /dev/null +++ b/test/testdata/UnrecognizedPragmasOn.hs @@ -0,0 +1,3 @@ +{-# OPTIONS_GHC -Wunrecognised-pragmas #-} +module UnrecognizedPragmasOn where +foo x = id x diff --git a/test/testdata/fixity/FixityDef.hs b/test/testdata/fixity/FixityDef.hs new file mode 100644 --- /dev/null +++ b/test/testdata/fixity/FixityDef.hs @@ -0,0 +1,5 @@ +module FixityDef where + +infixl 3 +() :: Maybe a -> Maybe (Maybe b) -> Maybe String +() a b = Nothing diff --git a/test/testdata/fixity/FixityUse.hs b/test/testdata/fixity/FixityUse.hs new file mode 100644 --- /dev/null +++ b/test/testdata/fixity/FixityUse.hs @@ -0,0 +1,6 @@ +module FixityUse where + +import FixityDef + +foo :: Char -> Maybe Int -> Maybe String +foo c mInt = show <$> mInt pure <$> Just c diff --git a/test/testdata/fixity/hie.yaml b/test/testdata/fixity/hie.yaml new file mode 100644 --- /dev/null +++ b/test/testdata/fixity/hie.yaml @@ -0,0 +1,6 @@ +cradle: + direct: + arguments: + - "FixityDef" + - "FixityUse" +