hls-hlint-plugin 1.0.2.1 → 1.0.3.0
raw patch · 12 files changed
+334/−100 lines, 12 filesdep +stmdep ~ghc-lib-parser-exdep ~ghcidedep ~hls-plugin-api
Dependencies added: stm
Dependency ranges changed: ghc-lib-parser-ex, ghcide, hls-plugin-api, hls-test-utils
Files
- hls-hlint-plugin.cabal +10/−5
- src/Ide/Plugin/Hlint.hs +153/−60
- test/Main.hs +127/−35
- test/testdata/RightToLeftFixities.expected.hs +6/−0
- test/testdata/RightToLeftFixities.hs +6/−0
- test/testdata/UnrecognizedPragmasOff.expected.hs +4/−0
- test/testdata/UnrecognizedPragmasOff.hs +3/−0
- test/testdata/UnrecognizedPragmasOn.expected.hs +5/−0
- test/testdata/UnrecognizedPragmasOn.hs +3/−0
- test/testdata/fixity/FixityDef.hs +5/−0
- test/testdata/fixity/FixityUse.hs +6/−0
- test/testdata/fixity/hie.yaml +6/−0
hls-hlint-plugin.cabal view
@@ -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 <https://github.com/haskell/haskell-language-server#readme>@@ -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
src/Ide/Plugin/Hlint.hs view
@@ -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
test/Main.hs view
@@ -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"+
+ test/testdata/RightToLeftFixities.expected.hs view
@@ -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
+ test/testdata/RightToLeftFixities.hs view
@@ -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
+ test/testdata/UnrecognizedPragmasOff.expected.hs view
@@ -0,0 +1,4 @@+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}+{-# HLINT ignore "Eta reduce" #-}+module UnrecognizedPragmasOff where+foo x = id x
+ test/testdata/UnrecognizedPragmasOff.hs view
@@ -0,0 +1,3 @@+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}+module UnrecognizedPragmasOff where+foo x = id x
+ test/testdata/UnrecognizedPragmasOn.expected.hs view
@@ -0,0 +1,5 @@+{-# OPTIONS_GHC -Wunrecognised-pragmas #-}+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}+{-# HLINT ignore "Eta reduce" #-}+module UnrecognizedPragmasOn where+foo x = id x
+ test/testdata/UnrecognizedPragmasOn.hs view
@@ -0,0 +1,3 @@+{-# OPTIONS_GHC -Wunrecognised-pragmas #-}+module UnrecognizedPragmasOn where+foo x = id x
+ test/testdata/fixity/FixityDef.hs view
@@ -0,0 +1,5 @@+module FixityDef where++infixl 3 <!>+(<!>) :: Maybe a -> Maybe (Maybe b) -> Maybe String+(<!>) a b = Nothing
+ test/testdata/fixity/FixityUse.hs view
@@ -0,0 +1,6 @@+module FixityUse where++import FixityDef++foo :: Char -> Maybe Int -> Maybe String+foo c mInt = show <$> mInt <!> pure <$> Just c
+ test/testdata/fixity/hie.yaml view
@@ -0,0 +1,6 @@+cradle:+ direct:+ arguments:+ - "FixityDef"+ - "FixityUse"+