hls-hlint-plugin 1.0.0.2 → 1.0.1.0
raw patch · 3 files changed
+798/−739 lines, 3 filesdep −shakedep ~apply-refactdep ~ghcdep ~ghc-libnew-uploaderPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
Dependencies removed: shake
Dependency ranges changed: apply-refact, ghc, ghc-lib, ghc-lib-parser-ex, ghcide, hlint
API changes (from Hackage documentation)
- Ide.Plugin.Hlint: instance GHC.Show.Show Ide.Plugin.Hlint.HlintUsage
Files
- LICENSE +201/−201
- hls-hlint-plugin.cabal +103/−79
- src/Ide/Plugin/Hlint.hs +494/−459
LICENSE view
@@ -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.
hls-hlint-plugin.cabal view
@@ -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
src/Ide/Plugin/Hlint.hs view
@@ -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 "<hint>" -instance Show ParseFlags where show = const "<parseFlags>" -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 "<hint>"+instance Show ParseFlags where show = const "<parseFlags>"+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 #-}