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/cabal.project b/cabal.project index 838349a717..ef5e93a50a 100644 --- a/cabal.project +++ b/cabal.project @@ -3,6 +3,7 @@ packages: ghcide hls-plugin-api ./plugins/tactics + ./plugins/hls-hlint-plugin source-repository-package type: git 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..9e593bff37 100644 --- a/haskell-language-server.cabal +++ b/haskell-language-server.cabal @@ -77,6 +77,7 @@ library default-language: Haskell2010 + executable haskell-language-server import: agpl, common-deps main-is: Main.hs @@ -119,6 +120,7 @@ executable haskell-language-server , hashable , haskell-language-server , haskell-lsp ^>=0.22 + , hls-hlint-plugin , hls-plugin-api , hls-tactics-plugin , lens @@ -197,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 @@ -274,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/hie.yaml.cbl b/hie.yaml.cbl index af9ba677d6..98e66395ac 100644 --- a/hie.yaml.cbl +++ b/hie.yaml.cbl @@ -34,7 +34,7 @@ cradle: - path: "./src" component: "lib:haskell-language-server" - - path: "./.stack-work/" + - path: "./dist-newstyle/" component: "lib:haskell-language-server" - path: "./ghcide/src" @@ -45,3 +45,6 @@ cradle: - path: "./hls-plugin-api/src" component: "hls-plugin-api:lib:hls-plugin-api" + + - path: "./plugins/hls-hlint-plugin/src" + component: "lib:hls-hlint-plugin" diff --git a/hie.yaml.stack b/hie.yaml.stack index 69c94ea0cc..e9aaa75c39 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/hls-hlint-plugin/src" + component: "hls-hlint-plugin:lib:hls-hlint-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/hls-plugin-api/src/Ide/Plugin.hs b/hls-plugin-api/src/Ide/Plugin.hs index 74221fd141..e509196dc9 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) @@ -25,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 @@ -32,6 +35,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 +592,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 <- unhashed <$> useNoFile_ GetClientSettings + logm $ "getClientConfigAction:clientSettings:" ++ show mbVal + case J.fromJSON <$> mbVal of + Just (J.Success c) -> return c + _ -> return Data.Default.def -- --------------------------------------------------------------------- diff --git a/plugins/hls-hlint-plugin/LICENSE b/plugins/hls-hlint-plugin/LICENSE new file mode 100644 index 0000000000..261eeb9e9f --- /dev/null +++ b/plugins/hls-hlint-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/hls-hlint-plugin/hls-hlint-plugin.cabal b/plugins/hls-hlint-plugin/hls-hlint-plugin.cabal new file mode 100644 index 0000000000..92862a5758 --- /dev/null +++ b/plugins/hls-hlint-plugin/hls-hlint-plugin.cabal @@ -0,0 +1,71 @@ +cabal-version: 2.2 +name: hls-hlint-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.2 + , 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.2.20200916 + , ghc-lib-parser-ex ^>= 8.10 + + cpp-options: -DGHC_LIB + + ghc-options: -Wall -Wredundant-constraints -Wno-name-shadowing + + if flag(pedantic) + ghc-options: -Werror + + default-language: Haskell2010 diff --git a/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs b/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs new file mode 100644 index 0000000000..d500ccd765 --- /dev/null +++ b/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs @@ -0,0 +1,394 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PackageImports #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} + +module Ide.Plugin.Hlint + ( + descriptor + --, provider + ) where +import Refact.Apply +import Control.Arrow ((&&&)) +import Control.DeepSeq +import Control.Exception +import Control.Lens ((^.)) +import Control.Monad +import Control.Monad.IO.Class +import Control.Monad.Trans.Except +import Data.Aeson.Types (ToJSON(..), FromJSON(..), Value(..)) +import Data.Binary +import Data.Hashable +import qualified Data.HashMap.Strict as Map +import Data.Maybe +import qualified Data.Text as T +import qualified Data.Text.IO as T +import Data.Typeable +import Development.IDE +import Development.IDE.Core.Rules (defineNoFile) +import Development.IDE.Core.Shake (getDiagnostics) + +#ifdef GHC_LIB +import Data.List (nub) +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 Development.IDE.GHC.Compat hiding (DynFlags(..)) +#endif + +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.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) + +-- --------------------------------------------------------------------- + +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 + } + +-- This rule only exists for generating file diagnostics +-- so the RuleResult is empty +data GetHlintDiagnostics = GetHlintDiagnostics + deriving (Eq, Show, Typeable, Generic) +instance Hashable GetHlintDiagnostics +instance NFData GetHlintDiagnostics +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` 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 () +rules = do + define $ \GetHlintDiagnostics file -> do + hlintOn' <- hlintOn <$> getClientConfigAction + ideas <- if hlintOn' then getIdeas file else return (Right []) + return (diagnostics file ideas, Just ()) + + getHlintSettingsRule (HlintEnabled []) + + action $ do + files <- getFilesOfInterest + void $ uses GetHlintDiagnostics $ Map.keys files + + where + + 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 + -- 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 + , _relatedInformation = Nothing + , _tags = Nothing + } + 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 + srcSpanToRange (RealSrcSpan span) = Range { + _start = LSP.Position { + _line = srcSpanStartLine span - 1 + , _character = srcSpanStartCol span - 1} + , _end = LSP.Position { + _line = srcSpanEndLine span - 1 + , _character = srcSpanEndCol span - 1} + } + srcSpanToRange (UnhelpfulSpan _) = noRange + +getIdeas :: NormalizedFilePath -> Action (Either ParseError [Idea]) +getIdeas nfp = do + logm $ "hlint:getIdeas:file:" ++ show nfp + (flags, classify, hint) <- useNoFile_ GetHlintSettings + + 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)) +#ifdef GHC_LIB + moduleEx flags = do + 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 + let dflags = hsc_dflags hsc + let hscExts = EnumSet.toList (extensionFlags dflags) + let hscExts' = mapMaybe (GhclibParserEx.readExtension . show) hscExts + let hlintExts = nub $ enabledExtensions flags ++ hscExts' + logm $ "hlint:getIdeas:setExtensions:" ++ show hlintExts + return $ flags { enabledExtensions = hlintExts } +#else + moduleEx _flags = do + mbpm <- getParsedModule nfp + return $ createModule <$> mbpm + where createModule pm = Right (createModuleEx anns modu) + where anns = pm_annotations pm + modu = pm_parsed_source pm +#endif + +-- --------------------------------------------------------------------- + +data HlintUsage + = HlintEnabled { cmdArgs :: [String] } + | 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 NFData ParseFlags where rnf = rwhnf +instance Show Hint where show = const "" +instance Show ParseFlags where show = const "" +instance Binary GetHlintSettings + +type instance RuleResult GetHlintSettings = (ParseFlags, [Classify], Hint) + +getHlintSettingsRule :: HlintUsage -> Rules () +getHlintSettingsRule usage = + defineNoFile $ \GetHlintSettings -> + liftIO $ case usage of + HlintEnabled cmdArgs -> argsSettings cmdArgs + HlintDisabled -> fail "hlint configuration unspecified" + +-- --------------------------------------------------------------------- + +codeActionProvider :: CodeActionProvider +codeActionProvider _lf ideState plId docId _ context = Right . LSP.List . map CACodeAction <$> getCodeActions + where + + getCodeActions = do + applyOne <- applyOneActions + diags <- getDiagnostics ideState + let docNfp = toNormalizedFilePath' <$> uriToFilePath' (docId ^. LSP.uri) + numHintsInDoc = length + [d | (nfp, _, d) <- diags + , 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 > 1 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") _ _ _) = + "refact:" `T.isPrefixOf` code + validCommand _ = + False + + LSP.List diags = context ^. LSP.diagnostics + + mkHlintAction :: LSP.Diagnostic -> IO (Maybe LSP.CodeAction) + mkHlintAction diag@(LSP.Diagnostic (LSP.Range start _) _s (Just (LSP.StringValue code)) (Just "hlint") _ _ _) = + Just . codeAction <$> mkLspCommand plId "applyOne" title (Just args) + 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) + args = [toJSON (AOP (docId ^. LSP.uri) start ideaHint)] + mkHlintAction (LSP.Diagnostic _r _s _c _source _m _ _) = return Nothing + +-- --------------------------------------------------------------------- + +applyAllCmd :: CommandFunction Uri +applyAllCmd lf ide uri = do + let file = maybe (error $ show uri ++ " is not a file.") + toNormalizedFilePath' + (uriToFilePath' uri) + 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)) + +-- --------------------------------------------------------------------- + +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 = maybe (error $ show uri ++ " is not a file.") toNormalizedFilePath' + (uriToFilePath' uri) + let progTitle = "Applying hint: " <> title + 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 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 + -- of each refactoring it will apply. + -- But "Idea"s returned by HLint point to starting position of the expressions + -- that contain refactorings, so they are often outside the refactorings' boundaries. + -- Example: + -- Given an expression "hlintTest = reid $ (myid ())" + -- Hlint returns an idea at the position (1,13) + -- That contains "Redundant brackets" refactoring at position (1,20): + -- + -- [("src/App/Test.hs:5:13: Warning: Redundant bracket\nFound:\n reid $ (myid ())\nWhy not:\n reid $ myid ()\n",[Replace {rtype = Expr, pos = SrcSpan {startLine = 5, startCol = 20, endLine = 5, endCol = 29}, subts = [("x",SrcSpan {startLine = 5, startCol = 21, endLine = 5, endCol = 28})], orig = "x"}])] + -- + -- If we provide "applyRefactorings" with "Just (1,13)" then + -- the "Redundant bracket" hint will never be executed + -- because SrcSpan (1,20,??,??) doesn't contain position (1,13). + let 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 + (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' nfp) + let wsEdit = diffText' True (uri, oldContent) (T.pack appliedFile) IncludeDeletions + liftIO $ logm $ "hlint:applyHint:diff=" ++ show wsEdit + ExceptT $ return (Right wsEdit) + Left err -> + throwE (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 x) = error $ "No real source span: " ++ show x + + 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 #-} + +writeFileUTF8NoNewLineTranslation :: FilePath -> T.Text -> IO() +writeFileUTF8NoNewLineTranslation file txt = + withFile file WriteMode $ \h -> do + hSetEncoding h utf8 + hSetNewlineMode h noNewlineTranslation + hPutStr h (T.unpack txt) diff --git a/stack-8.10.1.yaml b/stack-8.10.1.yaml index f6815707a6..9190f33e18 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/hls-hlint-plugin ghc-options: "$everything": -haddock extra-deps: -- aeson-1.5.2.0 - github: bubba/brittany commit: c59655f10d5ad295c2481537fc8abf0a297d9d1c - Cabal-3.0.2.0 @@ -18,7 +18,14 @@ 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 +- hlint-3.2 - 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 +34,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 ed1dca90f4..bb9e482840 100644 --- a/stack-8.10.2.yaml +++ b/stack-8.10.2.yaml @@ -1,16 +1,16 @@ -resolver: nightly-2020-10-03 +resolver: nightly-2020-10-19 packages: - . - ./ghcide/ - ./hls-plugin-api - ./plugins/tactics +- ./plugins/hls-hlint-plugin ghc-options: "$everything": -haddock extra-deps: -- aeson-1.5.2.0 - github: bubba/brittany commit: c59655f10d5ad295c2481537fc8abf0a297d9d1c - Cabal-3.0.2.0 @@ -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 0af17fb039..48fdc7c13c 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/hls-hlint-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,20 +28,24 @@ extra-deps: - fuzzy-0.1.0.0 # - ghcide-0.1.0 - ghc-check-0.5.0.1 -- ghc-exactprint-0.6.2 -- ghc-lib-parser-8.10.1.20200523 -- ghc-lib-parser-ex-8.10.0.4 +- ghc-exactprint-0.6.3.2 +- 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 - 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.2 - 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 @@ -61,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 169e480bba..564919937e 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/hls-hlint-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,8 +27,9 @@ extra-deps: - fuzzy-0.1.0.0 # - ghcide-0.1.0 - ghc-check-0.5.0.1 -- ghc-exactprint-0.6.2 -- ghc-lib-parser-8.10.2.20200808 +- ghc-exactprint-0.6.3.2 +- 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 @@ -34,11 +37,14 @@ extra-deps: - haskell-lsp-0.22.0.0 - haskell-lsp-types-0.22.0.0 - hie-bios-0.7.1 +- 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 +- 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 @@ -60,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 190d2b720a..3e704d09b9 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/hls-hlint-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,19 +24,24 @@ extra-deps: - fourmolu-0.2.0.0 # - ghcide-0.1.0 - ghc-check-0.5.0.1 -- ghc-lib-parser-8.10.1.20200523 -- ghc-lib-parser-ex-8.10.0.4 +- ghc-exactprint-0.6.3.2 +- 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 - haskell-lsp-types-0.22.0.0 - haskell-src-exts-1.21.1 -- hlint-2.2.8 +- hie-bios-0.7.1 +- hlint-3.2 - hoogle-5.0.17.11 - hsimport-0.11.0 - 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 @@ -47,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 333a4d1d80..db32b01a1f 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/hls-hlint-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,13 +23,19 @@ extra-deps: - floskell-0.10.4 - 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 -- hlint-2.2.8 +- 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 - 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 @@ -38,9 +45,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 b530da8080..819c9f1680 100644 --- a/stack-8.8.4.yaml +++ b/stack-8.8.4.yaml @@ -1,21 +1,21 @@ -resolver: lts-16.16 +resolver: lts-16.19 packages: - . - ./ghcide/ - ./hls-plugin-api - ./plugins/tactics +- ./plugins/hls-hlint-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,13 +23,17 @@ 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 +- hlint-3.2 +- HsYAML-aeson-0.2.0.0@rev:2 - 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 @@ -38,9 +42,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 93a47a3472..89fd3d2f96 100644 --- a/stack.yaml +++ b/stack.yaml @@ -5,12 +5,14 @@ packages: - ./ghcide/ - ./hls-plugin-api - ./plugins/tactics +- ./plugins/hls-hlint-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,8 @@ 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.2.20200808 - ghc-lib-parser-8.10.2.20200808 - ghc-lib-parser-ex-8.10.0.16 - ghc-source-gen-0.4.0.0 @@ -34,11 +37,14 @@ extra-deps: - haskell-lsp-0.22.0.0 - haskell-lsp-types-0.22.0.0 - hie-bios-0.7.1 +- 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 +- 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 @@ -60,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: diff --git a/test/functional/FunctionalCodeAction.hs b/test/functional/FunctionalCodeAction.hs index 02c3b6f7be..ce1fb9bd04 100644 --- a/test/functional/FunctionalCodeAction.hs +++ b/test/functional/FunctionalCodeAction.hs @@ -44,72 +44,85 @@ 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 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 + 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" - (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 + let redEta = find (\ca -> "Eta reduce" `T.isSuffixOf` (ca ^. L.title)) cas - -- Evaluate became redundant id in later hlint versions - liftIO $ (ca ^. L.title) `elem` ["Apply hint:Redundant id", "Apply hint:Evaluate"] @? "Title contains evaluate" + 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 ca + executeCodeAction (fromJust redId) contents <- getDocumentEdit doc liftIO $ contents @?= "main = undefined\nfoo x = x\n" - 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/hlint" $ do doc <- openDoc "ApplyRefact2.hs" "haskell" - _ <- waitForDiagnostics + _ <- waitForDiagnosticsSource "hlint" (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" - executeCommand cmd contents <- skipManyTill publishDiagnosticsNotification $ getDocumentEdit doc - liftIO $ contents @?= "main = undefined\nfoo x = x\n" - - noDiagnostics + liftIO $ contents `elem` ["main = undefined\nfoo = id\n", "main = undefined\nfoo x = x\n"] @? "Command is applied" - , ignoreTestBecause "Broken" $ testCase "runs diagnostics on save" $ runSession hlsCommand fullCaps "test/testdata" $ do - let config = def { diagnosticsOnChange = False } + , 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)) + _ <- openDoc "ApplyRefact2.hs" "haskell" + diags <- waitForDiagnosticsSource "hlint" + + liftIO $ length diags > 0 @? "There are hlint diagnostics" + + let config' = def { hlintOn = False } + sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (toJSON config')) + + diags' <- waitForDiagnostics + + 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@(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 -- "Eta Reduce" and "Redundant Id" - (CACodeAction ca:_) <- getAllCodeActions doc + let change = TextDocumentContentChangeEvent + (Just (Range (Position 1 8) (Position 1 12))) + Nothing "x" - -- Evaluate became redundant id in later hlint versions - liftIO $ (ca ^. L.title) `elem` ["Apply hint:Redundant id", "Apply hint:Evaluate"] @? "Title contains evaluate" + changeDoc doc [change] - executeCodeAction ca + diags' <- waitForDiagnostics - contents <- getDocumentEdit doc - liftIO $ contents @?= "main = undefined\nfoo x = x\n" - sendNotification TextDocumentDidSave (DidSaveTextDocumentParams doc) + 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'] - noDiagnostics + diags'' <- waitForDiagnosticsSource "hlint" + + liftIO $ length diags'' @?= 2 ] renameTests :: TestTree @@ -294,31 +307,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 @@ -336,30 +349,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/testdata/ApplyRefact.hs b/test/testdata/ApplyRefact.hs deleted file mode 100644 index 984656fbcc..0000000000 --- a/test/testdata/ApplyRefact.hs +++ /dev/null @@ -1,4 +0,0 @@ - -main = (putStrLn "hello") - -foo x = (x + 1) 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 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" 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 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"