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.2 name: hls-hlint-plugin -version: 0.2.0.0 +version: 1.0.0.1 synopsis: Hlint integration plugin with Haskell Language Server description: Please see Haskell Language Server Readme (https://github.com/haskell/haskell-language-server#readme) license: Apache-2.0 @@ -27,8 +27,8 @@ hs-source-dirs: src build-depends: , aeson - , apply-refact >=0.9 - , base >=4.12 && <5 + , apply-refact >=0.9 + , base >=4.12 && <5 , binary , bytestring , containers @@ -39,11 +39,11 @@ , extra , filepath , ghc-exactprint >=0.6.3.4 - , ghcide >=0.7.2.0 + , ghcide ^>= 1.0.0.0 , hashable - , haskell-lsp + , lsp , hlint >=3.2 - , hls-plugin-api >=0.7.0.0 + , hls-plugin-api ^>= 1.0.0.0 , hslogger , lens , regex-tdfa @@ -53,20 +53,21 @@ , transformers , unordered-containers - if ((!flag(ghc-lib) && impl(ghc >=8.10.1)) && impl(ghc <8.11.0)) + if (!flag(ghc-lib) && impl(ghc >=8.10.1) && impl(ghc <9.0.0)) build-depends: ghc ^>= 8.10 else build-depends: , ghc - , ghc-lib ^>= 8.10.2.20200916 + , ghc-lib ^>= 8.10.4.20210206 , ghc-lib-parser-ex ^>= 8.10 cpp-options: -DHLINT_ON_GHC_LIB - ghc-options: -Wall -Wredundant-constraints -Wno-name-shadowing + ghc-options: -Wall -Wredundant-constraints -Wno-name-shadowing -Wno-unticked-promoted-constructors if flag(pedantic) ghc-options: -Werror default-language: Haskell2010 + default-extensions: DataKinds, TypeOperators 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,74 +1,91 @@ -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PackageImports #-} -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PackageImports #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -Wno-orphans #-} module Ide.Plugin.Hlint ( descriptor --, provider ) where -import Refact.Apply -import Control.Arrow ((&&&)) -import Control.DeepSeq -import Control.Exception -import Control.Lens ((^.)) -import Control.Monad -import Control.Monad.IO.Class -import Control.Monad.Trans.Except -import Data.Aeson.Types (ToJSON(..), FromJSON(..), Value(..)) -import Data.Binary -import Data.Hashable -import qualified Data.HashMap.Strict as Map -import Data.Maybe -import qualified Data.Text as T -import qualified Data.Text.IO as T -import Data.Typeable -import Development.IDE -import Development.IDE.Core.Rules (getParsedModuleWithComments, defineNoFile) -import Development.IDE.Core.Shake (getDiagnostics) +import Control.Arrow ((&&&)) +import Control.DeepSeq +import Control.Exception +import Control.Lens ((^.)) +import Control.Monad +import Control.Monad.IO.Class +import Control.Monad.Trans.Except +import Data.Aeson.Types (FromJSON (..), + ToJSON (..), + Value (..)) +import Data.Binary +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 Data.Typeable +import Development.IDE +import Development.IDE.Core.Rules (defineNoFile, + getParsedModuleWithComments) +import Development.IDE.Core.Shake (getDiagnostics) +import Refact.Apply #ifdef HLINT_ON_GHC_LIB -import Data.List (nub) -import "ghc-lib" GHC hiding (DynFlags(..), ms_hspp_opts) -import "ghc-lib-parser" GHC.LanguageExtensions (Extension) -import "ghc" DynFlags as RealGHC.DynFlags (topDir) -import "ghc" GHC as RealGHC (DynFlags(..)) -import "ghc" HscTypes as RealGHC.HscTypes (hsc_dflags, ms_hspp_opts) -import qualified "ghc" EnumSet as EnumSet -import Language.Haskell.GhclibParserEx.GHC.Driver.Session as GhclibParserEx (readExtension) -import System.Environment(setEnv, unsetEnv) -import System.FilePath (takeFileName) -import System.IO (hPutStr, noNewlineTranslation, hSetNewlineMode, utf8, hSetEncoding, IOMode(WriteMode), withFile, hClose) -import System.IO.Temp +import Data.List (nub) +import "ghc" DynFlags as RealGHC.DynFlags (topDir) +import qualified "ghc" EnumSet as EnumSet +import "ghc" GHC as RealGHC (DynFlags (..)) +import "ghc-lib" GHC hiding + (DynFlags (..), + ms_hspp_opts) +import "ghc-lib-parser" GHC.LanguageExtensions (Extension) +import "ghc" HscTypes as RealGHC.HscTypes (hsc_dflags, + ms_hspp_opts) +import Language.Haskell.GhclibParserEx.GHC.Driver.Session as GhclibParserEx (readExtension) +import System.FilePath (takeFileName) +import System.IO (IOMode (WriteMode), + hClose, + hPutStr, + hSetEncoding, + hSetNewlineMode, + noNewlineTranslation, + utf8, + withFile) +import System.IO.Temp #else -import Development.IDE.GHC.Compat hiding (DynFlags(..)) -import Language.Haskell.GHC.ExactPrint.Parsers (postParseTransform) -import Language.Haskell.GHC.ExactPrint.Delta (deltaOptions) -import Language.Haskell.GHC.ExactPrint.Types (Rigidity(..)) +import Development.IDE.GHC.Compat hiding + (DynFlags (..)) +import Language.Haskell.GHC.ExactPrint.Delta (deltaOptions) +import Language.Haskell.GHC.ExactPrint.Parsers (postParseTransform) +import Language.Haskell.GHC.ExactPrint.Types (Rigidity (..)) #endif -import Ide.Logger -import Ide.Types -import Ide.Plugin.Config -import Ide.PluginUtils -import Language.Haskell.HLint as Hlint -import Language.Haskell.LSP.Core - ( LspFuncs(withIndefiniteProgress), - ProgressCancellable(Cancellable) ) -import Language.Haskell.LSP.Types -import qualified Language.Haskell.LSP.Types as LSP -import qualified Language.Haskell.LSP.Types.Lens as LSP +import Ide.Logger +import Ide.Plugin.Config +import Ide.PluginUtils +import Ide.Types +import Language.Haskell.HLint as Hlint +import Language.LSP.Server (ProgressCancellable (Cancellable), + sendRequest, + withIndefiniteProgress) +import Language.LSP.Types +import qualified Language.LSP.Types as LSP +import qualified Language.LSP.Types.Lens as LSP -import Text.Regex.TDFA.Text() -import GHC.Generics (Generic) +import GHC.Generics (Generic) +import Text.Regex.TDFA.Text () +import System.Environment (setEnv, + unsetEnv) -- --------------------------------------------------------------------- descriptor :: PluginId -> PluginDescriptor IdeState @@ -78,7 +95,7 @@ [ PluginCommand "applyOne" "Apply a single hint" applyOneCmd , PluginCommand "applyAll" "Apply all hints to the file" applyAllCmd ] - , pluginCodeActionProvider = Just codeActionProvider + , pluginHandlers = mkPluginHandler STextDocumentCodeAction codeActionProvider } -- This rule only exists for generating file diagnostics @@ -102,9 +119,9 @@ rules :: PluginId -> Rules () rules plugin = do define $ \GetHlintDiagnostics file -> do - config <- getClientConfigAction + config <- getClientConfigAction def let pluginConfig = configForPlugin config plugin - let hlintOn' = hlintOn config && pluginEnabled pluginConfig plcDiagnosticsOn + let hlintOn' = hlintOn config && plcGlobalOn pluginConfig && plcDiagnosticsOn pluginConfig ideas <- if hlintOn' then getIdeas file else return (Right []) return (diagnostics file ideas, Just ()) @@ -128,7 +145,7 @@ _range = srcSpanToRange $ ideaSpan idea , _severity = Just LSP.DsInfo -- we are encoding the fact that idea has refactorings in diagnostic code - , _code = Just (LSP.StringValue $ T.pack $ codePre ++ ideaHint idea) + , _code = Just (InR $ T.pack $ codePre ++ ideaHint idea) , _source = Just "hlint" , _message = idea2Message idea , _relatedInformation = Nothing @@ -151,7 +168,7 @@ LSP.Diagnostic { _range = srcSpanToRange l , _severity = Just LSP.DsInfo - , _code = Just (LSP.StringValue "parser") + , _code = Just (InR "parser") , _source = Just "hlint" , _message = T.unlines [T.pack msg,T.pack contents] , _relatedInformation = Nothing @@ -246,16 +263,15 @@ defineNoFile $ \GetHlintSettings -> liftIO $ case usage of HlintEnabled cmdArgs -> argsSettings cmdArgs - HlintDisabled -> fail "hlint configuration unspecified" + HlintDisabled -> fail "hlint configuration unspecified" -- --------------------------------------------------------------------- -codeActionProvider :: CodeActionProvider IdeState -codeActionProvider _lf ideState plId docId _ context = Right . LSP.List . map CACodeAction <$> getCodeActions +codeActionProvider :: PluginMethodHandler IdeState TextDocumentCodeAction +codeActionProvider ideState plId (CodeActionParams _ _ docId _ context) = Right . LSP.List . map InR <$> liftIO getCodeActions where getCodeActions = do - applyOne <- applyOneActions diags <- getDiagnostics ideState let docNfp = toNormalizedFilePath' <$> uriToFilePath' (docId ^. LSP.uri) numHintsInDoc = length @@ -266,54 +282,54 @@ -- We only want to show the applyAll code action if there is more than 1 -- hint in the current document if numHintsInDoc > 1 then do - applyAll <- applyAllAction - pure $ applyAll:applyOne + pure $ applyAllAction:applyOneActions else - pure applyOne + pure applyOneActions - applyAllAction = do + applyAllAction = let args = Just [toJSON (docId ^. LSP.uri)] - cmd <- mkLspCommand plId "applyAll" "Apply all hints" args - pure $ LSP.CodeAction "Apply all hints" (Just LSP.CodeActionQuickFix) Nothing Nothing (Just cmd) + cmd = mkLspCommand plId "applyAll" "Apply all hints" args + in LSP.CodeAction "Apply all hints" (Just LSP.CodeActionQuickFix) Nothing Nothing Nothing Nothing (Just cmd) - applyOneActions :: IO [LSP.CodeAction] - applyOneActions = catMaybes <$> mapM mkHlintAction (filter validCommand diags) + applyOneActions :: [LSP.CodeAction] + applyOneActions = mapMaybe mkHlintAction (filter validCommand diags) -- |Some hints do not have an associated refactoring - validCommand (LSP.Diagnostic _ _ (Just (LSP.StringValue code)) (Just "hlint") _ _ _) = + validCommand (LSP.Diagnostic _ _ (Just (InR code)) (Just "hlint") _ _ _) = "refact:" `T.isPrefixOf` code validCommand _ = False LSP.List diags = context ^. LSP.diagnostics - mkHlintAction :: LSP.Diagnostic -> IO (Maybe LSP.CodeAction) - mkHlintAction diag@(LSP.Diagnostic (LSP.Range start _) _s (Just (LSP.StringValue code)) (Just "hlint") _ _ _) = - Just . codeAction <$> mkLspCommand plId "applyOne" title (Just args) + 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 (Just cmd) + codeAction cmd = LSP.CodeAction title (Just LSP.CodeActionQuickFix) (Just (LSP.List [diag])) Nothing Nothing Nothing (Just cmd) -- 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 _ _) = return Nothing + mkHlintAction (LSP.Diagnostic _r _s _c _source _m _ _) = Nothing -- --------------------------------------------------------------------- applyAllCmd :: CommandFunction IdeState Uri -applyAllCmd lf ide uri = do +applyAllCmd ide uri = do let file = maybe (error $ show uri ++ " is not a file.") toNormalizedFilePath' (uriToFilePath' uri) - withIndefiniteProgress lf "Applying all hints" Cancellable $ do + withIndefiniteProgress "Applying all hints" Cancellable $ do logm $ "hlint:applyAllCmd:file=" ++ show file - res <- applyHint ide file Nothing + res <- liftIO $ applyHint ide file Nothing logm $ "hlint:applyAllCmd:res=" ++ show res - return $ - case res of - Left err -> (Left (responseError (T.pack $ "hlint:applyAll: " ++ show err)), Nothing) - Right fs -> (Right Null, Just (WorkspaceApplyEdit, ApplyWorkspaceEditParams fs)) + 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 -- --------------------------------------------------------------------- @@ -327,24 +343,25 @@ type HintTitle = T.Text data OneHint = OneHint - { oneHintPos :: Position + { oneHintPos :: Position , oneHintTitle :: HintTitle } deriving (Eq, Show) applyOneCmd :: CommandFunction IdeState ApplyOneParams -applyOneCmd lf ide (AOP uri pos title) = do +applyOneCmd 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 lf progTitle Cancellable $ do + withIndefiniteProgress progTitle Cancellable $ do logm $ "hlint:applyOneCmd:file=" ++ show file - res <- applyHint ide file (Just oneHint) + res <- liftIO $ applyHint ide file (Just oneHint) logm $ "hlint:applyOneCmd:res=" ++ show res - return $ - case res of - Left err -> (Left (responseError (T.pack $ "hlint:applyOne: " ++ show err)), Nothing) - Right fs -> (Right Null, Just (WorkspaceApplyEdit, ApplyWorkspaceEditParams fs)) + 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 = @@ -363,36 +380,27 @@ oldContent <- maybe (liftIO $ T.readFile fp) return mbOldContent (modsum, _) <- liftIO $ runAction' $ use_ GetModSummary nfp let dflags = ms_hspp_opts modsum + -- Setting a environment variable with the libdir used by ghc-exactprint. + -- It is a workaround for an error caused by the use of a hadcoded at compile time libdir + -- in ghc-exactprint that makes dependent executables non portables. + -- See https://github.com/alanz/ghc-exactprint/issues/96. + -- WARNING: this code is not thread safe, so if you try to apply several async refactorings + -- it could fail. That case is not very likely so we assume the risk. + let withRuntimeLibdir :: IO a -> IO a + withRuntimeLibdir = bracket_ (setEnv key $ topDir dflags) (unsetEnv key) + where key = "GHC_EXACTPRINT_GHC_LIBDIR" -- set Nothing as "position" for "applyRefactorings" because -- applyRefactorings expects the provided position to be _within_ the scope -- of each refactoring it will apply. -- But "Idea"s returned by HLint point to starting position of the expressions -- that contain refactorings, so they are often outside the refactorings' boundaries. - -- Example: - -- Given an expression "hlintTest = reid $ (myid ())" - -- Hlint returns an idea at the position (1,13) - -- That contains "Redundant brackets" refactoring at position (1,20): - -- - -- [("src/App/Test.hs:5:13: Warning: Redundant bracket\nFound:\n reid $ (myid ())\nWhy not:\n reid $ myid ()\n",[Replace {rtype = Expr, pos = SrcSpan {startLine = 5, startCol = 20, endLine = 5, endCol = 29}, subts = [("x",SrcSpan {startLine = 5, startCol = 21, endLine = 5, endCol = 28})], orig = "x"}])] - -- - -- If we provide "applyRefactorings" with "Just (1,13)" then - -- the "Redundant bracket" hint will never be executed - -- because SrcSpan (1,20,??,??) doesn't contain position (1,13). + let position = Nothing #ifdef HLINT_ON_GHC_LIB let writeFileUTF8NoNewLineTranslation file txt = withFile file WriteMode $ \h -> do hSetEncoding h utf8 hSetNewlineMode h noNewlineTranslation hPutStr h (T.unpack txt) - -- Setting a environment variable with the libdir used by ghc-exactprint. - -- It is a workaround for an error caused by the use of a hadcoded at compile time libdir - -- in ghc-exactprint that makes dependent executables non portables. - -- See https://github.com/alanz/ghc-exactprint/issues/96. - -- WARNING: this code is not thread safe, so if you try to apply several async refactorings - -- it could fail. That case is not very likely so we assume the risk. - let withRuntimeLibdir :: IO a -> IO a - withRuntimeLibdir = bracket_ (setEnv key $ topDir dflags) (unsetEnv key) - where key = "GHC_EXACTPRINT_GHC_LIBDIR" res <- liftIO $ withSystemTempFile (takeFileName fp) $ \temp h -> do hClose h @@ -402,7 +410,7 @@ -- We have to reparse extensions to remove the invalid ones let (enabled, disabled, _invalid) = parseExtensions $ map show exts let refactExts = map show $ enabled ++ disabled - (Right <$> withRuntimeLibdir (applyRefactorings Nothing commands temp refactExts)) + (Right <$> withRuntimeLibdir (applyRefactorings position commands temp refactExts)) `catches` errorHandlers #else mbParsedModule <- liftIO $ runAction' $ getParsedModuleWithComments nfp @@ -416,7 +424,7 @@ let rigidLayout = deltaOptions RigidLayout (anns', modu') <- ExceptT $ return $ postParseTransform (Right (anns, [], dflags, modu)) rigidLayout - liftIO $ (Right <$> applyRefactorings' Nothing commands anns' modu') + liftIO $ (Right <$> withRuntimeLibdir (applyRefactorings' position commands anns' modu')) `catches` errorHandlers #endif case res of