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.3.0 +version: 1.0.4.0 synopsis: Hlint integration plugin with Haskell Language Server description: Please see the README on GitHub at @@ -55,13 +55,14 @@ , extra , filepath , ghc-exactprint >=0.6.3.4 - , ghcide ^>=1.6 + , ghcide ^>=1.7 , hashable , hlint - , hls-plugin-api ^>=1.3 + , hls-plugin-api ^>=1.4 , hslogger , lens , lsp + , refact , regex-tdfa , stm , temporary @@ -127,7 +128,7 @@ , filepath , hls-hlint-plugin , hls-plugin-api - , hls-test-utils ^>=1.2 + , hls-test-utils ^>=1.3 , 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 @@ -12,11 +12,14 @@ {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} -{-# OPTIONS_GHC -Wno-orphans #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE StrictData #-} +{-# OPTIONS_GHC -Wno-orphans #-} + #ifdef HLINT_ON_GHC_LIB #define MIN_GHC_API_VERSION(x,y,z) MIN_VERSION_ghc_lib(x,y,z) #else @@ -26,6 +29,7 @@ module Ide.Plugin.Hlint ( descriptor + , Log(..) ) where import Control.Arrow ((&&&)) import Control.Concurrent.STM @@ -53,9 +57,9 @@ usePropertyAction) import Development.IDE.Core.Shake (getDiagnostics) import qualified Refact.Apply as Refact +import qualified Refact.Types as Refact #ifdef HLINT_ON_GHC_LIB -import Data.List (nub) import Development.IDE.GHC.Compat (BufSpan, DynFlags, WarningFlag (Opt_WarnUnrecognisedPragmas), @@ -83,7 +87,7 @@ import System.IO.Temp #else import Development.IDE.GHC.Compat hiding - (setEnv) + (setEnv, (<+>)) import GHC.Generics (Associativity (LeftAssociative, NotAssociative, RightAssociative)) import Language.Haskell.GHC.ExactPrint.Delta (deltaOptions) import Language.Haskell.GHC.ExactPrint.Parsers (postParseTransform) @@ -92,7 +96,6 @@ import qualified Refact.Fixity as Refact #endif -import Ide.Logger import Ide.Plugin.Config hiding (Config) import Ide.Plugin.Properties @@ -110,6 +113,7 @@ import qualified Language.LSP.Types as LSP import qualified Language.LSP.Types.Lens as LSP +import qualified Development.IDE.Core.Shake as Shake import Development.IDE.Spans.Pragmas (LineSplitTextEdits (LineSplitTextEdits), NextPragmaInfo (NextPragmaInfo), getNextPragmaInfo, @@ -123,6 +127,22 @@ import Text.Regex.TDFA.Text () -- --------------------------------------------------------------------- +data Log + = LogShake Shake.Log + | LogApplying NormalizedFilePath (Either String WorkspaceEdit) + | LogGeneratedIdeas NormalizedFilePath [[Refact.Refactoring Refact.SrcSpan]] + | LogGetIdeas NormalizedFilePath + | LogUsingExtensions NormalizedFilePath [String] -- Extension is only imported conditionally, so we just stringify them + deriving Show + +instance Pretty Log where + pretty = \case + LogShake log -> pretty log + LogApplying fp res -> "Applying hint(s) for" <+> viaShow fp <> ":" <+> viaShow res + 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 + #ifdef HLINT_ON_GHC_LIB -- Reimplementing this, since the one in Development.IDE.GHC.Compat isn't for ghc-lib pattern RealSrcSpan :: GHC.RealSrcSpan -> Maybe BufSpan -> GHC.SrcSpan @@ -134,12 +154,12 @@ {-# COMPLETE RealSrcSpan, UnhelpfulSpan #-} #endif -descriptor :: PluginId -> PluginDescriptor IdeState -descriptor plId = (defaultPluginDescriptor plId) - { pluginRules = rules plId +descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState +descriptor recorder plId = (defaultPluginDescriptor plId) + { pluginRules = rules recorder plId , pluginCommands = - [ PluginCommand "applyOne" "Apply a single hint" applyOneCmd - , PluginCommand "applyAll" "Apply all hints to the file" applyAllCmd + [ PluginCommand "applyOne" "Apply a single hint" (applyOneCmd recorder) + , PluginCommand "applyAll" "Apply all hints to the file" (applyAllCmd recorder) ] , pluginHandlers = mkPluginHandler STextDocumentCodeAction codeActionProvider , pluginConfigDescriptor = defaultConfigDescriptor @@ -164,15 +184,15 @@ -- | - `getIdeas` -> `getFileContents` if the hls ghc does not match the hlint default ghc -- | - The client settings have changed, to honour the `hlintOn` setting, via `getClientConfigAction` -- | - The hlint specific settings have changed, via `getHlintSettingsRule` -rules :: PluginId -> Rules () -rules plugin = do - define $ \GetHlintDiagnostics file -> do +rules :: Recorder (WithPriority Log) -> PluginId -> Rules () +rules recorder plugin = do + define (cmapWithPrio LogShake recorder) $ \GetHlintDiagnostics file -> do config <- getClientConfigAction def let hlintOn = pluginEnabledConfig plcDiagnosticsOn plugin config - ideas <- if hlintOn then getIdeas file else return (Right []) + ideas <- if hlintOn then getIdeas recorder file else return (Right []) return (diagnostics file ideas, Just ()) - defineNoFile $ \GetHlintSettings -> do + defineNoFile (cmapWithPrio LogShake recorder) $ \GetHlintSettings -> do (Config flags) <- getHlintConfig plugin liftIO $ argsSettings flags @@ -237,9 +257,9 @@ } srcSpanToRange (UnhelpfulSpan _) = noRange -getIdeas :: NormalizedFilePath -> Action (Either ParseError [Idea]) -getIdeas nfp = do - debugm $ "hlint:getIdeas:file:" ++ show nfp +getIdeas :: Recorder (WithPriority Log) -> NormalizedFilePath -> Action (Either ParseError [Idea]) +getIdeas recorder nfp = do + logWith recorder Debug $ LogGetIdeas nfp (flags, classify, hint) <- useNoFile_ GetHlintSettings let applyHints' (Just (Right modEx)) = Right $ applyHints classify hint [modEx] @@ -284,16 +304,26 @@ Just <$> liftIO (parseModuleEx flags' fp contents') setExtensions flags = do - hlintExts <- getExtensions flags nfp - debugm $ "hlint:getIdeas:setExtensions:" ++ show hlintExts + hlintExts <- getExtensions nfp + logWith recorder Debug $ LogUsingExtensions nfp (fmap show hlintExts) return $ flags { enabledExtensions = hlintExts } -getExtensions :: ParseFlags -> NormalizedFilePath -> Action [Extension] -getExtensions pflags nfp = do +-- Gets extensions from ModSummary dynflags for the file. +-- Previously this would union extensions from both hlint's parsedFlags +-- and the ModSummary dynflags. However using the parsedFlags extensions +-- can sometimes interfere with the hlint parsing of the file. +-- See https://github.com/haskell/haskell-language-server/issues/1279 +-- +-- Note: this is used when HLINT_ON_GHC_LIB is defined. We seem to need +-- these extensions to construct dynflags to parse the file again. Therefore +-- using hlint default extensions doesn't seem to be a problem when +-- HLINT_ON_GHC_LIB is not defined because we don't parse the file again. +getExtensions :: NormalizedFilePath -> Action [Extension] +getExtensions nfp = do dflags <- getFlags let hscExts = EnumSet.toList (extensionFlags dflags) let hscExts' = mapMaybe (GhclibParserEx.readExtension . show) hscExts - let hlintExts = nub $ enabledExtensions pflags ++ hscExts' + let hlintExts = hscExts' return hlintExts where getFlags :: Action DynFlags getFlags = do @@ -449,15 +479,14 @@ combinedTextEdit : lineSplitTextEditList -- --------------------------------------------------------------------- -applyAllCmd :: CommandFunction IdeState Uri -applyAllCmd ide uri = do +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 - logm $ "hlint:applyAllCmd:file=" ++ show file - res <- liftIO $ applyHint ide file Nothing - logm $ "hlint:applyAllCmd:res=" ++ show res + 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 @@ -480,37 +509,36 @@ , oneHintTitle :: HintTitle } deriving (Eq, Show) -applyOneCmd :: CommandFunction IdeState ApplyOneParams -applyOneCmd ide (AOP uri pos title) = do +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 - logm $ "hlint:applyOneCmd:file=" ++ show file - res <- liftIO $ applyHint ide file (Just oneHint) - logm $ "hlint:applyOneCmd:res=" ++ show res + 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 -applyHint :: IdeState -> NormalizedFilePath -> Maybe OneHint -> IO (Either String WorkspaceEdit) -applyHint ide nfp mhint = +applyHint :: Recorder (WithPriority Log) -> IdeState -> NormalizedFilePath -> Maybe OneHint -> IO (Either String WorkspaceEdit) +applyHint recorder ide nfp mhint = 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 nfp + ideas <- bimapExceptT showParseError id $ ExceptT $ runAction' $ getIdeas recorder nfp let ideas' = maybe ideas (`filterIdeas` ideas) mhint let commands = map ideaRefactoring ideas' - liftIO $ logm $ "applyHint:apply=" ++ show commands + logWith recorder Debug $ LogGeneratedIdeas nfp commands let fp = fromNormalizedFilePath nfp (_, mbOldContent) <- liftIO $ runAction' $ getFileContents nfp - oldContent <- maybe (liftIO $ fmap T.decodeUtf8 $ BS.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. @@ -538,8 +566,7 @@ liftIO $ withSystemTempFile (takeFileName fp) $ \temp h -> do hClose h writeFileUTF8NoNewLineTranslation temp oldContent - (pflags, _, _) <- runAction' $ useNoFile_ GetHlintSettings - exts <- runAction' $ getExtensions pflags nfp + exts <- runAction' $ getExtensions nfp -- We have to reparse extensions to remove the invalid ones let (enabled, disabled, _invalid) = Refact.parseExtensions $ map show exts let refactExts = map show $ enabled ++ disabled @@ -565,7 +592,6 @@ Right appliedFile -> do let uri = fromNormalizedUri (filePathToUri' nfp) let wsEdit = diffText' True (uri, oldContent) (T.pack appliedFile) IncludeDeletions - liftIO $ logm $ "hlint:applyHint:diff=" ++ show wsEdit ExceptT $ return (Right wsEdit) Left err -> throwE err diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -25,7 +25,7 @@ main = defaultTestRunner tests hlintPlugin :: PluginDescriptor IdeState -hlintPlugin = HLint.descriptor "hlint" +hlintPlugin = HLint.descriptor mempty "hlint" tests :: TestTree tests = testGroup "hlint" [ @@ -134,8 +134,7 @@ changeDoc doc [change'] testHlintDiagnostics doc - , knownBrokenForHlintOnGhcLib "hlint doesn't take in account cpp flag as ghc -D argument" $ - testCase "[#554] hlint diagnostics works with CPP via ghc -XCPP argument" $ runHlintSession "cpp" $ do + , testCase "[#554] hlint diagnostics works with CPP via ghc -XCPP argument" $ runHlintSession "cpp" $ do doc <- openDoc "CppCond.hs" "haskell" testHlintDiagnostics doc @@ -212,8 +211,7 @@ length diags @?= 1 unusedExt ^. L.code @?= Just (InR "refact:Unused LANGUAGE pragma") - , knownBrokenForHlintOnGhcLib "[#1279] hlint uses a fixed set of extensions" $ - testCase "hlint should not activate extensions like PatternSynonyms" $ runHlintSession "" $ do + , testCase "[#1279] hlint should not activate extensions like PatternSynonyms" $ runHlintSession "" $ do doc <- openDoc "PatternKeyword.hs" "haskell" waitForAllProgressDone