diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,201 +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. + 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/hls-hlint-plugin.cabal b/hls-hlint-plugin.cabal --- a/hls-hlint-plugin.cabal +++ b/hls-hlint-plugin.cabal @@ -1,79 +1,103 @@ -cabal-version: 2.2 -name: hls-hlint-plugin -version: 1.0.0.2 -synopsis: Hlint integration plugin with Haskell Language Server -description: - Please see Haskell Language Server Readme (https://github.com/haskell/haskell-language-server#readme) - -license: Apache-2.0 -license-file: LICENSE -author: The Haskell IDE Team -maintainer: alan.zimm@gmail.com -copyright: The Haskell IDE Team -category: Development -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 >=0.9 - , base >=4.12 && <5 - , binary - , bytestring - , containers - , data-default - , deepseq - , Diff ^>=0.4.0 - , directory - , extra - , filepath - , ghc-exactprint >=0.6.3.4 - , ghcide ^>=1.2 - , hashable - , hlint ^>=3.2 - , hls-plugin-api ^>=1.1 - , hslogger - , lens - , lsp - , regex-tdfa - , shake - , temporary - , text - , transformers - , unordered-containers - - if ((!flag(ghc-lib) && impl(ghc >=8.10.1)) && impl(ghc <9.0.0)) - build-depends: ghc ^>=8.10 - - else - build-depends: - , ghc - , ghc-lib ^>=8.10.4.20210206 - , ghc-lib-parser-ex ^>=8.10 - - cpp-options: -DHLINT_ON_GHC_LIB - - ghc-options: - -Wall -Wredundant-constraints -Wno-name-shadowing - -Wno-unticked-promoted-constructors - - if flag(pedantic) - ghc-options: -Werror - - default-language: Haskell2010 - default-extensions: - DataKinds - TypeOperators +cabal-version: 2.2 +name: hls-hlint-plugin +version: 1.0.1.0 +synopsis: Hlint integration plugin with Haskell Language Server +description: + Please see Haskell Language Server Readme (https://github.com/haskell/haskell-language-server#readme) + +license: Apache-2.0 +license-file: LICENSE +author: The Haskell IDE Team +maintainer: alan.zimm@gmail.com +copyright: The Haskell IDE Team +category: Development +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 + +flag hlint33 + default: True + manual: False + description: + Hlint-3.3 doesn't support versions ghc-lib < 9.0.1 nor ghc <= 8.6, so we can use hlint-3.2 for backwards compat + This flag can be removed when all dependencies support ghc-lib-9.0.1 and we drop support for ghc-8.6 + +library + exposed-modules: Ide.Plugin.Hlint + hs-source-dirs: src + build-depends: + , aeson + , apply-refact >=0.9.3.0 + , base >=4.12 && <5 + , binary + , bytestring + , containers + , data-default + , deepseq + , Diff ^>=0.4.0 + , directory + , extra + , filepath + , ghc-exactprint >=0.6.3.4 + , ghcide ^>=1.4 + , hashable + , hlint + , hls-plugin-api ^>=1.1 + , hslogger + , lens + , lsp + , regex-tdfa + , temporary + , text + , transformers + , unordered-containers + + if (flag(hlint33)) + -- This mirrors the logic in hlint.cabal for hlint-3.3 + -- https://github.com/ndmitchell/hlint/blob/d3576de4529d8df6cca5a345f5b7e04474ff7bff/hlint.cabal#L79-L88 + -- so we can make sure that we do the same thing as hlint + build-depends: hlint ^>=3.3 + if (!flag(ghc-lib) && impl(ghc >=9.0.1) && impl(ghc <9.1.0)) + build-depends: ghc ==9.0.* + else + build-depends: + , ghc + , ghc-lib == 9.0.* + , ghc-lib-parser-ex == 9.0.* + + cpp-options: -DHLINT_ON_GHC_LIB + + else + -- This mirrors the logic in hlint.cabal for hlint-3.2 + -- https://github.com/ndmitchell/hlint/blob/c7354e473c7d09213c8adc3dc94bf50a6eb4a42d/hlint.cabal#L79-L88 + build-depends: hlint ^>=3.2 + if (!flag(ghc-lib) && impl(ghc >=8.10.1) && impl(ghc < 8.11.0)) + build-depends: ghc >=8.10 && < 9.0 + else + build-depends: + , ghc + , ghc-lib ^>= 8.10.4.20210206 + , ghc-lib-parser-ex ^>= 8.10 + + cpp-options: -DHLINT_ON_GHC_LIB + + ghc-options: + -Wall -Wredundant-constraints -Wno-name-shadowing + -Wno-unticked-promoted-constructors + + if flag(pedantic) + ghc-options: -Werror + + default-language: Haskell2010 + default-extensions: + DataKinds + TypeOperators diff --git a/src/Ide/Plugin/Hlint.hs b/src/Ide/Plugin/Hlint.hs --- a/src/Ide/Plugin/Hlint.hs +++ b/src/Ide/Plugin/Hlint.hs @@ -1,459 +1,494 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PackageImports #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# OPTIONS_GHC -Wno-orphans #-} - -module Ide.Plugin.Hlint - ( - descriptor - --, provider - ) where -import Control.Arrow ((&&&)) -import Control.DeepSeq -import Control.Exception -import Control.Lens ((^.)) -import Control.Monad -import Control.Monad.IO.Class -import Control.Monad.Trans.Except -import Data.Aeson.Types (FromJSON (..), - ToJSON (..), - Value (..)) -import Data.Binary -import Data.Default -import qualified Data.HashMap.Strict as Map -import Data.Hashable -import Data.Maybe -import qualified Data.Text as T -import qualified Data.Text.IO as T -import Data.Typeable -import Development.IDE -import Development.IDE.Core.Rules (defineNoFile, - getParsedModuleWithComments) -import Development.IDE.Core.Shake (getDiagnostics) -import Refact.Apply - -#ifdef HLINT_ON_GHC_LIB -import Data.List (nub) -import "ghc" DynFlags as RealGHC.DynFlags (topDir) -import qualified "ghc" EnumSet as EnumSet -import "ghc" GHC as RealGHC (DynFlags (..)) -import "ghc-lib" GHC hiding - (DynFlags (..), - ms_hspp_opts) -import "ghc-lib-parser" GHC.LanguageExtensions (Extension) -import "ghc" HscTypes as RealGHC.HscTypes (hsc_dflags, - ms_hspp_opts) -import Language.Haskell.GhclibParserEx.GHC.Driver.Session as GhclibParserEx (readExtension) -import System.FilePath (takeFileName) -import System.IO (IOMode (WriteMode), - hClose, - hPutStr, - hSetEncoding, - hSetNewlineMode, - noNewlineTranslation, - utf8, - withFile) -import System.IO.Temp -#else -import Development.IDE.GHC.Compat hiding - (DynFlags (..)) -import Language.Haskell.GHC.ExactPrint.Delta (deltaOptions) -import Language.Haskell.GHC.ExactPrint.Parsers (postParseTransform) -import Language.Haskell.GHC.ExactPrint.Types (Rigidity (..)) -#endif - -import Ide.Logger -import Ide.Plugin.Config -import Ide.PluginUtils -import Ide.Types -import Language.Haskell.HLint as Hlint -import Language.LSP.Server (ProgressCancellable (Cancellable), - sendRequest, - withIndefiniteProgress) -import Language.LSP.Types -import qualified Language.LSP.Types as LSP -import qualified Language.LSP.Types.Lens as LSP - -import GHC.Generics (Generic) -import Text.Regex.TDFA.Text () - -import System.Environment (setEnv, - unsetEnv) --- --------------------------------------------------------------------- - -descriptor :: PluginId -> PluginDescriptor IdeState -descriptor plId = (defaultPluginDescriptor plId) - { pluginRules = rules plId - , pluginCommands = - [ PluginCommand "applyOne" "Apply a single hint" applyOneCmd - , PluginCommand "applyAll" "Apply all hints to the file" applyAllCmd - ] - , pluginHandlers = mkPluginHandler STextDocumentCodeAction 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 :: PluginId -> Rules () -rules plugin = do - define $ \GetHlintDiagnostics file -> do - config <- getClientConfigAction def - let pluginConfig = configForPlugin config plugin - let hlintOn' = hlintOn config && plcGlobalOn pluginConfig && plcDiagnosticsOn pluginConfig - ideas <- if hlintOn' then getIdeas file else return (Right []) - 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 (InR $ T.pack $ codePre ++ ideaHint idea) - , _source = Just "hlint" - , _message = idea2Message idea - , _relatedInformation = Nothing - , _tags = Nothing - } - where codePre = if null $ ideaRefactoring idea then "" else "refact:" - - 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] - - - parseErrorToDiagnostic :: ParseError -> Diagnostic - parseErrorToDiagnostic (Hlint.ParseError l msg contents) = - LSP.Diagnostic { - _range = srcSpanToRange l - , _severity = Just LSP.DsInfo - , _code = Just (InR "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 - debugm $ "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)) -#ifndef HLINT_ON_GHC_LIB - 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 -#else - 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 - hlintExts <- getExtensions flags nfp - debugm $ "hlint:getIdeas:setExtensions:" ++ show hlintExts - return $ flags { enabledExtensions = hlintExts } - -getExtensions :: ParseFlags -> NormalizedFilePath -> Action [Extension] -getExtensions pflags nfp = do - dflags <- getFlags - let hscExts = EnumSet.toList (extensionFlags dflags) - let hscExts' = mapMaybe (GhclibParserEx.readExtension . show) hscExts - let hlintExts = nub $ enabledExtensions pflags ++ hscExts' - return hlintExts - where getFlags :: Action DynFlags - getFlags = do - modsum <- use_ GetModSummary nfp - return $ ms_hspp_opts $ msrModSummary modsum -#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 :: PluginMethodHandler IdeState TextDocumentCodeAction -codeActionProvider ideState plId (CodeActionParams _ _ docId _ context) = Right . LSP.List . map InR <$> liftIO getCodeActions - where - - getCodeActions = do - 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 - pure $ applyAllAction:applyOneActions - else - pure applyOneActions - - applyAllAction = - let args = Just [toJSON (docId ^. LSP.uri)] - cmd = mkLspCommand plId "applyAll" "Apply all hints" args - in LSP.CodeAction "Apply all hints" (Just LSP.CodeActionQuickFix) Nothing Nothing Nothing Nothing (Just cmd) Nothing - - applyOneActions :: [LSP.CodeAction] - applyOneActions = mapMaybe mkHlintAction (filter validCommand diags) - - -- |Some hints do not have an associated refactoring - validCommand (LSP.Diagnostic _ _ (Just (InR code)) (Just "hlint") _ _ _) = - "refact:" `T.isPrefixOf` code - validCommand _ = - False - - LSP.List diags = context ^. LSP.diagnostics - - mkHlintAction :: LSP.Diagnostic -> Maybe LSP.CodeAction - mkHlintAction diag@(LSP.Diagnostic (LSP.Range start _) _s (Just (InR code)) (Just "hlint") _ _ _) = - Just . codeAction $ mkLspCommand plId "applyOne" title (Just args) - where - codeAction cmd = LSP.CodeAction title (Just LSP.CodeActionQuickFix) (Just (LSP.List [diag])) Nothing Nothing Nothing (Just cmd) Nothing - -- we have to recover the original ideaHint removing the prefix - ideaHint = T.replace "refact:" "" code - title = "Apply hint: " <> ideaHint - -- need 'file', 'start_pos' and hint title (to distinguish between alternative suggestions at the same location) - args = [toJSON (AOP (docId ^. LSP.uri) start ideaHint)] - mkHlintAction (LSP.Diagnostic _r _s _c _source _m _ _) = Nothing - --- --------------------------------------------------------------------- - -applyAllCmd :: CommandFunction IdeState Uri -applyAllCmd ide uri = do - let file = maybe (error $ show uri ++ " is not a file.") - toNormalizedFilePath' - (uriToFilePath' uri) - withIndefiniteProgress "Applying all hints" Cancellable $ do - logm $ "hlint:applyAllCmd:file=" ++ show file - res <- liftIO $ applyHint ide file Nothing - logm $ "hlint:applyAllCmd:res=" ++ show res - case res of - Left err -> pure $ Left (responseError (T.pack $ "hlint:applyAll: " ++ show err)) - Right fs -> do - _ <- sendRequest SWorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing fs) (\_ -> pure ()) - pure $ Right Null - --- --------------------------------------------------------------------- - -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 IdeState ApplyOneParams -applyOneCmd ide (AOP uri pos title) = do - let oneHint = OneHint pos title - let file = maybe (error $ show uri ++ " is not a file.") toNormalizedFilePath' - (uriToFilePath' uri) - let progTitle = "Applying hint: " <> title - withIndefiniteProgress progTitle Cancellable $ do - logm $ "hlint:applyOneCmd:file=" ++ show file - res <- liftIO $ applyHint ide file (Just oneHint) - logm $ "hlint:applyOneCmd:res=" ++ show res - case res of - Left err -> pure $ Left (responseError (T.pack $ "hlint:applyOne: " ++ show err)) - Right fs -> do - _ <- sendRequest SWorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing fs) (\_ -> pure ()) - pure $ Right Null - -applyHint :: IdeState -> NormalizedFilePath -> Maybe OneHint -> IO (Either String WorkspaceEdit) -applyHint ide nfp mhint = - runExceptT $ do - let runAction' :: Action a -> IO a - runAction' = runAction "applyHint" ide - let errorHandlers = [ Handler $ \e -> return (Left (show (e :: IOException))) - , Handler $ \e -> return (Left (show (e :: ErrorCall))) - ] - ideas <- bimapExceptT showParseError id $ ExceptT $ runAction' $ getIdeas nfp - let ideas' = maybe ideas (`filterIdeas` ideas) mhint - let commands = map ideaRefactoring ideas' - liftIO $ logm $ "applyHint:apply=" ++ show commands - let fp = fromNormalizedFilePath nfp - (_, mbOldContent) <- liftIO $ runAction' $ getFileContents nfp - oldContent <- maybe (liftIO $ T.readFile fp) return mbOldContent - modsum <- liftIO $ runAction' $ use_ GetModSummary nfp - let dflags = ms_hspp_opts $ msrModSummary modsum - -- Setting a environment variable with the libdir used by ghc-exactprint. - -- It is a workaround for an error caused by the use of a hadcoded at compile time libdir - -- in ghc-exactprint that makes dependent executables non portables. - -- See https://github.com/alanz/ghc-exactprint/issues/96. - -- WARNING: this code is not thread safe, so if you try to apply several async refactorings - -- it could fail. That case is not very likely so we assume the risk. - let withRuntimeLibdir :: IO a -> IO a - withRuntimeLibdir = bracket_ (setEnv key $ topDir dflags) (unsetEnv key) - where key = "GHC_EXACTPRINT_GHC_LIBDIR" - -- set Nothing as "position" for "applyRefactorings" because - -- applyRefactorings expects the provided position to be _within_ the scope - -- of each refactoring it will apply. - -- But "Idea"s returned by HLint point to starting position of the expressions - -- that contain refactorings, so they are often outside the refactorings' boundaries. - let position = Nothing -#ifdef HLINT_ON_GHC_LIB - let writeFileUTF8NoNewLineTranslation file txt = - withFile file WriteMode $ \h -> do - hSetEncoding h utf8 - hSetNewlineMode h noNewlineTranslation - hPutStr h (T.unpack txt) - res <- - liftIO $ withSystemTempFile (takeFileName fp) $ \temp h -> do - hClose h - writeFileUTF8NoNewLineTranslation temp oldContent - (pflags, _, _) <- runAction' $ useNoFile_ GetHlintSettings - exts <- runAction' $ getExtensions pflags nfp - -- We have to reparse extensions to remove the invalid ones - let (enabled, disabled, _invalid) = parseExtensions $ map show exts - let refactExts = map show $ enabled ++ disabled - (Right <$> withRuntimeLibdir (applyRefactorings position commands temp refactExts)) - `catches` errorHandlers -#else - mbParsedModule <- liftIO $ runAction' $ getParsedModuleWithComments nfp - res <- - case mbParsedModule of - Nothing -> throwE "Apply hint: error parsing the module" - Just pm -> do - let anns = pm_annotations pm - let modu = pm_parsed_source pm - -- apply-refact uses RigidLayout - let rigidLayout = deltaOptions RigidLayout - (anns', modu') <- - ExceptT $ return $ postParseTransform (Right (anns, [], dflags, modu)) rigidLayout - liftIO $ (Right <$> withRuntimeLibdir (applyRefactorings' position commands anns' modu')) - `catches` errorHandlers -#endif - 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 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 #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PackageImports #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +#ifdef HLINT_ON_GHC_LIB +#define MIN_GHC_API_VERSION(x,y,z) MIN_VERSION_ghc_lib(x,y,z) +#else +#define MIN_GHC_API_VERSION(x,y,z) MIN_VERSION_ghc(x,y,z) +#endif + +module Ide.Plugin.Hlint + ( + descriptor + --, provider + ) where +import Control.Arrow ((&&&)) +import Control.DeepSeq +import Control.Exception +import Control.Lens ((^.)) +import Control.Monad +import Control.Monad.IO.Class +import Control.Monad.Trans.Except +import Data.Aeson.Types (FromJSON (..), + ToJSON (..), + Value (..)) +import Data.Binary +import Data.Default +import qualified Data.HashMap.Strict as Map +import Data.Hashable +import Data.Maybe +import qualified Data.Text as T +import qualified Data.Text.IO as T +import Data.Typeable +import Development.IDE hiding + (Error) +import Development.IDE.Core.Rules (defineNoFile, + getParsedModuleWithComments, + usePropertyAction) +import Development.IDE.Core.Shake (getDiagnostics) +import Refact.Apply + +#ifdef HLINT_ON_GHC_LIB +import Data.List (nub) +import "ghc" DynFlags as RealGHC.DynFlags (topDir) +import qualified "ghc" EnumSet as EnumSet +import "ghc" GHC as RealGHC (DynFlags (..)) +import "ghc-lib" GHC hiding + (DynFlags (..), + ms_hspp_opts) +import "ghc-lib-parser" GHC.LanguageExtensions (Extension) +import "ghc" HscTypes as RealGHC.HscTypes (hsc_dflags, + ms_hspp_opts) +import Language.Haskell.GhclibParserEx.GHC.Driver.Session as GhclibParserEx (readExtension) +import System.FilePath (takeFileName) +import System.IO (IOMode (WriteMode), + hClose, + hPutStr, + hSetEncoding, + hSetNewlineMode, + noNewlineTranslation, + utf8, + withFile) +import System.IO.Temp +#else +import Development.IDE.GHC.Compat hiding + (DynFlags (..), + OldRealSrcSpan) +import Language.Haskell.GHC.ExactPrint.Delta (deltaOptions) +import Language.Haskell.GHC.ExactPrint.Parsers (postParseTransform) +import Language.Haskell.GHC.ExactPrint.Types (Rigidity (..)) +#endif + +import Ide.Logger +import Ide.Plugin.Config hiding + (Config) +import Ide.Plugin.Properties +import Ide.PluginUtils +import Ide.Types +import Language.Haskell.HLint as Hlint hiding + (Error) +import Language.LSP.Server (ProgressCancellable (Cancellable), + sendRequest, + withIndefiniteProgress) +import Language.LSP.Types +import qualified Language.LSP.Types as LSP +import qualified Language.LSP.Types.Lens as LSP + +import GHC.Generics (Generic) +import Text.Regex.TDFA.Text () + +import System.Environment (setEnv, + unsetEnv) +-- --------------------------------------------------------------------- + +-- Reimplementing this, since the one in Development.IDE.GHC.Compat isn't for ghc-lib +pattern OldRealSrcSpan :: RealSrcSpan -> SrcSpan +#if MIN_GHC_API_VERSION(9,0,0) +pattern OldRealSrcSpan span <- RealSrcSpan span _ +#else +pattern OldRealSrcSpan span <- RealSrcSpan span +#endif +{-# COMPLETE OldRealSrcSpan, UnhelpfulSpan #-} + +descriptor :: PluginId -> PluginDescriptor IdeState +descriptor plId = (defaultPluginDescriptor plId) + { pluginRules = rules plId + , pluginCommands = + [ PluginCommand "applyOne" "Apply a single hint" applyOneCmd + , PluginCommand "applyAll" "Apply all hints to the file" applyAllCmd + ] + , pluginHandlers = mkPluginHandler STextDocumentCodeAction codeActionProvider + , pluginConfigDescriptor = defaultConfigDescriptor + { configHasDiagnostics = True + , configCustomConfig = mkCustomConfig properties + } + } + +-- 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: +-- | - A file 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 :: PluginId -> Rules () +rules plugin = do + define $ \GetHlintDiagnostics file -> do + config <- getClientConfigAction def + let pluginConfig = configForPlugin config plugin + let hlintOn' = hlintOn config && plcGlobalOn pluginConfig && plcDiagnosticsOn pluginConfig + ideas <- if hlintOn' then getIdeas file else return (Right []) + return (diagnostics file ideas, Just ()) + + defineNoFile $ \GetHlintSettings -> do + (Config flags) <- getHlintConfig plugin + liftIO $ argsSettings flags + + action $ do + files <- getFilesOfInterestUntracked + 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 (InR $ T.pack $ codePre ++ ideaHint idea) + , _source = Just "hlint" + , _message = idea2Message idea + , _relatedInformation = Nothing + , _tags = Nothing + } + where codePre = if null $ ideaRefactoring idea then "" else "refact:" + + 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] + + + parseErrorToDiagnostic :: ParseError -> Diagnostic + parseErrorToDiagnostic (Hlint.ParseError l msg contents) = + LSP.Diagnostic { + _range = srcSpanToRange l + , _severity = Just LSP.DsInfo + , _code = Just (InR "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 (OldRealSrcSpan 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 + debugm $ "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)) +#ifndef HLINT_ON_GHC_LIB + 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 +#else + 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 + hlintExts <- getExtensions flags nfp + debugm $ "hlint:getIdeas:setExtensions:" ++ show hlintExts + return $ flags { enabledExtensions = hlintExts } + +getExtensions :: ParseFlags -> NormalizedFilePath -> Action [Extension] +getExtensions pflags nfp = do + dflags <- getFlags + let hscExts = EnumSet.toList (extensionFlags dflags) + let hscExts' = mapMaybe (GhclibParserEx.readExtension . show) hscExts + let hlintExts = nub $ enabledExtensions pflags ++ hscExts' + return hlintExts + where getFlags :: Action DynFlags + getFlags = do + modsum <- use_ GetModSummary nfp + return $ ms_hspp_opts $ msrModSummary modsum +#endif + +-- --------------------------------------------------------------------- + +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) + +-- --------------------------------------------------------------------- + +newtype Config = Config [String] + +properties :: Properties '[ 'PropertyKey "flags" ('TArray String)] +properties = emptyProperties + & defineArrayProperty #flags + "Flags used by hlint" [] + +-- | Get the plugin config +getHlintConfig :: PluginId -> Action Config +getHlintConfig pId = + Config + <$> usePropertyAction #flags pId properties + +-- --------------------------------------------------------------------- +codeActionProvider :: PluginMethodHandler IdeState TextDocumentCodeAction +codeActionProvider ideState plId (CodeActionParams _ _ docId _ context) = Right . LSP.List . map InR <$> liftIO getCodeActions + where + + getCodeActions = do + allDiags <- getDiagnostics ideState + let docNfp = toNormalizedFilePath' <$> uriToFilePath' (docId ^. LSP.uri) + numHintsInDoc = length + [d | (nfp, _, d) <- allDiags + , validCommand d + , Just nfp == docNfp + ] + numHintsInContext = length + [d | d <- diags + , validCommand d + ] + -- We only want to show the applyAll code action if there is more than 1 + -- hint in the current document and if code action range contains at + -- least one hint + if numHintsInDoc > 1 && numHintsInContext > 0 then do + pure $ applyAllAction:applyOneActions + else + pure applyOneActions + + applyAllAction = + let args = Just [toJSON (docId ^. LSP.uri)] + cmd = mkLspCommand plId "applyAll" "Apply all hints" args + in LSP.CodeAction "Apply all hints" (Just LSP.CodeActionQuickFix) Nothing Nothing Nothing Nothing (Just cmd) Nothing + + applyOneActions :: [LSP.CodeAction] + applyOneActions = mapMaybe mkHlintAction (filter validCommand diags) + + -- |Some hints do not have an associated refactoring + validCommand (LSP.Diagnostic _ _ (Just (InR code)) (Just "hlint") _ _ _) = + "refact:" `T.isPrefixOf` code + validCommand _ = + False + + LSP.List diags = context ^. LSP.diagnostics + + mkHlintAction :: LSP.Diagnostic -> Maybe LSP.CodeAction + mkHlintAction diag@(LSP.Diagnostic (LSP.Range start _) _s (Just (InR code)) (Just "hlint") _ _ _) = + Just . codeAction $ mkLspCommand plId "applyOne" title (Just args) + where + codeAction cmd = LSP.CodeAction title (Just LSP.CodeActionQuickFix) (Just (LSP.List [diag])) Nothing Nothing Nothing (Just cmd) Nothing + -- we have to recover the original ideaHint removing the prefix + ideaHint = T.replace "refact:" "" code + title = "Apply hint: " <> ideaHint + -- need 'file', 'start_pos' and hint title (to distinguish between alternative suggestions at the same location) + args = [toJSON (AOP (docId ^. LSP.uri) start ideaHint)] + mkHlintAction (LSP.Diagnostic _r _s _c _source _m _ _) = Nothing + +-- --------------------------------------------------------------------- + +applyAllCmd :: CommandFunction IdeState Uri +applyAllCmd ide uri = do + let file = maybe (error $ show uri ++ " is not a file.") + toNormalizedFilePath' + (uriToFilePath' uri) + withIndefiniteProgress "Applying all hints" Cancellable $ do + logm $ "hlint:applyAllCmd:file=" ++ show file + res <- liftIO $ applyHint ide file Nothing + logm $ "hlint:applyAllCmd:res=" ++ show res + case res of + Left err -> pure $ Left (responseError (T.pack $ "hlint:applyAll: " ++ show err)) + Right fs -> do + _ <- sendRequest SWorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing fs) (\_ -> pure ()) + pure $ Right Null + +-- --------------------------------------------------------------------- + +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 IdeState ApplyOneParams +applyOneCmd ide (AOP uri pos title) = do + let oneHint = OneHint pos title + let file = maybe (error $ show uri ++ " is not a file.") toNormalizedFilePath' + (uriToFilePath' uri) + let progTitle = "Applying hint: " <> title + withIndefiniteProgress progTitle Cancellable $ do + logm $ "hlint:applyOneCmd:file=" ++ show file + res <- liftIO $ applyHint ide file (Just oneHint) + logm $ "hlint:applyOneCmd:res=" ++ show res + case res of + Left err -> pure $ Left (responseError (T.pack $ "hlint:applyOne: " ++ show err)) + Right fs -> do + _ <- sendRequest SWorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing fs) (\_ -> pure ()) + pure $ Right Null + +applyHint :: IdeState -> NormalizedFilePath -> Maybe OneHint -> IO (Either String WorkspaceEdit) +applyHint ide nfp mhint = + runExceptT $ do + let runAction' :: Action a -> IO a + runAction' = runAction "applyHint" ide + let errorHandlers = [ Handler $ \e -> return (Left (show (e :: IOException))) + , Handler $ \e -> return (Left (show (e :: ErrorCall))) + ] + ideas <- bimapExceptT showParseError id $ ExceptT $ runAction' $ getIdeas nfp + let ideas' = maybe ideas (`filterIdeas` ideas) mhint + let commands = map ideaRefactoring ideas' + liftIO $ logm $ "applyHint:apply=" ++ show commands + let fp = fromNormalizedFilePath nfp + (_, mbOldContent) <- liftIO $ runAction' $ getFileContents nfp + oldContent <- maybe (liftIO $ T.readFile fp) return mbOldContent + modsum <- liftIO $ runAction' $ use_ GetModSummary nfp + let dflags = ms_hspp_opts $ msrModSummary modsum + -- Setting a environment variable with the libdir used by ghc-exactprint. + -- It is a workaround for an error caused by the use of a hadcoded at compile time libdir + -- in ghc-exactprint that makes dependent executables non portables. + -- See https://github.com/alanz/ghc-exactprint/issues/96. + -- WARNING: this code is not thread safe, so if you try to apply several async refactorings + -- it could fail. That case is not very likely so we assume the risk. + let withRuntimeLibdir :: IO a -> IO a + withRuntimeLibdir = bracket_ (setEnv key $ topDir dflags) (unsetEnv key) + where key = "GHC_EXACTPRINT_GHC_LIBDIR" + -- set Nothing as "position" for "applyRefactorings" because + -- applyRefactorings expects the provided position to be _within_ the scope + -- of each refactoring it will apply. + -- But "Idea"s returned by HLint point to starting position of the expressions + -- that contain refactorings, so they are often outside the refactorings' boundaries. + let position = Nothing +#ifdef HLINT_ON_GHC_LIB + let writeFileUTF8NoNewLineTranslation file txt = + withFile file WriteMode $ \h -> do + hSetEncoding h utf8 + hSetNewlineMode h noNewlineTranslation + hPutStr h (T.unpack txt) + res <- + liftIO $ withSystemTempFile (takeFileName fp) $ \temp h -> do + hClose h + writeFileUTF8NoNewLineTranslation temp oldContent + (pflags, _, _) <- runAction' $ useNoFile_ GetHlintSettings + exts <- runAction' $ getExtensions pflags nfp + -- We have to reparse extensions to remove the invalid ones + let (enabled, disabled, _invalid) = parseExtensions $ map show exts + let refactExts = map show $ enabled ++ disabled + (Right <$> withRuntimeLibdir (applyRefactorings position commands temp refactExts)) + `catches` errorHandlers +#else + mbParsedModule <- liftIO $ runAction' $ getParsedModuleWithComments nfp + res <- + case mbParsedModule of + Nothing -> throwE "Apply hint: error parsing the module" + Just pm -> do + let anns = pm_annotations pm + let modu = pm_parsed_source pm + -- apply-refact uses RigidLayout + let rigidLayout = deltaOptions RigidLayout + (anns', modu') <- + ExceptT $ return $ postParseTransform (Right (anns, [], dflags, modu)) rigidLayout + liftIO $ (Right <$> withRuntimeLibdir (applyRefactorings' position commands anns' modu')) + `catches` errorHandlers +#endif + 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 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 (OldRealSrcSpan 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 #-}