From 1ce53164f95d55b04fbcc841937c82ccfd955e08 Mon Sep 17 00:00:00 2001 From: Alan Zimmerman Date: Mon, 10 Feb 2020 20:59:19 +0000 Subject: [PATCH 01/71] WIP on integrating hlint using DAML approach But getting a mismatch on ghc-lib vs GHC types for the call to hlint. Closes #32 --- exe/Main.hs | 5 +- haskell-language-server.cabal | 47 +++ src/Ide/Plugin/Hlint.hs | 532 ++++++++++++++++++++++++++++++++++ 3 files changed, 583 insertions(+), 1 deletion(-) create mode 100644 src/Ide/Plugin/Hlint.hs diff --git a/exe/Main.hs b/exe/Main.hs index a3df59e7bc..575d80b3a0 100644 --- a/exe/Main.hs +++ b/exe/Main.hs @@ -11,6 +11,7 @@ import Ide.Main (defaultMain) import Ide.Types (IdePlugins) -- haskell-language-server plugins + import Ide.Plugin.Eval as Eval import Ide.Plugin.Example as Example import Ide.Plugin.Example2 as Example2 @@ -22,6 +23,7 @@ import Ide.Plugin.Ormolu as Ormolu import Ide.Plugin.Retrie as Retrie import Ide.Plugin.StylishHaskell as StylishHaskell import Ide.Plugin.Tactic as Tactic +import Ide.Plugin.Hlint as Hlint #if AGPL import Ide.Plugin.Brittany as Brittany #endif @@ -55,11 +57,12 @@ idePlugins includeExamples = pluginDescToIdePlugins allPlugins , StylishHaskell.descriptor "stylish-haskell" , Retrie.descriptor "retrie" #if AGPL - , Brittany.descriptor "brittany" + , Brittany.descriptor "brittany" #endif , Eval.descriptor "eval" , ImportLens.descriptor "importLens" , ModuleName.descriptor "moduleName" + , Hlint.descriptor "hlint" ] examplePlugins = [Example.descriptor "eg" diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal index 6b514fc6f4..addbf8af74 100644 --- a/haskell-language-server.cabal +++ b/haskell-language-server.cabal @@ -77,6 +77,53 @@ library default-language: Haskell2010 +flag ghc-lib + default: False + manual: True + description: Force dependency on ghc-lib-parser even if GHC API in the ghc package is supported + +library hls-ghc-lib + exposed-modules: + Ide.Plugin.Hlint + hs-source-dirs: + src + build-depends: + base + , aeson + , binary + , bytestring + , containers + , data-default + , deepseq + , directory + , extra + , filepath + , ghcide + , hashable + , haskell-lsp + , haskell-src-exts + , hlint >= 3.0 + , regex-tdfa + , shake + , text + , transformers + , unordered-containers + if !flag(ghc-lib) && impl(ghc >= 8.10.1) && impl(ghc < 8.11.0) + build-depends: + ghc == 8.10.* + else + build-depends: + ghc-lib == 8.10.* + + ghc-options: + -Wall + -Wredundant-constraints + -Wno-name-shadowing + if flag(pedantic) + ghc-options: -Werror + + default-language: Haskell2010 + executable haskell-language-server import: agpl, common-deps main-is: Main.hs diff --git a/src/Ide/Plugin/Hlint.hs b/src/Ide/Plugin/Hlint.hs new file mode 100644 index 0000000000..c3ea2f604d --- /dev/null +++ b/src/Ide/Plugin/Hlint.hs @@ -0,0 +1,532 @@ +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} + +module Ide.Plugin.Hlint + ( + descriptor + --, provider + ) where + +-- import DA.Daml.DocTest +-- import Development.IDE.Core.Service.Daml +-- import qualified DA.Daml.LF.Ast as LF +-- import qualified DA.Daml.LF.ScenarioServiceClient as SS +-- import Control.Exception.Safe +-- import Development.IDE.Core.RuleTypes.Daml +-- import Development.IDE.Core.Rules +-- import Development.IDE.Core.Service.Daml +-- import Development.IDE.Types.Location +-- import qualified DA.Daml.LF.Ast as LF +-- import qualified DA.Daml.Visual as Visual +-- import qualified Data.NameMap as NM +import Control.DeepSeq +import Control.Exception +import Control.Monad +import Control.Monad.Extra +import Control.Monad.Trans.Maybe +import qualified Data.Aeson as Aeson +import Data.Aeson.Types (toJSON, fromJSON, Value(..), Result(..)) +import Data.Binary +import qualified Data.ByteString as BS +import Data.Either.Extra +import Data.Foldable +import Data.Functor +import qualified Data.HashMap.Strict as Map +import Data.Hashable +import Data.List +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Data.Maybe +import qualified Data.Set as Set +import Data.Set (Set) +import qualified Data.Text as T +import Data.Typeable +import Data.Typeable (Typeable) +import Development.IDE.Core.OfInterest +import Development.IDE.Core.RuleTypes +import Development.IDE.Core.Rules +import Development.IDE.Core.Service +import Development.IDE.Core.Shake +import Development.IDE.LSP.Server +import Development.IDE.Plugin +import Development.IDE.Types.Diagnostics as D +import Development.IDE.Types.Location +import Development.IDE.Types.Logger +import Development.Shake +-- import Development.Shake hiding ( Diagnostic ) +import GHC +import GHC.Generics +import GHC.Generics (Generic) +import HscTypes (ModIface, ModSummary) +import Ide.Types +import qualified Language.Haskell.Exts.SrcLoc as HSE +import Language.Haskell.HLint +import Language.Haskell.HLint as Hlint +import qualified Language.Haskell.LSP.Core as LSP +import Language.Haskell.LSP.Messages +import Language.Haskell.LSP.Types +import qualified Language.Haskell.LSP.Types as LSP +import qualified Language.Haskell.LSP.Types.Lens as LSP +import System.Directory +import System.Directory.Extra as Dir +import System.Environment.Blank +import System.FilePath +import System.IO.Error +import Text.Regex.TDFA.Text() + + +-- import "ghc-lib-parser" Module (UnitId) +-- --------------------------------------------------------------------- + +descriptor :: PluginId -> PluginDescriptor +descriptor plId = (defaultPluginDescriptor plId) + { pluginRules = rules +-- , pluginCommands = +-- [ PluginCommand "applyOne" "Apply a single hint" applyOneCmd +-- , PluginCommand "applyAll" "Apply all hints to the file" applyAllCmd +-- ] +-- , pluginCodeActionProvider = Just codeActionProvider + } + +data GetHlintDiagnostics = GetHlintDiagnostics + deriving (Eq, Show, Typeable, Generic) +instance Hashable GetHlintDiagnostics +instance NFData GetHlintDiagnostics +instance Binary GetHlintDiagnostics + +type instance RuleResult GetHlintDiagnostics = () + +rules :: Rules () +rules = do + define $ \GetHlintDiagnostics file -> do + pm <- use_ GetParsedModule file + let anns = pm_annotations pm + let modu = pm_parsed_source pm + (classify, hint) <- useNoFile_ GetHlintSettings + let ideas = applyHints classify hint [createModuleEx anns modu] + return ([diagnostic file i | i <- ideas, ideaSeverity i /= Ignore], Just ()) + + action $ do + files <- getFilesOfInterest + void $ uses GetHlintDiagnostics $ Set.toList files + + where + srcSpanToRange :: HSE.SrcSpan -> LSP.Range + srcSpanToRange span = Range { + _start = LSP.Position { + _line = HSE.srcSpanStartLine span - 1 + , _character = HSE.srcSpanStartColumn span - 1} + , _end = LSP.Position { + _line = HSE.srcSpanEndLine span - 1 + , _character = HSE.srcSpanEndColumn span - 1} + } + diagnostic :: NormalizedFilePath -> Idea -> FileDiagnostic + diagnostic file i = + (file, ShowDiag, LSP.Diagnostic { + _range = srcSpanToRange $ ideaSpan i + , _severity = Just LSP.DsInfo + , _code = Nothing + , _source = Just "hlint" + , _message = T.pack $ show i + , _relatedInformation = Nothing + }) + +-- --------------------------------------------------------------------- + +data HlintUsage + = HlintEnabled { hlintUseDataDir :: FilePath, hlintAllowOverrides :: Bool } + | HlintDisabled + deriving Show + +data GetHlintSettings = GetHlintSettings + deriving (Eq, Show, Typeable, Generic) +instance Hashable GetHlintSettings +instance NFData GetHlintSettings +instance NFData Hint where rnf = rwhnf +instance NFData Classify where rnf = rwhnf +instance Show Hint where show = const "" +instance Binary GetHlintSettings + +type instance RuleResult GetHlintSettings = ([Classify], Hint) + +getHlintSettingsRule :: HlintUsage -> Rules () +getHlintSettingsRule usage = + defineNoFile $ \GetHlintSettings -> + liftIO $ case usage of + HlintEnabled dir enableOverrides -> hlintSettings dir enableOverrides + HlintDisabled -> fail "hlint configuration unspecified" + +hlintSettings :: FilePath -> Bool -> IO ([Classify], Hint) +hlintSettings hlintDataDir enableOverrides = do + curdir <- getCurrentDirectory + home <- ((:[]) <$> getHomeDirectory) `catchIOError` (const $ return []) + hlintYaml <- if enableOverrides + then + findM Dir.doesFileExist $ + map ( ".hlint.yaml") (ancestors curdir ++ home) + else + return Nothing + (_, cs, hs) <- foldMapM parseSettings $ + (hlintDataDir "hlint.yaml") : maybeToList hlintYaml + return (cs, hs) + where + ancestors = init . map joinPath . reverse . inits . splitPath + -- `findSettings` calls `readFilesConfig` which in turn calls + -- `readFileConfigYaml` which finally calls `decodeFileEither` from + -- the `yaml` library. Annoyingly that function catches async + -- exceptions and in particular, it ends up catching + -- `ThreadKilled`. So, we have to mask to stop it from doing that. + parseSettings f = mask $ \unmask -> + findSettings (unmask . const (return (f, Nothing))) (Just f) + foldMapM f = foldlM (\acc a -> do w <- f a; return $! mappend acc w) mempty + +-- --------------------------------------------------------------------- +-- --------------------------------------------------------------------- +-- --------------------------------------------------------------------- +{- +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE OverloadedStrings #-} +-- | apply-refact applies refactorings specified by the refact package. It is +-- currently integrated into hlint to enable the automatic application of +-- suggestions. +module Haskell.Ide.Engine.Plugin.ApplyRefact where + +import Control.Arrow +import Control.Exception ( IOException + , ErrorCall + , Handler(..) + , catches + , try + ) +import Control.Lens hiding ( List ) +import Control.Monad.IO.Class +import Control.Monad.Trans.Except +import Data.Aeson hiding (Error) +import Data.Maybe + +#if __GLASGOW_HASKELL__ < 808 +import Data.Monoid ((<>)) +#endif + +import qualified Data.Text as T +import GHC.Generics +import Haskell.Ide.Engine.MonadFunctions +import Haskell.Ide.Engine.MonadTypes +import Haskell.Ide.Engine.PluginUtils +import Language.Haskell.Exts.SrcLoc +import Language.Haskell.Exts.Parser +import Language.Haskell.Exts.Extension +import Language.Haskell.HLint4 as Hlint +import qualified Language.Haskell.LSP.Types as LSP +import qualified Language.Haskell.LSP.Types.Lens as LSP +import Refact.Apply + +-- --------------------------------------------------------------------- +{-# ANN module ("HLint: ignore Eta reduce" :: String) #-} +{-# ANN module ("HLint: ignore Redundant do" :: String) #-} +{-# ANN module ("HLint: ignore Reduce duplication" :: String) #-} +-- --------------------------------------------------------------------- + +type HintTitle = T.Text + +applyRefactDescriptor :: PluginId -> PluginDescriptor +applyRefactDescriptor plId = PluginDescriptor + { pluginId = plId + , pluginName = "ApplyRefact" + , pluginDesc = "apply-refact applies refactorings specified by the refact package. It is currently integrated into hlint to enable the automatic application of suggestions." + , pluginCommands = + [ PluginCommand "applyOne" "Apply a single hint" applyOneCmd + , PluginCommand "applyAll" "Apply all hints to the file" applyAllCmd + ] + , pluginCodeActionProvider = Just codeActionProvider + , pluginDiagnosticProvider = Nothing + , pluginHoverProvider = Nothing + , pluginSymbolProvider = Nothing + , pluginFormattingProvider = Nothing + } + +-- --------------------------------------------------------------------- + +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 OneHint = OneHint + { oneHintPos :: Position + , oneHintTitle :: HintTitle + } deriving (Eq, Show) + +applyOneCmd :: ApplyOneParams -> IdeGhcM (IdeResult WorkspaceEdit) +applyOneCmd (AOP uri pos title) = pluginGetFile "applyOne: " uri $ \fp -> do + let oneHint = OneHint pos title + revMapp <- reverseFileMap + let defaultResult = do + debugm "applyOne: no access to the persisted file." + return $ IdeResultOk mempty + withMappedFile fp defaultResult $ \file' -> do + res <- liftToGhc $ applyHint file' (Just oneHint) revMapp + logm $ "applyOneCmd:file=" ++ show fp + logm $ "applyOneCmd:res=" ++ show res + case res of + Left err -> return $ IdeResultFail + (IdeError PluginError (T.pack $ "applyOne: " ++ show err) Null) + Right fs -> return (IdeResultOk fs) + + +-- --------------------------------------------------------------------- + +applyAllCmd :: Uri -> IdeGhcM (IdeResult WorkspaceEdit) +applyAllCmd uri = pluginGetFile "applyAll: " uri $ \fp -> do + let defaultResult = do + debugm "applyAll: no access to the persisted file." + return $ IdeResultOk mempty + revMapp <- reverseFileMap + withMappedFile fp defaultResult $ \file' -> do + res <- liftToGhc $ applyHint file' Nothing revMapp + logm $ "applyAllCmd:res=" ++ show res + case res of + Left err -> return $ IdeResultFail (IdeError PluginError + (T.pack $ "applyAll: " ++ show err) Null) + Right fs -> return (IdeResultOk fs) + +-- --------------------------------------------------------------------- + +-- AZ:TODO: Why is this in IdeGhcM? +lint :: Uri -> IdeGhcM (IdeResult PublishDiagnosticsParams) +lint uri = pluginGetFile "lint: " uri $ \fp -> do + let + defaultResult = do + debugm "lint: no access to the persisted file." + return + $ IdeResultOk (PublishDiagnosticsParams (filePathToUri fp) $ List []) + withMappedFile fp defaultResult $ \file' -> do + eitherErrorResult <- liftIO + (try $ runExceptT $ runLint file' [] :: IO + (Either IOException (Either [Diagnostic] [Idea])) + ) + case eitherErrorResult of + Left err -> return $ IdeResultFail + (IdeError PluginError (T.pack $ "lint: " ++ show err) Null) + Right res -> case res of + Left diags -> + return + (IdeResultOk + (PublishDiagnosticsParams (filePathToUri fp) $ List diags) + ) + Right fs -> + return + $ IdeResultOk + $ PublishDiagnosticsParams (filePathToUri fp) + $ List (map hintToDiagnostic $ stripIgnores fs) + +runLint :: FilePath -> [String] -> ExceptT [Diagnostic] IO [Idea] +runLint fp args = do + (flags,classify,hint) <- liftIO $ argsSettings args + let myflags = flags { hseFlags = (hseFlags flags) { extensions = EnableExtension TypeApplications:extensions (hseFlags flags)}} + res <- bimapExceptT parseErrorToDiagnostic id $ ExceptT $ parseModuleEx myflags fp Nothing + pure $ applyHints classify hint [res] + +parseErrorToDiagnostic :: Hlint.ParseError -> [Diagnostic] +parseErrorToDiagnostic (Hlint.ParseError l msg contents) = + [Diagnostic + { _range = srcLoc2Range l + , _severity = Just DsInfo -- Not displayed + , _code = Just (LSP.StringValue "parser") + , _source = Just "hlint" + , _message = T.unlines [T.pack msg,T.pack contents] + , _relatedInformation = Nothing + }] + +{- +-- | An idea suggest by a 'Hint'. +data Idea = Idea + {ideaModule :: String -- ^ The module the idea applies to, may be @\"\"@ if the module cannot be determined or is a result of cross-module hints. + ,ideaDecl :: String -- ^ The declaration the idea applies to, typically the function name, but may be a type name. + ,ideaSeverity :: Severity -- ^ The severity of the idea, e.g. 'Warning'. + ,ideaHint :: String -- ^ The name of the hint that generated the idea, e.g. @\"Use reverse\"@. + ,ideaSpan :: SrcSpan -- ^ The source code the idea relates to. + ,ideaFrom :: String -- ^ The contents of the source code the idea relates to. + ,ideaTo :: Maybe String -- ^ The suggested replacement, or 'Nothing' for no replacement (e.g. on parse errors). + ,ideaNote :: [Note] -- ^ Notes about the effect of applying the replacement. + ,ideaRefactoring :: [Refactoring R.SrcSpan] -- ^ How to perform this idea + } + deriving (Eq,Ord) + +-} + +-- | Map over both failure and success. +bimapExceptT :: Functor m => (e -> f) -> (a -> b) -> ExceptT e m a -> ExceptT f m b +bimapExceptT f g (ExceptT m) = ExceptT (fmap h m) where + h (Left e) = Left (f e) + h (Right a) = Right (g a) +{-# INLINE bimapExceptT #-} + +-- --------------------------------------------------------------------- + +stripIgnores :: [Idea] -> [Idea] +stripIgnores ideas = filter notIgnored ideas + where + notIgnored idea = ideaSeverity idea /= Ignore + +-- --------------------------------------------------------------------- + +hintToDiagnostic :: Idea -> Diagnostic +hintToDiagnostic idea + = Diagnostic + { _range = ss2Range (ideaSpan idea) + , _severity = Just (hintSeverityMap $ ideaSeverity idea) + , _code = Just (LSP.StringValue $ T.pack $ ideaHint idea) + , _source = Just "hlint" + , _message = idea2Message idea + , _relatedInformation = Nothing + } + +-- --------------------------------------------------------------------- + +idea2Message :: Idea -> T.Text +idea2Message idea = T.unlines $ [T.pack $ ideaHint idea, "Found:", " " <> T.pack (ideaFrom idea)] + <> toIdea <> map (T.pack . show) (ideaNote idea) + where + toIdea :: [T.Text] + toIdea = case ideaTo idea of + Nothing -> [] + Just i -> [T.pack "Why not:", T.pack $ " " ++ i] + +-- --------------------------------------------------------------------- +-- | Maps hlint severities to LSP severities +-- | We want to lower the severities so HLint errors and warnings +-- | don't mix with GHC errors and warnings: +-- | as per https://github.com/haskell/haskell-ide-engine/issues/375 +hintSeverityMap :: Severity -> DiagnosticSeverity +hintSeverityMap Ignore = DsInfo -- cannot really happen after stripIgnores +hintSeverityMap Suggestion = DsHint +hintSeverityMap Warning = DsInfo +hintSeverityMap Error = DsInfo + +-- --------------------------------------------------------------------- + +srcLoc2Range :: SrcLoc -> Range +srcLoc2Range (SrcLoc _ l c) = Range ps pe + where + ps = Position (l-1) (c-1) + pe = Position (l-1) 100000 + +-- --------------------------------------------------------------------- + +ss2Range :: SrcSpan -> Range +ss2Range ss = Range ps pe + where + ps = Position (srcSpanStartLine ss - 1) (srcSpanStartColumn ss - 1) + pe = Position (srcSpanEndLine ss - 1) (srcSpanEndColumn ss - 1) + +-- --------------------------------------------------------------------- + +applyHint :: FilePath -> Maybe OneHint -> (FilePath -> FilePath) -> IdeM (Either String WorkspaceEdit) +applyHint fp mhint fileMap = do + runExceptT $ do + ideas <- getIdeas fp mhint + let commands = map (show &&& ideaRefactoring) ideas + liftIO $ logm $ "applyHint:apply=" ++ show commands + -- 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 pont 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). + res <- liftIO $ (Right <$> applyRefactorings Nothing commands fp) `catches` + [ Handler $ \e -> return (Left (show (e :: IOException))) + , Handler $ \e -> return (Left (show (e :: ErrorCall))) + ] + case res of + Right appliedFile -> do + diff <- ExceptT $ Right <$> makeDiffResult fp (T.pack appliedFile) fileMap + liftIO $ logm $ "applyHint:diff=" ++ show diff + return diff + Left err -> + throwE (show err) + +-- | Gets HLint ideas for +getIdeas :: MonadIO m => FilePath -> Maybe OneHint -> ExceptT String m [Idea] +getIdeas lintFile mhint = do + let hOpts = hlintOpts lintFile (oneHintPos <$> mhint) + ideas <- runHlint lintFile hOpts + pure $ maybe ideas (`filterIdeas` ideas) mhint + +-- | If we are only interested in applying a particular hint then +-- let's filter out all the irrelevant ideas +filterIdeas :: OneHint -> [Idea] -> [Idea] +filterIdeas (OneHint (Position l c) title) ideas = + let + title' = T.unpack title + ideaPos = (srcSpanStartLine &&& srcSpanStartColumn) . ideaSpan + in filter (\i -> ideaHint i == title' && ideaPos i == (l+1, c+1)) ideas + +hlintOpts :: FilePath -> Maybe Position -> [String] +hlintOpts lintFile mpos = + let + posOpt (Position l c) = " --pos " ++ show (l+1) ++ "," ++ show (c+1) + opts = maybe "" posOpt mpos + in [lintFile, "--quiet", "--refactor", "--refactor-options=" ++ opts ] + +runHlint :: MonadIO m => FilePath -> [String] -> ExceptT String m [Idea] +runHlint fp args = + do (flags,classify,hint) <- liftIO $ argsSettings args + let myflags = flags { hseFlags = (hseFlags flags) { extensions = EnableExtension TypeApplications:extensions (hseFlags flags)}} + res <- bimapExceptT showParseError id $ ExceptT $ liftIO $ parseModuleEx myflags fp Nothing + pure $ applyHints classify hint [res] + +showParseError :: Hlint.ParseError -> String +showParseError (Hlint.ParseError location message content) = + unlines [show location, message, content] + +-- --------------------------------------------------------------------- + +codeActionProvider :: CodeActionProvider +codeActionProvider plId docId _ context = IdeResultOk <$> hlintActions + where + + hlintActions :: IdeM [LSP.CodeAction] + hlintActions = catMaybes <$> mapM mkHlintAction (filter validCommand diags) + + -- |Some hints do not have an associated refactoring + validCommand (LSP.Diagnostic _ _ (Just (LSP.StringValue code)) (Just "hlint") _ _) = + case code of + "Eta reduce" -> False + _ -> True + validCommand _ = False + + LSP.List diags = context ^. LSP.diagnostics + + mkHlintAction :: LSP.Diagnostic -> IdeM (Maybe LSP.CodeAction) + mkHlintAction diag@(LSP.Diagnostic (LSP.Range start _) _s (Just (LSP.StringValue code)) (Just "hlint") m _) = + Just . codeAction <$> mkLspCommand plId "applyOne" title (Just args) + where + codeAction cmd = LSP.CodeAction title (Just LSP.CodeActionQuickFix) (Just (LSP.List [diag])) Nothing (Just cmd) + title = "Apply hint:" <> head (T.lines m) + -- need 'file', 'start_pos' and hint title (to distinguish between alternative suggestions at the same location) + args = [toJSON (AOP (docId ^. LSP.uri) start code)] + mkHlintAction (LSP.Diagnostic _r _s _c _source _m _) = return Nothing +-} From beb2e258c68455b545f89162c6acdbf01e5c0c28 Mon Sep 17 00:00:00 2001 From: jneira Date: Thu, 18 Jun 2020 11:35:04 +0200 Subject: [PATCH 02/71] hlint plugin version with only diagnostics --- haskell-language-server.cabal | 4 +- src/Ide/Plugin/Hlint.hs | 107 +++++++++++++++++++++------------- 2 files changed, 69 insertions(+), 42 deletions(-) diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal index addbf8af74..794f317b3b 100644 --- a/haskell-language-server.cabal +++ b/haskell-language-server.cabal @@ -101,8 +101,8 @@ library hls-ghc-lib , ghcide , hashable , haskell-lsp - , haskell-src-exts , hlint >= 3.0 + , lens , regex-tdfa , shake , text @@ -114,6 +114,8 @@ library hls-ghc-lib else build-depends: ghc-lib == 8.10.* + cpp-options: + -DGHC_LIB ghc-options: -Wall diff --git a/src/Ide/Plugin/Hlint.hs b/src/Ide/Plugin/Hlint.hs index c3ea2f604d..a1b9a396c3 100644 --- a/src/Ide/Plugin/Hlint.hs +++ b/src/Ide/Plugin/Hlint.hs @@ -1,4 +1,5 @@ -{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} @@ -15,31 +16,21 @@ module Ide.Plugin.Hlint --, provider ) where --- import DA.Daml.DocTest --- import Development.IDE.Core.Service.Daml --- import qualified DA.Daml.LF.Ast as LF --- import qualified DA.Daml.LF.ScenarioServiceClient as SS --- import Control.Exception.Safe --- import Development.IDE.Core.RuleTypes.Daml --- import Development.IDE.Core.Rules --- import Development.IDE.Core.Service.Daml --- import Development.IDE.Types.Location --- import qualified DA.Daml.LF.Ast as LF --- import qualified DA.Daml.Visual as Visual --- import qualified Data.NameMap as NM import Control.DeepSeq import Control.Exception +import Control.Lens ((^.)) import Control.Monad import Control.Monad.Extra import Control.Monad.Trans.Maybe import qualified Data.Aeson as Aeson -import Data.Aeson.Types (toJSON, fromJSON, Value(..), Result(..)) +import Data.Aeson.Types (ToJSON(..), FromJSON(..), Value(..), Result(..)) import Data.Binary import qualified Data.ByteString as BS import Data.Either.Extra import Data.Foldable import Data.Functor import qualified Data.HashMap.Strict as Map +import qualified Data.HashSet as HashSet import Data.Hashable import Data.List import Data.Map.Strict (Map) @@ -65,9 +56,10 @@ import Development.Shake import GHC import GHC.Generics import GHC.Generics (Generic) +import SrcLoc import HscTypes (ModIface, ModSummary) import Ide.Types -import qualified Language.Haskell.Exts.SrcLoc as HSE +import Ide.Plugin import Language.Haskell.HLint import Language.Haskell.HLint as Hlint import qualified Language.Haskell.LSP.Core as LSP @@ -82,8 +74,6 @@ import System.FilePath import System.IO.Error import Text.Regex.TDFA.Text() - --- import "ghc-lib-parser" Module (UnitId) -- --------------------------------------------------------------------- descriptor :: PluginId -> PluginDescriptor @@ -93,7 +83,7 @@ descriptor plId = (defaultPluginDescriptor plId) -- [ PluginCommand "applyOne" "Apply a single hint" applyOneCmd -- , PluginCommand "applyAll" "Apply all hints to the file" applyAllCmd -- ] --- , pluginCodeActionProvider = Just codeActionProvider +-- , pluginCodeActionProvider = Just codeActionProvider } data GetHlintDiagnostics = GetHlintDiagnostics @@ -107,37 +97,71 @@ type instance RuleResult GetHlintDiagnostics = () rules :: Rules () rules = do define $ \GetHlintDiagnostics file -> do - pm <- use_ GetParsedModule file - let anns = pm_annotations pm - let modu = pm_parsed_source pm (classify, hint) <- useNoFile_ GetHlintSettings - let ideas = applyHints classify hint [createModuleEx anns modu] - return ([diagnostic file i | i <- ideas, ideaSeverity i /= Ignore], Just ()) + eModuleEx <- getModuleEx file + let getIdeas moduleEx = applyHints classify hint [moduleEx] + return $ (diagnostics file (fmap getIdeas eModuleEx), Just ()) + + hlintDataDir <- liftIO getExecutablePath + + getHlintSettingsRule (HlintEnabled hlintDataDir True) action $ do files <- getFilesOfInterest - void $ uses GetHlintDiagnostics $ Set.toList files + void $ uses GetHlintDiagnostics $ HashSet.toList files where - srcSpanToRange :: HSE.SrcSpan -> LSP.Range - srcSpanToRange span = Range { + + getModuleEx :: NormalizedFilePath -> Action (Either ParseError ModuleEx) + getModuleEx fp = do +#ifndef GHC_LIB + pm <- use_ GetParsedModule fp + let anns = pm_annotations pm + let modu = pm_parsed_source pm + return $ Right (createModuleEx anns modu) +#else + liftIO $ parseModuleEx defaultParseFlags (fromNormalizedFilePath fp) Nothing +#endif + + diagnostics :: NormalizedFilePath -> Either ParseError [Idea] -> [FileDiagnostic] + diagnostics file (Right ideas) = + [(file, ShowDiag, ideaToDiagnostic i) | i <- ideas, ideaSeverity i /= Ignore] + diagnostics file (Left parseErr) = + [(file, ShowDiag, parseErrorToDiagnostic parseErr)] + + ideaToDiagnostic :: Idea -> Diagnostic + ideaToDiagnostic idea = + LSP.Diagnostic { + _range = srcSpanToRange $ ideaSpan idea + , _severity = Just LSP.DsInfo + , _code = Just (LSP.StringValue $ T.pack $ ideaHint idea) + , _source = Just "hlint" + , _message = T.pack $ show idea + , _relatedInformation = Nothing + } + + parseErrorToDiagnostic :: ParseError -> Diagnostic + parseErrorToDiagnostic (Hlint.ParseError l msg contents) = + LSP.Diagnostic { + _range = srcSpanToRange l + , _severity = Just LSP.DsInfo + , _code = Just (LSP.StringValue "parser") + , _source = Just "hlint" + , _message = T.unlines [T.pack msg,T.pack contents] + , _relatedInformation = Nothing + } + -- This one is defined in Development.IDE.GHC.Error but here + -- the types could come from ghc-lib or ghc + srcSpanToRange :: SrcSpan -> LSP.Range + srcSpanToRange (RealSrcSpan span) = Range { _start = LSP.Position { - _line = HSE.srcSpanStartLine span - 1 - , _character = HSE.srcSpanStartColumn span - 1} + _line = srcSpanStartLine span - 1 + , _character = srcSpanStartCol span - 1} , _end = LSP.Position { - _line = HSE.srcSpanEndLine span - 1 - , _character = HSE.srcSpanEndColumn span - 1} + _line = srcSpanEndLine span - 1 + , _character = srcSpanEndCol span - 1} } - diagnostic :: NormalizedFilePath -> Idea -> FileDiagnostic - diagnostic file i = - (file, ShowDiag, LSP.Diagnostic { - _range = srcSpanToRange $ ideaSpan i - , _severity = Just LSP.DsInfo - , _code = Nothing - , _source = Just "hlint" - , _message = T.pack $ show i - , _relatedInformation = Nothing - }) + srcSpanToRange (UnhelpfulSpan _) = noRange -- --------------------------------------------------------------------- @@ -189,7 +213,8 @@ hlintSettings hlintDataDir enableOverrides = do foldMapM f = foldlM (\acc a -> do w <- f a; return $! mappend acc w) mempty -- --------------------------------------------------------------------- --- --------------------------------------------------------------------- + + -- --------------------------------------------------------------------- {- {-# LANGUAGE CPP #-} From 70ce253c3bede6b40382f8012ff4681c7d0c3e05 Mon Sep 17 00:00:00 2001 From: jneira Date: Sun, 21 Jun 2020 23:39:02 +0200 Subject: [PATCH 03/71] Add apply-refact dependency --- haskell-language-server.cabal | 1 + 1 file changed, 1 insertion(+) diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal index 794f317b3b..34a1a178d8 100644 --- a/haskell-language-server.cabal +++ b/haskell-language-server.cabal @@ -90,6 +90,7 @@ library hls-ghc-lib build-depends: base , aeson + , apply-refact , binary , bytestring , containers From a49ad1a2b39762e4e9d415a426290bafe024742c Mon Sep 17 00:00:00 2001 From: jneira Date: Sun, 21 Jun 2020 23:41:28 +0200 Subject: [PATCH 04/71] WIP adding apply hlint hints --- src/Ide/Plugin/Hlint.hs | 98 ++++++++++++++++++++++++++++++++++++++--- 1 file changed, 92 insertions(+), 6 deletions(-) diff --git a/src/Ide/Plugin/Hlint.hs b/src/Ide/Plugin/Hlint.hs index a1b9a396c3..da1aa71f07 100644 --- a/src/Ide/Plugin/Hlint.hs +++ b/src/Ide/Plugin/Hlint.hs @@ -15,7 +15,7 @@ module Ide.Plugin.Hlint descriptor --, provider ) where - +import Refact.Apply import Control.DeepSeq import Control.Exception import Control.Lens ((^.)) @@ -79,11 +79,11 @@ import Text.Regex.TDFA.Text() descriptor :: PluginId -> PluginDescriptor descriptor plId = (defaultPluginDescriptor plId) { pluginRules = rules --- , pluginCommands = --- [ PluginCommand "applyOne" "Apply a single hint" applyOneCmd + , pluginCommands = + [ PluginCommand "applyOne" "Apply a single hint" applyOneCmd -- , PluginCommand "applyAll" "Apply all hints to the file" applyAllCmd --- ] --- , pluginCodeActionProvider = Just codeActionProvider + ] + , pluginCodeActionProvider = Just codeActionProvider } data GetHlintDiagnostics = GetHlintDiagnostics @@ -115,7 +115,7 @@ rules = do getModuleEx :: NormalizedFilePath -> Action (Either ParseError ModuleEx) getModuleEx fp = do #ifndef GHC_LIB - pm <- use_ GetParsedModule fp + pm <- getParsedModule fp let anns = pm_annotations pm let modu = pm_parsed_source pm return $ Right (createModuleEx anns modu) @@ -214,6 +214,92 @@ hlintSettings hlintDataDir enableOverrides = do -- --------------------------------------------------------------------- +codeActionProvider :: CodeActionProvider +codeActionProvider _ _ plId docId _ context = (Right . LSP.List . map CACodeAction) <$> hlintActions + where + + hlintActions :: IO [LSP.CodeAction] + hlintActions = catMaybes <$> mapM mkHlintAction (filter validCommand diags) + + -- |Some hints do not have an associated refactoring + validCommand (LSP.Diagnostic _ _ (Just (LSP.StringValue code)) (Just "hlint") _ _ _) = + case code of + "Eta reduce" -> False + _ -> True + 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") m _ _) = + Just . codeAction <$> mkLspCommand plId "applyOne" title (Just args) + where + codeAction cmd = LSP.CodeAction title (Just LSP.CodeActionQuickFix) (Just (LSP.List [diag])) Nothing (Just cmd) + title = "Apply hint:" <> head (T.lines m) + -- need 'file', 'start_pos' and hint title (to distinguish between alternative suggestions at the same location) + args = [toJSON (AOP (docId ^. LSP.uri) start code)] + mkHlintAction (LSP.Diagnostic _r _s _c _source _m _ _) = return Nothing + +-- --------------------------------------------------------------------- + +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) + +type HintTitle = T.Text + +data OneHint = OneHint + { oneHintPos :: Position + , oneHintTitle :: HintTitle + } deriving (Eq, Show) + +applyOneCmd :: CommandFunction ApplyOneParams +applyOneCmd _lf ide (AOP uri pos title) = do + let oneHint = OneHint pos title + let file = uriToFilePath' uri + applyHint file (Just oneHint) + logm $ "applyOneCmd:file=" ++ show file + logm $ "applyOneCmd:res=" ++ show res + case res of + Left err -> return $ IdeResultFail + (IdeError PluginError (T.pack $ "applyOne: " ++ show err) Null) + Right fs -> return (IdeResultOk fs) + +applyHint :: FilePath -> Maybe OneHint -> IO (Either String WorkspaceEdit) +applyHint fp mhint fileMap = do + runExceptT $ do + ideas <- getIdeas fp mhint + let commands = map (show &&& ideaRefactoring) ideas + liftIO $ logm $ "applyHint:apply=" ++ show commands + -- 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 pont 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). + res <- liftIO $ (Right <$> applyRefactorings Nothing commands fp) `catches` + [ Handler $ \e -> return (Left (show (e :: IOException))) + , Handler $ \e -> return (Left (show (e :: ErrorCall))) + ] + case res of + Right appliedFile -> do + diff <- ExceptT $ Right <$> makeDiffResult fp (T.pack appliedFile) fileMap + liftIO $ logm $ "applyHint:diff=" ++ show diff + return diff + Left err -> + throwE (show err) -- --------------------------------------------------------------------- {- From 91af64b9279369fd308608d695ed6c373313c5a4 Mon Sep 17 00:00:00 2001 From: jneira Date: Thu, 2 Jul 2020 01:19:21 +0200 Subject: [PATCH 05/71] Add missing dependencies --- haskell-language-server.cabal | 3 +++ 1 file changed, 3 insertions(+) diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal index 34a1a178d8..4c427d8bd0 100644 --- a/haskell-language-server.cabal +++ b/haskell-language-server.cabal @@ -96,13 +96,16 @@ library hls-ghc-lib , containers , data-default , deepseq + , Diff , directory , extra , filepath , ghcide , hashable + , haskell-language-server , haskell-lsp , hlint >= 3.0 + , hslogger , lens , regex-tdfa , shake From 6334ed56c24ec7bb1659b9e0adf6802a59b8b2fe Mon Sep 17 00:00:00 2001 From: jneira Date: Thu, 2 Jul 2020 01:20:12 +0200 Subject: [PATCH 06/71] Add hlint private lib --- hie.yaml.cbl | 3 +++ 1 file changed, 3 insertions(+) diff --git a/hie.yaml.cbl b/hie.yaml.cbl index af9ba677d6..c4e9ae176c 100644 --- a/hie.yaml.cbl +++ b/hie.yaml.cbl @@ -33,6 +33,9 @@ cradle: - path: "./src" component: "lib:haskell-language-server" + + - path: "./src/Ide/Plugin/Hlint.hs" + component: "lib:hls-ghc-lib" - path: "./.stack-work/" component: "lib:haskell-language-server" From 6b06854b67f55ef50db39e2ed1d2324096bfd3bc Mon Sep 17 00:00:00 2001 From: jneira Date: Thu, 2 Jul 2020 01:20:48 +0200 Subject: [PATCH 07/71] Update stack extra-deps --- stack.yaml | 1 + 1 file changed, 1 insertion(+) diff --git a/stack.yaml b/stack.yaml index 93a47a3472..6415a56a63 100644 --- a/stack.yaml +++ b/stack.yaml @@ -34,6 +34,7 @@ extra-deps: - haskell-lsp-0.22.0.0 - haskell-lsp-types-0.22.0.0 - hie-bios-0.7.1 +- hlint-3.1.4 - HsYAML-0.2.1.0@rev:1 - HsYAML-aeson-0.2.0.0@rev:2 - indexed-profunctors-0.1 From cd8be0233d49b25f0f36c4108af8b56c2f0ef72e Mon Sep 17 00:00:00 2001 From: jneira Date: Thu, 2 Jul 2020 01:21:39 +0200 Subject: [PATCH 08/71] Implement hlint applyOneCmd --- src/Ide/Plugin/Hlint.hs | 95 ++++++++++++++++++++++++++++------------- 1 file changed, 65 insertions(+), 30 deletions(-) diff --git a/src/Ide/Plugin/Hlint.hs b/src/Ide/Plugin/Hlint.hs index da1aa71f07..c2f60aa18c 100644 --- a/src/Ide/Plugin/Hlint.hs +++ b/src/Ide/Plugin/Hlint.hs @@ -16,12 +16,15 @@ module Ide.Plugin.Hlint --, provider ) where import Refact.Apply +import Control.Arrow ((&&&)) import Control.DeepSeq import Control.Exception import Control.Lens ((^.)) import Control.Monad import Control.Monad.Extra import Control.Monad.Trans.Maybe +import Control.Monad.IO.Class +import Control.Monad.Trans.Except import qualified Data.Aeson as Aeson import Data.Aeson.Types (ToJSON(..), FromJSON(..), Value(..), Result(..)) import Data.Binary @@ -39,6 +42,7 @@ import Data.Maybe import qualified Data.Set as Set import Data.Set (Set) import qualified Data.Text as T +import qualified Data.Text.IO as T import Data.Typeable import Data.Typeable (Typeable) import Development.IDE.Core.OfInterest @@ -58,8 +62,10 @@ import GHC.Generics import GHC.Generics (Generic) import SrcLoc import HscTypes (ModIface, ModSummary) +import Ide.Logger import Ide.Types import Ide.Plugin +import Ide.PluginUtils import Language.Haskell.HLint import Language.Haskell.HLint as Hlint import qualified Language.Haskell.LSP.Core as LSP @@ -97,10 +103,8 @@ type instance RuleResult GetHlintDiagnostics = () rules :: Rules () rules = do define $ \GetHlintDiagnostics file -> do - (classify, hint) <- useNoFile_ GetHlintSettings - eModuleEx <- getModuleEx file - let getIdeas moduleEx = applyHints classify hint [moduleEx] - return $ (diagnostics file (fmap getIdeas eModuleEx), Just ()) + ideas <- getIdeas file + return $ (diagnostics file ideas, Just ()) hlintDataDir <- liftIO getExecutablePath @@ -112,17 +116,6 @@ rules = do where - getModuleEx :: NormalizedFilePath -> Action (Either ParseError ModuleEx) - getModuleEx fp = do -#ifndef GHC_LIB - pm <- getParsedModule fp - let anns = pm_annotations pm - let modu = pm_parsed_source pm - return $ Right (createModuleEx anns modu) -#else - liftIO $ parseModuleEx defaultParseFlags (fromNormalizedFilePath fp) Nothing -#endif - diagnostics :: NormalizedFilePath -> Either ParseError [Idea] -> [FileDiagnostic] diagnostics file (Right ideas) = [(file, ShowDiag, ideaToDiagnostic i) | i <- ideas, ideaSeverity i /= Ignore] @@ -163,6 +156,22 @@ rules = do } srcSpanToRange (UnhelpfulSpan _) = noRange +getIdeas :: NormalizedFilePath -> Action (Either ParseError [Idea]) +getIdeas nfp = do + (classify, hint) <- useNoFile_ GetHlintSettings + let applyHints' modEx = applyHints classify hint [modEx] + fmap (fmap applyHints') moduleEx + where moduleEx :: Action (Either ParseError ModuleEx) + moduleEx = do +#ifndef GHC_LIB + pm <- getParsedModule fnp + let anns = pm_annotations pm + let modu = pm_parsed_source pm + return $ Right (createModuleEx anns modu) +#else + liftIO $ parseModuleEx defaultParseFlags (fromNormalizedFilePath nfp) Nothing +#endif + -- --------------------------------------------------------------------- data HlintUsage @@ -257,22 +266,24 @@ data OneHint = OneHint } deriving (Eq, Show) applyOneCmd :: CommandFunction ApplyOneParams -applyOneCmd _lf ide (AOP uri pos title) = do +applyOneCmd _lf ide (AOP uri pos title) = do let oneHint = OneHint pos title - let file = uriToFilePath' uri - applyHint file (Just oneHint) + let file = maybe (error $ show uri ++ " is not a file") toNormalizedFilePath' + (uriToFilePath' uri) + res <- applyHint ide file (Just oneHint) logm $ "applyOneCmd:file=" ++ show file logm $ "applyOneCmd:res=" ++ show res - case res of - Left err -> return $ IdeResultFail - (IdeError PluginError (T.pack $ "applyOne: " ++ show err) Null) - Right fs -> return (IdeResultOk fs) + return $ + case res of + Left err -> (Left (responseError (T.pack $ "applyOne: " ++ show err)), Nothing) + Right fs -> (Right Null, Just (WorkspaceApplyEdit, ApplyWorkspaceEditParams fs)) -applyHint :: FilePath -> Maybe OneHint -> IO (Either String WorkspaceEdit) -applyHint fp mhint fileMap = do +applyHint :: IdeState -> NormalizedFilePath -> Maybe OneHint -> IO (Either String WorkspaceEdit) +applyHint ide nfp mhint = runExceptT $ do - ideas <- getIdeas fp mhint - let commands = map (show &&& ideaRefactoring) ideas + ideas <- bimapExceptT showParseError id $ ExceptT $ liftIO $ runAction "applyHint" ide $ getIdeas nfp + let ideas' = maybe ideas (`filterIdeas` ideas) mhint + let commands = map (show &&& ideaRefactoring) ideas' liftIO $ logm $ "applyHint:apply=" ++ show commands -- set Nothing as "position" for "applyRefactorings" because -- applyRefactorings expects the provided position to be _within_ the scope @@ -289,18 +300,42 @@ applyHint fp mhint fileMap = do -- 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 fp = fromNormalizedFilePath nfp res <- liftIO $ (Right <$> applyRefactorings Nothing commands fp) `catches` [ Handler $ \e -> return (Left (show (e :: IOException))) , Handler $ \e -> return (Left (show (e :: ErrorCall))) ] case res of Right appliedFile -> do - diff <- ExceptT $ Right <$> makeDiffResult fp (T.pack appliedFile) fileMap - liftIO $ logm $ "applyHint:diff=" ++ show diff - return diff + let uri = fromNormalizedUri (filePathToUri' nfp) + oldContent <- liftIO $ T.readFile fp + let wsEdit = diffText' True (uri, oldContent) (T.pack appliedFile) IncludeDeletions + liftIO $ logm $ "applyHint:diff=" ++ show wsEdit + ExceptT $ Right <$> (return wsEdit) Left err -> - throwE (show err) + throwE (show err) + where + -- | If we are only interested in applying a particular hint then + -- let's filter out all the irrelevant ideas + filterIdeas :: OneHint -> [Idea] -> [Idea] + 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 + + toRealSrcSpan (RealSrcSpan real) = real + toRealSrcSpan (UnhelpfulSpan _) = error "No real souce span" + + showParseError :: Hlint.ParseError -> String + showParseError (Hlint.ParseError location message content) = + unlines [show location, message, content] +-- | Map over both failure and success. +bimapExceptT :: Functor m => (e -> f) -> (a -> b) -> ExceptT e m a -> ExceptT f m b +bimapExceptT f g (ExceptT m) = ExceptT (fmap h m) where + h (Left e) = Left (f e) + h (Right a) = Right (g a) +{-# INLINE bimapExceptT #-} -- --------------------------------------------------------------------- {- {-# LANGUAGE CPP #-} From bd2a772f5b3ad185362e99998c4a9567a2a5baad Mon Sep 17 00:00:00 2001 From: jneira Date: Thu, 2 Jul 2020 23:32:03 +0200 Subject: [PATCH 09/71] Move hlint module to its own src dir --- {src => hlint-plugin/src}/Ide/Plugin/Hlint.hs | 19 +++++++++++++++++-- 1 file changed, 17 insertions(+), 2 deletions(-) rename {src => hlint-plugin/src}/Ide/Plugin/Hlint.hs (97%) diff --git a/src/Ide/Plugin/Hlint.hs b/hlint-plugin/src/Ide/Plugin/Hlint.hs similarity index 97% rename from src/Ide/Plugin/Hlint.hs rename to hlint-plugin/src/Ide/Plugin/Hlint.hs index c2f60aa18c..7c332c14fc 100644 --- a/src/Ide/Plugin/Hlint.hs +++ b/hlint-plugin/src/Ide/Plugin/Hlint.hs @@ -87,7 +87,7 @@ descriptor plId = (defaultPluginDescriptor plId) { pluginRules = rules , pluginCommands = [ PluginCommand "applyOne" "Apply a single hint" applyOneCmd --- , PluginCommand "applyAll" "Apply all hints to the file" applyAllCmd + , PluginCommand "applyAll" "Apply all hints to the file" applyAllCmd ] , pluginCodeActionProvider = Just codeActionProvider } @@ -251,6 +251,21 @@ codeActionProvider _ _ plId docId _ context = (Right . LSP.List . map CACodeActi -- --------------------------------------------------------------------- +applyAllCmd :: CommandFunction Uri +applyAllCmd _lf ide uri = do + let file = maybe (error $ show uri ++ " is not a file") + toNormalizedFilePath' + (uriToFilePath' uri) + logm $ "applyAllCmd:file=" ++ show file + res <- applyHint ide file Nothing + logm $ "applyAllCmd:res=" ++ show res + return $ + case res of + Left err -> (Left (responseError (T.pack $ "applyAll: " ++ show err)), Nothing) + Right fs -> (Right Null, Just (WorkspaceApplyEdit, ApplyWorkspaceEditParams fs)) + +-- --------------------------------------------------------------------- + data ApplyOneParams = AOP { file :: Uri , start_pos :: Position @@ -288,7 +303,7 @@ applyHint ide nfp mhint = -- 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 pont to starting position of the expressions + -- 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 ())" From 787a474e428214bbdc9ed0ea87c3a618b28bc8bc Mon Sep 17 00:00:00 2001 From: jneira Date: Thu, 2 Jul 2020 23:33:33 +0200 Subject: [PATCH 10/71] Rename lib to hlint-plugin --- haskell-language-server.cabal | 4 ++-- hie.yaml.cbl | 6 +++--- 2 files changed, 5 insertions(+), 5 deletions(-) diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal index 4c427d8bd0..18549e90a9 100644 --- a/haskell-language-server.cabal +++ b/haskell-language-server.cabal @@ -82,11 +82,11 @@ flag ghc-lib manual: True description: Force dependency on ghc-lib-parser even if GHC API in the ghc package is supported -library hls-ghc-lib +library hlint-plugin exposed-modules: Ide.Plugin.Hlint hs-source-dirs: - src + hlint-plugin/src build-depends: base , aeson diff --git a/hie.yaml.cbl b/hie.yaml.cbl index c4e9ae176c..e11784d0b7 100644 --- a/hie.yaml.cbl +++ b/hie.yaml.cbl @@ -34,10 +34,10 @@ cradle: - path: "./src" component: "lib:haskell-language-server" - - path: "./src/Ide/Plugin/Hlint.hs" - component: "lib:hls-ghc-lib" + - path: "./hlint-plugin/src/Ide/Plugin/Hlint.hs" + component: "lib:hlint-plugin" - - path: "./.stack-work/" + - path: "./dist-newstyle/" component: "lib:haskell-language-server" - path: "./ghcide/src" From 4fbabd7c1c262964871ac0b7f4493f395f3cae10 Mon Sep 17 00:00:00 2001 From: jneira Date: Fri, 3 Jul 2020 13:06:43 +0200 Subject: [PATCH 11/71] Move hlint plugin to a more generic path --- haskell-language-server.cabal | 2 +- hie.yaml.cbl | 4 ++-- .../hlint-hls-plugin}/src/Ide/Plugin/Hlint.hs | 0 3 files changed, 3 insertions(+), 3 deletions(-) rename {hlint-plugin => plugins/hlint-hls-plugin}/src/Ide/Plugin/Hlint.hs (100%) diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal index 18549e90a9..bd8541d121 100644 --- a/haskell-language-server.cabal +++ b/haskell-language-server.cabal @@ -86,7 +86,7 @@ library hlint-plugin exposed-modules: Ide.Plugin.Hlint hs-source-dirs: - hlint-plugin/src + plugins/hlint-hls-plugin/src build-depends: base , aeson diff --git a/hie.yaml.cbl b/hie.yaml.cbl index e11784d0b7..e8881d953e 100644 --- a/hie.yaml.cbl +++ b/hie.yaml.cbl @@ -33,8 +33,8 @@ cradle: - path: "./src" component: "lib:haskell-language-server" - - - path: "./hlint-plugin/src/Ide/Plugin/Hlint.hs" + + - path: "./plugins/hlint-hls-plugin/src/Ide/Plugin/Hlint.hs" component: "lib:hlint-plugin" - path: "./dist-newstyle/" diff --git a/hlint-plugin/src/Ide/Plugin/Hlint.hs b/plugins/hlint-hls-plugin/src/Ide/Plugin/Hlint.hs similarity index 100% rename from hlint-plugin/src/Ide/Plugin/Hlint.hs rename to plugins/hlint-hls-plugin/src/Ide/Plugin/Hlint.hs From c03c385c924229200b1673c7ce7872f3225e1cc5 Mon Sep 17 00:00:00 2001 From: jneira Date: Tue, 7 Jul 2020 06:28:39 +0200 Subject: [PATCH 12/71] Parse module with ghc session extensions --- .../hlint-hls-plugin/src/Ide/Plugin/Hlint.hs | 103 +++++++++--------- 1 file changed, 52 insertions(+), 51 deletions(-) diff --git a/plugins/hlint-hls-plugin/src/Ide/Plugin/Hlint.hs b/plugins/hlint-hls-plugin/src/Ide/Plugin/Hlint.hs index 7c332c14fc..4b4bee2584 100644 --- a/plugins/hlint-hls-plugin/src/Ide/Plugin/Hlint.hs +++ b/plugins/hlint-hls-plugin/src/Ide/Plugin/Hlint.hs @@ -13,7 +13,7 @@ module Ide.Plugin.Hlint ( descriptor - --, provider + --, provider ) where import Refact.Apply import Control.Arrow ((&&&)) @@ -50,6 +50,7 @@ import Development.IDE.Core.RuleTypes import Development.IDE.Core.Rules import Development.IDE.Core.Service import Development.IDE.Core.Shake +import Development.IDE.GHC.Util (hscEnv) import Development.IDE.LSP.Server import Development.IDE.Plugin import Development.IDE.Types.Diagnostics as D @@ -57,11 +58,22 @@ import Development.IDE.Types.Location import Development.IDE.Types.Logger import Development.Shake -- import Development.Shake hiding ( Diagnostic ) -import GHC +import GHC hiding (DynFlags(..)) import GHC.Generics import GHC.Generics (Generic) import SrcLoc import HscTypes (ModIface, ModSummary) + +#ifndef GHC_LIB +import GHC (DynFlags(..)) +import HscTypes (hsc_dflags) +#else +import RealGHC (DynFlags(..)) +import RealGHC.HscTypes (hsc_dflags) +import qualified RealGHC.EnumSet as EnumSet +import Language.Haskell.GhclibParserEx.GHC.Driver.Session as GhclibParserEx (readExtension) +#endif + import Ide.Logger import Ide.Types import Ide.Plugin @@ -106,9 +118,7 @@ rules = do ideas <- getIdeas file return $ (diagnostics file ideas, Just ()) - hlintDataDir <- liftIO getExecutablePath - - getHlintSettingsRule (HlintEnabled hlintDataDir True) + getHlintSettingsRule (HlintEnabled []) action $ do files <- getFilesOfInterest @@ -117,9 +127,9 @@ rules = do where diagnostics :: NormalizedFilePath -> Either ParseError [Idea] -> [FileDiagnostic] - diagnostics file (Right ideas) = + diagnostics file (Right ideas) = [(file, ShowDiag, ideaToDiagnostic i) | i <- ideas, ideaSeverity i /= Ignore] - diagnostics file (Left parseErr) = + diagnostics file (Left parseErr) = [(file, ShowDiag, parseErrorToDiagnostic parseErr)] ideaToDiagnostic :: Idea -> Diagnostic @@ -131,17 +141,19 @@ rules = do , _source = Just "hlint" , _message = T.pack $ show idea , _relatedInformation = Nothing + , _tags = Nothing } - + parseErrorToDiagnostic :: ParseError -> Diagnostic parseErrorToDiagnostic (Hlint.ParseError l msg contents) = - LSP.Diagnostic { + LSP.Diagnostic { _range = srcSpanToRange l , _severity = Just LSP.DsInfo , _code = Just (LSP.StringValue "parser") , _source = Just "hlint" , _message = T.unlines [T.pack msg,T.pack contents] , _relatedInformation = Nothing + , _tags = Nothing } -- This one is defined in Development.IDE.GHC.Error but here -- the types could come from ghc-lib or ghc @@ -158,24 +170,35 @@ rules = do getIdeas :: NormalizedFilePath -> Action (Either ParseError [Idea]) getIdeas nfp = do - (classify, hint) <- useNoFile_ GetHlintSettings + logm $ "getIdeas:file:" ++ show nfp + (flags, classify, hint) <- useNoFile_ GetHlintSettings let applyHints' modEx = applyHints classify hint [modEx] - fmap (fmap applyHints') moduleEx - where moduleEx :: Action (Either ParseError ModuleEx) - moduleEx = do + fmap (fmap applyHints') (moduleEx flags) + where moduleEx :: ParseFlags -> Action (Either ParseError ModuleEx) + moduleEx flags = do #ifndef GHC_LIB - pm <- getParsedModule fnp + pm <- getParsedModule nfp let anns = pm_annotations pm let modu = pm_parsed_source pm return $ Right (createModuleEx anns modu) #else - liftIO $ parseModuleEx defaultParseFlags (fromNormalizedFilePath nfp) Nothing + flags' <- setExtensions flags + liftIO $ parseModuleEx flags' (fromNormalizedFilePath nfp) Nothing + + setExtensions flags = do + hsc <- hscEnv <$> use_ GhcSession nfp + let dflags = hsc_dflags hsc + let hscExts = EnumSet.toList (extensionFlags dflags) + logm $ "getIdeas:setExtensions:hscExtensions:" ++ show hscExts + let hlintExts = mapMaybe (GhclibParserEx.readExtension . show) hscExts + logm $ "getIdeas:setExtensions:hlintExtensions:" ++ show hlintExts + return $ flags { enabledExtensions = hlintExts } #endif -- --------------------------------------------------------------------- data HlintUsage - = HlintEnabled { hlintUseDataDir :: FilePath, hlintAllowOverrides :: Bool } + = HlintEnabled { cmdArgs :: [String] } | HlintDisabled deriving Show @@ -185,42 +208,20 @@ instance Hashable GetHlintSettings instance NFData GetHlintSettings instance NFData Hint where rnf = rwhnf instance NFData Classify where rnf = rwhnf +instance NFData ParseFlags where rnf = rwhnf instance Show Hint where show = const "" +instance Show ParseFlags where show = const "" instance Binary GetHlintSettings -type instance RuleResult GetHlintSettings = ([Classify], Hint) +type instance RuleResult GetHlintSettings = (ParseFlags, [Classify], Hint) getHlintSettingsRule :: HlintUsage -> Rules () getHlintSettingsRule usage = defineNoFile $ \GetHlintSettings -> liftIO $ case usage of - HlintEnabled dir enableOverrides -> hlintSettings dir enableOverrides + HlintEnabled cmdArgs -> argsSettings cmdArgs HlintDisabled -> fail "hlint configuration unspecified" -hlintSettings :: FilePath -> Bool -> IO ([Classify], Hint) -hlintSettings hlintDataDir enableOverrides = do - curdir <- getCurrentDirectory - home <- ((:[]) <$> getHomeDirectory) `catchIOError` (const $ return []) - hlintYaml <- if enableOverrides - then - findM Dir.doesFileExist $ - map ( ".hlint.yaml") (ancestors curdir ++ home) - else - return Nothing - (_, cs, hs) <- foldMapM parseSettings $ - (hlintDataDir "hlint.yaml") : maybeToList hlintYaml - return (cs, hs) - where - ancestors = init . map joinPath . reverse . inits . splitPath - -- `findSettings` calls `readFilesConfig` which in turn calls - -- `readFileConfigYaml` which finally calls `decodeFileEither` from - -- the `yaml` library. Annoyingly that function catches async - -- exceptions and in particular, it ends up catching - -- `ThreadKilled`. So, we have to mask to stop it from doing that. - parseSettings f = mask $ \unmask -> - findSettings (unmask . const (return (f, Nothing))) (Just f) - foldMapM f = foldlM (\acc a -> do w <- f a; return $! mappend acc w) mempty - -- --------------------------------------------------------------------- codeActionProvider :: CodeActionProvider @@ -253,8 +254,8 @@ codeActionProvider _ _ plId docId _ context = (Right . LSP.List . map CACodeActi applyAllCmd :: CommandFunction Uri applyAllCmd _lf ide uri = do - let file = maybe (error $ show uri ++ " is not a file") - toNormalizedFilePath' + let file = maybe (error $ show uri ++ " is not a file.") + toNormalizedFilePath' (uriToFilePath' uri) logm $ "applyAllCmd:file=" ++ show file res <- applyHint ide file Nothing @@ -283,12 +284,12 @@ data OneHint = OneHint applyOneCmd :: CommandFunction ApplyOneParams applyOneCmd _lf ide (AOP uri pos title) = do let oneHint = OneHint pos title - let file = maybe (error $ show uri ++ " is not a file") toNormalizedFilePath' + let file = maybe (error $ show uri ++ " is not a file.") toNormalizedFilePath' (uriToFilePath' uri) res <- applyHint ide file (Just oneHint) logm $ "applyOneCmd:file=" ++ show file logm $ "applyOneCmd:res=" ++ show res - return $ + return $ case res of Left err -> (Left (responseError (T.pack $ "applyOne: " ++ show err)), Nothing) Right fs -> (Right Null, Just (WorkspaceApplyEdit, ApplyWorkspaceEditParams fs)) @@ -297,7 +298,7 @@ applyHint :: IdeState -> NormalizedFilePath -> Maybe OneHint -> IO (Either Strin applyHint ide nfp mhint = runExceptT $ do ideas <- bimapExceptT showParseError id $ ExceptT $ liftIO $ runAction "applyHint" ide $ getIdeas nfp - let ideas' = maybe ideas (`filterIdeas` ideas) mhint + let ideas' = maybe ideas (`filterIdeas` ideas) mhint let commands = map (show &&& ideaRefactoring) ideas' liftIO $ logm $ "applyHint:apply=" ++ show commands -- set Nothing as "position" for "applyRefactorings" because @@ -328,8 +329,8 @@ applyHint ide nfp mhint = liftIO $ logm $ "applyHint:diff=" ++ show wsEdit ExceptT $ Right <$> (return wsEdit) Left err -> - throwE (show err) - where + throwE (show err) + where -- | If we are only interested in applying a particular hint then -- let's filter out all the irrelevant ideas filterIdeas :: OneHint -> [Idea] -> [Idea] @@ -339,7 +340,7 @@ applyHint ide nfp mhint = in filter (\i -> ideaHint i == title' && ideaPos i == (l+1, c+1)) ideas toRealSrcSpan (RealSrcSpan real) = real - toRealSrcSpan (UnhelpfulSpan _) = error "No real souce span" + toRealSrcSpan (UnhelpfulSpan x) = error $ "No real source span: " ++ show x showParseError :: Hlint.ParseError -> String showParseError (Hlint.ParseError location message content) = @@ -350,7 +351,7 @@ bimapExceptT :: Functor m => (e -> f) -> (a -> b) -> ExceptT e m a -> ExceptT f bimapExceptT f g (ExceptT m) = ExceptT (fmap h m) where h (Left e) = Left (f e) h (Right a) = Right (g a) -{-# INLINE bimapExceptT #-} +{-# INLINE bimapExceptT #-} -- --------------------------------------------------------------------- {- {-# LANGUAGE CPP #-} From 1e3350cfc855ac14a8f2aba17a52d3fe11cee7ab Mon Sep 17 00:00:00 2001 From: jneira Date: Tue, 7 Jul 2020 06:29:48 +0200 Subject: [PATCH 13/71] Use both ghc and ghc-lib --- haskell-language-server.cabal | 12 ++++++++---- 1 file changed, 8 insertions(+), 4 deletions(-) diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal index bd8541d121..0c1d78407d 100644 --- a/haskell-language-server.cabal +++ b/haskell-language-server.cabal @@ -114,13 +114,17 @@ library hlint-plugin , unordered-containers if !flag(ghc-lib) && impl(ghc >= 8.10.1) && impl(ghc < 8.11.0) build-depends: - ghc == 8.10.* + ghc == 8.10.* else build-depends: - ghc-lib == 8.10.* + ghc + , ghc-lib == 8.10.* + , ghc-lib-parser-ex == 8.10.* cpp-options: - -DGHC_LIB - + -DGHC_LIB + mixins: + ghc (GHC as RealGHC, HscTypes as RealGHC.HscTypes, EnumSet as RealGHC.EnumSet) + ghc-options: -Wall -Wredundant-constraints From 765d857cfe408f9781492a4c77bc6dbbd057d9f8 Mon Sep 17 00:00:00 2001 From: jneira Date: Thu, 9 Jul 2020 23:09:04 +0200 Subject: [PATCH 14/71] Make compile ghc-8.10.1 code path --- .../hlint-hls-plugin/src/Ide/Plugin/Hlint.hs | 31 ++++++++++++------- 1 file changed, 19 insertions(+), 12 deletions(-) diff --git a/plugins/hlint-hls-plugin/src/Ide/Plugin/Hlint.hs b/plugins/hlint-hls-plugin/src/Ide/Plugin/Hlint.hs index 4b4bee2584..1901e16f21 100644 --- a/plugins/hlint-hls-plugin/src/Ide/Plugin/Hlint.hs +++ b/plugins/hlint-hls-plugin/src/Ide/Plugin/Hlint.hs @@ -172,18 +172,27 @@ getIdeas :: NormalizedFilePath -> Action (Either ParseError [Idea]) getIdeas nfp = do logm $ "getIdeas:file:" ++ show nfp (flags, classify, hint) <- useNoFile_ GetHlintSettings - let applyHints' modEx = applyHints classify hint [modEx] - fmap (fmap applyHints') (moduleEx flags) - where moduleEx :: ParseFlags -> Action (Either ParseError ModuleEx) - moduleEx flags = do + + let applyHints' (Just (Right modEx)) = Right $ applyHints classify hint [modEx] + applyHints' (Just (Left err)) = Left err + applyHints' Nothing = Right [] + + fmap applyHints' (moduleEx flags) + + where moduleEx :: ParseFlags -> Action (Maybe (Either ParseError ModuleEx)) #ifndef GHC_LIB - pm <- getParsedModule nfp - let anns = pm_annotations pm - let modu = pm_parsed_source pm - return $ Right (createModuleEx anns modu) + moduleEx _flags = do + mbpm <- getParsedModule nfp + case mbpm of + Nothing -> return Nothing + Just pm -> do + let anns = pm_annotations pm + let modu = pm_parsed_source pm + return $ Just $ Right (createModuleEx anns modu) #else + moduleEx flags = do flags' <- setExtensions flags - liftIO $ parseModuleEx flags' (fromNormalizedFilePath nfp) Nothing + Just <$> (liftIO $ parseModuleEx flags' (fromNormalizedFilePath nfp) Nothing) setExtensions flags = do hsc <- hscEnv <$> use_ GhcSession nfp @@ -233,9 +242,7 @@ codeActionProvider _ _ plId docId _ context = (Right . LSP.List . map CACodeActi -- |Some hints do not have an associated refactoring validCommand (LSP.Diagnostic _ _ (Just (LSP.StringValue code)) (Just "hlint") _ _ _) = - case code of - "Eta reduce" -> False - _ -> True + code /= "Eta reduce" validCommand _ = False LSP.List diags = context ^. LSP.diagnostics From d3c6ee55a72251b18f6fd868c2d0254ef477521f Mon Sep 17 00:00:00 2001 From: jneira Date: Tue, 14 Jul 2020 11:22:20 +0200 Subject: [PATCH 15/71] Remove unused imports and refact cpp blocks --- .../hlint-hls-plugin/src/Ide/Plugin/Hlint.hs | 62 +++++-------------- 1 file changed, 15 insertions(+), 47 deletions(-) diff --git a/plugins/hlint-hls-plugin/src/Ide/Plugin/Hlint.hs b/plugins/hlint-hls-plugin/src/Ide/Plugin/Hlint.hs index 1901e16f21..d1d92c2c93 100644 --- a/plugins/hlint-hls-plugin/src/Ide/Plugin/Hlint.hs +++ b/plugins/hlint-hls-plugin/src/Ide/Plugin/Hlint.hs @@ -21,53 +21,28 @@ import Control.DeepSeq import Control.Exception import Control.Lens ((^.)) import Control.Monad -import Control.Monad.Extra -import Control.Monad.Trans.Maybe import Control.Monad.IO.Class import Control.Monad.Trans.Except -import qualified Data.Aeson as Aeson -import Data.Aeson.Types (ToJSON(..), FromJSON(..), Value(..), Result(..)) +import Data.Aeson.Types (ToJSON(..), FromJSON(..), Value(..)) import Data.Binary -import qualified Data.ByteString as BS -import Data.Either.Extra -import Data.Foldable -import Data.Functor -import qualified Data.HashMap.Strict as Map import qualified Data.HashSet as HashSet import Data.Hashable -import Data.List -import Data.Map.Strict (Map) -import qualified Data.Map.Strict as Map import Data.Maybe -import qualified Data.Set as Set -import Data.Set (Set) import qualified Data.Text as T import qualified Data.Text.IO as T import Data.Typeable -import Data.Typeable (Typeable) import Development.IDE.Core.OfInterest -import Development.IDE.Core.RuleTypes import Development.IDE.Core.Rules -import Development.IDE.Core.Service import Development.IDE.Core.Shake -import Development.IDE.GHC.Util (hscEnv) -import Development.IDE.LSP.Server -import Development.IDE.Plugin import Development.IDE.Types.Diagnostics as D import Development.IDE.Types.Location -import Development.IDE.Types.Logger import Development.Shake -- import Development.Shake hiding ( Diagnostic ) import GHC hiding (DynFlags(..)) -import GHC.Generics -import GHC.Generics (Generic) -import SrcLoc -import HscTypes (ModIface, ModSummary) -#ifndef GHC_LIB -import GHC (DynFlags(..)) -import HscTypes (hsc_dflags) -#else +#ifdef GHC_LIB +import Development.IDE.Core.RuleTypes (GhcSession(..)) +import Development.IDE.GHC.Util (hscEnv) import RealGHC (DynFlags(..)) import RealGHC.HscTypes (hsc_dflags) import qualified RealGHC.EnumSet as EnumSet @@ -78,19 +53,12 @@ import Ide.Logger import Ide.Types import Ide.Plugin import Ide.PluginUtils -import Language.Haskell.HLint import Language.Haskell.HLint as Hlint -import qualified Language.Haskell.LSP.Core as LSP -import Language.Haskell.LSP.Messages import Language.Haskell.LSP.Types import qualified Language.Haskell.LSP.Types as LSP import qualified Language.Haskell.LSP.Types.Lens as LSP -import System.Directory -import System.Directory.Extra as Dir -import System.Environment.Blank -import System.FilePath -import System.IO.Error import Text.Regex.TDFA.Text() +import GHC.Generics (Generic) -- --------------------------------------------------------------------- @@ -180,16 +148,7 @@ getIdeas nfp = do fmap applyHints' (moduleEx flags) where moduleEx :: ParseFlags -> Action (Maybe (Either ParseError ModuleEx)) -#ifndef GHC_LIB - moduleEx _flags = do - mbpm <- getParsedModule nfp - case mbpm of - Nothing -> return Nothing - Just pm -> do - let anns = pm_annotations pm - let modu = pm_parsed_source pm - return $ Just $ Right (createModuleEx anns modu) -#else +#ifdef GHC_LIB moduleEx flags = do flags' <- setExtensions flags Just <$> (liftIO $ parseModuleEx flags' (fromNormalizedFilePath nfp) Nothing) @@ -202,6 +161,15 @@ getIdeas nfp = do let hlintExts = mapMaybe (GhclibParserEx.readExtension . show) hscExts logm $ "getIdeas:setExtensions:hlintExtensions:" ++ show hlintExts return $ flags { enabledExtensions = hlintExts } +#else + moduleEx _flags = do + mbpm <- getParsedModule nfp + case mbpm of + Nothing -> return Nothing + Just pm -> do + let anns = pm_annotations pm + let modu = pm_parsed_source pm + return $ Just $ Right (createModuleEx anns modu) #endif -- --------------------------------------------------------------------- From 5c6885e904a5149dbf4cdcb07254f3217731b0ff Mon Sep 17 00:00:00 2001 From: jneira Date: Wed, 15 Jul 2020 09:04:53 +0200 Subject: [PATCH 16/71] Remove trailing whitespace --- haskell-language-server.cabal | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal index 0c1d78407d..27c2903e5c 100644 --- a/haskell-language-server.cabal +++ b/haskell-language-server.cabal @@ -123,8 +123,8 @@ library hlint-plugin cpp-options: -DGHC_LIB mixins: - ghc (GHC as RealGHC, HscTypes as RealGHC.HscTypes, EnumSet as RealGHC.EnumSet) - + ghc (GHC as RealGHC, HscTypes as RealGHC.HscTypes, EnumSet as RealGHC.EnumSet) + ghc-options: -Wall -Wredundant-constraints From fd6fc8049a4477e364e1c5aa7aa4731b006d0586 Mon Sep 17 00:00:00 2001 From: jneira Date: Sun, 9 Aug 2020 16:59:19 +0200 Subject: [PATCH 17/71] Use ghcide with config in shakeExtras --- .gitmodules | 1 + 1 file changed, 1 insertion(+) diff --git a/.gitmodules b/.gitmodules index c8abb211bc..4a0089e4cd 100644 --- a/.gitmodules +++ b/.gitmodules @@ -15,3 +15,4 @@ url = https://github.com/haskell/ghcide.git # url = https://github.com/fendor/ghcide.git # url = https://github.com/bubba/ghcide.git + # url = https://github.com/jneira/ghcide.git From 6e9a7bc584e7b908763b8c611ccf42ab21cc0a5c Mon Sep 17 00:00:00 2001 From: jneira Date: Sun, 16 Aug 2020 15:42:37 +0200 Subject: [PATCH 18/71] Add action to get client settings --- hls-plugin-api/src/Ide/Plugin.hs | 12 ++++++++++++ 1 file changed, 12 insertions(+) diff --git a/hls-plugin-api/src/Ide/Plugin.hs b/hls-plugin-api/src/Ide/Plugin.hs index 74221fd141..e837923795 100644 --- a/hls-plugin-api/src/Ide/Plugin.hs +++ b/hls-plugin-api/src/Ide/Plugin.hs @@ -17,6 +17,8 @@ module Ide.Plugin , allLspCmdIds' , getPid , responseError + , getClientConfig + , getClientConfigAction ) where import Control.Exception(SomeException, catch) @@ -32,6 +34,7 @@ import qualified Data.Text as T import Development.IDE hiding (pluginRules) import Development.IDE.LSP.Server import GHC.Generics +import Ide.Logger import Ide.Plugin.Config import Ide.Plugin.Formatter import Ide.Types @@ -588,4 +591,13 @@ getPrefixAtPos lf uri pos = do getClientConfig :: LSP.LspFuncs Config -> IO Config getClientConfig lf = fromMaybe Data.Default.def <$> LSP.config lf +-- | Returns the client configurarion stored in the IdeState. +-- You can use this function to access it from shake Rules +getClientConfigAction :: Action Config +getClientConfigAction = do + mbVal <- useNoFile_ GetClientSettings + logm $ "getClientConfigAction:clientSettings:" ++ show mbVal + case J.fromJSON <$> mbVal of + Just (J.Success c) -> return c + _ -> return Data.Default.def -- --------------------------------------------------------------------- From 752c838ecdb976a0179a46fe6a5e9b72d44413ce Mon Sep 17 00:00:00 2001 From: jneira Date: Sun, 16 Aug 2020 15:45:08 +0200 Subject: [PATCH 19/71] Make hlint depend on client setting --- .../hlint-hls-plugin/src/Ide/Plugin/Hlint.hs | 27 ++++++++++--------- 1 file changed, 15 insertions(+), 12 deletions(-) diff --git a/plugins/hlint-hls-plugin/src/Ide/Plugin/Hlint.hs b/plugins/hlint-hls-plugin/src/Ide/Plugin/Hlint.hs index d1d92c2c93..2b69f73c15 100644 --- a/plugins/hlint-hls-plugin/src/Ide/Plugin/Hlint.hs +++ b/plugins/hlint-hls-plugin/src/Ide/Plugin/Hlint.hs @@ -52,6 +52,7 @@ import Language.Haskell.GhclibParserEx.GHC.Driver.Session as GhclibParserEx (rea import Ide.Logger import Ide.Types import Ide.Plugin +import Ide.Plugin.Config import Ide.PluginUtils import Language.Haskell.HLint as Hlint import Language.Haskell.LSP.Types @@ -83,8 +84,10 @@ type instance RuleResult GetHlintDiagnostics = () rules :: Rules () rules = do define $ \GetHlintDiagnostics file -> do - ideas <- getIdeas file - return $ (diagnostics file ideas, Just ()) + hlintOn' <- hlintOn <$> getClientConfigAction + logm $ "hlint:rules:hlintOn=" <> show hlintOn' + ideas <- if hlintOn' then getIdeas file else return (Right []) + return (diagnostics file ideas, Just ()) getHlintSettingsRule (HlintEnabled []) @@ -138,7 +141,7 @@ rules = do getIdeas :: NormalizedFilePath -> Action (Either ParseError [Idea]) getIdeas nfp = do - logm $ "getIdeas:file:" ++ show nfp + logm $ "hlint:getIdeas:file:" ++ show nfp (flags, classify, hint) <- useNoFile_ GetHlintSettings let applyHints' (Just (Right modEx)) = Right $ applyHints classify hint [modEx] @@ -157,9 +160,9 @@ getIdeas nfp = do hsc <- hscEnv <$> use_ GhcSession nfp let dflags = hsc_dflags hsc let hscExts = EnumSet.toList (extensionFlags dflags) - logm $ "getIdeas:setExtensions:hscExtensions:" ++ show hscExts + logm $ "hlint:getIdeas:setExtensions:hscExtensions:" ++ show hscExts let hlintExts = mapMaybe (GhclibParserEx.readExtension . show) hscExts - logm $ "getIdeas:setExtensions:hlintExtensions:" ++ show hlintExts + logm $ "hlint:getIdeas:setExtensions:hlintExtensions:" ++ show hlintExts return $ flags { enabledExtensions = hlintExts } #else moduleEx _flags = do @@ -232,12 +235,12 @@ applyAllCmd _lf ide uri = do let file = maybe (error $ show uri ++ " is not a file.") toNormalizedFilePath' (uriToFilePath' uri) - logm $ "applyAllCmd:file=" ++ show file + logm $ "hlint:applyAllCmd:file=" ++ show file res <- applyHint ide file Nothing - logm $ "applyAllCmd:res=" ++ show res + logm $ "hlint:applyAllCmd:res=" ++ show res return $ case res of - Left err -> (Left (responseError (T.pack $ "applyAll: " ++ show err)), Nothing) + Left err -> (Left (responseError (T.pack $ "hlint:applyAll: " ++ show err)), Nothing) Right fs -> (Right Null, Just (WorkspaceApplyEdit, ApplyWorkspaceEditParams fs)) -- --------------------------------------------------------------------- @@ -262,11 +265,11 @@ applyOneCmd _lf ide (AOP uri pos title) = do let file = maybe (error $ show uri ++ " is not a file.") toNormalizedFilePath' (uriToFilePath' uri) res <- applyHint ide file (Just oneHint) - logm $ "applyOneCmd:file=" ++ show file - logm $ "applyOneCmd:res=" ++ show res + logm $ "hlint:applyOneCmd:file=" ++ show file + logm $ "hlint:applyOneCmd:res=" ++ show res return $ case res of - Left err -> (Left (responseError (T.pack $ "applyOne: " ++ show err)), Nothing) + Left err -> (Left (responseError (T.pack $ "hlint:applyOne: " ++ show err)), Nothing) Right fs -> (Right Null, Just (WorkspaceApplyEdit, ApplyWorkspaceEditParams fs)) applyHint :: IdeState -> NormalizedFilePath -> Maybe OneHint -> IO (Either String WorkspaceEdit) @@ -301,7 +304,7 @@ applyHint ide nfp mhint = let uri = fromNormalizedUri (filePathToUri' nfp) oldContent <- liftIO $ T.readFile fp let wsEdit = diffText' True (uri, oldContent) (T.pack appliedFile) IncludeDeletions - liftIO $ logm $ "applyHint:diff=" ++ show wsEdit + liftIO $ logm $ "hlint:applyHint:diff=" ++ show wsEdit ExceptT $ Right <$> (return wsEdit) Left err -> throwE (show err) From 0aef0030f3656dc23a9f5832a4670709077c1ab4 Mon Sep 17 00:00:00 2001 From: jneira Date: Tue, 25 Aug 2020 07:10:12 +0200 Subject: [PATCH 20/71] Use getFileContents action rule --- .../hlint-hls-plugin/src/Ide/Plugin/Hlint.hs | 19 ++++++++++--------- 1 file changed, 10 insertions(+), 9 deletions(-) diff --git a/plugins/hlint-hls-plugin/src/Ide/Plugin/Hlint.hs b/plugins/hlint-hls-plugin/src/Ide/Plugin/Hlint.hs index 2b69f73c15..71934ffa2e 100644 --- a/plugins/hlint-hls-plugin/src/Ide/Plugin/Hlint.hs +++ b/plugins/hlint-hls-plugin/src/Ide/Plugin/Hlint.hs @@ -31,6 +31,7 @@ import Data.Maybe import qualified Data.Text as T import qualified Data.Text.IO as T import Data.Typeable +import Development.IDE.Core.FileStore import Development.IDE.Core.OfInterest import Development.IDE.Core.Rules import Development.IDE.Core.Shake @@ -154,25 +155,25 @@ getIdeas nfp = do #ifdef GHC_LIB moduleEx flags = do flags' <- setExtensions flags - Just <$> (liftIO $ parseModuleEx flags' (fromNormalizedFilePath nfp) Nothing) + (_, contents) <- getFileContents nfp + let fp = fromNormalizedFilePath nfp + let contents' = T.unpack <$> contents + Just <$> (liftIO $ parseModuleEx flags' fp contents') setExtensions flags = do hsc <- hscEnv <$> use_ GhcSession nfp let dflags = hsc_dflags hsc let hscExts = EnumSet.toList (extensionFlags dflags) - logm $ "hlint:getIdeas:setExtensions:hscExtensions:" ++ show hscExts let hlintExts = mapMaybe (GhclibParserEx.readExtension . show) hscExts - logm $ "hlint:getIdeas:setExtensions:hlintExtensions:" ++ show hlintExts + logm $ "hlint:getIdeas:setExtensions:" ++ show hlintExts return $ flags { enabledExtensions = hlintExts } #else moduleEx _flags = do mbpm <- getParsedModule nfp - case mbpm of - Nothing -> return Nothing - Just pm -> do - let anns = pm_annotations pm - let modu = pm_parsed_source pm - return $ Just $ Right (createModuleEx anns modu) + return $ createModule <$> mbpm + where createModule pm = Right (createModuleEx anns modu) + where anns = pm_annotations pm + modu = pm_parsed_source pm #endif -- --------------------------------------------------------------------- From d13184eb1cfe07ee1ad40bb1cc93e1ecf1b0d505 Mon Sep 17 00:00:00 2001 From: jneira Date: Thu, 27 Aug 2020 07:51:24 +0200 Subject: [PATCH 21/71] Remove commented code from hie --- .../hlint-hls-plugin/src/Ide/Plugin/Hlint.hs | 340 ------------------ 1 file changed, 340 deletions(-) diff --git a/plugins/hlint-hls-plugin/src/Ide/Plugin/Hlint.hs b/plugins/hlint-hls-plugin/src/Ide/Plugin/Hlint.hs index 71934ffa2e..f9366af723 100644 --- a/plugins/hlint-hls-plugin/src/Ide/Plugin/Hlint.hs +++ b/plugins/hlint-hls-plugin/src/Ide/Plugin/Hlint.hs @@ -331,343 +331,3 @@ bimapExceptT f g (ExceptT m) = ExceptT (fmap h m) where h (Left e) = Left (f e) h (Right a) = Right (g a) {-# INLINE bimapExceptT #-} --- --------------------------------------------------------------------- -{- -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE OverloadedStrings #-} --- | apply-refact applies refactorings specified by the refact package. It is --- currently integrated into hlint to enable the automatic application of --- suggestions. -module Haskell.Ide.Engine.Plugin.ApplyRefact where - -import Control.Arrow -import Control.Exception ( IOException - , ErrorCall - , Handler(..) - , catches - , try - ) -import Control.Lens hiding ( List ) -import Control.Monad.IO.Class -import Control.Monad.Trans.Except -import Data.Aeson hiding (Error) -import Data.Maybe - -#if __GLASGOW_HASKELL__ < 808 -import Data.Monoid ((<>)) -#endif - -import qualified Data.Text as T -import GHC.Generics -import Haskell.Ide.Engine.MonadFunctions -import Haskell.Ide.Engine.MonadTypes -import Haskell.Ide.Engine.PluginUtils -import Language.Haskell.Exts.SrcLoc -import Language.Haskell.Exts.Parser -import Language.Haskell.Exts.Extension -import Language.Haskell.HLint4 as Hlint -import qualified Language.Haskell.LSP.Types as LSP -import qualified Language.Haskell.LSP.Types.Lens as LSP -import Refact.Apply - --- --------------------------------------------------------------------- -{-# ANN module ("HLint: ignore Eta reduce" :: String) #-} -{-# ANN module ("HLint: ignore Redundant do" :: String) #-} -{-# ANN module ("HLint: ignore Reduce duplication" :: String) #-} --- --------------------------------------------------------------------- - -type HintTitle = T.Text - -applyRefactDescriptor :: PluginId -> PluginDescriptor -applyRefactDescriptor plId = PluginDescriptor - { pluginId = plId - , pluginName = "ApplyRefact" - , pluginDesc = "apply-refact applies refactorings specified by the refact package. It is currently integrated into hlint to enable the automatic application of suggestions." - , pluginCommands = - [ PluginCommand "applyOne" "Apply a single hint" applyOneCmd - , PluginCommand "applyAll" "Apply all hints to the file" applyAllCmd - ] - , pluginCodeActionProvider = Just codeActionProvider - , pluginDiagnosticProvider = Nothing - , pluginHoverProvider = Nothing - , pluginSymbolProvider = Nothing - , pluginFormattingProvider = Nothing - } - --- --------------------------------------------------------------------- - -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 OneHint = OneHint - { oneHintPos :: Position - , oneHintTitle :: HintTitle - } deriving (Eq, Show) - -applyOneCmd :: ApplyOneParams -> IdeGhcM (IdeResult WorkspaceEdit) -applyOneCmd (AOP uri pos title) = pluginGetFile "applyOne: " uri $ \fp -> do - let oneHint = OneHint pos title - revMapp <- reverseFileMap - let defaultResult = do - debugm "applyOne: no access to the persisted file." - return $ IdeResultOk mempty - withMappedFile fp defaultResult $ \file' -> do - res <- liftToGhc $ applyHint file' (Just oneHint) revMapp - logm $ "applyOneCmd:file=" ++ show fp - logm $ "applyOneCmd:res=" ++ show res - case res of - Left err -> return $ IdeResultFail - (IdeError PluginError (T.pack $ "applyOne: " ++ show err) Null) - Right fs -> return (IdeResultOk fs) - - --- --------------------------------------------------------------------- - -applyAllCmd :: Uri -> IdeGhcM (IdeResult WorkspaceEdit) -applyAllCmd uri = pluginGetFile "applyAll: " uri $ \fp -> do - let defaultResult = do - debugm "applyAll: no access to the persisted file." - return $ IdeResultOk mempty - revMapp <- reverseFileMap - withMappedFile fp defaultResult $ \file' -> do - res <- liftToGhc $ applyHint file' Nothing revMapp - logm $ "applyAllCmd:res=" ++ show res - case res of - Left err -> return $ IdeResultFail (IdeError PluginError - (T.pack $ "applyAll: " ++ show err) Null) - Right fs -> return (IdeResultOk fs) - --- --------------------------------------------------------------------- - --- AZ:TODO: Why is this in IdeGhcM? -lint :: Uri -> IdeGhcM (IdeResult PublishDiagnosticsParams) -lint uri = pluginGetFile "lint: " uri $ \fp -> do - let - defaultResult = do - debugm "lint: no access to the persisted file." - return - $ IdeResultOk (PublishDiagnosticsParams (filePathToUri fp) $ List []) - withMappedFile fp defaultResult $ \file' -> do - eitherErrorResult <- liftIO - (try $ runExceptT $ runLint file' [] :: IO - (Either IOException (Either [Diagnostic] [Idea])) - ) - case eitherErrorResult of - Left err -> return $ IdeResultFail - (IdeError PluginError (T.pack $ "lint: " ++ show err) Null) - Right res -> case res of - Left diags -> - return - (IdeResultOk - (PublishDiagnosticsParams (filePathToUri fp) $ List diags) - ) - Right fs -> - return - $ IdeResultOk - $ PublishDiagnosticsParams (filePathToUri fp) - $ List (map hintToDiagnostic $ stripIgnores fs) - -runLint :: FilePath -> [String] -> ExceptT [Diagnostic] IO [Idea] -runLint fp args = do - (flags,classify,hint) <- liftIO $ argsSettings args - let myflags = flags { hseFlags = (hseFlags flags) { extensions = EnableExtension TypeApplications:extensions (hseFlags flags)}} - res <- bimapExceptT parseErrorToDiagnostic id $ ExceptT $ parseModuleEx myflags fp Nothing - pure $ applyHints classify hint [res] - -parseErrorToDiagnostic :: Hlint.ParseError -> [Diagnostic] -parseErrorToDiagnostic (Hlint.ParseError l msg contents) = - [Diagnostic - { _range = srcLoc2Range l - , _severity = Just DsInfo -- Not displayed - , _code = Just (LSP.StringValue "parser") - , _source = Just "hlint" - , _message = T.unlines [T.pack msg,T.pack contents] - , _relatedInformation = Nothing - }] - -{- --- | An idea suggest by a 'Hint'. -data Idea = Idea - {ideaModule :: String -- ^ The module the idea applies to, may be @\"\"@ if the module cannot be determined or is a result of cross-module hints. - ,ideaDecl :: String -- ^ The declaration the idea applies to, typically the function name, but may be a type name. - ,ideaSeverity :: Severity -- ^ The severity of the idea, e.g. 'Warning'. - ,ideaHint :: String -- ^ The name of the hint that generated the idea, e.g. @\"Use reverse\"@. - ,ideaSpan :: SrcSpan -- ^ The source code the idea relates to. - ,ideaFrom :: String -- ^ The contents of the source code the idea relates to. - ,ideaTo :: Maybe String -- ^ The suggested replacement, or 'Nothing' for no replacement (e.g. on parse errors). - ,ideaNote :: [Note] -- ^ Notes about the effect of applying the replacement. - ,ideaRefactoring :: [Refactoring R.SrcSpan] -- ^ How to perform this idea - } - deriving (Eq,Ord) - --} - --- | Map over both failure and success. -bimapExceptT :: Functor m => (e -> f) -> (a -> b) -> ExceptT e m a -> ExceptT f m b -bimapExceptT f g (ExceptT m) = ExceptT (fmap h m) where - h (Left e) = Left (f e) - h (Right a) = Right (g a) -{-# INLINE bimapExceptT #-} - --- --------------------------------------------------------------------- - -stripIgnores :: [Idea] -> [Idea] -stripIgnores ideas = filter notIgnored ideas - where - notIgnored idea = ideaSeverity idea /= Ignore - --- --------------------------------------------------------------------- - -hintToDiagnostic :: Idea -> Diagnostic -hintToDiagnostic idea - = Diagnostic - { _range = ss2Range (ideaSpan idea) - , _severity = Just (hintSeverityMap $ ideaSeverity idea) - , _code = Just (LSP.StringValue $ T.pack $ ideaHint idea) - , _source = Just "hlint" - , _message = idea2Message idea - , _relatedInformation = Nothing - } - --- --------------------------------------------------------------------- - -idea2Message :: Idea -> T.Text -idea2Message idea = T.unlines $ [T.pack $ ideaHint idea, "Found:", " " <> T.pack (ideaFrom idea)] - <> toIdea <> map (T.pack . show) (ideaNote idea) - where - toIdea :: [T.Text] - toIdea = case ideaTo idea of - Nothing -> [] - Just i -> [T.pack "Why not:", T.pack $ " " ++ i] - --- --------------------------------------------------------------------- --- | Maps hlint severities to LSP severities --- | We want to lower the severities so HLint errors and warnings --- | don't mix with GHC errors and warnings: --- | as per https://github.com/haskell/haskell-ide-engine/issues/375 -hintSeverityMap :: Severity -> DiagnosticSeverity -hintSeverityMap Ignore = DsInfo -- cannot really happen after stripIgnores -hintSeverityMap Suggestion = DsHint -hintSeverityMap Warning = DsInfo -hintSeverityMap Error = DsInfo - --- --------------------------------------------------------------------- - -srcLoc2Range :: SrcLoc -> Range -srcLoc2Range (SrcLoc _ l c) = Range ps pe - where - ps = Position (l-1) (c-1) - pe = Position (l-1) 100000 - --- --------------------------------------------------------------------- - -ss2Range :: SrcSpan -> Range -ss2Range ss = Range ps pe - where - ps = Position (srcSpanStartLine ss - 1) (srcSpanStartColumn ss - 1) - pe = Position (srcSpanEndLine ss - 1) (srcSpanEndColumn ss - 1) - --- --------------------------------------------------------------------- - -applyHint :: FilePath -> Maybe OneHint -> (FilePath -> FilePath) -> IdeM (Either String WorkspaceEdit) -applyHint fp mhint fileMap = do - runExceptT $ do - ideas <- getIdeas fp mhint - let commands = map (show &&& ideaRefactoring) ideas - liftIO $ logm $ "applyHint:apply=" ++ show commands - -- 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 pont 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). - res <- liftIO $ (Right <$> applyRefactorings Nothing commands fp) `catches` - [ Handler $ \e -> return (Left (show (e :: IOException))) - , Handler $ \e -> return (Left (show (e :: ErrorCall))) - ] - case res of - Right appliedFile -> do - diff <- ExceptT $ Right <$> makeDiffResult fp (T.pack appliedFile) fileMap - liftIO $ logm $ "applyHint:diff=" ++ show diff - return diff - Left err -> - throwE (show err) - --- | Gets HLint ideas for -getIdeas :: MonadIO m => FilePath -> Maybe OneHint -> ExceptT String m [Idea] -getIdeas lintFile mhint = do - let hOpts = hlintOpts lintFile (oneHintPos <$> mhint) - ideas <- runHlint lintFile hOpts - pure $ maybe ideas (`filterIdeas` ideas) mhint - --- | If we are only interested in applying a particular hint then --- let's filter out all the irrelevant ideas -filterIdeas :: OneHint -> [Idea] -> [Idea] -filterIdeas (OneHint (Position l c) title) ideas = - let - title' = T.unpack title - ideaPos = (srcSpanStartLine &&& srcSpanStartColumn) . ideaSpan - in filter (\i -> ideaHint i == title' && ideaPos i == (l+1, c+1)) ideas - -hlintOpts :: FilePath -> Maybe Position -> [String] -hlintOpts lintFile mpos = - let - posOpt (Position l c) = " --pos " ++ show (l+1) ++ "," ++ show (c+1) - opts = maybe "" posOpt mpos - in [lintFile, "--quiet", "--refactor", "--refactor-options=" ++ opts ] - -runHlint :: MonadIO m => FilePath -> [String] -> ExceptT String m [Idea] -runHlint fp args = - do (flags,classify,hint) <- liftIO $ argsSettings args - let myflags = flags { hseFlags = (hseFlags flags) { extensions = EnableExtension TypeApplications:extensions (hseFlags flags)}} - res <- bimapExceptT showParseError id $ ExceptT $ liftIO $ parseModuleEx myflags fp Nothing - pure $ applyHints classify hint [res] - -showParseError :: Hlint.ParseError -> String -showParseError (Hlint.ParseError location message content) = - unlines [show location, message, content] - --- --------------------------------------------------------------------- - -codeActionProvider :: CodeActionProvider -codeActionProvider plId docId _ context = IdeResultOk <$> hlintActions - where - - hlintActions :: IdeM [LSP.CodeAction] - hlintActions = catMaybes <$> mapM mkHlintAction (filter validCommand diags) - - -- |Some hints do not have an associated refactoring - validCommand (LSP.Diagnostic _ _ (Just (LSP.StringValue code)) (Just "hlint") _ _) = - case code of - "Eta reduce" -> False - _ -> True - validCommand _ = False - - LSP.List diags = context ^. LSP.diagnostics - - mkHlintAction :: LSP.Diagnostic -> IdeM (Maybe LSP.CodeAction) - mkHlintAction diag@(LSP.Diagnostic (LSP.Range start _) _s (Just (LSP.StringValue code)) (Just "hlint") m _) = - Just . codeAction <$> mkLspCommand plId "applyOne" title (Just args) - where - codeAction cmd = LSP.CodeAction title (Just LSP.CodeActionQuickFix) (Just (LSP.List [diag])) Nothing (Just cmd) - title = "Apply hint:" <> head (T.lines m) - -- need 'file', 'start_pos' and hint title (to distinguish between alternative suggestions at the same location) - args = [toJSON (AOP (docId ^. LSP.uri) start code)] - mkHlintAction (LSP.Diagnostic _r _s _c _source _m _) = return Nothing --} From adeb930f0a5765bc56c0a41c852ab9088588fd10 Mon Sep 17 00:00:00 2001 From: jneira Date: Fri, 28 Aug 2020 06:33:09 +0200 Subject: [PATCH 22/71] Use edited content for compute edits --- plugins/hlint-hls-plugin/src/Ide/Plugin/Hlint.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/plugins/hlint-hls-plugin/src/Ide/Plugin/Hlint.hs b/plugins/hlint-hls-plugin/src/Ide/Plugin/Hlint.hs index f9366af723..5f5fa2fafc 100644 --- a/plugins/hlint-hls-plugin/src/Ide/Plugin/Hlint.hs +++ b/plugins/hlint-hls-plugin/src/Ide/Plugin/Hlint.hs @@ -303,7 +303,8 @@ applyHint ide nfp mhint = case res of Right appliedFile -> do let uri = fromNormalizedUri (filePathToUri' nfp) - oldContent <- liftIO $ T.readFile fp + (_, mbOldContent) <- liftIO $ runAction "hlint" ide $ getFileContents nfp + oldContent <- maybe (liftIO $ T.readFile fp) return mbOldContent let wsEdit = diffText' True (uri, oldContent) (T.pack appliedFile) IncludeDeletions liftIO $ logm $ "hlint:applyHint:diff=" ++ show wsEdit ExceptT $ Right <$> (return wsEdit) From 26740f1dfe77ecaa69d9dc3f1796fd7eef53297f Mon Sep 17 00:00:00 2001 From: Luke Lau Date: Sat, 29 Aug 2020 14:54:21 +0100 Subject: [PATCH 23/71] Use persisted VFS file with apply refact, expose applyAll In the code action request if there is more than one hint available for the document --- .../hlint-hls-plugin/src/Ide/Plugin/Hlint.hs | 85 +++++++++++++------ 1 file changed, 59 insertions(+), 26 deletions(-) diff --git a/plugins/hlint-hls-plugin/src/Ide/Plugin/Hlint.hs b/plugins/hlint-hls-plugin/src/Ide/Plugin/Hlint.hs index 5f5fa2fafc..28907f7d3d 100644 --- a/plugins/hlint-hls-plugin/src/Ide/Plugin/Hlint.hs +++ b/plugins/hlint-hls-plugin/src/Ide/Plugin/Hlint.hs @@ -56,6 +56,7 @@ import Ide.Plugin import Ide.Plugin.Config import Ide.PluginUtils import Language.Haskell.HLint as Hlint +import Language.Haskell.LSP.Core import Language.Haskell.LSP.Types import qualified Language.Haskell.LSP.Types as LSP import qualified Language.Haskell.LSP.Types.Lens as LSP @@ -206,11 +207,33 @@ getHlintSettingsRule usage = -- --------------------------------------------------------------------- codeActionProvider :: CodeActionProvider -codeActionProvider _ _ plId docId _ context = (Right . LSP.List . map CACodeAction) <$> hlintActions +codeActionProvider _lf ideState plId docId _ context = Right . LSP.List . map CACodeAction <$> getCodeActions where - hlintActions :: IO [LSP.CodeAction] - hlintActions = catMaybes <$> mapM mkHlintAction (filter validCommand diags) + getCodeActions = do + applyOne <- applyOneActions + diags <- getDiagnostics ideState + let docNfp = toNormalizedFilePath' <$> uriToFilePath' (docId ^. LSP.uri) + numHintsInDoc = length + [d | (nfp, _, d) <- diags + , d ^. LSP.source == Just "hlint" + , Just nfp == docNfp + ] + -- We only want to show the applyAll code action if there is more than 1 + -- hint in the current document + if numHintsInDoc >= 2 then do + applyAll <- applyAllAction + pure $ applyAll:applyOne + else + pure applyOne + + applyAllAction = do + 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) + + applyOneActions :: IO [LSP.CodeAction] + applyOneActions = catMaybes <$> mapM mkHlintAction (filter validCommand diags) -- |Some hints do not have an associated refactoring validCommand (LSP.Diagnostic _ _ (Just (LSP.StringValue code)) (Just "hlint") _ _ _) = @@ -232,17 +255,22 @@ codeActionProvider _ _ plId docId _ context = (Right . LSP.List . map CACodeActi -- --------------------------------------------------------------------- applyAllCmd :: CommandFunction Uri -applyAllCmd _lf ide uri = do +applyAllCmd lf ide uri = do let file = maybe (error $ show uri ++ " is not a file.") toNormalizedFilePath' (uriToFilePath' uri) - logm $ "hlint:applyAllCmd:file=" ++ show file - res <- 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)) + -- Persist the virtual file first since apply-refact works on files, not text content + mvfp <- persistVirtualFileFunc lf (toNormalizedUri uri) + case mvfp of + Nothing -> pure (Left (responseError (T.pack $ "Couldn't persist virtual file for " ++ show uri)), Nothing) + Just vfp -> do + logm $ "hlint:applyAllCmd:file=" ++ show file + res <- applyHint ide (toNormalizedFilePath vfp) 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)) -- --------------------------------------------------------------------- @@ -261,22 +289,27 @@ data OneHint = OneHint } deriving (Eq, Show) applyOneCmd :: CommandFunction ApplyOneParams -applyOneCmd _lf ide (AOP uri pos title) = do +applyOneCmd lf ide (AOP uri pos title) = do let oneHint = OneHint pos title let file = maybe (error $ show uri ++ " is not a file.") toNormalizedFilePath' (uriToFilePath' uri) - res <- applyHint ide file (Just oneHint) - logm $ "hlint:applyOneCmd:file=" ++ show file - 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)) - -applyHint :: IdeState -> NormalizedFilePath -> Maybe OneHint -> IO (Either String WorkspaceEdit) -applyHint ide nfp mhint = + -- Persist the virtual file first since apply-refact works on files, not text content + mvfp <- persistVirtualFileFunc lf (toNormalizedUri uri) + case mvfp of + Nothing -> pure (Left (responseError (T.pack $ "Couldn't persist virtual file for " ++ show uri)), Nothing) + Just vfp -> do + res <- applyHint ide (toNormalizedFilePath vfp) file (Just oneHint) + logm $ "hlint:applyOneCmd:file=" ++ show file + 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)) + +applyHint :: IdeState -> NormalizedFilePath -> NormalizedFilePath -> Maybe OneHint -> IO (Either String WorkspaceEdit) +applyHint ide virtualFp actualFp mhint = runExceptT $ do - ideas <- bimapExceptT showParseError id $ ExceptT $ liftIO $ runAction "applyHint" ide $ getIdeas nfp + ideas <- bimapExceptT showParseError id $ ExceptT $ liftIO $ runAction "applyHint" ide $ getIdeas virtualFp let ideas' = maybe ideas (`filterIdeas` ideas) mhint let commands = map (show &&& ideaRefactoring) ideas' liftIO $ logm $ "applyHint:apply=" ++ show commands @@ -295,15 +328,15 @@ applyHint ide nfp mhint = -- 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 fp = fromNormalizedFilePath nfp + let fp = fromNormalizedFilePath virtualFp res <- liftIO $ (Right <$> applyRefactorings Nothing commands fp) `catches` [ Handler $ \e -> return (Left (show (e :: IOException))) , Handler $ \e -> return (Left (show (e :: ErrorCall))) ] case res of Right appliedFile -> do - let uri = fromNormalizedUri (filePathToUri' nfp) - (_, mbOldContent) <- liftIO $ runAction "hlint" ide $ getFileContents nfp + let uri = fromNormalizedUri (filePathToUri' actualFp) + (_, mbOldContent) <- liftIO $ runAction "hlint" ide $ getFileContents actualFp oldContent <- maybe (liftIO $ T.readFile fp) return mbOldContent let wsEdit = diffText' True (uri, oldContent) (T.pack appliedFile) IncludeDeletions liftIO $ logm $ "hlint:applyHint:diff=" ++ show wsEdit From 7674fe7eab6b2d70923566f3e7cafd3ed77b157c Mon Sep 17 00:00:00 2001 From: jneira Date: Sat, 29 Aug 2020 16:45:16 +0200 Subject: [PATCH 24/71] Enable hlint tests --- test/functional/FunctionalCodeAction.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/test/functional/FunctionalCodeAction.hs b/test/functional/FunctionalCodeAction.hs index 02c3b6f7be..f3ad3a3c09 100644 --- a/test/functional/FunctionalCodeAction.hs +++ b/test/functional/FunctionalCodeAction.hs @@ -44,7 +44,7 @@ tests = testGroup "code actions" [ hlintTests :: TestTree hlintTests = testGroup "hlint suggestions" [ - ignoreTestBecause "Broken" $ testCase "provides 3.8 code actions" $ runSession hlsCommand fullCaps "test/testdata" $ do + testCase "provides 3.8 code actions" $ runSession hlsCommand fullCaps "test/testdata" $ do doc <- openDoc "ApplyRefact2.hs" "haskell" diags@(reduceDiag:_) <- waitForDiagnostics @@ -67,7 +67,7 @@ hlintTests = testGroup "hlint suggestions" [ noDiagnostics - , ignoreTestBecause "Broken" $ testCase "falls back to pre 3.8 code actions" $ runSession hlsCommand noLiteralCaps "test/testdata" $ do + , testCase "falls back to pre 3.8 code actions" $ runSession hlsCommand noLiteralCaps "test/testdata" $ do doc <- openDoc "ApplyRefact2.hs" "haskell" _ <- waitForDiagnostics From ff778b64fc868086b193c7267df10cc882149c8f Mon Sep 17 00:00:00 2001 From: jneira Date: Sun, 30 Aug 2020 23:55:44 +0200 Subject: [PATCH 25/71] Move test data to fix the cradle loading --- test/testdata/{ => hlint}/ApplyRefact.hs | 0 test/testdata/{ => hlint}/ApplyRefact2.hs | 0 2 files changed, 0 insertions(+), 0 deletions(-) rename test/testdata/{ => hlint}/ApplyRefact.hs (100%) rename test/testdata/{ => hlint}/ApplyRefact2.hs (100%) diff --git a/test/testdata/ApplyRefact.hs b/test/testdata/hlint/ApplyRefact.hs similarity index 100% rename from test/testdata/ApplyRefact.hs rename to test/testdata/hlint/ApplyRefact.hs diff --git a/test/testdata/ApplyRefact2.hs b/test/testdata/hlint/ApplyRefact2.hs similarity index 100% rename from test/testdata/ApplyRefact2.hs rename to test/testdata/hlint/ApplyRefact2.hs From 0e71e8762664e9f1c5e579a278a8ce17d589e947 Mon Sep 17 00:00:00 2001 From: jneira Date: Mon, 31 Aug 2020 00:03:03 +0200 Subject: [PATCH 26/71] Fix hlint tests --- test/functional/FunctionalCodeAction.hs | 22 +++++++--------------- 1 file changed, 7 insertions(+), 15 deletions(-) diff --git a/test/functional/FunctionalCodeAction.hs b/test/functional/FunctionalCodeAction.hs index f3ad3a3c09..0af484da99 100644 --- a/test/functional/FunctionalCodeAction.hs +++ b/test/functional/FunctionalCodeAction.hs @@ -44,12 +44,12 @@ tests = testGroup "code actions" [ hlintTests :: TestTree hlintTests = testGroup "hlint suggestions" [ - testCase "provides 3.8 code actions" $ runSession hlsCommand fullCaps "test/testdata" $ do + testCase "provides 3.8 code actions" $ runSession hlsCommand fullCaps "test/testdata/hlint" $ do doc <- openDoc "ApplyRefact2.hs" "haskell" diags@(reduceDiag:_) <- waitForDiagnostics liftIO $ do - length diags @?= 2 + 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.code @?= Just (StringValue "Eta reduce") @@ -57,17 +57,14 @@ hlintTests = testGroup "hlint suggestions" [ (CACodeAction ca:_) <- getAllCodeActions doc - -- Evaluate became redundant id in later hlint versions - liftIO $ (ca ^. L.title) `elem` ["Apply hint:Redundant id", "Apply hint:Evaluate"] @? "Title contains evaluate" + liftIO $ "Redundant id" `T.isSuffixOf` (ca ^. L.title) @? "Title contains Redundant id" executeCodeAction ca contents <- getDocumentEdit doc liftIO $ contents @?= "main = undefined\nfoo x = x\n" - noDiagnostics - - , testCase "falls back to pre 3.8 code actions" $ runSession hlsCommand noLiteralCaps "test/testdata" $ do + , testCase "falls back to pre 3.8 code actions" $ runSession hlsCommand noLiteralCaps "test/testdata/hlint" $ do doc <- openDoc "ApplyRefact2.hs" "haskell" _ <- waitForDiagnostics @@ -75,16 +72,14 @@ hlintTests = testGroup "hlint suggestions" [ (CACommand cmd:_) <- getAllCodeActions doc -- Evaluate became redundant id in later hlint versions - liftIO $ (cmd ^. L.title) `elem` ["Apply hint:Redundant id", "Apply hint:Evaluate"] @? "Title contains evaluate" + liftIO $ "Redundant id" `T.isSuffixOf` (cmd ^. L.title) @? "Title contains Redundant id" executeCommand cmd contents <- skipManyTill publishDiagnosticsNotification $ getDocumentEdit doc liftIO $ contents @?= "main = undefined\nfoo x = x\n" - noDiagnostics - - , ignoreTestBecause "Broken" $ testCase "runs diagnostics on save" $ runSession hlsCommand fullCaps "test/testdata" $ do + , testCase "runs diagnostics on save" $ runSession hlsCommand fullCaps "test/testdata/hlint" $ do let config = def { diagnosticsOnChange = False } sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (toJSON config)) @@ -100,16 +95,13 @@ hlintTests = testGroup "hlint suggestions" [ (CACodeAction ca:_) <- getAllCodeActions doc - -- Evaluate became redundant id in later hlint versions - liftIO $ (ca ^. L.title) `elem` ["Apply hint:Redundant id", "Apply hint:Evaluate"] @? "Title contains evaluate" + liftIO $ "Redundant id" `T.isSuffixOf` (ca ^. L.title) @? "Title contains Redundant id" executeCodeAction ca contents <- getDocumentEdit doc liftIO $ contents @?= "main = undefined\nfoo x = x\n" sendNotification TextDocumentDidSave (DidSaveTextDocumentParams doc) - - noDiagnostics ] renameTests :: TestTree From 36982a574065eaeec18077c05913e1a0aee5c47f Mon Sep 17 00:00:00 2001 From: jneira Date: Wed, 2 Sep 2020 07:25:54 +0200 Subject: [PATCH 27/71] Add indefinite progress to apply refact --- .../hlint-hls-plugin/src/Ide/Plugin/Hlint.hs | 45 ++++++++++--------- 1 file changed, 25 insertions(+), 20 deletions(-) diff --git a/plugins/hlint-hls-plugin/src/Ide/Plugin/Hlint.hs b/plugins/hlint-hls-plugin/src/Ide/Plugin/Hlint.hs index 28907f7d3d..6b0f635e66 100644 --- a/plugins/hlint-hls-plugin/src/Ide/Plugin/Hlint.hs +++ b/plugins/hlint-hls-plugin/src/Ide/Plugin/Hlint.hs @@ -34,7 +34,7 @@ import Data.Typeable import Development.IDE.Core.FileStore import Development.IDE.Core.OfInterest import Development.IDE.Core.Rules -import Development.IDE.Core.Shake +import Development.IDE.Core.Shake hiding (withIndefiniteProgress) import Development.IDE.Types.Diagnostics as D import Development.IDE.Types.Location import Development.Shake @@ -262,15 +262,17 @@ applyAllCmd lf ide uri = do -- Persist the virtual file first since apply-refact works on files, not text content mvfp <- persistVirtualFileFunc lf (toNormalizedUri uri) case mvfp of - Nothing -> pure (Left (responseError (T.pack $ "Couldn't persist virtual file for " ++ show uri)), Nothing) - Just vfp -> do - logm $ "hlint:applyAllCmd:file=" ++ show file - res <- applyHint ide (toNormalizedFilePath vfp) 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)) + Nothing -> + pure (Left (responseError (T.pack $ "Couldn't persist virtual file for " ++ show uri)), Nothing) + Just vfp -> + withIndefiniteProgress lf "Applying all hints" Cancellable $ do + logm $ "hlint:applyAllCmd:file=" ++ show file + res <- applyHint ide (toNormalizedFilePath vfp) 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)) -- --------------------------------------------------------------------- @@ -293,18 +295,21 @@ applyOneCmd lf 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 -- Persist the virtual file first since apply-refact works on files, not text content mvfp <- persistVirtualFileFunc lf (toNormalizedUri uri) case mvfp of - Nothing -> pure (Left (responseError (T.pack $ "Couldn't persist virtual file for " ++ show uri)), Nothing) - Just vfp -> do - res <- applyHint ide (toNormalizedFilePath vfp) file (Just oneHint) - logm $ "hlint:applyOneCmd:file=" ++ show file - 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)) + Nothing -> + pure (Left (responseError (T.pack $ "Couldn't persist virtual file for " ++ show uri)), Nothing) + Just vfp -> + withIndefiniteProgress lf progTitle Cancellable $ do + res <- applyHint ide (toNormalizedFilePath vfp) file (Just oneHint) + logm $ "hlint:applyOneCmd:file=" ++ show file + 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)) applyHint :: IdeState -> NormalizedFilePath -> NormalizedFilePath -> Maybe OneHint -> IO (Either String WorkspaceEdit) applyHint ide virtualFp actualFp mhint = @@ -340,7 +345,7 @@ applyHint ide virtualFp actualFp mhint = oldContent <- maybe (liftIO $ T.readFile fp) return mbOldContent let wsEdit = diffText' True (uri, oldContent) (T.pack appliedFile) IncludeDeletions liftIO $ logm $ "hlint:applyHint:diff=" ++ show wsEdit - ExceptT $ Right <$> (return wsEdit) + ExceptT $ return (Right wsEdit) Left err -> throwE (show err) where From 11086d509ba295f0957905ffaa379092ade5086e Mon Sep 17 00:00:00 2001 From: jneira Date: Mon, 7 Sep 2020 12:41:23 +0200 Subject: [PATCH 28/71] Bump ghcide submodule --- .gitmodules | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/.gitmodules b/.gitmodules index 4a0089e4cd..231895e286 100644 --- a/.gitmodules +++ b/.gitmodules @@ -12,7 +12,7 @@ path = ghcide # url = https://github.com/alanz/ghcide.git # url = https://github.com/wz1000/ghcide.git - url = https://github.com/haskell/ghcide.git + # url = https://github.com/haskell/ghcide.git # url = https://github.com/fendor/ghcide.git # url = https://github.com/bubba/ghcide.git - # url = https://github.com/jneira/ghcide.git + url = https://github.com/jneira/ghcide.git From b44ecb409f59cfe9847cfa4066d519b549cbe76a Mon Sep 17 00:00:00 2001 From: jneira Date: Mon, 7 Sep 2020 12:41:48 +0200 Subject: [PATCH 29/71] Adapt code to handle hashed value --- hls-plugin-api/src/Ide/Plugin.hs | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/hls-plugin-api/src/Ide/Plugin.hs b/hls-plugin-api/src/Ide/Plugin.hs index e837923795..e509196dc9 100644 --- a/hls-plugin-api/src/Ide/Plugin.hs +++ b/hls-plugin-api/src/Ide/Plugin.hs @@ -27,6 +27,7 @@ import Control.Monad import qualified Data.Aeson as J import qualified Data.Default import Data.Either +import Data.Hashable (unhashed) import qualified Data.List as List import qualified Data.Map as Map import Data.Maybe @@ -592,10 +593,10 @@ getClientConfig :: LSP.LspFuncs Config -> IO Config getClientConfig lf = fromMaybe Data.Default.def <$> LSP.config lf -- | Returns the client configurarion stored in the IdeState. --- You can use this function to access it from shake Rules +-- You can use this function to access it from shake Rules getClientConfigAction :: Action Config getClientConfigAction = do - mbVal <- useNoFile_ GetClientSettings + mbVal <- unhashed <$> useNoFile_ GetClientSettings logm $ "getClientConfigAction:clientSettings:" ++ show mbVal case J.fromJSON <$> mbVal of Just (J.Success c) -> return c From 523953c1412c77468b0b1019b324b8f01efeab46 Mon Sep 17 00:00:00 2001 From: jneira Date: Wed, 2 Sep 2020 15:28:36 +0200 Subject: [PATCH 30/71] Replace vfs with raw temp file --- haskell-language-server.cabal | 1 + .../hlint-hls-plugin/src/Ide/Plugin/Hlint.hs | 83 ++++++++++--------- 2 files changed, 43 insertions(+), 41 deletions(-) diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal index 27c2903e5c..26a32399dc 100644 --- a/haskell-language-server.cabal +++ b/haskell-language-server.cabal @@ -109,6 +109,7 @@ library hlint-plugin , lens , regex-tdfa , shake + , temporary , text , transformers , unordered-containers diff --git a/plugins/hlint-hls-plugin/src/Ide/Plugin/Hlint.hs b/plugins/hlint-hls-plugin/src/Ide/Plugin/Hlint.hs index 6b0f635e66..13a60b4a2d 100644 --- a/plugins/hlint-hls-plugin/src/Ide/Plugin/Hlint.hs +++ b/plugins/hlint-hls-plugin/src/Ide/Plugin/Hlint.hs @@ -60,6 +60,9 @@ import Language.Haskell.LSP.Core import Language.Haskell.LSP.Types import qualified Language.Haskell.LSP.Types as LSP import qualified Language.Haskell.LSP.Types.Lens as LSP +import System.FilePath (takeFileName) +import System.IO (hPutStr, noNewlineTranslation, hSetNewlineMode, utf8, hSetEncoding, IOMode(WriteMode), withFile, hClose) +import System.IO.Temp import Text.Regex.TDFA.Text() import GHC.Generics (Generic) @@ -95,7 +98,7 @@ rules = do action $ do files <- getFilesOfInterest - void $ uses GetHlintDiagnostics $ HashSet.toList files + void $ uses GetHlintDiagnostics $ HashSet.toList (files) where @@ -259,20 +262,14 @@ applyAllCmd lf ide uri = do let file = maybe (error $ show uri ++ " is not a file.") toNormalizedFilePath' (uriToFilePath' uri) - -- Persist the virtual file first since apply-refact works on files, not text content - mvfp <- persistVirtualFileFunc lf (toNormalizedUri uri) - case mvfp of - Nothing -> - pure (Left (responseError (T.pack $ "Couldn't persist virtual file for " ++ show uri)), Nothing) - Just vfp -> - withIndefiniteProgress lf "Applying all hints" Cancellable $ do - logm $ "hlint:applyAllCmd:file=" ++ show file - res <- applyHint ide (toNormalizedFilePath vfp) 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)) + withIndefiniteProgress lf "Applying all hints" Cancellable $ do + logm $ "hlint:applyAllCmd:file=" ++ show file + res <- 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)) -- --------------------------------------------------------------------- @@ -296,25 +293,19 @@ applyOneCmd lf ide (AOP uri pos title) = do let file = maybe (error $ show uri ++ " is not a file.") toNormalizedFilePath' (uriToFilePath' uri) let progTitle = "Applying hint: " <> title - -- Persist the virtual file first since apply-refact works on files, not text content - mvfp <- persistVirtualFileFunc lf (toNormalizedUri uri) - case mvfp of - Nothing -> - pure (Left (responseError (T.pack $ "Couldn't persist virtual file for " ++ show uri)), Nothing) - Just vfp -> - withIndefiniteProgress lf progTitle Cancellable $ do - res <- applyHint ide (toNormalizedFilePath vfp) file (Just oneHint) - logm $ "hlint:applyOneCmd:file=" ++ show file - 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)) - -applyHint :: IdeState -> NormalizedFilePath -> NormalizedFilePath -> Maybe OneHint -> IO (Either String WorkspaceEdit) -applyHint ide virtualFp actualFp mhint = + withIndefiniteProgress lf progTitle Cancellable $ do + logm $ "hlint:applyOneCmd:file=" ++ show file + res <- 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)) + +applyHint :: IdeState -> NormalizedFilePath -> Maybe OneHint -> IO (Either String WorkspaceEdit) +applyHint ide nfp mhint = runExceptT $ do - ideas <- bimapExceptT showParseError id $ ExceptT $ liftIO $ runAction "applyHint" ide $ getIdeas virtualFp + ideas <- bimapExceptT showParseError id $ ExceptT $ liftIO $ runAction "applyHint" ide $ getIdeas nfp let ideas' = maybe ideas (`filterIdeas` ideas) mhint let commands = map (show &&& ideaRefactoring) ideas' liftIO $ logm $ "applyHint:apply=" ++ show commands @@ -333,16 +324,19 @@ applyHint ide virtualFp actualFp mhint = -- 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 fp = fromNormalizedFilePath virtualFp - res <- liftIO $ (Right <$> applyRefactorings Nothing commands fp) `catches` - [ Handler $ \e -> return (Left (show (e :: IOException))) - , Handler $ \e -> return (Left (show (e :: ErrorCall))) - ] + let fp = fromNormalizedFilePath nfp + (_, mbOldContent) <- liftIO $ runAction "hlint" ide $ getFileContents nfp + oldContent <- maybe (liftIO $ T.readFile fp) return mbOldContent + res <- liftIO $ withSystemTempFile (takeFileName fp) $ \temp h -> do + hClose h + writeFileUTF8NoNewLineTranslation temp oldContent + (Right <$> applyRefactorings Nothing commands temp) `catches` + [ Handler $ \e -> return (Left (show (e :: IOException))) + , Handler $ \e -> return (Left (show (e :: ErrorCall))) + ] case res of Right appliedFile -> do - let uri = fromNormalizedUri (filePathToUri' actualFp) - (_, mbOldContent) <- liftIO $ runAction "hlint" ide $ getFileContents actualFp - oldContent <- maybe (liftIO $ T.readFile fp) return mbOldContent + 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) @@ -370,3 +364,10 @@ bimapExceptT f g (ExceptT m) = ExceptT (fmap h m) where h (Left e) = Left (f e) h (Right a) = Right (g a) {-# INLINE bimapExceptT #-} + +writeFileUTF8NoNewLineTranslation :: FilePath -> T.Text -> IO() +writeFileUTF8NoNewLineTranslation file txt = + withFile file WriteMode $ \h -> do + hSetEncoding h utf8 + hSetNewlineMode h noNewlineTranslation + hPutStr h (T.unpack txt) \ No newline at end of file From 3a46078e1541efda057145c6473cb5cbb3bbc75c Mon Sep 17 00:00:00 2001 From: jneira Date: Wed, 9 Sep 2020 13:18:06 +0200 Subject: [PATCH 31/71] Convert hlint-hls-plugin in a package Include resolver bumps for stack-8.8.3, 8.8.4, 8.10.1 and 8.10.2 --- cabal.project | 1 + haskell-language-server.cabal | 58 +---- hie.yaml.stack | 3 + hls-plugin-api/hls-plugin-api.cabal | 1 + plugins/hlint-hls-plugin/LICENSE | 201 ++++++++++++++++++ .../hlint-hls-plugin/hlint-hls-plugin.cabal | 73 +++++++ stack-8.10.1.yaml | 4 +- stack-8.10.2.yaml | 2 +- stack-8.6.4.yaml | 8 +- stack-8.6.5.yaml | 5 +- stack-8.8.2.yaml | 10 +- stack-8.8.3.yaml | 8 +- stack-8.8.4.yaml | 7 +- stack.yaml | 4 +- 14 files changed, 312 insertions(+), 73 deletions(-) create mode 100644 plugins/hlint-hls-plugin/LICENSE create mode 100644 plugins/hlint-hls-plugin/hlint-hls-plugin.cabal diff --git a/cabal.project b/cabal.project index 838349a717..2ae1b6e8f5 100644 --- a/cabal.project +++ b/cabal.project @@ -3,6 +3,7 @@ packages: ghcide hls-plugin-api ./plugins/tactics + ./plugins/hlint-hls-plugin source-repository-package type: git diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal index 26a32399dc..afe3a8e36f 100644 --- a/haskell-language-server.cabal +++ b/haskell-language-server.cabal @@ -77,63 +77,6 @@ library default-language: Haskell2010 -flag ghc-lib - default: False - manual: True - description: Force dependency on ghc-lib-parser even if GHC API in the ghc package is supported - -library hlint-plugin - exposed-modules: - Ide.Plugin.Hlint - hs-source-dirs: - plugins/hlint-hls-plugin/src - build-depends: - base - , aeson - , apply-refact - , binary - , bytestring - , containers - , data-default - , deepseq - , Diff - , directory - , extra - , filepath - , ghcide - , hashable - , haskell-language-server - , haskell-lsp - , hlint >= 3.0 - , hslogger - , lens - , regex-tdfa - , shake - , temporary - , text - , transformers - , unordered-containers - if !flag(ghc-lib) && impl(ghc >= 8.10.1) && impl(ghc < 8.11.0) - build-depends: - ghc == 8.10.* - else - build-depends: - ghc - , ghc-lib == 8.10.* - , ghc-lib-parser-ex == 8.10.* - cpp-options: - -DGHC_LIB - mixins: - ghc (GHC as RealGHC, HscTypes as RealGHC.HscTypes, EnumSet as RealGHC.EnumSet) - - ghc-options: - -Wall - -Wredundant-constraints - -Wno-name-shadowing - if flag(pedantic) - ghc-options: -Werror - - default-language: Haskell2010 executable haskell-language-server import: agpl, common-deps @@ -177,6 +120,7 @@ executable haskell-language-server , hashable , haskell-language-server , haskell-lsp ^>=0.22 + , hlint-hls-plugin , hls-plugin-api , hls-tactics-plugin , lens diff --git a/hie.yaml.stack b/hie.yaml.stack index 69c94ea0cc..d74387d8ab 100644 --- a/hie.yaml.stack +++ b/hie.yaml.stack @@ -48,3 +48,6 @@ cradle: - path: "./hls-plugin-api/src" component: "hls-plugin-api:lib:hls-plugin-api" + + - path: "./plugins/hlint-hls-plugin/src" + component: "hlint-hls-plugin:lib:hlint-hls-plugin" diff --git a/hls-plugin-api/hls-plugin-api.cabal b/hls-plugin-api/hls-plugin-api.cabal index 5b2bdf6253..423422dfe3 100644 --- a/hls-plugin-api/hls-plugin-api.cabal +++ b/hls-plugin-api/hls-plugin-api.cabal @@ -44,6 +44,7 @@ library , ghc-boot-th , ghcide >=0.4 , haskell-lsp ^>=0.22 + , hashable , hslogger , lens , process diff --git a/plugins/hlint-hls-plugin/LICENSE b/plugins/hlint-hls-plugin/LICENSE new file mode 100644 index 0000000000..261eeb9e9f --- /dev/null +++ b/plugins/hlint-hls-plugin/LICENSE @@ -0,0 +1,201 @@ + Apache License + Version 2.0, January 2004 + http://www.apache.org/licenses/ + + TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION + + 1. Definitions. + + "License" shall mean the terms and conditions for use, reproduction, + and distribution as defined by Sections 1 through 9 of this document. + + "Licensor" shall mean the copyright owner or entity authorized by + the copyright owner that is granting the License. + + "Legal Entity" shall mean the union of the acting entity and all + other entities that control, are controlled by, or are under common + control with that entity. For the purposes of this definition, + "control" means (i) the power, direct or indirect, to cause the + direction or management of such entity, whether by contract or + otherwise, or (ii) ownership of fifty percent (50%) or more of the + outstanding shares, or (iii) beneficial ownership of such entity. + + "You" (or "Your") shall mean an individual or Legal Entity + exercising permissions granted by this License. + + "Source" form shall mean the preferred form for making modifications, + including but not limited to software source code, documentation + source, and configuration files. + + "Object" form shall mean any form resulting from mechanical + transformation or translation of a Source form, including but + not limited to compiled object code, generated documentation, + and conversions to other media types. + + "Work" shall mean the work of authorship, whether in Source or + Object form, made available under the License, as indicated by a + copyright notice that is included in or attached to the work + (an example is provided in the Appendix below). + + "Derivative Works" shall mean any work, whether in Source or Object + form, that is based on (or derived from) the Work and for which the + editorial revisions, annotations, elaborations, or other modifications + represent, as a whole, an original work of authorship. For the purposes + of this License, Derivative Works shall not include works that remain + separable from, or merely link (or bind by name) to the interfaces of, + the Work and Derivative Works thereof. + + "Contribution" shall mean any work of authorship, including + the original version of the Work and any modifications or additions + to that Work or Derivative Works thereof, that is intentionally + submitted to Licensor for inclusion in the Work by the copyright owner + or by an individual or Legal Entity authorized to submit on behalf of + the copyright owner. For the purposes of this definition, "submitted" + means any form of electronic, verbal, or written communication sent + to the Licensor or its representatives, including but not limited to + communication on electronic mailing lists, source code control systems, + and issue tracking systems that are managed by, or on behalf of, the + Licensor for the purpose of discussing and improving the Work, but + excluding communication that is conspicuously marked or otherwise + designated in writing by the copyright owner as "Not a Contribution." + + "Contributor" shall mean Licensor and any individual or Legal Entity + on behalf of whom a Contribution has been received by Licensor and + subsequently incorporated within the Work. + + 2. Grant of Copyright License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + copyright license to reproduce, prepare Derivative Works of, + publicly display, publicly perform, sublicense, and distribute the + Work and such Derivative Works in Source or Object form. + + 3. Grant of Patent License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + (except as stated in this section) patent license to make, have made, + use, offer to sell, sell, import, and otherwise transfer the Work, + where such license applies only to those patent claims licensable + by such Contributor that are necessarily infringed by their + Contribution(s) alone or by combination of their Contribution(s) + with the Work to which such Contribution(s) was submitted. If You + institute patent litigation against any entity (including a + cross-claim or counterclaim in a lawsuit) alleging that the Work + or a Contribution incorporated within the Work constitutes direct + or contributory patent infringement, then any patent licenses + granted to You under this License for that Work shall terminate + as of the date such litigation is filed. + + 4. Redistribution. You may reproduce and distribute copies of the + Work or Derivative Works thereof in any medium, with or without + modifications, and in Source or Object form, provided that You + meet the following conditions: + + (a) You must give any other recipients of the Work or + Derivative Works a copy of this License; and + + (b) You must cause any modified files to carry prominent notices + stating that You changed the files; and + + (c) You must retain, in the Source form of any Derivative Works + that You distribute, all copyright, patent, trademark, and + attribution notices from the Source form of the Work, + excluding those notices that do not pertain to any part of + the Derivative Works; and + + (d) If the Work includes a "NOTICE" text file as part of its + distribution, then any Derivative Works that You distribute must + include a readable copy of the attribution notices contained + within such NOTICE file, excluding those notices that do not + pertain to any part of the Derivative Works, in at least one + of the following places: within a NOTICE text file distributed + as part of the Derivative Works; within the Source form or + documentation, if provided along with the Derivative Works; or, + within a display generated by the Derivative Works, if and + wherever such third-party notices normally appear. The contents + of the NOTICE file are for informational purposes only and + do not modify the License. You may add Your own attribution + notices within Derivative Works that You distribute, alongside + or as an addendum to the NOTICE text from the Work, provided + that such additional attribution notices cannot be construed + as modifying the License. + + You may add Your own copyright statement to Your modifications and + may provide additional or different license terms and conditions + for use, reproduction, or distribution of Your modifications, or + for any such Derivative Works as a whole, provided Your use, + reproduction, and distribution of the Work otherwise complies with + the conditions stated in this License. + + 5. Submission of Contributions. Unless You explicitly state otherwise, + any Contribution intentionally submitted for inclusion in the Work + by You to the Licensor shall be under the terms and conditions of + this License, without any additional terms or conditions. + Notwithstanding the above, nothing herein shall supersede or modify + the terms of any separate license agreement you may have executed + with Licensor regarding such Contributions. + + 6. Trademarks. This License does not grant permission to use the trade + names, trademarks, service marks, or product names of the Licensor, + except as required for reasonable and customary use in describing the + origin of the Work and reproducing the content of the NOTICE file. + + 7. Disclaimer of Warranty. Unless required by applicable law or + agreed to in writing, Licensor provides the Work (and each + Contributor provides its Contributions) on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or + implied, including, without limitation, any warranties or conditions + of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A + PARTICULAR PURPOSE. You are solely responsible for determining the + appropriateness of using or redistributing the Work and assume any + risks associated with Your exercise of permissions under this License. + + 8. Limitation of Liability. In no event and under no legal theory, + whether in tort (including negligence), contract, or otherwise, + unless required by applicable law (such as deliberate and grossly + negligent acts) or agreed to in writing, shall any Contributor be + liable to You for damages, including any direct, indirect, special, + incidental, or consequential damages of any character arising as a + result of this License or out of the use or inability to use the + Work (including but not limited to damages for loss of goodwill, + work stoppage, computer failure or malfunction, or any and all + other commercial damages or losses), even if such Contributor + has been advised of the possibility of such damages. + + 9. Accepting Warranty or Additional Liability. While redistributing + the Work or Derivative Works thereof, You may choose to offer, + and charge a fee for, acceptance of support, warranty, indemnity, + or other liability obligations and/or rights consistent with this + License. However, in accepting such obligations, You may act only + on Your own behalf and on Your sole responsibility, not on behalf + of any other Contributor, and only if You agree to indemnify, + defend, and hold each Contributor harmless for any liability + incurred by, or claims asserted against, such Contributor by reason + of your accepting any such warranty or additional liability. + + END OF TERMS AND CONDITIONS + + APPENDIX: How to apply the Apache License to your work. + + To apply the Apache License to your work, attach the following + boilerplate notice, with the fields enclosed by brackets "[]" + replaced with your own identifying information. (Don't include + the brackets!) The text should be enclosed in the appropriate + comment syntax for the file format. We also recommend that a + file or class name and description of purpose be included on the + same "printed page" as the copyright notice for easier + identification within third-party archives. + + Copyright [yyyy] [name of copyright owner] + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. diff --git a/plugins/hlint-hls-plugin/hlint-hls-plugin.cabal b/plugins/hlint-hls-plugin/hlint-hls-plugin.cabal new file mode 100644 index 0000000000..d2c4e6660c --- /dev/null +++ b/plugins/hlint-hls-plugin/hlint-hls-plugin.cabal @@ -0,0 +1,73 @@ +cabal-version: 2.2 +name: hlint-hls-plugin +version: 0.1.0.0 +synopsis: Hlint integration plugin with Haskell Language Server +description: Please see README.md +license: Apache-2.0 +license-file: LICENSE +author: Many,TBD when we release +maintainer: alan.zimm@gmail.com (for now) +copyright: Alan Zimmerman +category: Web +build-type: Simple + +flag pedantic + description: Enable -Werror + default: False + manual: True + +flag ghc-lib + default: False + manual: True + description: + Force dependency on ghc-lib-parser even if GHC API in the ghc package is supported + +library + exposed-modules: Ide.Plugin.Hlint + hs-source-dirs: src + build-depends: + , aeson + , apply-refact + , base + , binary + , bytestring + , containers + , data-default + , deepseq + , Diff + , directory + , extra + , filepath + , ghcide + , hashable + , haskell-lsp + , hlint >=3.0 + , hls-plugin-api + , hslogger + , lens + , regex-tdfa + , shake + , temporary + , text + , transformers + , unordered-containers + + if ((!flag(ghc-lib) && impl(ghc >=8.10.1)) && impl(ghc <8.11.0)) + build-depends: ghc ^>=8.10 + + else + build-depends: + , ghc + , ghc-lib ^>=8.10 + , ghc-lib-parser-ex ^>=8.10 + + cpp-options: -DGHC_LIB + mixins: + ghc (GHC as RealGHC, HscTypes as RealGHC.HscTypes, EnumSet as RealGHC.EnumSet) + + ghc-options: -Wall -Wredundant-constraints -Wno-name-shadowing + + if flag(pedantic) + ghc-options: -Werror + + default-language: Haskell2010 diff --git a/stack-8.10.1.yaml b/stack-8.10.1.yaml index f6815707a6..af48f2afa4 100644 --- a/stack-8.10.1.yaml +++ b/stack-8.10.1.yaml @@ -1,16 +1,16 @@ -resolver: nightly-2020-08-08 +resolver: nightly-2020-08-16 # Last 8.10.1 packages: - . - ./ghcide/ - ./hls-plugin-api - ./plugins/tactics +- ./plugins/hlint-hls-plugin ghc-options: "$everything": -haddock extra-deps: -- aeson-1.5.2.0 - github: bubba/brittany commit: c59655f10d5ad295c2481537fc8abf0a297d9d1c - Cabal-3.0.2.0 diff --git a/stack-8.10.2.yaml b/stack-8.10.2.yaml index ed1dca90f4..354ccf40c9 100644 --- a/stack-8.10.2.yaml +++ b/stack-8.10.2.yaml @@ -5,12 +5,12 @@ packages: - ./ghcide/ - ./hls-plugin-api - ./plugins/tactics +- ./plugins/hlint-hls-plugin ghc-options: "$everything": -haddock extra-deps: -- aeson-1.5.2.0 - github: bubba/brittany commit: c59655f10d5ad295c2481537fc8abf0a297d9d1c - Cabal-3.0.2.0 diff --git a/stack-8.6.4.yaml b/stack-8.6.4.yaml index 0af17fb039..9a11c8bf2c 100644 --- a/stack-8.6.4.yaml +++ b/stack-8.6.4.yaml @@ -6,12 +6,14 @@ packages: - ./ghcide/ - ./hls-plugin-api - ./plugins/tactics +- ./plugins/hlint-hls-plugin ghc-options: "$everything": -haddock extra-deps: - aeson-1.5.2.0 +- apply-refact-0.8.2.1 - ansi-terminal-0.10.3 - base-compat-0.10.5 - github: bubba/brittany @@ -26,15 +28,17 @@ extra-deps: - fuzzy-0.1.0.0 # - ghcide-0.1.0 - ghc-check-0.5.0.1 -- ghc-exactprint-0.6.2 +- ghc-exactprint-0.6.3.2 +- ghc-lib-8.10.1.20200523 - ghc-lib-parser-8.10.1.20200523 -- ghc-lib-parser-ex-8.10.0.4 +- ghc-lib-parser-ex-8.10.0.14 - ghc-source-gen-0.4.0.0 - haddock-api-2.22.0@rev:1 - haddock-library-1.8.0 - haskell-lsp-0.22.0.0 - haskell-lsp-types-0.22.0.0 - hie-bios-0.7.1 +- hlint-3.1.4 - HsYAML-0.2.1.0@rev:1 - HsYAML-aeson-0.2.0.0@rev:2 - indexed-profunctors-0.1 diff --git a/stack-8.6.5.yaml b/stack-8.6.5.yaml index 169e480bba..c97de44595 100644 --- a/stack-8.6.5.yaml +++ b/stack-8.6.5.yaml @@ -5,12 +5,14 @@ packages: - ./ghcide/ - ./hls-plugin-api - ./plugins/tactics +- ./plugins/hlint-hls-plugin ghc-options: "$everything": -haddock extra-deps: - aeson-1.5.2.0 +- apply-refact-0.8.2.1 - ansi-terminal-0.10.3 - base-compat-0.10.5 - github: bubba/brittany @@ -25,7 +27,7 @@ extra-deps: - fuzzy-0.1.0.0 # - ghcide-0.1.0 - ghc-check-0.5.0.1 -- ghc-exactprint-0.6.2 +- ghc-exactprint-0.6.3.2 - ghc-lib-parser-8.10.2.20200808 - ghc-lib-parser-ex-8.10.0.16 - ghc-source-gen-0.4.0.0 @@ -34,6 +36,7 @@ extra-deps: - haskell-lsp-0.22.0.0 - haskell-lsp-types-0.22.0.0 - hie-bios-0.7.1 +- hlint-3.1.4 - HsYAML-0.2.1.0@rev:1 - HsYAML-aeson-0.2.0.0@rev:2 - indexed-profunctors-0.1 diff --git a/stack-8.8.2.yaml b/stack-8.8.2.yaml index 190d2b720a..e0df425bc6 100644 --- a/stack-8.8.2.yaml +++ b/stack-8.8.2.yaml @@ -5,13 +5,14 @@ packages: - ./ghcide/ - ./hls-plugin-api - ./plugins/tactics +- ./plugins/hlint-hls-plugin ghc-options: "$everything": -haddock extra-deps: - aeson-1.5.2.0 -- apply-refact-0.7.0.0 +- apply-refact-0.8.2.1 - github: bubba/brittany commit: c59655f10d5ad295c2481537fc8abf0a297d9d1c - butcher-1.3.3.2 @@ -23,13 +24,16 @@ extra-deps: - fourmolu-0.2.0.0 # - ghcide-0.1.0 - ghc-check-0.5.0.1 +- ghc-exactprint-0.6.3.2 +- ghc-lib-8.10.1.20200523 - ghc-lib-parser-8.10.1.20200523 -- ghc-lib-parser-ex-8.10.0.4 +- ghc-lib-parser-ex-8.10.0.14 - haddock-library-1.8.0 - haskell-lsp-0.22.0.0 - haskell-lsp-types-0.22.0.0 - haskell-src-exts-1.21.1 -- hlint-2.2.8 +- hie-bios-0.7.1 +- hlint-3.1.4 - hoogle-5.0.17.11 - hsimport-0.11.0 - HsYAML-0.2.1.0@rev:1 diff --git a/stack-8.8.3.yaml b/stack-8.8.3.yaml index 333a4d1d80..46ec14daac 100644 --- a/stack-8.8.3.yaml +++ b/stack-8.8.3.yaml @@ -1,17 +1,18 @@ -resolver: lts-16.11 +resolver: lts-16.11 # Last 8.8.3 packages: - . - ./ghcide/ - ./hls-plugin-api - ./plugins/tactics +- ./plugins/hlint-hls-plugin ghc-options: "$everything": -haddock extra-deps: - aeson-1.5.2.0 -- apply-refact-0.7.0.0 +- apply-refact-0.8.2.1 - github: bubba/brittany commit: c59655f10d5ad295c2481537fc8abf0a297d9d1c - bytestring-trie-0.2.5.0 @@ -22,8 +23,9 @@ extra-deps: - floskell-0.10.4 - fourmolu-0.2.0.0 # - ghcide-0.1.0 +- ghc-exactprint-0.6.3.2 - haskell-src-exts-1.21.1 -- hlint-2.2.8 +- hie-bios-0.7.1 - HsYAML-aeson-0.2.0.0@rev:2 - hoogle-5.0.17.11 - hsimport-0.11.0 diff --git a/stack-8.8.4.yaml b/stack-8.8.4.yaml index b530da8080..00d03de83a 100644 --- a/stack-8.8.4.yaml +++ b/stack-8.8.4.yaml @@ -5,17 +5,17 @@ packages: - ./ghcide/ - ./hls-plugin-api - ./plugins/tactics +- ./plugins/hlint-hls-plugin ghc-options: "$everything": -haddock extra-deps: - aeson-1.5.2.0 -- apply-refact-0.7.0.0 +- apply-refact-0.8.2.1 - github: bubba/brittany commit: c59655f10d5ad295c2481537fc8abf0a297d9d1c - bytestring-trie-0.2.5.0 -- cabal-helper-1.1.0.0 - cabal-plan-0.6.2.0 - clock-0.7.2 - constrained-dynamic-0.1.0.0 @@ -23,9 +23,10 @@ extra-deps: - floskell-0.10.4 - fourmolu-0.2.0.0 # - ghcide-0.1.0 +- ghc-exactprint-0.6.3.2 - haskell-src-exts-1.21.1 - hie-bios-0.7.1 -- hlint-2.2.8 +- HsYAML-aeson-0.2.0.0@rev:2 - hoogle-5.0.17.11 - hsimport-0.11.0 - ilist-0.3.1.0 diff --git a/stack.yaml b/stack.yaml index 6415a56a63..8de05dedf1 100644 --- a/stack.yaml +++ b/stack.yaml @@ -5,12 +5,14 @@ packages: - ./ghcide/ - ./hls-plugin-api - ./plugins/tactics +- ./plugins/hlint-hls-plugin ghc-options: "$everything": -haddock extra-deps: - aeson-1.5.2.0 +- apply-refact-0.8.2.1 - ansi-terminal-0.10.3 - base-compat-0.10.5 - github: bubba/brittany @@ -25,7 +27,7 @@ extra-deps: - fuzzy-0.1.0.0 # - ghcide-0.1.0 - ghc-check-0.5.0.1 -- ghc-exactprint-0.6.2 +- ghc-exactprint-0.6.3.2 - ghc-lib-parser-8.10.2.20200808 - ghc-lib-parser-ex-8.10.0.16 - ghc-source-gen-0.4.0.0 From a99912f563e5e5db8eda2e2285f6c772c34031ff Mon Sep 17 00:00:00 2001 From: jneira Date: Tue, 15 Sep 2020 22:15:03 +0200 Subject: [PATCH 32/71] Rename to hls-hlint-plugin --- cabal.project | 2 +- haskell-language-server.cabal | 2 +- hie.yaml.cbl | 8 ++++---- hie.yaml.stack | 4 ++-- plugins/{hlint-hls-plugin => hls-hlint-plugin}/LICENSE | 0 .../hls-hlint-plugin.cabal} | 2 +- .../src/Ide/Plugin/Hlint.hs | 3 ++- stack-8.10.1.yaml | 2 +- stack-8.10.2.yaml | 2 +- stack-8.6.4.yaml | 2 +- stack-8.6.5.yaml | 2 +- stack-8.8.2.yaml | 2 +- stack-8.8.3.yaml | 2 +- stack-8.8.4.yaml | 2 +- stack.yaml | 2 +- 15 files changed, 19 insertions(+), 18 deletions(-) rename plugins/{hlint-hls-plugin => hls-hlint-plugin}/LICENSE (100%) rename plugins/{hlint-hls-plugin/hlint-hls-plugin.cabal => hls-hlint-plugin/hls-hlint-plugin.cabal} (98%) rename plugins/{hlint-hls-plugin => hls-hlint-plugin}/src/Ide/Plugin/Hlint.hs (99%) diff --git a/cabal.project b/cabal.project index 2ae1b6e8f5..ef5e93a50a 100644 --- a/cabal.project +++ b/cabal.project @@ -3,7 +3,7 @@ packages: ghcide hls-plugin-api ./plugins/tactics - ./plugins/hlint-hls-plugin + ./plugins/hls-hlint-plugin source-repository-package type: git diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal index afe3a8e36f..8398781a02 100644 --- a/haskell-language-server.cabal +++ b/haskell-language-server.cabal @@ -120,7 +120,7 @@ executable haskell-language-server , hashable , haskell-language-server , haskell-lsp ^>=0.22 - , hlint-hls-plugin + , hls-hlint-plugin , hls-plugin-api , hls-tactics-plugin , lens diff --git a/hie.yaml.cbl b/hie.yaml.cbl index e8881d953e..6869c0247d 100644 --- a/hie.yaml.cbl +++ b/hie.yaml.cbl @@ -34,10 +34,7 @@ cradle: - path: "./src" component: "lib:haskell-language-server" - - path: "./plugins/hlint-hls-plugin/src/Ide/Plugin/Hlint.hs" - component: "lib:hlint-plugin" - - - path: "./dist-newstyle/" + - path: "./dist-newstyle/" component: "lib:haskell-language-server" - path: "./ghcide/src" @@ -48,3 +45,6 @@ cradle: - path: "./hls-plugin-api/src" component: "hls-plugin-api:lib:hls-plugin-api" + + - path: "./plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs" + component: "lib:hlint-plugin" diff --git a/hie.yaml.stack b/hie.yaml.stack index d74387d8ab..e9aaa75c39 100644 --- a/hie.yaml.stack +++ b/hie.yaml.stack @@ -49,5 +49,5 @@ cradle: - path: "./hls-plugin-api/src" component: "hls-plugin-api:lib:hls-plugin-api" - - path: "./plugins/hlint-hls-plugin/src" - component: "hlint-hls-plugin:lib:hlint-hls-plugin" + - path: "./plugins/hls-hlint-plugin/src" + component: "hls-hlint-plugin:lib:hls-hlint-plugin" diff --git a/plugins/hlint-hls-plugin/LICENSE b/plugins/hls-hlint-plugin/LICENSE similarity index 100% rename from plugins/hlint-hls-plugin/LICENSE rename to plugins/hls-hlint-plugin/LICENSE diff --git a/plugins/hlint-hls-plugin/hlint-hls-plugin.cabal b/plugins/hls-hlint-plugin/hls-hlint-plugin.cabal similarity index 98% rename from plugins/hlint-hls-plugin/hlint-hls-plugin.cabal rename to plugins/hls-hlint-plugin/hls-hlint-plugin.cabal index d2c4e6660c..52d0cec47a 100644 --- a/plugins/hlint-hls-plugin/hlint-hls-plugin.cabal +++ b/plugins/hls-hlint-plugin/hls-hlint-plugin.cabal @@ -1,5 +1,5 @@ cabal-version: 2.2 -name: hlint-hls-plugin +name: hls-hlint-plugin version: 0.1.0.0 synopsis: Hlint integration plugin with Haskell Language Server description: Please see README.md diff --git a/plugins/hlint-hls-plugin/src/Ide/Plugin/Hlint.hs b/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs similarity index 99% rename from plugins/hlint-hls-plugin/src/Ide/Plugin/Hlint.hs rename to plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs index 13a60b4a2d..e3217e16ff 100644 --- a/plugins/hlint-hls-plugin/src/Ide/Plugin/Hlint.hs +++ b/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs @@ -370,4 +370,5 @@ writeFileUTF8NoNewLineTranslation file txt = withFile file WriteMode $ \h -> do hSetEncoding h utf8 hSetNewlineMode h noNewlineTranslation - hPutStr h (T.unpack txt) \ No newline at end of file + hPutStr h (T.unpack txt) + \ No newline at end of file diff --git a/stack-8.10.1.yaml b/stack-8.10.1.yaml index af48f2afa4..c18c9775c4 100644 --- a/stack-8.10.1.yaml +++ b/stack-8.10.1.yaml @@ -5,7 +5,7 @@ packages: - ./ghcide/ - ./hls-plugin-api - ./plugins/tactics -- ./plugins/hlint-hls-plugin +- ./plugins/hls-hlint-plugin ghc-options: "$everything": -haddock diff --git a/stack-8.10.2.yaml b/stack-8.10.2.yaml index 354ccf40c9..62f98295ed 100644 --- a/stack-8.10.2.yaml +++ b/stack-8.10.2.yaml @@ -5,7 +5,7 @@ packages: - ./ghcide/ - ./hls-plugin-api - ./plugins/tactics -- ./plugins/hlint-hls-plugin +- ./plugins/hls-hlint-plugin ghc-options: "$everything": -haddock diff --git a/stack-8.6.4.yaml b/stack-8.6.4.yaml index 9a11c8bf2c..d9d2156fbe 100644 --- a/stack-8.6.4.yaml +++ b/stack-8.6.4.yaml @@ -6,7 +6,7 @@ packages: - ./ghcide/ - ./hls-plugin-api - ./plugins/tactics -- ./plugins/hlint-hls-plugin +- ./plugins/hls-hlint-plugin ghc-options: "$everything": -haddock diff --git a/stack-8.6.5.yaml b/stack-8.6.5.yaml index c97de44595..79d9b5c414 100644 --- a/stack-8.6.5.yaml +++ b/stack-8.6.5.yaml @@ -5,7 +5,7 @@ packages: - ./ghcide/ - ./hls-plugin-api - ./plugins/tactics -- ./plugins/hlint-hls-plugin +- ./plugins/hls-hlint-plugin ghc-options: "$everything": -haddock diff --git a/stack-8.8.2.yaml b/stack-8.8.2.yaml index e0df425bc6..3d19c06d0b 100644 --- a/stack-8.8.2.yaml +++ b/stack-8.8.2.yaml @@ -5,7 +5,7 @@ packages: - ./ghcide/ - ./hls-plugin-api - ./plugins/tactics -- ./plugins/hlint-hls-plugin +- ./plugins/hls-hlint-plugin ghc-options: "$everything": -haddock diff --git a/stack-8.8.3.yaml b/stack-8.8.3.yaml index 46ec14daac..973658dabb 100644 --- a/stack-8.8.3.yaml +++ b/stack-8.8.3.yaml @@ -5,7 +5,7 @@ packages: - ./ghcide/ - ./hls-plugin-api - ./plugins/tactics -- ./plugins/hlint-hls-plugin +- ./plugins/hls-hlint-plugin ghc-options: "$everything": -haddock diff --git a/stack-8.8.4.yaml b/stack-8.8.4.yaml index 00d03de83a..8b184e0502 100644 --- a/stack-8.8.4.yaml +++ b/stack-8.8.4.yaml @@ -5,7 +5,7 @@ packages: - ./ghcide/ - ./hls-plugin-api - ./plugins/tactics -- ./plugins/hlint-hls-plugin +- ./plugins/hls-hlint-plugin ghc-options: "$everything": -haddock diff --git a/stack.yaml b/stack.yaml index 8de05dedf1..7ba7f6faa9 100644 --- a/stack.yaml +++ b/stack.yaml @@ -5,7 +5,7 @@ packages: - ./ghcide/ - ./hls-plugin-api - ./plugins/tactics -- ./plugins/hlint-hls-plugin +- ./plugins/hls-hlint-plugin ghc-options: "$everything": -haddock From 105c37ffa23dd067dcfc7b538f58bfd5b854c80a Mon Sep 17 00:00:00 2001 From: jneira Date: Wed, 16 Sep 2020 21:08:17 +0200 Subject: [PATCH 33/71] Adapt to ghcide api changes --- plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs b/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs index e3217e16ff..47636b12f6 100644 --- a/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs +++ b/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs @@ -25,8 +25,8 @@ import Control.Monad.IO.Class import Control.Monad.Trans.Except import Data.Aeson.Types (ToJSON(..), FromJSON(..), Value(..)) import Data.Binary -import qualified Data.HashSet as HashSet 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 @@ -98,7 +98,7 @@ rules = do action $ do files <- getFilesOfInterest - void $ uses GetHlintDiagnostics $ HashSet.toList (files) + void $ uses GetHlintDiagnostics $ Map.keys files where From 706dfcc880feddb2e63304e68bc494631d4d48b4 Mon Sep 17 00:00:00 2001 From: jneira Date: Wed, 7 Oct 2020 08:42:13 +0200 Subject: [PATCH 34/71] Fix and clean stack extra-deps --- stack-8.10.1.yaml | 7 ++++--- stack-8.10.2.yaml | 6 +++--- stack-8.6.4.yaml | 12 ++++++------ stack-8.6.5.yaml | 7 ++++--- stack-8.8.2.yaml | 13 ++++++------- stack-8.8.3.yaml | 7 +++---- stack-8.8.4.yaml | 7 +++---- stack.yaml | 7 ++++--- 8 files changed, 33 insertions(+), 33 deletions(-) diff --git a/stack-8.10.1.yaml b/stack-8.10.1.yaml index c18c9775c4..cb4321f00d 100644 --- a/stack-8.10.1.yaml +++ b/stack-8.10.1.yaml @@ -18,7 +18,11 @@ extra-deps: - data-tree-print-0.1.0.2 - floskell-0.10.4 - fourmolu-0.2.0.0 +- hie-bios-0.7.1 - HsYAML-aeson-0.2.0.0@rev:2 +- implicit-hie-cradle-0.2.0.1 +- implicit-hie-0.1.2.0 +- lsp-test-0.11.0.6 - monad-dijkstra-0.1.1.2 - opentelemetry-0.4.2 - ormolu-0.1.3.0 @@ -27,9 +31,6 @@ extra-deps: - stylish-haskell-0.12.2.0 - semigroups-0.18.5 - temporary-1.2.1.1 -- implicit-hie-cradle-0.2.0.1 -- implicit-hie-0.1.2.0 -- hie-bios-0.7.1 flags: haskell-language-server: diff --git a/stack-8.10.2.yaml b/stack-8.10.2.yaml index 62f98295ed..b4a2b1c5d8 100644 --- a/stack-8.10.2.yaml +++ b/stack-8.10.2.yaml @@ -18,6 +18,9 @@ extra-deps: - data-tree-print-0.1.0.2 - floskell-0.10.4 - fourmolu-0.2.0.0 +- implicit-hie-cradle-0.2.0.1 +- implicit-hie-0.1.2.0 +- lsp-test-0.11.0.6 - monad-dijkstra-0.1.1.2 - opentelemetry-0.4.2 - refinery-0.3.0.0 @@ -25,9 +28,6 @@ extra-deps: - stylish-haskell-0.12.2.0 - semigroups-0.18.5 - temporary-1.2.1.1 -- implicit-hie-cradle-0.2.0.1 -- implicit-hie-0.1.2.0 -- hie-bios-0.7.1 flags: haskell-language-server: diff --git a/stack-8.6.4.yaml b/stack-8.6.4.yaml index d9d2156fbe..331891f68c 100644 --- a/stack-8.6.4.yaml +++ b/stack-8.6.4.yaml @@ -29,9 +29,9 @@ extra-deps: # - ghcide-0.1.0 - ghc-check-0.5.0.1 - ghc-exactprint-0.6.3.2 -- ghc-lib-8.10.1.20200523 -- ghc-lib-parser-8.10.1.20200523 -- ghc-lib-parser-ex-8.10.0.14 +- ghc-lib-8.10.2.20200808 +- ghc-lib-parser-8.10.2.20200808 +- ghc-lib-parser-ex-8.10.0.16 - ghc-source-gen-0.4.0.0 - haddock-api-2.22.0@rev:1 - haddock-library-1.8.0 @@ -41,9 +41,11 @@ extra-deps: - hlint-3.1.4 - HsYAML-0.2.1.0@rev:1 - HsYAML-aeson-0.2.0.0@rev:2 +- implicit-hie-cradle-0.2.0.1 +- implicit-hie-0.1.2.0 - indexed-profunctors-0.1 - lens-4.18 -- lsp-test-0.11.0.5 +- lsp-test-0.11.0.6 - monad-dijkstra-0.1.1.2 - opentelemetry-0.4.2 - optics-core-0.2 @@ -65,8 +67,6 @@ extra-deps: - these-1.1.1.1 - type-equality-1 - topograph-1 -- implicit-hie-cradle-0.2.0.1 -- implicit-hie-0.1.2.0 flags: haskell-language-server: diff --git a/stack-8.6.5.yaml b/stack-8.6.5.yaml index 79d9b5c414..2681c21a56 100644 --- a/stack-8.6.5.yaml +++ b/stack-8.6.5.yaml @@ -28,6 +28,7 @@ extra-deps: # - ghcide-0.1.0 - ghc-check-0.5.0.1 - ghc-exactprint-0.6.3.2 +- ghc-lib-8.10.2.20200808 - ghc-lib-parser-8.10.2.20200808 - ghc-lib-parser-ex-8.10.0.16 - ghc-source-gen-0.4.0.0 @@ -39,9 +40,11 @@ extra-deps: - hlint-3.1.4 - HsYAML-0.2.1.0@rev:1 - HsYAML-aeson-0.2.0.0@rev:2 +- implicit-hie-cradle-0.2.0.1 +- implicit-hie-0.1.2.0 - indexed-profunctors-0.1 - lens-4.18 -- lsp-test-0.11.0.5 +- lsp-test-0.11.0.6 - monad-dijkstra-0.1.1.2 - opentelemetry-0.4.2 - optics-core-0.2 @@ -63,8 +66,6 @@ extra-deps: - these-1.1.1.1 - type-equality-1 - topograph-1 -- implicit-hie-cradle-0.2.0.1 -- implicit-hie-0.1.2.0 flags: haskell-language-server: diff --git a/stack-8.8.2.yaml b/stack-8.8.2.yaml index 3d19c06d0b..2cb2dece5c 100644 --- a/stack-8.8.2.yaml +++ b/stack-8.8.2.yaml @@ -25,9 +25,9 @@ extra-deps: # - ghcide-0.1.0 - ghc-check-0.5.0.1 - ghc-exactprint-0.6.3.2 -- ghc-lib-8.10.1.20200523 -- ghc-lib-parser-8.10.1.20200523 -- ghc-lib-parser-ex-8.10.0.14 +- ghc-lib-8.10.2.20200808 +- ghc-lib-parser-8.10.2.20200808 +- ghc-lib-parser-ex-8.10.0.16 - haddock-library-1.8.0 - haskell-lsp-0.22.0.0 - haskell-lsp-types-0.22.0.0 @@ -39,7 +39,9 @@ extra-deps: - HsYAML-0.2.1.0@rev:1 - HsYAML-aeson-0.2.0.0@rev:2 - ilist-0.3.1.0 -- lsp-test-0.11.0.5 +- implicit-hie-cradle-0.2.0.1 +- implicit-hie-0.1.2.0 +- lsp-test-0.11.0.6 - monad-dijkstra-0.1.1.2 - opentelemetry-0.4.2 - ormolu-0.1.3.0 @@ -51,9 +53,6 @@ extra-deps: - stylish-haskell-0.12.2.0 - temporary-1.2.1.1 - these-1.1.1.1 -- implicit-hie-cradle-0.2.0.1 -- implicit-hie-0.1.2.0 -- hie-bios-0.7.1 flags: haskell-language-server: diff --git a/stack-8.8.3.yaml b/stack-8.8.3.yaml index 973658dabb..780410d47c 100644 --- a/stack-8.8.3.yaml +++ b/stack-8.8.3.yaml @@ -30,7 +30,9 @@ extra-deps: - hoogle-5.0.17.11 - hsimport-0.11.0 - ilist-0.3.1.0 -- lsp-test-0.11.0.5 +- implicit-hie-cradle-0.2.0.1 +- implicit-hie-0.1.2.0 +- lsp-test-0.11.0.6 - monad-dijkstra-0.1.1.2 - ormolu-0.1.3.0 - refinery-0.3.0.0 @@ -40,9 +42,6 @@ extra-deps: # commit: fb3859dca2e54d1bbb2c873e68ed225fa179fbef - stylish-haskell-0.12.2.0 - temporary-1.2.1.1 -- implicit-hie-cradle-0.2.0.1 -- implicit-hie-0.1.2.0 -- hie-bios-0.7.1 flags: haskell-language-server: diff --git a/stack-8.8.4.yaml b/stack-8.8.4.yaml index 8b184e0502..e6b04fdbe6 100644 --- a/stack-8.8.4.yaml +++ b/stack-8.8.4.yaml @@ -30,7 +30,9 @@ extra-deps: - hoogle-5.0.17.11 - hsimport-0.11.0 - ilist-0.3.1.0 -- lsp-test-0.11.0.5 +- implicit-hie-cradle-0.2.0.1 +- implicit-hie-0.1.2.0 +- lsp-test-0.11.0.6 - monad-dijkstra-0.1.1.2 - refinery-0.3.0.0 - retrie-0.1.1.1 @@ -39,9 +41,6 @@ extra-deps: # commit: fb3859dca2e54d1bbb2c873e68ed225fa179fbef - stylish-haskell-0.12.2.0 - temporary-1.2.1.1 -- ghc-exactprint-0.6.3.2 -- implicit-hie-cradle-0.2.0.1 -- implicit-hie-0.1.2.0 flags: haskell-language-server: diff --git a/stack.yaml b/stack.yaml index 7ba7f6faa9..d220d73d01 100644 --- a/stack.yaml +++ b/stack.yaml @@ -28,6 +28,7 @@ extra-deps: # - ghcide-0.1.0 - ghc-check-0.5.0.1 - ghc-exactprint-0.6.3.2 +- ghc-lib-8.10.2.20200808 - ghc-lib-parser-8.10.2.20200808 - ghc-lib-parser-ex-8.10.0.16 - ghc-source-gen-0.4.0.0 @@ -39,9 +40,11 @@ extra-deps: - hlint-3.1.4 - HsYAML-0.2.1.0@rev:1 - HsYAML-aeson-0.2.0.0@rev:2 +- implicit-hie-cradle-0.2.0.1 +- implicit-hie-0.1.1.0 - indexed-profunctors-0.1 - lens-4.18 -- lsp-test-0.11.0.5 +- lsp-test-0.11.0.6 - monad-dijkstra-0.1.1.2 - opentelemetry-0.4.2 - optics-core-0.2 @@ -63,8 +66,6 @@ extra-deps: - these-1.1.1.1 - type-equality-1 - topograph-1 -- implicit-hie-cradle-0.2.0.1 -- implicit-hie-0.1.1.0 flags: haskell-language-server: From bff0d242d038de7c7581e02f5338ab5257621c76 Mon Sep 17 00:00:00 2001 From: jneira Date: Sat, 17 Oct 2020 21:46:47 +0200 Subject: [PATCH 35/71] Use lsp-test-0.11.0.6 --- haskell-language-server.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal index 8398781a02..a0167faba1 100644 --- a/haskell-language-server.cabal +++ b/haskell-language-server.cabal @@ -199,7 +199,7 @@ common hls-test-utils , hslogger , hspec , hspec-core - , lsp-test >=0.11.0.4 + , lsp-test >=0.11.0.6 , stm , tasty-hunit , temporary From 55dfc3b2e804b5335471b115199961128b8c5cea Mon Sep 17 00:00:00 2001 From: jneira Date: Sun, 18 Oct 2020 22:23:24 +0200 Subject: [PATCH 36/71] Fix hlint tests --- test/functional/FunctionalCodeAction.hs | 47 +++++++++++-------------- 1 file changed, 21 insertions(+), 26 deletions(-) diff --git a/test/functional/FunctionalCodeAction.hs b/test/functional/FunctionalCodeAction.hs index 0af484da99..e757964ecf 100644 --- a/test/functional/FunctionalCodeAction.hs +++ b/test/functional/FunctionalCodeAction.hs @@ -44,9 +44,9 @@ tests = testGroup "code actions" [ hlintTests :: TestTree hlintTests = testGroup "hlint suggestions" [ - testCase "provides 3.8 code actions" $ runSession hlsCommand fullCaps "test/testdata/hlint" $ do + testCase "provides 3.8 code actions including apply all" $ runSession hlsCommand fullCaps "test/testdata/hlint" $ do doc <- openDoc "ApplyRefact2.hs" "haskell" - diags@(reduceDiag:_) <- waitForDiagnostics + diags@(reduceDiag:_) <- waitForDiagnosticsSource "hlint" liftIO $ do length diags @?= 2 -- "Eta Reduce" and "Redundant Id" @@ -55,11 +55,15 @@ hlintTests = testGroup "hlint suggestions" [ reduceDiag ^. L.code @?= Just (StringValue "Eta reduce") reduceDiag ^. L.source @?= Just "hlint" - (CACodeAction ca:_) <- getAllCodeActions doc + cas <- map fromAction <$> getAllCodeActions doc + + 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 - liftIO $ "Redundant id" `T.isSuffixOf` (ca ^. L.title) @? "Title contains Redundant id" + liftIO $ isJust applyAll @? "There is 'Apply all hints' code action" + liftIO $ isJust redId @? "There is 'Redundant id' code action" - executeCodeAction ca + executeCodeAction (fromJust redId) contents <- getDocumentEdit doc liftIO $ contents @?= "main = undefined\nfoo x = x\n" @@ -69,39 +73,30 @@ hlintTests = testGroup "hlint suggestions" [ _ <- waitForDiagnostics - (CACommand cmd:_) <- getAllCodeActions doc - - -- Evaluate became redundant id in later hlint versions - liftIO $ "Redundant id" `T.isSuffixOf` (cmd ^. L.title) @? "Title contains Redundant id" + (CACommand cmdApplyAll:_) <- getAllCodeActions doc - executeCommand cmd + executeCommand cmdApplyAll contents <- skipManyTill publishDiagnosticsNotification $ getDocumentEdit doc - liftIO $ contents @?= "main = undefined\nfoo x = x\n" + liftIO $ contents @?= "main = undefined\nfoo = id\n" - , testCase "runs diagnostics on save" $ runSession hlsCommand fullCaps "test/testdata/hlint" $ do - let config = def { diagnosticsOnChange = False } + , testCase "changing configuration enables or disables hints" $ runSession hlsCommand fullCaps "test/testdata/hlint" $ do + let config = def { hlintOn = True } sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (toJSON config)) doc <- openDoc "ApplyRefact2.hs" "haskell" - diags@(reduceDiag:_) <- waitForDiagnostics + diags <- waitForDiagnosticsSource "hlint" - liftIO $ do - length diags @?= 2 - reduceDiag ^. L.range @?= Range (Position 1 0) (Position 1 12) - reduceDiag ^. L.severity @?= Just DsInfo - reduceDiag ^. L.code @?= Just (StringValue "Eta reduce") - reduceDiag ^. L.source @?= Just "hlint" + liftIO $ length diags @?= 2 - (CACodeAction ca:_) <- getAllCodeActions doc + let config' = def { hlintOn = False} + sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (toJSON config')) - liftIO $ "Redundant id" `T.isSuffixOf` (ca ^. L.title) @? "Title contains Redundant id" + _ <- waitForDiagnosticsSource "typecheck" + diags' <- getCurrentDiagnostics doc - executeCodeAction ca + liftIO $ length diags' @?= 1 -- typecheck diagnostic "Defined but not used" - contents <- getDocumentEdit doc - liftIO $ contents @?= "main = undefined\nfoo x = x\n" - sendNotification TextDocumentDidSave (DidSaveTextDocumentParams doc) ] renameTests :: TestTree From e24ebd2dd8c39f609d3655ba74885bfe7d2fd554 Mon Sep 17 00:00:00 2001 From: jneira Date: Mon, 19 Oct 2020 06:23:02 +0200 Subject: [PATCH 37/71] Use hint name for code action title --- plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs b/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs index 47636b12f6..d1d4770f0f 100644 --- a/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs +++ b/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs @@ -250,7 +250,7 @@ codeActionProvider _lf ideState plId docId _ context = Right . LSP.List . map CA Just . codeAction <$> mkLspCommand plId "applyOne" title (Just args) where codeAction cmd = LSP.CodeAction title (Just LSP.CodeActionQuickFix) (Just (LSP.List [diag])) Nothing (Just cmd) - title = "Apply hint:" <> head (T.lines m) + title = "Apply hint: " <> code -- need 'file', 'start_pos' and hint title (to distinguish between alternative suggestions at the same location) args = [toJSON (AOP (docId ^. LSP.uri) start code)] mkHlintAction (LSP.Diagnostic _r _s _c _source _m _ _) = return Nothing @@ -371,4 +371,3 @@ writeFileUTF8NoNewLineTranslation file txt = hSetEncoding h utf8 hSetNewlineMode h noNewlineTranslation hPutStr h (T.unpack txt) - \ No newline at end of file From 2f31ffb9c91055be51bbe4a5126e449cf455ade4 Mon Sep 17 00:00:00 2001 From: jneira Date: Mon, 19 Oct 2020 06:23:38 +0200 Subject: [PATCH 38/71] Remove unused test data file --- test/testdata/hlint/ApplyRefact.hs | 4 ---- 1 file changed, 4 deletions(-) delete mode 100644 test/testdata/hlint/ApplyRefact.hs diff --git a/test/testdata/hlint/ApplyRefact.hs b/test/testdata/hlint/ApplyRefact.hs deleted file mode 100644 index 984656fbcc..0000000000 --- a/test/testdata/hlint/ApplyRefact.hs +++ /dev/null @@ -1,4 +0,0 @@ - -main = (putStrLn "hello") - -foo x = (x + 1) From 839e75ca7833db6a22e777e53cb57d26f175e8b9 Mon Sep 17 00:00:00 2001 From: jneira Date: Mon, 19 Oct 2020 08:39:16 +0200 Subject: [PATCH 39/71] Remove unused parameter --- plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs b/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs index d1d4770f0f..e7d0794e60 100644 --- a/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs +++ b/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs @@ -246,7 +246,7 @@ codeActionProvider _lf ideState plId docId _ context = Right . LSP.List . map CA 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") m _ _) = + mkHlintAction diag@(LSP.Diagnostic (LSP.Range start _) _s (Just (LSP.StringValue 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) From bf5108b689f96af77eecd0df2765b41ac921eb83 Mon Sep 17 00:00:00 2001 From: jneira Date: Mon, 19 Oct 2020 08:40:01 +0200 Subject: [PATCH 40/71] Add forcily needed hie.yaml --- test/testdata/hlint/hie.yaml | 4 ++++ 1 file changed, 4 insertions(+) create mode 100644 test/testdata/hlint/hie.yaml diff --git a/test/testdata/hlint/hie.yaml b/test/testdata/hlint/hie.yaml new file mode 100644 index 0000000000..c3a48bbd34 --- /dev/null +++ b/test/testdata/hlint/hie.yaml @@ -0,0 +1,4 @@ +cradle: + direct: + arguments: + - "ApplyRefact2" From 7759c08cb41b69e9aaf8fe63fcfcb6a745f30635 Mon Sep 17 00:00:00 2001 From: jneira Date: Mon, 19 Oct 2020 09:46:26 +0200 Subject: [PATCH 41/71] Make test not sensitive to commands order --- test/functional/FunctionalCodeAction.hs | 12 ++++++++---- 1 file changed, 8 insertions(+), 4 deletions(-) diff --git a/test/functional/FunctionalCodeAction.hs b/test/functional/FunctionalCodeAction.hs index e757964ecf..941ab9a0ee 100644 --- a/test/functional/FunctionalCodeAction.hs +++ b/test/functional/FunctionalCodeAction.hs @@ -73,12 +73,16 @@ hlintTests = testGroup "hlint suggestions" [ _ <- waitForDiagnostics - (CACommand cmdApplyAll:_) <- getAllCodeActions doc + (CACommand cmd:_) <- getAllCodeActions doc - executeCommand cmdApplyAll + executeCommand cmd + + let expectedContent = if "Apply all hints" `T.isSuffixOf` (cmd ^. L.title) + then "main = undefined\nfoo = id\n" + else "main = undefined\nfoo x = x\n" -- only redundant id contents <- skipManyTill publishDiagnosticsNotification $ getDocumentEdit doc - liftIO $ contents @?= "main = undefined\nfoo = id\n" + liftIO $ contents @?= expectedContent , testCase "changing configuration enables or disables hints" $ runSession hlsCommand fullCaps "test/testdata/hlint" $ do let config = def { hlintOn = True } @@ -89,7 +93,7 @@ hlintTests = testGroup "hlint suggestions" [ liftIO $ length diags @?= 2 - let config' = def { hlintOn = False} + let config' = def { hlintOn = False } sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (toJSON config')) _ <- waitForDiagnosticsSource "typecheck" From cd0b6157b304deb82b18da263281594b22ac8262 Mon Sep 17 00:00:00 2001 From: jneira Date: Mon, 19 Oct 2020 10:32:53 +0200 Subject: [PATCH 42/71] Make test resilient to default diags --- test/functional/FunctionalCodeAction.hs | 11 +++++------ 1 file changed, 5 insertions(+), 6 deletions(-) diff --git a/test/functional/FunctionalCodeAction.hs b/test/functional/FunctionalCodeAction.hs index 941ab9a0ee..257e4817cc 100644 --- a/test/functional/FunctionalCodeAction.hs +++ b/test/functional/FunctionalCodeAction.hs @@ -88,18 +88,17 @@ hlintTests = testGroup "hlint suggestions" [ let config = def { hlintOn = True } sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (toJSON config)) - doc <- openDoc "ApplyRefact2.hs" "haskell" - diags <- waitForDiagnosticsSource "hlint" + _ <- openDoc "ApplyRefact2.hs" "haskell" + diags <- waitForDiagnostics - liftIO $ length diags @?= 2 + liftIO $ (Just "hlint" `elem` map (^. L.source) diags) @? "There are hlint diagnostics" let config' = def { hlintOn = False } sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (toJSON config')) - _ <- waitForDiagnosticsSource "typecheck" - diags' <- getCurrentDiagnostics doc + diags' <- waitForDiagnostics - liftIO $ length diags' @?= 1 -- typecheck diagnostic "Defined but not used" + liftIO $ (not $ Just "hlint" `elem` map (^. L.source) diags') @? "There are not hlint diagnostics" ] From 3adb99528dbfc740774df8da6666341b35adf33b Mon Sep 17 00:00:00 2001 From: jneira Date: Mon, 19 Oct 2020 10:40:24 +0200 Subject: [PATCH 43/71] Test only if the command has been applied --- test/functional/FunctionalCodeAction.hs | 6 +----- 1 file changed, 1 insertion(+), 5 deletions(-) diff --git a/test/functional/FunctionalCodeAction.hs b/test/functional/FunctionalCodeAction.hs index 257e4817cc..6b28fa2bb1 100644 --- a/test/functional/FunctionalCodeAction.hs +++ b/test/functional/FunctionalCodeAction.hs @@ -77,12 +77,8 @@ hlintTests = testGroup "hlint suggestions" [ executeCommand cmd - let expectedContent = if "Apply all hints" `T.isSuffixOf` (cmd ^. L.title) - then "main = undefined\nfoo = id\n" - else "main = undefined\nfoo x = x\n" -- only redundant id - contents <- skipManyTill publishDiagnosticsNotification $ getDocumentEdit doc - liftIO $ contents @?= expectedContent + liftIO $ contents `elem` ["main = undefined\nfoo = id\n", "main = undefined\nfoo x = x\n"] @? "Command is applied" , testCase "changing configuration enables or disables hints" $ runSession hlsCommand fullCaps "test/testdata/hlint" $ do let config = def { hlintOn = True } From f8dc9e01f03951678cce12f11c6e290bea532504 Mon Sep 17 00:00:00 2001 From: jneira Date: Mon, 19 Oct 2020 11:35:34 +0200 Subject: [PATCH 44/71] Wait for hlint diagnostics explicitly --- test/functional/FunctionalCodeAction.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/test/functional/FunctionalCodeAction.hs b/test/functional/FunctionalCodeAction.hs index 6b28fa2bb1..9f4b39a541 100644 --- a/test/functional/FunctionalCodeAction.hs +++ b/test/functional/FunctionalCodeAction.hs @@ -71,7 +71,7 @@ hlintTests = testGroup "hlint suggestions" [ , testCase "falls back to pre 3.8 code actions" $ runSession hlsCommand noLiteralCaps "test/testdata/hlint" $ do doc <- openDoc "ApplyRefact2.hs" "haskell" - _ <- waitForDiagnostics + _ <- waitForDiagnosticsSource "hlint" (CACommand cmd:_) <- getAllCodeActions doc @@ -85,16 +85,16 @@ hlintTests = testGroup "hlint suggestions" [ sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (toJSON config)) _ <- openDoc "ApplyRefact2.hs" "haskell" - diags <- waitForDiagnostics + diags <- waitForDiagnosticsSource "hlint" - liftIO $ (Just "hlint" `elem` map (^. L.source) diags) @? "There are hlint diagnostics" + liftIO $ length diags > 0 @? "There are hlint diagnostics" let config' = def { hlintOn = False } sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (toJSON config')) diags' <- waitForDiagnostics - liftIO $ (not $ Just "hlint" `elem` map (^. L.source) diags') @? "There are not hlint diagnostics" + liftIO $ (not $ Just "hlint" `elem` map (^. L.source) diags') @? "There are no hlint diagnostics" ] From 3f4e9501bbe731aa8b9bc4c89684d4f7eb68c2c6 Mon Sep 17 00:00:00 2001 From: jneira Date: Mon, 19 Oct 2020 12:17:30 +0200 Subject: [PATCH 45/71] Bump up ghc-lib min version --- plugins/hls-hlint-plugin/hls-hlint-plugin.cabal | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/plugins/hls-hlint-plugin/hls-hlint-plugin.cabal b/plugins/hls-hlint-plugin/hls-hlint-plugin.cabal index 52d0cec47a..aebfa00ece 100644 --- a/plugins/hls-hlint-plugin/hls-hlint-plugin.cabal +++ b/plugins/hls-hlint-plugin/hls-hlint-plugin.cabal @@ -53,13 +53,13 @@ library , unordered-containers if ((!flag(ghc-lib) && impl(ghc >=8.10.1)) && impl(ghc <8.11.0)) - build-depends: ghc ^>=8.10 + build-depends: ghc ^>= 8.10 else build-depends: , ghc - , ghc-lib ^>=8.10 - , ghc-lib-parser-ex ^>=8.10 + , ghc-lib ^>= 8.10.2.20200916 + , ghc-lib-parser-ex ^>= 8.10 cpp-options: -DGHC_LIB mixins: From 89c4851ec19ed076a73d459dfcad8dd1331275bd Mon Sep 17 00:00:00 2001 From: jneira Date: Mon, 19 Oct 2020 13:14:17 +0200 Subject: [PATCH 46/71] Use latest ghc-lib version --- stack-8.10.1.yaml | 2 ++ stack-8.10.2.yaml | 2 +- stack-8.6.4.yaml | 4 ++-- stack-8.6.5.yaml | 4 ++-- stack-8.8.2.yaml | 4 ++-- stack-8.8.3.yaml | 2 ++ stack-8.8.4.yaml | 2 +- 7 files changed, 12 insertions(+), 8 deletions(-) diff --git a/stack-8.10.1.yaml b/stack-8.10.1.yaml index cb4321f00d..70385547d6 100644 --- a/stack-8.10.1.yaml +++ b/stack-8.10.1.yaml @@ -18,6 +18,8 @@ extra-deps: - data-tree-print-0.1.0.2 - floskell-0.10.4 - fourmolu-0.2.0.0 +- ghc-lib-8.10.2.20200916 +- ghc-lib-parser-8.10.2.20200916 - hie-bios-0.7.1 - HsYAML-aeson-0.2.0.0@rev:2 - implicit-hie-cradle-0.2.0.1 diff --git a/stack-8.10.2.yaml b/stack-8.10.2.yaml index b4a2b1c5d8..bb9e482840 100644 --- a/stack-8.10.2.yaml +++ b/stack-8.10.2.yaml @@ -1,4 +1,4 @@ -resolver: nightly-2020-10-03 +resolver: nightly-2020-10-19 packages: - . diff --git a/stack-8.6.4.yaml b/stack-8.6.4.yaml index 331891f68c..22c794d79b 100644 --- a/stack-8.6.4.yaml +++ b/stack-8.6.4.yaml @@ -29,8 +29,8 @@ extra-deps: # - ghcide-0.1.0 - ghc-check-0.5.0.1 - ghc-exactprint-0.6.3.2 -- ghc-lib-8.10.2.20200808 -- ghc-lib-parser-8.10.2.20200808 +- ghc-lib-8.10.2.20200916 +- ghc-lib-parser-8.10.2.20200916 - ghc-lib-parser-ex-8.10.0.16 - ghc-source-gen-0.4.0.0 - haddock-api-2.22.0@rev:1 diff --git a/stack-8.6.5.yaml b/stack-8.6.5.yaml index 2681c21a56..497d111f52 100644 --- a/stack-8.6.5.yaml +++ b/stack-8.6.5.yaml @@ -28,8 +28,8 @@ extra-deps: # - ghcide-0.1.0 - ghc-check-0.5.0.1 - ghc-exactprint-0.6.3.2 -- ghc-lib-8.10.2.20200808 -- ghc-lib-parser-8.10.2.20200808 +- ghc-lib-8.10.2.20200916 +- ghc-lib-parser-8.10.2.20200916 - ghc-lib-parser-ex-8.10.0.16 - ghc-source-gen-0.4.0.0 - haddock-api-2.22.0@rev:1 diff --git a/stack-8.8.2.yaml b/stack-8.8.2.yaml index 2cb2dece5c..dcace5e11a 100644 --- a/stack-8.8.2.yaml +++ b/stack-8.8.2.yaml @@ -25,8 +25,8 @@ extra-deps: # - ghcide-0.1.0 - ghc-check-0.5.0.1 - ghc-exactprint-0.6.3.2 -- ghc-lib-8.10.2.20200808 -- ghc-lib-parser-8.10.2.20200808 +- ghc-lib-8.10.2.20200916 +- ghc-lib-parser-8.10.2.20200916 - ghc-lib-parser-ex-8.10.0.16 - haddock-library-1.8.0 - haskell-lsp-0.22.0.0 diff --git a/stack-8.8.3.yaml b/stack-8.8.3.yaml index 780410d47c..4fd6a1c188 100644 --- a/stack-8.8.3.yaml +++ b/stack-8.8.3.yaml @@ -24,6 +24,8 @@ extra-deps: - fourmolu-0.2.0.0 # - ghcide-0.1.0 - ghc-exactprint-0.6.3.2 +- ghc-lib-8.10.2.20200916 +- ghc-lib-parser-8.10.2.20200916 - haskell-src-exts-1.21.1 - hie-bios-0.7.1 - HsYAML-aeson-0.2.0.0@rev:2 diff --git a/stack-8.8.4.yaml b/stack-8.8.4.yaml index e6b04fdbe6..19820a1407 100644 --- a/stack-8.8.4.yaml +++ b/stack-8.8.4.yaml @@ -1,4 +1,4 @@ -resolver: lts-16.16 +resolver: lts-16.19 packages: - . From 8603c5cb13a77b427478235505eed9924120e18a Mon Sep 17 00:00:00 2001 From: jneira Date: Wed, 21 Oct 2020 13:36:40 +0200 Subject: [PATCH 47/71] Change mixins for PackageImport --- plugins/hls-hlint-plugin/hls-hlint-plugin.cabal | 2 -- plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs | 12 +++++++----- 2 files changed, 7 insertions(+), 7 deletions(-) diff --git a/plugins/hls-hlint-plugin/hls-hlint-plugin.cabal b/plugins/hls-hlint-plugin/hls-hlint-plugin.cabal index aebfa00ece..6fe3b68ee7 100644 --- a/plugins/hls-hlint-plugin/hls-hlint-plugin.cabal +++ b/plugins/hls-hlint-plugin/hls-hlint-plugin.cabal @@ -62,8 +62,6 @@ library , ghc-lib-parser-ex ^>= 8.10 cpp-options: -DGHC_LIB - mixins: - ghc (GHC as RealGHC, HscTypes as RealGHC.HscTypes, EnumSet as RealGHC.EnumSet) ghc-options: -Wall -Wredundant-constraints -Wno-name-shadowing diff --git a/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs b/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs index e7d0794e60..9e69e27efa 100644 --- a/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs +++ b/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs @@ -5,6 +5,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PackageImports #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-} @@ -38,16 +39,17 @@ import Development.IDE.Core.Shake hiding (withIndefiniteProgress) import Development.IDE.Types.Diagnostics as D import Development.IDE.Types.Location import Development.Shake --- import Development.Shake hiding ( Diagnostic ) -import GHC hiding (DynFlags(..)) #ifdef GHC_LIB import Development.IDE.Core.RuleTypes (GhcSession(..)) import Development.IDE.GHC.Util (hscEnv) -import RealGHC (DynFlags(..)) -import RealGHC.HscTypes (hsc_dflags) -import qualified RealGHC.EnumSet as EnumSet +import "ghc-lib" GHC hiding (DynFlags(..)) +import "ghc" GHC as RealGHC (DynFlags(..)) +import "ghc" HscTypes as RealGHC.HscTypes (hsc_dflags) +import qualified "ghc" EnumSet as EnumSet import Language.Haskell.GhclibParserEx.GHC.Driver.Session as GhclibParserEx (readExtension) +#else +import GHC hiding (DynFlags(..)) #endif import Ide.Logger From 02308cd8352efe8b0f2a1925ea77707b862c2c5d Mon Sep 17 00:00:00 2001 From: jneira Date: Thu, 22 Oct 2020 22:31:58 +0200 Subject: [PATCH 48/71] Remove ghcide alternate repo --- .gitmodules | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/.gitmodules b/.gitmodules index 231895e286..c8abb211bc 100644 --- a/.gitmodules +++ b/.gitmodules @@ -12,7 +12,6 @@ path = ghcide # url = https://github.com/alanz/ghcide.git # url = https://github.com/wz1000/ghcide.git - # url = https://github.com/haskell/ghcide.git + url = https://github.com/haskell/ghcide.git # url = https://github.com/fendor/ghcide.git # url = https://github.com/bubba/ghcide.git - url = https://github.com/jneira/ghcide.git From e456f66116454068640d58d7096a9210412f875d Mon Sep 17 00:00:00 2001 From: Javier Neira Date: Sun, 25 Oct 2020 19:14:07 +0100 Subject: [PATCH 49/71] Simplify imports from ghcide Co-authored-by: Pepe Iborra --- plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs | 7 +------ 1 file changed, 1 insertion(+), 6 deletions(-) diff --git a/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs b/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs index 9e69e27efa..24a0108c6e 100644 --- a/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs +++ b/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs @@ -32,12 +32,7 @@ import Data.Maybe import qualified Data.Text as T import qualified Data.Text.IO as T import Data.Typeable -import Development.IDE.Core.FileStore -import Development.IDE.Core.OfInterest -import Development.IDE.Core.Rules -import Development.IDE.Core.Shake hiding (withIndefiniteProgress) -import Development.IDE.Types.Diagnostics as D -import Development.IDE.Types.Location +import Development.IDE import Development.Shake #ifdef GHC_LIB From 814ad46e98b998baf24b24120a8c91fad7d6e785 Mon Sep 17 00:00:00 2001 From: Javier Neira Date: Sun, 25 Oct 2020 19:16:05 +0100 Subject: [PATCH 50/71] Use GHC.Compat from ghcide Co-authored-by: Pepe Iborra --- plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs b/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs index 24a0108c6e..3a50be1589 100644 --- a/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs +++ b/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs @@ -44,7 +44,7 @@ import "ghc" HscTypes as RealGHC.HscTypes (hsc_dflags) import qualified "ghc" EnumSet as EnumSet import Language.Haskell.GhclibParserEx.GHC.Driver.Session as GhclibParserEx (readExtension) #else -import GHC hiding (DynFlags(..)) +import Development.IDE.GHC.Compat hiding (DynFlags(..)) #endif import Ide.Logger From 95dde7c668900e1c079b387bceac1a646133ec1d Mon Sep 17 00:00:00 2001 From: jneira Date: Sun, 25 Oct 2020 22:26:09 +0100 Subject: [PATCH 51/71] Restore imports for missing defs --- plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs b/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs index 3a50be1589..8749d62bea 100644 --- a/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs +++ b/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs @@ -33,6 +33,8 @@ 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) +import Development.IDE.Core.Shake (getDiagnostics) import Development.Shake #ifdef GHC_LIB From fc4ea3036a1202479d108dfdf5e67139b2f1d195 Mon Sep 17 00:00:00 2001 From: jneira Date: Sun, 25 Oct 2020 22:51:23 +0100 Subject: [PATCH 52/71] Comment about the need to use tmp file --- plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs b/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs index 8749d62bea..0cf1509e3a 100644 --- a/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs +++ b/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs @@ -326,6 +326,9 @@ applyHint ide nfp mhint = let fp = fromNormalizedFilePath nfp (_, mbOldContent) <- liftIO $ runAction "hlint" ide $ getFileContents nfp oldContent <- maybe (liftIO $ T.readFile fp) return mbOldContent + -- We need to save a file with last edited contents cause `apply-refact` + -- doesn't expose a function taking directly contents instead a file path. + -- Ideally we should try to expose that function upstream and remove this. res <- liftIO $ withSystemTempFile (takeFileName fp) $ \temp h -> do hClose h writeFileUTF8NoNewLineTranslation temp oldContent From 73f669d251df2036bf45d1b78605c4cd25cc06d0 Mon Sep 17 00:00:00 2001 From: jneira Date: Sun, 25 Oct 2020 22:54:12 +0100 Subject: [PATCH 53/71] Remove hlintOn logging --- plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs b/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs index 0cf1509e3a..23b84a37e8 100644 --- a/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs +++ b/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs @@ -89,7 +89,6 @@ rules :: Rules () rules = do define $ \GetHlintDiagnostics file -> do hlintOn' <- hlintOn <$> getClientConfigAction - logm $ "hlint:rules:hlintOn=" <> show hlintOn' ideas <- if hlintOn' then getIdeas file else return (Right []) return (diagnostics file ideas, Just ()) From 21b47f24c51771f4b254a81f44a6101aefa1219d Mon Sep 17 00:00:00 2001 From: jneira Date: Sun, 25 Oct 2020 23:36:40 +0100 Subject: [PATCH 54/71] Remove hlint parser error from diagnostics --- plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs | 16 +++------------- 1 file changed, 3 insertions(+), 13 deletions(-) diff --git a/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs b/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs index 23b84a37e8..dedf0d20ba 100644 --- a/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs +++ b/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs @@ -103,8 +103,9 @@ rules = do diagnostics :: NormalizedFilePath -> Either ParseError [Idea] -> [FileDiagnostic] diagnostics file (Right ideas) = [(file, ShowDiag, ideaToDiagnostic i) | i <- ideas, ideaSeverity i /= Ignore] - diagnostics file (Left parseErr) = - [(file, ShowDiag, parseErrorToDiagnostic parseErr)] + -- We don't return parse errors as diagnostics cause they match the emitted ones + -- by ghc and they would be duplicated + diagnostics file (Left parseErr) = [] ideaToDiagnostic :: Idea -> Diagnostic ideaToDiagnostic idea = @@ -118,17 +119,6 @@ rules = do , _tags = Nothing } - parseErrorToDiagnostic :: ParseError -> Diagnostic - parseErrorToDiagnostic (Hlint.ParseError l msg contents) = - LSP.Diagnostic { - _range = srcSpanToRange l - , _severity = Just LSP.DsInfo - , _code = Just (LSP.StringValue "parser") - , _source = Just "hlint" - , _message = T.unlines [T.pack msg,T.pack contents] - , _relatedInformation = Nothing - , _tags = Nothing - } -- This one is defined in Development.IDE.GHC.Error but here -- the types could come from ghc-lib or ghc srcSpanToRange :: SrcSpan -> LSP.Range From d558e9a9a4ad8ee2ce9007e3b1b7f28fc85b696c Mon Sep 17 00:00:00 2001 From: jneira Date: Mon, 26 Oct 2020 08:50:14 +0100 Subject: [PATCH 55/71] Comment about GetHlintDiagnostics RuleResult --- plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs b/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs index dedf0d20ba..c7d0a584e9 100644 --- a/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs +++ b/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs @@ -77,6 +77,8 @@ descriptor plId = (defaultPluginDescriptor plId) , pluginCodeActionProvider = Just codeActionProvider } +-- This rule only exists for generating file diagnostics +-- so the RuleResult is empty data GetHlintDiagnostics = GetHlintDiagnostics deriving (Eq, Show, Typeable, Generic) instance Hashable GetHlintDiagnostics From 1245439c9cc78036286858ead648f8ae7b4efda9 Mon Sep 17 00:00:00 2001 From: jneira Date: Mon, 26 Oct 2020 09:08:08 +0100 Subject: [PATCH 56/71] Comment how hlint diags are recomputed --- plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs b/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs index c7d0a584e9..6cbb96e96e 100644 --- a/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs +++ b/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs @@ -87,6 +87,14 @@ instance Binary GetHlintDiagnostics type instance RuleResult GetHlintDiagnostics = () +-- | Hlint rules to generate file diagnostics based on hlint hints +-- | This rule is recomputed when: +-- | - The files of interest have changed via `getFilesOfInterest` +-- | - One of those files has been edited via +-- | - `getIdeas` -> `getParsedModule`, if the hls ghc matches the hlint default ghc +-- | - `getIdeas` -> `getFileContents` otherwise (hlint is using ghc-lib) +-- | - The client settings have changed, to honour the `hlintOn` setting, via `getClientConfigAction` +-- | - The hlint specific settings have changed, via `getHlintSettingsRule` rules :: Rules () rules = do define $ \GetHlintDiagnostics file -> do From e26b23fee13812c8edb34f99ddd9652adbacbd3b Mon Sep 17 00:00:00 2001 From: jneira Date: Mon, 26 Oct 2020 10:22:51 +0100 Subject: [PATCH 57/71] Correct identation --- hie.yaml.cbl | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/hie.yaml.cbl b/hie.yaml.cbl index 6869c0247d..7def33807c 100644 --- a/hie.yaml.cbl +++ b/hie.yaml.cbl @@ -34,7 +34,7 @@ cradle: - path: "./src" component: "lib:haskell-language-server" - - path: "./dist-newstyle/" + - path: "./dist-newstyle/" component: "lib:haskell-language-server" - path: "./ghcide/src" From 7f5a4ef9c6fdb02b373a1187d6e0622271d9605d Mon Sep 17 00:00:00 2001 From: jneira Date: Mon, 26 Oct 2020 10:24:57 +0100 Subject: [PATCH 58/71] Use diagnostic code prefix "refact:" to check if a hlint hint should trigger a code action --- plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs | 14 ++++++++------ 1 file changed, 8 insertions(+), 6 deletions(-) diff --git a/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs b/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs index 6cbb96e96e..815e4a34c7 100644 --- a/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs +++ b/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs @@ -122,12 +122,13 @@ rules = do LSP.Diagnostic { _range = srcSpanToRange $ ideaSpan idea , _severity = Just LSP.DsInfo - , _code = Just (LSP.StringValue $ T.pack $ ideaHint idea) + , _code = Just $ (LSP.StringValue $ T.pack $ codePre ++ ideaHint idea) , _source = Just "hlint" , _message = T.pack $ show idea , _relatedInformation = Nothing , _tags = Nothing } + where codePre = if null $ ideaRefactoring idea then "" else "refact:" -- This one is defined in Development.IDE.GHC.Error but here -- the types could come from ghc-lib or ghc @@ -217,12 +218,12 @@ codeActionProvider _lf ideState plId docId _ context = Right . LSP.List . map CA let docNfp = toNormalizedFilePath' <$> uriToFilePath' (docId ^. LSP.uri) numHintsInDoc = length [d | (nfp, _, d) <- diags - , d ^. LSP.source == Just "hlint" + , validCommand d , Just nfp == docNfp ] -- We only want to show the applyAll code action if there is more than 1 -- hint in the current document - if numHintsInDoc >= 2 then do + if numHintsInDoc > 1 then do applyAll <- applyAllAction pure $ applyAll:applyOne else @@ -238,8 +239,9 @@ codeActionProvider _lf ideState plId docId _ context = Right . LSP.List . map CA -- |Some hints do not have an associated refactoring validCommand (LSP.Diagnostic _ _ (Just (LSP.StringValue code)) (Just "hlint") _ _ _) = - code /= "Eta reduce" - validCommand _ = False + "refact:" `T.isPrefixOf` code + validCommand _ = + False LSP.List diags = context ^. LSP.diagnostics @@ -248,7 +250,7 @@ codeActionProvider _lf ideState plId docId _ context = Right . LSP.List . map CA Just . codeAction <$> mkLspCommand plId "applyOne" title (Just args) where codeAction cmd = LSP.CodeAction title (Just LSP.CodeActionQuickFix) (Just (LSP.List [diag])) Nothing (Just cmd) - title = "Apply hint: " <> code + title = T.replace code "refact:" "Apply hint: " -- need 'file', 'start_pos' and hint title (to distinguish between alternative suggestions at the same location) args = [toJSON (AOP (docId ^. LSP.uri) start code)] mkHlintAction (LSP.Diagnostic _r _s _c _source _m _ _) = return Nothing From eeb62e0a91e37962ec723f0bbe1e36a31d5fc4b4 Mon Sep 17 00:00:00 2001 From: jneira Date: Mon, 26 Oct 2020 11:59:36 +0100 Subject: [PATCH 59/71] Return hlint diags if no ghc parse errors --- .../hls-hlint-plugin/src/Ide/Plugin/Hlint.hs | 33 ++++++++++++++----- 1 file changed, 24 insertions(+), 9 deletions(-) diff --git a/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs b/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs index 815e4a34c7..ebcb54d802 100644 --- a/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs +++ b/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs @@ -35,7 +35,6 @@ import Data.Typeable import Development.IDE import Development.IDE.Core.Rules (defineNoFile) import Development.IDE.Core.Shake (getDiagnostics) -import Development.Shake #ifdef GHC_LIB import Development.IDE.Core.RuleTypes (GhcSession(..)) @@ -113,9 +112,8 @@ rules = do diagnostics :: NormalizedFilePath -> Either ParseError [Idea] -> [FileDiagnostic] diagnostics file (Right ideas) = [(file, ShowDiag, ideaToDiagnostic i) | i <- ideas, ideaSeverity i /= Ignore] - -- We don't return parse errors as diagnostics cause they match the emitted ones - -- by ghc and they would be duplicated - diagnostics file (Left parseErr) = [] + diagnostics file (Left parseErr) = + [(file, ShowDiag, parseErrorToDiagnostic parseErr)] ideaToDiagnostic :: Idea -> Diagnostic ideaToDiagnostic idea = @@ -130,6 +128,18 @@ rules = do } where codePre = if null $ ideaRefactoring idea then "" else "refact:" + parseErrorToDiagnostic :: ParseError -> Diagnostic + parseErrorToDiagnostic (Hlint.ParseError l msg contents) = + LSP.Diagnostic { + _range = srcSpanToRange l + , _severity = Just LSP.DsInfo + , _code = Just (LSP.StringValue "parser") + , _source = Just "hlint" + , _message = T.unlines [T.pack msg,T.pack contents] + , _relatedInformation = Nothing + , _tags = Nothing + } + -- This one is defined in Development.IDE.GHC.Error but here -- the types could come from ghc-lib or ghc srcSpanToRange :: SrcSpan -> LSP.Range @@ -157,11 +167,16 @@ getIdeas nfp = do where moduleEx :: ParseFlags -> Action (Maybe (Either ParseError ModuleEx)) #ifdef GHC_LIB moduleEx flags = do - flags' <- setExtensions flags - (_, contents) <- getFileContents nfp - let fp = fromNormalizedFilePath nfp - let contents' = T.unpack <$> contents - Just <$> (liftIO $ parseModuleEx flags' fp contents') + mbpm <- getParsedModule nfp + -- If ghc was not able to parse the module, we disable hlint diagnostics + if isNothing mbpm + then return Nothing + else do + flags' <- setExtensions flags + (_, contents) <- getFileContents nfp + let fp = fromNormalizedFilePath nfp + let contents' = T.unpack <$> contents + Just <$> (liftIO $ parseModuleEx flags' fp contents') setExtensions flags = do hsc <- hscEnv <$> use_ GhcSession nfp From 929aaea3d33b6e7e9892e9bd48f386eb274b987f Mon Sep 17 00:00:00 2001 From: jneira Date: Mon, 26 Oct 2020 12:04:24 +0100 Subject: [PATCH 60/71] Combine hlint and hscEnv extensions --- plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs b/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs index ebcb54d802..ded22f4f27 100644 --- a/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs +++ b/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs @@ -37,8 +37,7 @@ import Development.IDE.Core.Rules (defineNoFile) import Development.IDE.Core.Shake (getDiagnostics) #ifdef GHC_LIB -import Development.IDE.Core.RuleTypes (GhcSession(..)) -import Development.IDE.GHC.Util (hscEnv) +import Data.List (nub) import "ghc-lib" GHC hiding (DynFlags(..)) import "ghc" GHC as RealGHC (DynFlags(..)) import "ghc" HscTypes as RealGHC.HscTypes (hsc_dflags) @@ -182,7 +181,8 @@ getIdeas nfp = do hsc <- hscEnv <$> use_ GhcSession nfp let dflags = hsc_dflags hsc let hscExts = EnumSet.toList (extensionFlags dflags) - let hlintExts = mapMaybe (GhclibParserEx.readExtension . show) hscExts + let hscExts' = mapMaybe (GhclibParserEx.readExtension . show) hscExts + let hlintExts = nub $ enabledExtensions flags ++ hscExts' logm $ "hlint:getIdeas:setExtensions:" ++ show hlintExts return $ flags { enabledExtensions = hlintExts } #else From f5d431112e38533ef7587eadf513baae287febc1 Mon Sep 17 00:00:00 2001 From: jneira Date: Mon, 26 Oct 2020 12:30:20 +0100 Subject: [PATCH 61/71] Correct replace params --- plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs b/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs index ded22f4f27..673896b3eb 100644 --- a/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs +++ b/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs @@ -265,7 +265,7 @@ codeActionProvider _lf ideState plId docId _ context = Right . LSP.List . map CA Just . codeAction <$> mkLspCommand plId "applyOne" title (Just args) where codeAction cmd = LSP.CodeAction title (Just LSP.CodeActionQuickFix) (Just (LSP.List [diag])) Nothing (Just cmd) - title = T.replace code "refact:" "Apply hint: " + title = T.replace "refact:" "Apply hint: " code -- need 'file', 'start_pos' and hint title (to distinguish between alternative suggestions at the same location) args = [toJSON (AOP (docId ^. LSP.uri) start code)] mkHlintAction (LSP.Diagnostic _r _s _c _source _m _ _) = return Nothing From 1c1f7f31e800ddec64b0ebb92feb29f2d451dd38 Mon Sep 17 00:00:00 2001 From: jneira Date: Mon, 26 Oct 2020 12:56:11 +0100 Subject: [PATCH 62/71] Correct component name --- hie.yaml.cbl | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/hie.yaml.cbl b/hie.yaml.cbl index 7def33807c..98e66395ac 100644 --- a/hie.yaml.cbl +++ b/hie.yaml.cbl @@ -46,5 +46,5 @@ cradle: - path: "./hls-plugin-api/src" component: "hls-plugin-api:lib:hls-plugin-api" - - path: "./plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs" - component: "lib:hlint-plugin" + - path: "./plugins/hls-hlint-plugin/src" + component: "lib:hls-hlint-plugin" From 8b8e568795162c8f0bd39139580c9a3386a2d2da Mon Sep 17 00:00:00 2001 From: jneira Date: Mon, 26 Oct 2020 13:42:33 +0100 Subject: [PATCH 63/71] Fix apply refactoring --- plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs b/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs index 673896b3eb..1beff7715e 100644 --- a/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs +++ b/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs @@ -119,7 +119,7 @@ rules = do LSP.Diagnostic { _range = srcSpanToRange $ ideaSpan idea , _severity = Just LSP.DsInfo - , _code = Just $ (LSP.StringValue $ T.pack $ codePre ++ ideaHint idea) + , _code = Just (LSP.StringValue $ T.pack $ codePre ++ ideaHint idea) , _source = Just "hlint" , _message = T.pack $ show idea , _relatedInformation = Nothing @@ -265,9 +265,10 @@ codeActionProvider _lf ideState plId docId _ context = Right . LSP.List . map CA Just . codeAction <$> mkLspCommand plId "applyOne" title (Just args) where codeAction cmd = LSP.CodeAction title (Just LSP.CodeActionQuickFix) (Just (LSP.List [diag])) Nothing (Just cmd) - title = T.replace "refact:" "Apply hint: " code + 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 code)] + args = [toJSON (AOP (docId ^. LSP.uri) start ideaHint)] mkHlintAction (LSP.Diagnostic _r _s _c _source _m _ _) = return Nothing -- --------------------------------------------------------------------- From c35cdda57c801d15ebce042921e922d12bfd1bcb Mon Sep 17 00:00:00 2001 From: jneira Date: Mon, 26 Oct 2020 14:09:56 +0100 Subject: [PATCH 64/71] Update tests to match new diags and ca's --- test/functional/FunctionalCodeAction.hs | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/test/functional/FunctionalCodeAction.hs b/test/functional/FunctionalCodeAction.hs index 9f4b39a541..6c5921c27e 100644 --- a/test/functional/FunctionalCodeAction.hs +++ b/test/functional/FunctionalCodeAction.hs @@ -52,16 +52,18 @@ hlintTests = testGroup "hlint suggestions" [ 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.code @?= Just (StringValue "Eta reduce") + reduceDiag ^. L.code @?= Just (StringValue "refact:Eta reduce") reduceDiag ^. L.source @?= Just "hlint" cas <- map fromAction <$> getAllCodeActions doc 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 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" executeCodeAction (fromJust redId) From 0e72151bf91df0f9c59f87e5a3c029f84a3957c1 Mon Sep 17 00:00:00 2001 From: jneira Date: Tue, 27 Oct 2020 00:29:56 +0100 Subject: [PATCH 65/71] Add GHC810 explicit version --- test/functional/FunctionalCodeAction.hs | 98 ++++++++++++------------- test/utils/Test/Hls/Util.hs | 7 +- 2 files changed, 54 insertions(+), 51 deletions(-) diff --git a/test/functional/FunctionalCodeAction.hs b/test/functional/FunctionalCodeAction.hs index 6c5921c27e..587cb44da3 100644 --- a/test/functional/FunctionalCodeAction.hs +++ b/test/functional/FunctionalCodeAction.hs @@ -282,31 +282,31 @@ typedHoleTests = testGroup "typed hole code actions" [ _ <- waitForDiagnosticsSource "bios" cas <- map (\(CACodeAction x)-> x) <$> getAllCodeActions doc - suggestion <- - case ghcVersion of - GHC88 -> do - liftIO $ map (^. L.title) cas `matchList` - [ "Substitute hole (Int) with x ([Int])" - , "Substitute hole (Int) with foo ([Int] -> Int Valid hole fits include)" - , "Substitute hole (Int) with maxBound (forall a. Bounded a => a with maxBound @Int)" - , "Substitute hole (Int) with minBound (forall a. Bounded a => a with minBound @Int)" - ] @? "Contains substitutions" - return "x" - GHC86 -> do - liftIO $ map (^. L.title) cas `matchList` - [ "Substitute hole (Int) with x ([Int])" - , "Substitute hole (Int) with foo ([Int] -> Int Valid hole fits include)" - , "Substitute hole (Int) with maxBound (forall a. Bounded a => a with maxBound @Int)" - , "Substitute hole (Int) with minBound (forall a. Bounded a => a with minBound @Int)" - ] @? "Contains substitutions" - return "x" - GHC84 -> do - liftIO $ map (^. L.title) cas `matchList` - [ "Substitute hole (Int) with maxBound (forall a. Bounded a => a)" - , "Substitute hole (Int) with minBound (forall a. Bounded a => a)" - , "Substitute hole (Int) with undefined (forall (a :: TYPE r). GHC.Stack.Types.HasCallStack => a)" - ] @? "Contains substitutions" - return "maxBound" + let substitutions GHC810 = substitutions GHC88 + substitutions GHC88 = + [ "Substitute hole (Int) with x ([Int])" + , "Substitute hole (Int) with foo ([Int] -> Int Valid hole fits include)" + , "Substitute hole (Int) with maxBound (forall a. Bounded a => a with maxBound @Int)" + , "Substitute hole (Int) with minBound (forall a. Bounded a => a with minBound @Int)" + ] + substitutions GHC86 = + [ "Substitute hole (Int) with x ([Int])" + , "Substitute hole (Int) with foo ([Int] -> Int Valid hole fits include)" + , "Substitute hole (Int) with maxBound (forall a. Bounded a => a with maxBound @Int)" + , "Substitute hole (Int) with minBound (forall a. Bounded a => a with minBound @Int)" + ] + substitutions GHC84 = + [ "Substitute hole (Int) with maxBound (forall a. Bounded a => a)" + , "Substitute hole (Int) with minBound (forall a. Bounded a => a)" + , "Substitute hole (Int) with undefined (forall (a :: TYPE r). GHC.Stack.Types.HasCallStack => a)" + ] + + liftIO $ map (^. L.title) cas `matchList` + substitutions ghcVersion @? "Contains substitutions" + + let suggestion = case ghcVersion of + GHC84 -> "maxBound" + _ -> "x" executeCodeAction $ head cas @@ -324,30 +324,30 @@ typedHoleTests = testGroup "typed hole code actions" [ _ <- waitForDiagnosticsSource "bios" cas <- map fromAction <$> getAllCodeActions doc - suggestion <- - case ghcVersion of - GHC88 -> do - liftIO $ map (^. L.title) cas `matchList` - [ "Substitute hole (A) with stuff (A -> A)" - , "Substitute hole (A) with x ([A])" - , "Substitute hole (A) with foo2 ([A] -> A)" - ] @? "Contains substitutions" - return "stuff" - GHC86 -> do - liftIO $ map (^. L.title) cas `matchList` - [ "Substitute hole (A) with stuff (A -> A)" - , "Substitute hole (A) with x ([A])" - , "Substitute hole (A) with foo2 ([A] -> A)" - ] @? "Contains substituions" - return "stuff" - GHC84 -> do - liftIO $ map (^. L.title) cas `matchList` - [ "Substitute hole (A) with undefined (forall (a :: TYPE r). GHC.Stack.Types.HasCallStack => a)" - , "Substitute hole (A) with stuff (A -> A)" - , "Substitute hole (A) with x ([A])" - , "Substitute hole (A) with foo2 ([A] -> A)" - ] @? "Contains substitutions" - return "undefined" + let substitutions GHC810 = substitutions GHC88 + substitutions GHC88 = + [ "Substitute hole (A) with stuff (A -> A)" + , "Substitute hole (A) with x ([A])" + , "Substitute hole (A) with foo2 ([A] -> A)" + ] + substitutions GHC86 = + [ "Substitute hole (A) with stuff (A -> A)" + , "Substitute hole (A) with x ([A])" + , "Substitute hole (A) with foo2 ([A] -> A)" + ] + substitutions GHC84 = + [ "Substitute hole (A) with undefined (forall (a :: TYPE r). GHC.Stack.Types.HasCallStack => a)" + , "Substitute hole (A) with stuff (A -> A)" + , "Substitute hole (A) with x ([A])" + , "Substitute hole (A) with foo2 ([A] -> A)" + ] + + liftIO $ map (^. L.title) cas `matchList` + substitutions ghcVersion @? "Contains substitutions" + + let suggestion = case ghcVersion of + GHC84 -> "undefined" + _ -> "stuff" executeCodeAction $ head cas diff --git a/test/utils/Test/Hls/Util.hs b/test/utils/Test/Hls/Util.hs index 4e6ac6e55a..87e2682dd6 100644 --- a/test/utils/Test/Hls/Util.hs +++ b/test/utils/Test/Hls/Util.hs @@ -96,13 +96,16 @@ files = ] data GhcVersion - = GHC88 + = GHC810 + | GHC88 | GHC86 | GHC84 deriving (Eq,Show) ghcVersion :: GhcVersion -#if (defined(MIN_VERSION_GLASGOW_HASKELL) && (MIN_VERSION_GLASGOW_HASKELL(8,8,0,0))) +#if (defined(MIN_VERSION_GLASGOW_HASKELL) && (MIN_VERSION_GLASGOW_HASKELL(8,10,0,0))) +ghcVersion = GHC810 +#elif (defined(MIN_VERSION_GLASGOW_HASKELL) && (MIN_VERSION_GLASGOW_HASKELL(8,8,0,0))) ghcVersion = GHC88 #elif (defined(MIN_VERSION_GLASGOW_HASKELL) && (MIN_VERSION_GLASGOW_HASKELL(8,6,0,0))) ghcVersion = GHC86 From 5d4d2e2b631b39d51a05a537a967e105fde28b4f Mon Sep 17 00:00:00 2001 From: jneira Date: Tue, 27 Oct 2020 00:33:56 +0100 Subject: [PATCH 66/71] Set hlint code by ghc version --- test/functional/FunctionalCodeAction.hs | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/test/functional/FunctionalCodeAction.hs b/test/functional/FunctionalCodeAction.hs index 587cb44da3..b8f1920a8b 100644 --- a/test/functional/FunctionalCodeAction.hs +++ b/test/functional/FunctionalCodeAction.hs @@ -48,11 +48,15 @@ hlintTests = testGroup "hlint suggestions" [ doc <- openDoc "ApplyRefact2.hs" "haskell" diags@(reduceDiag:_) <- waitForDiagnosticsSource "hlint" + let etaReduceCode = case ghcVersion of + GHC810 -> "refact:Eta reduce" + _ -> "Eta reduce" + 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.code @?= Just (StringValue "refact:Eta reduce") + reduceDiag ^. L.code @?= Just (StringValue etaReduceCode) reduceDiag ^. L.source @?= Just "hlint" cas <- map fromAction <$> getAllCodeActions doc From f1751b710a2f79847a30be91af65c8712253a79a Mon Sep 17 00:00:00 2001 From: jneira Date: Tue, 27 Oct 2020 08:26:57 +0100 Subject: [PATCH 67/71] Use hlint-3.2 --- plugins/hls-hlint-plugin/hls-hlint-plugin.cabal | 2 +- stack-8.10.1.yaml | 1 + stack-8.6.4.yaml | 2 +- stack-8.6.5.yaml | 2 +- stack-8.8.2.yaml | 2 +- stack-8.8.3.yaml | 1 + stack-8.8.4.yaml | 1 + stack.yaml | 2 +- 8 files changed, 8 insertions(+), 5 deletions(-) diff --git a/plugins/hls-hlint-plugin/hls-hlint-plugin.cabal b/plugins/hls-hlint-plugin/hls-hlint-plugin.cabal index 6fe3b68ee7..92862a5758 100644 --- a/plugins/hls-hlint-plugin/hls-hlint-plugin.cabal +++ b/plugins/hls-hlint-plugin/hls-hlint-plugin.cabal @@ -41,7 +41,7 @@ library , ghcide , hashable , haskell-lsp - , hlint >=3.0 + , hlint >=3.2 , hls-plugin-api , hslogger , lens diff --git a/stack-8.10.1.yaml b/stack-8.10.1.yaml index 70385547d6..9190f33e18 100644 --- a/stack-8.10.1.yaml +++ b/stack-8.10.1.yaml @@ -21,6 +21,7 @@ extra-deps: - ghc-lib-8.10.2.20200916 - ghc-lib-parser-8.10.2.20200916 - hie-bios-0.7.1 +- hlint-3.2 - HsYAML-aeson-0.2.0.0@rev:2 - implicit-hie-cradle-0.2.0.1 - implicit-hie-0.1.2.0 diff --git a/stack-8.6.4.yaml b/stack-8.6.4.yaml index 22c794d79b..48fdc7c13c 100644 --- a/stack-8.6.4.yaml +++ b/stack-8.6.4.yaml @@ -38,7 +38,7 @@ extra-deps: - haskell-lsp-0.22.0.0 - haskell-lsp-types-0.22.0.0 - hie-bios-0.7.1 -- hlint-3.1.4 +- hlint-3.2 - HsYAML-0.2.1.0@rev:1 - HsYAML-aeson-0.2.0.0@rev:2 - implicit-hie-cradle-0.2.0.1 diff --git a/stack-8.6.5.yaml b/stack-8.6.5.yaml index 497d111f52..564919937e 100644 --- a/stack-8.6.5.yaml +++ b/stack-8.6.5.yaml @@ -37,7 +37,7 @@ extra-deps: - haskell-lsp-0.22.0.0 - haskell-lsp-types-0.22.0.0 - hie-bios-0.7.1 -- hlint-3.1.4 +- hlint-3.2 - HsYAML-0.2.1.0@rev:1 - HsYAML-aeson-0.2.0.0@rev:2 - implicit-hie-cradle-0.2.0.1 diff --git a/stack-8.8.2.yaml b/stack-8.8.2.yaml index dcace5e11a..3e704d09b9 100644 --- a/stack-8.8.2.yaml +++ b/stack-8.8.2.yaml @@ -33,7 +33,7 @@ extra-deps: - haskell-lsp-types-0.22.0.0 - haskell-src-exts-1.21.1 - hie-bios-0.7.1 -- hlint-3.1.4 +- hlint-3.2 - hoogle-5.0.17.11 - hsimport-0.11.0 - HsYAML-0.2.1.0@rev:1 diff --git a/stack-8.8.3.yaml b/stack-8.8.3.yaml index 4fd6a1c188..db32b01a1f 100644 --- a/stack-8.8.3.yaml +++ b/stack-8.8.3.yaml @@ -28,6 +28,7 @@ extra-deps: - ghc-lib-parser-8.10.2.20200916 - haskell-src-exts-1.21.1 - hie-bios-0.7.1 +- hlint-3.2 - HsYAML-aeson-0.2.0.0@rev:2 - hoogle-5.0.17.11 - hsimport-0.11.0 diff --git a/stack-8.8.4.yaml b/stack-8.8.4.yaml index 19820a1407..819c9f1680 100644 --- a/stack-8.8.4.yaml +++ b/stack-8.8.4.yaml @@ -26,6 +26,7 @@ extra-deps: - ghc-exactprint-0.6.3.2 - haskell-src-exts-1.21.1 - hie-bios-0.7.1 +- hlint-3.2 - HsYAML-aeson-0.2.0.0@rev:2 - hoogle-5.0.17.11 - hsimport-0.11.0 diff --git a/stack.yaml b/stack.yaml index d220d73d01..89fd3d2f96 100644 --- a/stack.yaml +++ b/stack.yaml @@ -37,7 +37,7 @@ extra-deps: - haskell-lsp-0.22.0.0 - haskell-lsp-types-0.22.0.0 - hie-bios-0.7.1 -- hlint-3.1.4 +- hlint-3.2 - HsYAML-0.2.1.0@rev:1 - HsYAML-aeson-0.2.0.0@rev:2 - implicit-hie-cradle-0.2.0.1 From b549506a46a93d0dd6368c2764aa7587c299fb54 Mon Sep 17 00:00:00 2001 From: jneira Date: Tue, 27 Oct 2020 08:27:22 +0100 Subject: [PATCH 68/71] Remove ghc specific diag title --- test/functional/FunctionalCodeAction.hs | 8 ++------ 1 file changed, 2 insertions(+), 6 deletions(-) diff --git a/test/functional/FunctionalCodeAction.hs b/test/functional/FunctionalCodeAction.hs index b8f1920a8b..da7c670154 100644 --- a/test/functional/FunctionalCodeAction.hs +++ b/test/functional/FunctionalCodeAction.hs @@ -48,15 +48,11 @@ hlintTests = testGroup "hlint suggestions" [ doc <- openDoc "ApplyRefact2.hs" "haskell" diags@(reduceDiag:_) <- waitForDiagnosticsSource "hlint" - let etaReduceCode = case ghcVersion of - GHC810 -> "refact:Eta reduce" - _ -> "Eta reduce" - 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.code @?= Just (StringValue etaReduceCode) + reduceDiag ^. L.code @?= Just (StringValue "refact:Eta reduce") reduceDiag ^. L.source @?= Just "hlint" cas <- map fromAction <$> getAllCodeActions doc @@ -100,7 +96,7 @@ hlintTests = testGroup "hlint suggestions" [ diags' <- waitForDiagnostics - liftIO $ (not $ Just "hlint" `elem` map (^. L.source) diags') @? "There are no hlint diagnostics" + liftIO $ Just "hlint" `notElem` map (^. L.source) diags' @? "There are no hlint diagnostics" ] From ff0e4c7b29b149f7859a0574ab3d152894280912 Mon Sep 17 00:00:00 2001 From: jneira Date: Tue, 27 Oct 2020 08:42:06 +0100 Subject: [PATCH 69/71] Add and update comments --- plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs b/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs index 1beff7715e..d500ccd765 100644 --- a/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs +++ b/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs @@ -89,8 +89,8 @@ type instance RuleResult GetHlintDiagnostics = () -- | This rule is recomputed when: -- | - The files of interest have changed via `getFilesOfInterest` -- | - One of those files has been edited via --- | - `getIdeas` -> `getParsedModule`, if the hls ghc matches the hlint default ghc --- | - `getIdeas` -> `getFileContents` otherwise (hlint is using ghc-lib) +-- | - `getIdeas` -> `getParsedModule` in any case +-- | - `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 :: Rules () @@ -119,6 +119,7 @@ rules = do LSP.Diagnostic { _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) , _source = Just "hlint" , _message = T.pack $ show idea @@ -265,6 +266,7 @@ codeActionProvider _lf ideState plId docId _ context = Right . LSP.List . map CA Just . codeAction <$> mkLspCommand plId "applyOne" title (Just args) where codeAction cmd = LSP.CodeAction title (Just LSP.CodeActionQuickFix) (Just (LSP.List [diag])) 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) From 01f8fd8b22b505be3f7ccad8d074b39d86609d0e Mon Sep 17 00:00:00 2001 From: jneira Date: Tue, 27 Oct 2020 14:00:49 +0100 Subject: [PATCH 70/71] Provide evidence edits changes hlint diags --- test/functional/FunctionalCodeAction.hs | 27 ++++++++++++++++++++++++- 1 file changed, 26 insertions(+), 1 deletion(-) diff --git a/test/functional/FunctionalCodeAction.hs b/test/functional/FunctionalCodeAction.hs index da7c670154..ce1fb9bd04 100644 --- a/test/functional/FunctionalCodeAction.hs +++ b/test/functional/FunctionalCodeAction.hs @@ -82,7 +82,7 @@ hlintTests = testGroup "hlint suggestions" [ contents <- skipManyTill publishDiagnosticsNotification $ getDocumentEdit doc liftIO $ contents `elem` ["main = undefined\nfoo = id\n", "main = undefined\nfoo x = x\n"] @? "Command is applied" - , testCase "changing configuration enables or disables hints" $ runSession hlsCommand fullCaps "test/testdata/hlint" $ do + , testCase "changing configuration enables or disables hlint diagnostics" $ runSession hlsCommand fullCaps "test/testdata/hlint" $ do let config = def { hlintOn = True } sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (toJSON config)) @@ -98,6 +98,31 @@ hlintTests = testGroup "hlint suggestions" [ liftIO $ Just "hlint" `notElem` map (^. L.source) diags' @? "There are no hlint diagnostics" + , testCase "changing document contents updates hlint diagnostics" $ runSession hlsCommand fullCaps "test/testdata/hlint" $ do + doc <- openDoc "ApplyRefact2.hs" "haskell" + diags <- waitForDiagnosticsSource "hlint" + + liftIO $ length diags @?= 2 -- "Eta Reduce" and "Redundant Id" + + let change = TextDocumentContentChangeEvent + (Just (Range (Position 1 8) (Position 1 12))) + Nothing "x" + + changeDoc doc [change] + + diags' <- waitForDiagnostics + + liftIO $ (not $ Just "hlint" `elem` map (^. L.source) diags') @? "There are no hlint diagnostics" + + let change' = TextDocumentContentChangeEvent + (Just (Range (Position 1 8) (Position 1 12))) + Nothing "id x" + + changeDoc doc [change'] + + diags'' <- waitForDiagnosticsSource "hlint" + + liftIO $ length diags'' @?= 2 ] renameTests :: TestTree From 94b7a3ea6fc3642d85a8cd49d548721000ac61b2 Mon Sep 17 00:00:00 2001 From: jneira Date: Wed, 28 Oct 2020 22:26:43 +0100 Subject: [PATCH 71/71] Rerun test suite to avoid flaky tests --- .github/workflows/test.yml | 2 +- .gitignore | 2 ++ haskell-language-server.cabal | 1 + test/wrapper/Main.hs | 7 +++++-- 4 files changed, 9 insertions(+), 3 deletions(-) diff --git a/.github/workflows/test.yml b/.github/workflows/test.yml index 2f8693bf94..0265ce51c5 100644 --- a/.github/workflows/test.yml +++ b/.github/workflows/test.yml @@ -64,5 +64,5 @@ jobs: # run the tests without parallelism, otherwise tasty will attempt to run # all functional test cases simultaneously which causes way too many hls # instances to be spun up for the poor github actions runner to handle - run: cabal test --test-options=-j1 + run: cabal test --test-options="-j1 --rerun-update" || cabal test --test-options="-j1 --rerun" || LSP_TEST_LOG_COLOR=0 LSP_TEST_LOG_MESSAGES=true LSP_TEST_LOG_STDERR=true cabal test --test-options="-j1 --rerun" diff --git a/.gitignore b/.gitignore index 02ba240d25..a611b847e7 100644 --- a/.gitignore +++ b/.gitignore @@ -6,6 +6,8 @@ cabal.project.local *~ *.lock +.tasty-rerun-log + # shake build information _build/ diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal index a0167faba1..9e593bff37 100644 --- a/haskell-language-server.cabal +++ b/haskell-language-server.cabal @@ -276,6 +276,7 @@ test-suite wrapper-test , process , tasty , tasty-ant-xml >=1.1.6 + , tasty-rerun hs-source-dirs: test/wrapper main-is: Main.hs diff --git a/test/wrapper/Main.hs b/test/wrapper/Main.hs index 8243ca1168..e071327f81 100644 --- a/test/wrapper/Main.hs +++ b/test/wrapper/Main.hs @@ -4,14 +4,17 @@ import Data.Maybe import Test.Hls.Util import Test.Tasty import Test.Tasty.HUnit +import Test.Tasty.Ingredients.Rerun +import Test.Tasty.Runners ( listingTests, consoleTestReporter) import System.Process import System.Environment main :: IO () main = do flushStackEnvironment - defaultMain $ - testGroup "haskell-language-server-wrapper" [projectGhcVersionTests] + defaultMainWithIngredients + [rerunningTests [listingTests, consoleTestReporter]] $ + testGroup "haskell-language-server-wrapper" [projectGhcVersionTests] projectGhcVersionTests :: TestTree projectGhcVersionTests = testGroup "--project-ghc-version"