hls-plugin-api 0.5.0.0 → 0.5.0.1
raw patch · 9 files changed
+1504/−1493 lines, 9 filesPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
API changes (from Hackage documentation)
- Ide.Types: type FormattingProvider m = LspFuncs Config -> IdeState -> FormattingType " How much to format
" -> Text " Text to format
" -> NormalizedFilePath " location of the file being formatted
" -> FormattingOptions " Options for the formatter
" -> m (Either ResponseError (List TextEdit)) " Result of the formatting
"
+ Ide.Types: type FormattingProvider m = LspFuncs Config -> IdeState -> FormattingType " How much to format" -> Text " Text to format" -> NormalizedFilePath " location of the file being formatted" -> FormattingOptions " Options for the formatter" -> m (Either ResponseError (List TextEdit)) " Result of the formatting"
Files
- LICENSE +201/−201
- hls-plugin-api.cabal +61/−61
- src/Ide/Logger.hs +43/−43
- src/Ide/Plugin.hs +603/−604
- src/Ide/Plugin/Config.hs +107/−107
- src/Ide/Plugin/Formatter.hs +110/−98
- src/Ide/Plugin/GhcIde.hs +65/−65
- src/Ide/PluginUtils.hs +110/−110
- src/Ide/Types.hs +204/−204
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-plugin-api.cabal view
@@ -1,61 +1,61 @@-cabal-version: 2.2 -name: hls-plugin-api -version: 0.5.0.0 -synopsis: Haskell Language Server API for plugin communication -description: - Please see the README on GitHub at <https://github.com/haskell/haskell-language-server#readme> -homepage: https://github.com/haskell/haskell-language-server/hls-plugin-api -bug-reports: https://github.com/haskell/haskell-language-server/issues -license: Apache-2.0 -license-file: LICENSE -author: Many,TBD when we release -maintainer: alan.zimm@gmail.com (for now) -copyright: Alan Zimmerman -category: Web -build-type: Simple - -flag pedantic - description: Enable -Werror - default: False - manual: True - -source-repository head - type: git - location: https://github.com/haskell/haskell-language-server - -library - exposed-modules: - Ide.Logger - Ide.Plugin - Ide.Plugin.Config - Ide.Plugin.Formatter - Ide.Plugin.GhcIde - Ide.PluginUtils - Ide.Types - - hs-source-dirs: src - build-depends: - , aeson - , base >=4.12 && <5 - , containers - , data-default - , Diff - , ghc - , ghc-boot-th - , ghcide >=0.5 - , haskell-lsp ^>=0.22 - , hashable - , hslogger - , lens - , process - , regex-tdfa >=1.3.1.0 - , shake >=0.17.5 - , text - , unordered-containers - - ghc-options: -Wall -Wredundant-constraints -Wno-name-shadowing - - if flag(pedantic) - ghc-options: -Werror - - default-language: Haskell2010 +cabal-version: 2.2+name: hls-plugin-api+version: 0.5.0.1+synopsis: Haskell Language Server API for plugin communication+description:+ Please see the README on GitHub at <https://github.com/haskell/haskell-language-server#readme>+homepage: https://github.com/haskell/haskell-language-server/hls-plugin-api+bug-reports: https://github.com/haskell/haskell-language-server/issues+license: Apache-2.0+license-file: LICENSE+author: Many,TBD when we release+maintainer: alan.zimm@gmail.com (for now)+copyright: Alan Zimmerman+category: Web+build-type: Simple++flag pedantic+ description: Enable -Werror+ default: False+ manual: True++source-repository head+ type: git+ location: https://github.com/haskell/haskell-language-server++library+ exposed-modules:+ Ide.Logger+ Ide.Plugin+ Ide.Plugin.Config+ Ide.Plugin.Formatter+ Ide.Plugin.GhcIde+ Ide.PluginUtils+ Ide.Types++ hs-source-dirs: src+ build-depends:+ , aeson+ , base >=4.12 && <5+ , containers+ , data-default+ , Diff+ , ghc+ , ghc-boot-th+ , ghcide >=0.5+ , haskell-lsp ^>=0.22+ , hashable+ , hslogger+ , lens+ , process+ , regex-tdfa >=1.3.1.0+ , shake >=0.17.5+ , text+ , unordered-containers++ ghc-options: -Wall -Wredundant-constraints -Wno-name-shadowing++ if flag(pedantic)+ ghc-options: -Werror++ default-language: Haskell2010
src/Ide/Logger.hs view
@@ -1,43 +1,43 @@-{- | Provides an implementation of the ghcide @Logger@ which uses - @System.Log.Logger@ under the hood. --} -module Ide.Logger - ( - hlsLogger - , logm - , debugm - , warningm - , errorm - ) where - -import Control.Monad.IO.Class -import qualified Data.Text as T -import qualified Development.IDE.Types.Logger as L -import System.Log.Logger - --- --------------------------------------------------------------------- - -hlsLogger :: L.Logger -hlsLogger = L.Logger $ \pri txt -> - case pri of - L.Telemetry -> logm (T.unpack txt) - L.Debug -> debugm (T.unpack txt) - L.Info -> logm (T.unpack txt) - L.Warning -> warningm (T.unpack txt) - L.Error -> errorm (T.unpack txt) - --- --------------------------------------------------------------------- - -logm :: MonadIO m => String -> m () -logm s = liftIO $ infoM "hls" s - -debugm :: MonadIO m => String -> m () -debugm s = liftIO $ debugM "hls" s - -warningm :: MonadIO m => String -> m () -warningm s = liftIO $ warningM "hls" s - -errorm :: MonadIO m => String -> m () -errorm s = liftIO $ errorM "hls" s - --- --------------------------------------------------------------------- +{- | Provides an implementation of the ghcide @Logger@ which uses+ @System.Log.Logger@ under the hood.+-}+module Ide.Logger+ (+ hlsLogger+ , logm+ , debugm+ , warningm+ , errorm+ ) where++import Control.Monad.IO.Class+import qualified Data.Text as T+import qualified Development.IDE.Types.Logger as L+import System.Log.Logger++-- ---------------------------------------------------------------------++hlsLogger :: L.Logger+hlsLogger = L.Logger $ \pri txt ->+ case pri of+ L.Telemetry -> logm (T.unpack txt)+ L.Debug -> debugm (T.unpack txt)+ L.Info -> logm (T.unpack txt)+ L.Warning -> warningm (T.unpack txt)+ L.Error -> errorm (T.unpack txt)++-- ---------------------------------------------------------------------++logm :: MonadIO m => String -> m ()+logm s = liftIO $ infoM "hls" s++debugm :: MonadIO m => String -> m ()+debugm s = liftIO $ debugM "hls" s++warningm :: MonadIO m => String -> m ()+warningm s = liftIO $ warningM "hls" s++errorm :: MonadIO m => String -> m ()+errorm s = liftIO $ errorM "hls" s++-- ---------------------------------------------------------------------
src/Ide/Plugin.hs view
@@ -1,604 +1,603 @@-{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} - -module Ide.Plugin - ( - asGhcIdePlugin - , pluginDescToIdePlugins - , mkLspCommand - , mkLspCmdId - , allLspCmdIds - , allLspCmdIds' - , getPid - , responseError - , getClientConfig - , getClientConfigAction - ) where - -import Control.Exception(SomeException, catch) -import Control.Lens ( (^.) ) -import Control.Monad -import qualified Data.Aeson as J -import qualified Data.Default -import Data.Either -import Data.Hashable (unhashed) -import qualified Data.List as List -import qualified Data.Map as Map -import Data.Maybe -import qualified Data.Text as T -import Development.IDE hiding (pluginRules) -import Development.IDE.LSP.Server -import GHC.Generics -import Ide.Logger -import Ide.Plugin.Config -import Ide.Plugin.Formatter -import Ide.Types -import qualified Language.Haskell.LSP.Core as LSP -import Language.Haskell.LSP.Messages -import Language.Haskell.LSP.Types -import qualified Language.Haskell.LSP.Types as J -import qualified Language.Haskell.LSP.Types.Capabilities as C -import Language.Haskell.LSP.Types.Lens as L hiding (formatting, rangeFormatting) -import qualified Language.Haskell.LSP.VFS as VFS -import Text.Regex.TDFA.Text() - --- --------------------------------------------------------------------- - --- | Map a set of plugins to the underlying ghcide engine. Main point is --- IdePlugins are arranged by kind of operation, 'Plugin' is arranged by message --- category ('Notifaction', 'Request' etc). -asGhcIdePlugin :: IdePlugins -> Plugin Config -asGhcIdePlugin mp = - mkPlugin rulesPlugins (Just . pluginRules) <> - mkPlugin executeCommandPlugins (Just . pluginCommands) <> - mkPlugin codeActionPlugins pluginCodeActionProvider <> - mkPlugin codeLensPlugins pluginCodeLensProvider <> - -- Note: diagnostics are provided via Rules from pluginDiagnosticProvider - mkPlugin hoverPlugins pluginHoverProvider <> - mkPlugin symbolsPlugins pluginSymbolsProvider <> - mkPlugin formatterPlugins pluginFormattingProvider <> - mkPlugin completionsPlugins pluginCompletionProvider <> - mkPlugin renamePlugins pluginRenameProvider - where - justs (p, Just x) = [(p, x)] - justs (_, Nothing) = [] - - ls = Map.toList (ipMap mp) - - mkPlugin :: ([(PluginId, b)] -> Plugin Config) -> (PluginDescriptor -> Maybe b) -> Plugin Config - mkPlugin maker selector = - case concatMap (\(pid, p) -> justs (pid, selector p)) ls of - -- If there are no plugins that provide a descriptor, use mempty to - -- create the plugin – otherwise we we end up declaring handlers for - -- capabilities that there are no plugins for - [] -> mempty - xs -> maker xs - - -pluginDescToIdePlugins :: [PluginDescriptor] -> IdePlugins -pluginDescToIdePlugins plugins = IdePlugins $ Map.fromList $ map (\p -> (pluginId p, p)) plugins - -allLspCmdIds' :: T.Text -> IdePlugins -> [T.Text] -allLspCmdIds' pid mp = mkPlugin (allLspCmdIds pid) (Just . pluginCommands) - where - justs (p, Just x) = [(p, x)] - justs (_, Nothing) = [] - - ls = Map.toList (ipMap mp) - - mkPlugin maker selector - = maker $ concatMap (\(pid, p) -> justs (pid, selector p)) ls - --- --------------------------------------------------------------------- - -rulesPlugins :: [(PluginId, Rules ())] -> Plugin Config -rulesPlugins rs = Plugin rules mempty - where - rules = mconcat $ map snd rs - -codeActionPlugins :: [(PluginId, CodeActionProvider)] -> Plugin Config -codeActionPlugins cas = Plugin codeActionRules (codeActionHandlers cas) - -codeActionRules :: Rules () -codeActionRules = mempty - -codeActionHandlers :: [(PluginId, CodeActionProvider)] -> PartialHandlers Config -codeActionHandlers cas = PartialHandlers $ \WithMessage{..} x -> return x - { LSP.codeActionHandler - = withResponse RspCodeAction (makeCodeAction cas) - } - -makeCodeAction :: [(PluginId, CodeActionProvider)] - -> LSP.LspFuncs Config -> IdeState - -> CodeActionParams - -> IO (Either ResponseError (List CAResult)) -makeCodeAction cas lf ideState (CodeActionParams docId range context _) = do - let caps = LSP.clientCapabilities lf - unL (List ls) = ls - r <- mapM (\(pid,provider) -> provider lf ideState pid docId range context) cas - let actions = filter wasRequested . concat $ map unL $ rights r - res <- send caps actions - return $ Right res - where - wasRequested :: CAResult -> Bool - wasRequested (CACommand _) = True - wasRequested (CACodeAction ca) - | Nothing <- only context = True - | Just (List allowed) <- only context - , Just caKind <- ca ^. kind = caKind `elem` allowed - | otherwise = False - - wrapCodeAction :: C.ClientCapabilities -> CAResult -> IO (Maybe CAResult) - wrapCodeAction _ (CACommand cmd) = return $ Just (CACommand cmd) - wrapCodeAction caps (CACodeAction action) = do - - let (C.ClientCapabilities _ textDocCaps _ _) = caps - let literalSupport = textDocCaps >>= C._codeAction >>= C._codeActionLiteralSupport - - case literalSupport of - Nothing -> do - let cmdParams = [J.toJSON (FallbackCodeActionParams (action ^. edit) (action ^. command))] - cmd <- mkLspCommand "hls" "fallbackCodeAction" (action ^. title) (Just cmdParams) - return $ Just (CACommand cmd) - Just _ -> return $ Just (CACodeAction action) - - send :: C.ClientCapabilities -> [CAResult] -> IO (List CAResult) - send caps codeActions = List . catMaybes <$> mapM (wrapCodeAction caps) codeActions - -data FallbackCodeActionParams = - FallbackCodeActionParams - { fallbackWorkspaceEdit :: Maybe WorkspaceEdit - , fallbackCommand :: Maybe Command - } - deriving (Generic, J.ToJSON, J.FromJSON) - --- ----------------------------------------------------------- - -codeLensPlugins :: [(PluginId, CodeLensProvider)] -> Plugin Config -codeLensPlugins cas = Plugin codeLensRules (codeLensHandlers cas) - -codeLensRules :: Rules () -codeLensRules = mempty - -codeLensHandlers :: [(PluginId, CodeLensProvider)] -> PartialHandlers Config -codeLensHandlers cas = PartialHandlers $ \WithMessage{..} x -> return x - { LSP.codeLensHandler - = withResponse RspCodeLens (makeCodeLens cas) - } - -makeCodeLens :: [(PluginId, CodeLensProvider)] - -> LSP.LspFuncs Config - -> IdeState - -> CodeLensParams - -> IO (Either ResponseError (List CodeLens)) -makeCodeLens cas lf ideState params = do - logInfo (ideLogger ideState) "Plugin.makeCodeLens (ideLogger)" -- AZ - let - makeLens (pid, provider) = do - r <- provider lf ideState pid params - return (pid, r) - breakdown :: [(PluginId, Either ResponseError a)] -> ([(PluginId, ResponseError)], [(PluginId, a)]) - breakdown ls = (concatMap doOneLeft ls, concatMap doOneRight ls) - where - doOneLeft (pid, Left err) = [(pid,err)] - doOneLeft (_, Right _) = [] - - doOneRight (pid, Right a) = [(pid,a)] - doOneRight (_, Left _) = [] - - r <- mapM makeLens cas - case breakdown r of - ([],[]) -> return $ Right $ List [] - (es,[]) -> return $ Left $ ResponseError InternalError (T.pack $ "codeLens failed:" ++ show es) Nothing - (_,rs) -> return $ Right $ List (concatMap (\(_,List cs) -> cs) rs) - --- ----------------------------------------------------------- - -executeCommandPlugins :: [(PluginId, [PluginCommand])] -> Plugin Config -executeCommandPlugins ecs = Plugin mempty (executeCommandHandlers ecs) - -executeCommandHandlers :: [(PluginId, [PluginCommand])] -> PartialHandlers Config -executeCommandHandlers ecs = PartialHandlers $ \WithMessage{..} x -> return x{ - LSP.executeCommandHandler = withResponseAndRequest RspExecuteCommand ReqApplyWorkspaceEdit (makeExecuteCommands ecs) - } - --- type ExecuteCommandProvider = IdeState --- -> ExecuteCommandParams --- -> IO (Either ResponseError Value, Maybe (ServerMethod, ApplyWorkspaceEditParams)) -makeExecuteCommands :: [(PluginId, [PluginCommand])] -> LSP.LspFuncs Config -> ExecuteCommandProvider -makeExecuteCommands ecs lf ide = wrapUnhandledExceptions $ do - let - pluginMap = Map.fromList ecs - parseCmdId :: T.Text -> Maybe (PluginId, CommandId) - parseCmdId x = case T.splitOn ":" x of - [plugin, command] -> Just (PluginId plugin, CommandId command) - [_, plugin, command] -> Just (PluginId plugin, CommandId command) - _ -> Nothing - - execCmd :: ExecuteCommandParams -> IO (Either ResponseError J.Value, Maybe (ServerMethod, ApplyWorkspaceEditParams)) - execCmd (ExecuteCommandParams cmdId args _) = do - -- The parameters to the HIE command are always the first element - let cmdParams :: J.Value - cmdParams = case args of - Just (J.List (x:_)) -> x - _ -> J.Null - - case parseCmdId cmdId of - -- Shortcut for immediately applying a applyWorkspaceEdit as a fallback for v3.8 code actions - Just ("hls", "fallbackCodeAction") -> - case J.fromJSON cmdParams of - J.Success (FallbackCodeActionParams mEdit mCmd) -> do - - -- Send off the workspace request if it has one - forM_ mEdit $ \edit -> do - let eParams = J.ApplyWorkspaceEditParams edit - -- TODO: Use lspfuncs to send an applyedit message. Or change - -- the API to allow a list of messages to be returned. - return (Right J.Null, Just(J.WorkspaceApplyEdit, eParams)) - - case mCmd of - -- If we have a command, continue to execute it - Just (J.Command _ innerCmdId innerArgs) - -> execCmd (ExecuteCommandParams innerCmdId innerArgs Nothing) - Nothing -> return (Right J.Null, Nothing) - - J.Error _str -> return (Right J.Null, Nothing) - -- Couldn't parse the fallback command params - -- _ -> liftIO $ - -- LSP.sendErrorResponseS (LSP.sendFunc lf) - -- (J.responseId (req ^. J.id)) - -- J.InvalidParams - -- "Invalid fallbackCodeAction params" - - -- Just an ordinary HIE command - Just (plugin, cmd) -> runPluginCommand pluginMap lf ide plugin cmd cmdParams - - -- Couldn't parse the command identifier - _ -> return (Left $ ResponseError InvalidParams "Invalid command identifier" Nothing, Nothing) - - execCmd - -{- - ReqExecuteCommand req -> do - liftIO $ U.logs $ "reactor:got ExecuteCommandRequest:" ++ show req - lf <- asks lspFuncs - - let params = req ^. J.params - - parseCmdId :: T.Text -> Maybe (PluginId, CommandId) - parseCmdId x = case T.splitOn ":" x of - [plugin, command] -> Just (PluginId plugin, CommandId command) - [_, plugin, command] -> Just (PluginId plugin, CommandId command) - _ -> Nothing - - callback obj = do - liftIO $ U.logs $ "ExecuteCommand response got:r=" ++ show obj - case fromDynJSON obj :: Maybe J.WorkspaceEdit of - Just v -> do - lid <- nextLspReqId - reactorSend $ RspExecuteCommand $ Core.makeResponseMessage req (A.Object mempty) - let msg = fmServerApplyWorkspaceEditRequest lid $ J.ApplyWorkspaceEditParams v - liftIO $ U.logs $ "ExecuteCommand sending edit: " ++ show msg - reactorSend $ ReqApplyWorkspaceEdit msg - Nothing -> reactorSend $ RspExecuteCommand $ Core.makeResponseMessage req $ dynToJSON obj - - execCmd cmdId args = do - -- The parameters to the HIE command are always the first element - let cmdParams = case args of - Just (J.List (x:_)) -> x - _ -> A.Null - - case parseCmdId cmdId of - -- Shortcut for immediately applying a applyWorkspaceEdit as a fallback for v3.8 code actions - Just ("hls", "fallbackCodeAction") -> do - case A.fromJSON cmdParams of - A.Success (FallbackCodeActionParams mEdit mCmd) -> do - - -- Send off the workspace request if it has one - forM_ mEdit $ \edit -> do - lid <- nextLspReqId - let eParams = J.ApplyWorkspaceEditParams edit - eReq = fmServerApplyWorkspaceEditRequest lid eParams - reactorSend $ ReqApplyWorkspaceEdit eReq - - case mCmd of - -- If we have a command, continue to execute it - Just (J.Command _ innerCmdId innerArgs) -> execCmd innerCmdId innerArgs - - -- Otherwise we need to send back a response oureslves - Nothing -> reactorSend $ RspExecuteCommand $ Core.makeResponseMessage req (A.Object mempty) - - -- Couldn't parse the fallback command params - _ -> liftIO $ - Core.sendErrorResponseS (Core.sendFunc lf) - (J.responseId (req ^. J.id)) - J.InvalidParams - "Invalid fallbackCodeAction params" - -- Just an ordinary HIE command - Just (plugin, cmd) -> - let preq = GReq tn "plugin" Nothing Nothing (Just $ req ^. J.id) callback (toDynJSON (Nothing :: Maybe J.WorkspaceEdit)) - $ runPluginCommand plugin cmd cmdParams - in makeRequest preq - - -- Couldn't parse the command identifier - _ -> liftIO $ - Core.sendErrorResponseS (Core.sendFunc lf) - (J.responseId (req ^. J.id)) - J.InvalidParams - "Invalid command identifier" - - execCmd (params ^. J.command) (params ^. J.arguments) --} - --- ----------------------------------------------------------- -wrapUnhandledExceptions :: - (a -> IO (Either ResponseError J.Value, Maybe b)) -> - a -> IO (Either ResponseError J.Value, Maybe b) -wrapUnhandledExceptions action input = - catch (action input) $ \(e::SomeException) -> do - let resp = ResponseError InternalError (T.pack $ show e) Nothing - return (Left resp, Nothing) - - --- | Runs a plugin command given a PluginId, CommandId and --- arguments in the form of a JSON object. -runPluginCommand :: Map.Map PluginId [PluginCommand] - -> LSP.LspFuncs Config - -> IdeState - -> PluginId - -> CommandId - -> J.Value - -> IO (Either ResponseError J.Value, - Maybe (ServerMethod, ApplyWorkspaceEditParams)) -runPluginCommand m lf ide p@(PluginId p') com@(CommandId com') arg = - case Map.lookup p m of - Nothing -> return - (Left $ ResponseError InvalidRequest ("Plugin " <> p' <> " doesn't exist") Nothing, Nothing) - Just xs -> case List.find ((com ==) . commandId) xs of - Nothing -> return (Left $ - ResponseError InvalidRequest ("Command " <> com' <> " isn't defined for plugin " <> p' - <> ". Legal commands are: " <> T.pack(show $ map commandId xs)) Nothing, Nothing) - Just (PluginCommand _ _ f) -> case J.fromJSON arg of - J.Error err -> return (Left $ - ResponseError InvalidParams ("error while parsing args for " <> com' <> " in plugin " <> p' - <> ": " <> T.pack err - <> "\narg = " <> T.pack (show arg)) Nothing, Nothing) - J.Success a -> f lf ide a - --- lsp-request: error while parsing args for typesignature.add in plugin ghcide: --- When parsing the record ExecuteCommandParams of type --- Language.Haskell.LSP.Types.DataTypesJSON.ExecuteCommandParams the key command --- was not present. - --- ----------------------------------------------------------- - -mkLspCommand :: PluginId -> CommandId -> T.Text -> Maybe [J.Value] -> IO Command -mkLspCommand plid cn title args' = do - pid <- getPid - let cmdId = mkLspCmdId pid plid cn - let args = List <$> args' - return $ Command title cmdId args - -mkLspCmdId :: T.Text -> PluginId -> CommandId -> T.Text -mkLspCmdId pid (PluginId plid) (CommandId cid) - = pid <> ":" <> plid <> ":" <> cid - -allLspCmdIds :: T.Text -> [(PluginId, [PluginCommand])] -> [T.Text] -allLspCmdIds pid commands = concat $ map go commands - where - go (plid, cmds) = map (mkLspCmdId pid plid . commandId) cmds - --- --------------------------------------------------------------------- - -hoverPlugins :: [(PluginId, HoverProvider)] -> Plugin Config -hoverPlugins hs = Plugin hoverRules (hoverHandlers hs) - -hoverRules :: Rules () -hoverRules = mempty - -hoverHandlers :: [(PluginId, HoverProvider)] -> PartialHandlers Config -hoverHandlers hps = PartialHandlers $ \WithMessage{..} x -> - return x{LSP.hoverHandler = withResponse RspHover (makeHover hps)} - -makeHover :: [(PluginId, HoverProvider)] - -> LSP.LspFuncs Config -> IdeState - -> TextDocumentPositionParams - -> IO (Either ResponseError (Maybe Hover)) -makeHover hps _lf ideState params - = do - mhs <- mapM (\(_,p) -> p ideState params) hps - -- TODO: We should support ServerCapabilities and declare that - -- we don't support hover requests during initialization if we - -- don't have any hover providers - -- TODO: maybe only have provider give MarkedString and - -- work out range here? - let hs = catMaybes (rights mhs) - r = listToMaybe $ mapMaybe (^. range) hs - h = case mconcat ((map (^. contents) hs) :: [HoverContents]) of - HoverContentsMS (List []) -> Nothing - hh -> Just $ Hover hh r - return $ Right h - --- --------------------------------------------------------------------- --- --------------------------------------------------------------------- - -symbolsPlugins :: [(PluginId, SymbolsProvider)] -> Plugin Config -symbolsPlugins hs = Plugin symbolsRules (symbolsHandlers hs) - -symbolsRules :: Rules () -symbolsRules = mempty - -symbolsHandlers :: [(PluginId, SymbolsProvider)] -> PartialHandlers Config -symbolsHandlers hps = PartialHandlers $ \WithMessage{..} x -> - return x {LSP.documentSymbolHandler = withResponse RspDocumentSymbols (makeSymbols hps)} - -makeSymbols :: [(PluginId, SymbolsProvider)] - -> LSP.LspFuncs Config - -> IdeState - -> DocumentSymbolParams - -> IO (Either ResponseError DSResult) -makeSymbols sps lf ideState params - = do - let uri' = params ^. textDocument . uri - (C.ClientCapabilities _ tdc _ _) = LSP.clientCapabilities lf - supportsHierarchy = fromMaybe False $ tdc >>= C._documentSymbol - >>= C._hierarchicalDocumentSymbolSupport - convertSymbols :: [DocumentSymbol] -> DSResult - convertSymbols symbs - | supportsHierarchy = DSDocumentSymbols $ List symbs - | otherwise = DSSymbolInformation (List $ concatMap (go Nothing) symbs) - where - go :: Maybe T.Text -> DocumentSymbol -> [SymbolInformation] - go parent ds = - let children' :: [SymbolInformation] - children' = concatMap (go (Just name')) (fromMaybe mempty (ds ^. children)) - loc = Location uri' (ds ^. range) - name' = ds ^. name - si = SymbolInformation name' (ds ^. kind) (ds ^. deprecated) loc parent - in [si] <> children' - - mhs <- mapM (\(_,p) -> p lf ideState params) sps - case rights mhs of - [] -> return $ Left $ responseError $ T.pack $ show $ lefts mhs - hs -> return $ Right $ convertSymbols $ concat hs - - --- --------------------------------------------------------------------- --- --------------------------------------------------------------------- - -renamePlugins :: [(PluginId, RenameProvider)] -> Plugin Config -renamePlugins providers = Plugin rules handlers - where - rules = mempty - handlers = PartialHandlers $ \WithMessage{..} x -> return x - { LSP.renameHandler = withResponse RspRename (renameWith providers)} - -renameWith :: - [(PluginId, RenameProvider)] -> - LSP.LspFuncs Config -> - IdeState -> - RenameParams -> - IO (Either ResponseError WorkspaceEdit) -renameWith providers lspFuncs state params = do - results <- mapM (\(_,p) -> p lspFuncs state params) providers - case partitionEithers results of - (errors, []) -> return $ Left $ responseError $ T.pack $ show $ errors - (_, edits) -> return $ Right $ mconcat edits - --- --------------------------------------------------------------------- --- --------------------------------------------------------------------- - -formatterPlugins :: [(PluginId, FormattingProvider IO)] -> Plugin Config -formatterPlugins providers - = Plugin formatterRules - (formatterHandlers (Map.fromList (("none",noneProvider):providers))) - -formatterRules :: Rules () -formatterRules = mempty - -formatterHandlers :: Map.Map PluginId (FormattingProvider IO) -> PartialHandlers Config -formatterHandlers providers = PartialHandlers $ \WithMessage{..} x -> return x - { LSP.documentFormattingHandler - = withResponse RspDocumentFormatting (formatting providers) - , LSP.documentRangeFormattingHandler - = withResponse RspDocumentRangeFormatting (rangeFormatting providers) - } - --- --------------------------------------------------------------------- --- --------------------------------------------------------------------- - -completionsPlugins :: [(PluginId, CompletionProvider)] -> Plugin Config -completionsPlugins cs = Plugin completionsRules (completionsHandlers cs) - -completionsRules :: Rules () -completionsRules = mempty - -completionsHandlers :: [(PluginId, CompletionProvider)] -> PartialHandlers Config -completionsHandlers cps = PartialHandlers $ \WithMessage{..} x -> - return x {LSP.completionHandler = withResponse RspCompletion (makeCompletions cps)} - -makeCompletions :: [(PluginId, CompletionProvider)] - -> LSP.LspFuncs Config - -> IdeState - -> CompletionParams - -> IO (Either ResponseError CompletionResponseResult) -makeCompletions sps lf ideState params@(CompletionParams (TextDocumentIdentifier doc) pos _context _mt) - = do - mprefix <- getPrefixAtPos lf doc pos - _snippets <- WithSnippets <$> completionSnippetsOn <$> (getClientConfig lf) - - let - combine :: [CompletionResponseResult] -> CompletionResponseResult - combine cs = go (Completions $ List []) cs - where - go acc [] = acc - go (Completions (List ls)) (Completions (List ls2):rest) - = go (Completions (List (ls <> ls2))) rest - go (Completions (List ls)) (CompletionList (CompletionListType complete (List ls2)):rest) - = go (CompletionList $ CompletionListType complete (List (ls <> ls2))) rest - go (CompletionList (CompletionListType complete (List ls))) (CompletionList (CompletionListType complete2 (List ls2)):rest) - = go (CompletionList $ CompletionListType (complete || complete2) (List (ls <> ls2))) rest - go (CompletionList (CompletionListType complete (List ls))) (Completions (List ls2):rest) - = go (CompletionList $ CompletionListType complete (List (ls <> ls2))) rest - - case mprefix of - Nothing -> return $ Right $ Completions $ List [] - Just _prefix -> do - mhs <- mapM (\(_,p) -> p lf ideState params) sps - case rights mhs of - [] -> return $ Left $ responseError $ T.pack $ show $ lefts mhs - hs -> return $ Right $ combine hs - -{- - ReqCompletion req -> do - liftIO $ U.logs $ "reactor:got CompletionRequest:" ++ show req - let (_, doc, pos) = reqParams req - - mprefix <- getPrefixAtPos doc pos - - let callback compls = do - let rspMsg = Core.makeResponseMessage req - $ J.Completions $ J.List compls - reactorSend $ RspCompletion rspMsg - case mprefix of - Nothing -> callback [] - Just prefix -> do - snippets <- Completions.WithSnippets <$> configVal completionSnippetsOn - let hreq = IReq tn "completion" (req ^. J.id) callback - $ lift $ Completions.getCompletions doc prefix snippets - makeRequest hreq --} - -getPrefixAtPos :: LSP.LspFuncs Config -> Uri -> Position -> IO (Maybe VFS.PosPrefixInfo) -getPrefixAtPos lf uri pos = do - mvf <- (LSP.getVirtualFileFunc lf) (J.toNormalizedUri uri) - case mvf of - Just vf -> VFS.getCompletionPrefix pos vf - Nothing -> return Nothing - --- --------------------------------------------------------------------- --- | Returns the current client configuration. It is not wise to permanently --- cache the returned value of this function, as clients can at runitime change --- their configuration. --- --- If no custom configuration has been set by the client, this function returns --- our own defaults. -getClientConfig :: LSP.LspFuncs Config -> IO Config -getClientConfig lf = fromMaybe Data.Default.def <$> LSP.config lf - --- | Returns the client configurarion stored in the IdeState. --- You can use this function to access it from shake Rules -getClientConfigAction :: Action Config -getClientConfigAction = do - mbVal <- unhashed <$> useNoFile_ GetClientSettings - logm $ "getClientConfigAction:clientSettings:" ++ show mbVal - case J.fromJSON <$> mbVal of - Just (J.Success c) -> return c - _ -> return Data.Default.def --- --------------------------------------------------------------------- +{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Ide.Plugin+ (+ asGhcIdePlugin+ , pluginDescToIdePlugins+ , mkLspCommand+ , mkLspCmdId+ , allLspCmdIds+ , allLspCmdIds'+ , getPid+ , responseError+ , getClientConfig+ , getClientConfigAction+ ) where++import Control.Exception(SomeException, catch)+import Control.Lens ( (^.) )+import Control.Monad+import qualified Data.Aeson as J+import qualified Data.Default+import Data.Either+import Data.Hashable (unhashed)+import qualified Data.List as List+import qualified Data.Map as Map+import Data.Maybe+import qualified Data.Text as T+import Development.IDE hiding (pluginRules)+import Development.IDE.LSP.Server+import GHC.Generics+import Ide.Logger+import Ide.Plugin.Config+import Ide.Plugin.Formatter+import Ide.Types+import qualified Language.Haskell.LSP.Core as LSP+import Language.Haskell.LSP.Messages+import Language.Haskell.LSP.Types+import qualified Language.Haskell.LSP.Types as J+import qualified Language.Haskell.LSP.Types.Capabilities as C+import Language.Haskell.LSP.Types.Lens as L hiding (formatting, rangeFormatting)+import qualified Language.Haskell.LSP.VFS as VFS+import Text.Regex.TDFA.Text()++-- ---------------------------------------------------------------------++-- | Map a set of plugins to the underlying ghcide engine. Main point is+-- IdePlugins are arranged by kind of operation, 'Plugin' is arranged by message+-- category ('Notifaction', 'Request' etc).+asGhcIdePlugin :: IdePlugins -> Plugin Config+asGhcIdePlugin mp =+ mkPlugin rulesPlugins (Just . pluginRules) <>+ mkPlugin executeCommandPlugins (Just . pluginCommands) <>+ mkPlugin codeActionPlugins pluginCodeActionProvider <>+ mkPlugin codeLensPlugins pluginCodeLensProvider <>+ -- Note: diagnostics are provided via Rules from pluginDiagnosticProvider+ mkPlugin hoverPlugins pluginHoverProvider <>+ mkPlugin symbolsPlugins pluginSymbolsProvider <>+ mkPlugin formatterPlugins pluginFormattingProvider <>+ mkPlugin completionsPlugins pluginCompletionProvider <>+ mkPlugin renamePlugins pluginRenameProvider+ where+ justs (p, Just x) = [(p, x)]+ justs (_, Nothing) = []++ ls = Map.toList (ipMap mp)++ mkPlugin :: ([(PluginId, b)] -> Plugin Config) -> (PluginDescriptor -> Maybe b) -> Plugin Config+ mkPlugin maker selector =+ case concatMap (\(pid, p) -> justs (pid, selector p)) ls of+ -- If there are no plugins that provide a descriptor, use mempty to+ -- create the plugin – otherwise we we end up declaring handlers for+ -- capabilities that there are no plugins for+ [] -> mempty+ xs -> maker xs+++pluginDescToIdePlugins :: [PluginDescriptor] -> IdePlugins+pluginDescToIdePlugins plugins = IdePlugins $ Map.fromList $ map (\p -> (pluginId p, p)) plugins++allLspCmdIds' :: T.Text -> IdePlugins -> [T.Text]+allLspCmdIds' pid mp = mkPlugin (allLspCmdIds pid) (Just . pluginCommands)+ where+ justs (p, Just x) = [(p, x)]+ justs (_, Nothing) = []++ ls = Map.toList (ipMap mp)++ mkPlugin maker selector+ = maker $ concatMap (\(pid, p) -> justs (pid, selector p)) ls++-- ---------------------------------------------------------------------++rulesPlugins :: [(PluginId, Rules ())] -> Plugin Config+rulesPlugins rs = Plugin rules mempty+ where+ rules = mconcat $ map snd rs++codeActionPlugins :: [(PluginId, CodeActionProvider)] -> Plugin Config+codeActionPlugins cas = Plugin codeActionRules (codeActionHandlers cas)++codeActionRules :: Rules ()+codeActionRules = mempty++codeActionHandlers :: [(PluginId, CodeActionProvider)] -> PartialHandlers Config+codeActionHandlers cas = PartialHandlers $ \WithMessage{..} x -> return x+ { LSP.codeActionHandler+ = withResponse RspCodeAction (makeCodeAction cas)+ }++makeCodeAction :: [(PluginId, CodeActionProvider)]+ -> LSP.LspFuncs Config -> IdeState+ -> CodeActionParams+ -> IO (Either ResponseError (List CAResult))+makeCodeAction cas lf ideState (CodeActionParams docId range context _) = do+ let caps = LSP.clientCapabilities lf+ unL (List ls) = ls+ r <- mapM (\(pid,provider) -> provider lf ideState pid docId range context) cas+ let actions = filter wasRequested . concat $ map unL $ rights r+ res <- send caps actions+ return $ Right res+ where+ wasRequested :: CAResult -> Bool+ wasRequested (CACommand _) = True+ wasRequested (CACodeAction ca)+ | Nothing <- only context = True+ | Just (List allowed) <- only context+ , Just caKind <- ca ^. kind = caKind `elem` allowed+ | otherwise = False++ wrapCodeAction :: C.ClientCapabilities -> CAResult -> IO (Maybe CAResult)+ wrapCodeAction _ (CACommand cmd) = return $ Just (CACommand cmd)+ wrapCodeAction caps (CACodeAction action) = do++ let (C.ClientCapabilities _ textDocCaps _ _) = caps+ let literalSupport = textDocCaps >>= C._codeAction >>= C._codeActionLiteralSupport++ case literalSupport of+ Nothing -> do+ let cmdParams = [J.toJSON (FallbackCodeActionParams (action ^. edit) (action ^. command))]+ cmd <- mkLspCommand "hls" "fallbackCodeAction" (action ^. title) (Just cmdParams)+ return $ Just (CACommand cmd)+ Just _ -> return $ Just (CACodeAction action)++ send :: C.ClientCapabilities -> [CAResult] -> IO (List CAResult)+ send caps codeActions = List . catMaybes <$> mapM (wrapCodeAction caps) codeActions++data FallbackCodeActionParams =+ FallbackCodeActionParams+ { fallbackWorkspaceEdit :: Maybe WorkspaceEdit+ , fallbackCommand :: Maybe Command+ }+ deriving (Generic, J.ToJSON, J.FromJSON)++-- -----------------------------------------------------------++codeLensPlugins :: [(PluginId, CodeLensProvider)] -> Plugin Config+codeLensPlugins cas = Plugin codeLensRules (codeLensHandlers cas)++codeLensRules :: Rules ()+codeLensRules = mempty++codeLensHandlers :: [(PluginId, CodeLensProvider)] -> PartialHandlers Config+codeLensHandlers cas = PartialHandlers $ \WithMessage{..} x -> return x+ { LSP.codeLensHandler+ = withResponse RspCodeLens (makeCodeLens cas)+ }++makeCodeLens :: [(PluginId, CodeLensProvider)]+ -> LSP.LspFuncs Config+ -> IdeState+ -> CodeLensParams+ -> IO (Either ResponseError (List CodeLens))+makeCodeLens cas lf ideState params = do+ logInfo (ideLogger ideState) "Plugin.makeCodeLens (ideLogger)" -- AZ+ let+ makeLens (pid, provider) = do+ r <- provider lf ideState pid params+ return (pid, r)+ breakdown :: [(PluginId, Either ResponseError a)] -> ([(PluginId, ResponseError)], [(PluginId, a)])+ breakdown ls = (concatMap doOneLeft ls, concatMap doOneRight ls)+ where+ doOneLeft (pid, Left err) = [(pid,err)]+ doOneLeft (_, Right _) = []++ doOneRight (pid, Right a) = [(pid,a)]+ doOneRight (_, Left _) = []++ r <- mapM makeLens cas+ case breakdown r of+ ([],[]) -> return $ Right $ List []+ (es,[]) -> return $ Left $ ResponseError InternalError (T.pack $ "codeLens failed:" ++ show es) Nothing+ (_,rs) -> return $ Right $ List (concatMap (\(_,List cs) -> cs) rs)++-- -----------------------------------------------------------++executeCommandPlugins :: [(PluginId, [PluginCommand])] -> Plugin Config+executeCommandPlugins ecs = Plugin mempty (executeCommandHandlers ecs)++executeCommandHandlers :: [(PluginId, [PluginCommand])] -> PartialHandlers Config+executeCommandHandlers ecs = PartialHandlers $ \WithMessage{..} x -> return x{+ LSP.executeCommandHandler = withResponseAndRequest RspExecuteCommand ReqApplyWorkspaceEdit (makeExecuteCommands ecs)+ }++-- type ExecuteCommandProvider = IdeState+-- -> ExecuteCommandParams+-- -> IO (Either ResponseError Value, Maybe (ServerMethod, ApplyWorkspaceEditParams))+makeExecuteCommands :: [(PluginId, [PluginCommand])] -> LSP.LspFuncs Config -> ExecuteCommandProvider+makeExecuteCommands ecs lf ide = wrapUnhandledExceptions $ do+ let+ pluginMap = Map.fromList ecs+ parseCmdId :: T.Text -> Maybe (PluginId, CommandId)+ parseCmdId x = case T.splitOn ":" x of+ [plugin, command] -> Just (PluginId plugin, CommandId command)+ [_, plugin, command] -> Just (PluginId plugin, CommandId command)+ _ -> Nothing++ execCmd :: ExecuteCommandParams -> IO (Either ResponseError J.Value, Maybe (ServerMethod, ApplyWorkspaceEditParams))+ execCmd (ExecuteCommandParams cmdId args _) = do+ -- The parameters to the HIE command are always the first element+ let cmdParams :: J.Value+ cmdParams = case args of+ Just (J.List (x:_)) -> x+ _ -> J.Null++ case parseCmdId cmdId of+ -- Shortcut for immediately applying a applyWorkspaceEdit as a fallback for v3.8 code actions+ Just ("hls", "fallbackCodeAction") ->+ case J.fromJSON cmdParams of+ J.Success (FallbackCodeActionParams mEdit mCmd) -> do++ -- Send off the workspace request if it has one+ forM_ mEdit $ \edit -> do+ let eParams = J.ApplyWorkspaceEditParams edit+ reqId <- LSP.getNextReqId lf+ LSP.sendFunc lf $ ReqApplyWorkspaceEdit $ RequestMessage "2.0" reqId WorkspaceApplyEdit eParams++ case mCmd of+ -- If we have a command, continue to execute it+ Just (J.Command _ innerCmdId innerArgs)+ -> execCmd (ExecuteCommandParams innerCmdId innerArgs Nothing)+ Nothing -> return (Right J.Null, Nothing)++ J.Error _str -> return (Right J.Null, Nothing)+ -- Couldn't parse the fallback command params+ -- _ -> liftIO $+ -- LSP.sendErrorResponseS (LSP.sendFunc lf)+ -- (J.responseId (req ^. J.id))+ -- J.InvalidParams+ -- "Invalid fallbackCodeAction params"++ -- Just an ordinary HIE command+ Just (plugin, cmd) -> runPluginCommand pluginMap lf ide plugin cmd cmdParams++ -- Couldn't parse the command identifier+ _ -> return (Left $ ResponseError InvalidParams "Invalid command identifier" Nothing, Nothing)++ execCmd++{-+ ReqExecuteCommand req -> do+ liftIO $ U.logs $ "reactor:got ExecuteCommandRequest:" ++ show req+ lf <- asks lspFuncs++ let params = req ^. J.params++ parseCmdId :: T.Text -> Maybe (PluginId, CommandId)+ parseCmdId x = case T.splitOn ":" x of+ [plugin, command] -> Just (PluginId plugin, CommandId command)+ [_, plugin, command] -> Just (PluginId plugin, CommandId command)+ _ -> Nothing++ callback obj = do+ liftIO $ U.logs $ "ExecuteCommand response got:r=" ++ show obj+ case fromDynJSON obj :: Maybe J.WorkspaceEdit of+ Just v -> do+ lid <- nextLspReqId+ reactorSend $ RspExecuteCommand $ Core.makeResponseMessage req (A.Object mempty)+ let msg = fmServerApplyWorkspaceEditRequest lid $ J.ApplyWorkspaceEditParams v+ liftIO $ U.logs $ "ExecuteCommand sending edit: " ++ show msg+ reactorSend $ ReqApplyWorkspaceEdit msg+ Nothing -> reactorSend $ RspExecuteCommand $ Core.makeResponseMessage req $ dynToJSON obj++ execCmd cmdId args = do+ -- The parameters to the HIE command are always the first element+ let cmdParams = case args of+ Just (J.List (x:_)) -> x+ _ -> A.Null++ case parseCmdId cmdId of+ -- Shortcut for immediately applying a applyWorkspaceEdit as a fallback for v3.8 code actions+ Just ("hls", "fallbackCodeAction") -> do+ case A.fromJSON cmdParams of+ A.Success (FallbackCodeActionParams mEdit mCmd) -> do++ -- Send off the workspace request if it has one+ forM_ mEdit $ \edit -> do+ lid <- nextLspReqId+ let eParams = J.ApplyWorkspaceEditParams edit+ eReq = fmServerApplyWorkspaceEditRequest lid eParams+ reactorSend $ ReqApplyWorkspaceEdit eReq++ case mCmd of+ -- If we have a command, continue to execute it+ Just (J.Command _ innerCmdId innerArgs) -> execCmd innerCmdId innerArgs++ -- Otherwise we need to send back a response oureslves+ Nothing -> reactorSend $ RspExecuteCommand $ Core.makeResponseMessage req (A.Object mempty)++ -- Couldn't parse the fallback command params+ _ -> liftIO $+ Core.sendErrorResponseS (Core.sendFunc lf)+ (J.responseId (req ^. J.id))+ J.InvalidParams+ "Invalid fallbackCodeAction params"+ -- Just an ordinary HIE command+ Just (plugin, cmd) ->+ let preq = GReq tn "plugin" Nothing Nothing (Just $ req ^. J.id) callback (toDynJSON (Nothing :: Maybe J.WorkspaceEdit))+ $ runPluginCommand plugin cmd cmdParams+ in makeRequest preq++ -- Couldn't parse the command identifier+ _ -> liftIO $+ Core.sendErrorResponseS (Core.sendFunc lf)+ (J.responseId (req ^. J.id))+ J.InvalidParams+ "Invalid command identifier"++ execCmd (params ^. J.command) (params ^. J.arguments)+-}++-- -----------------------------------------------------------+wrapUnhandledExceptions ::+ (a -> IO (Either ResponseError J.Value, Maybe b)) ->+ a -> IO (Either ResponseError J.Value, Maybe b)+wrapUnhandledExceptions action input =+ catch (action input) $ \(e::SomeException) -> do+ let resp = ResponseError InternalError (T.pack $ show e) Nothing+ return (Left resp, Nothing)+++-- | Runs a plugin command given a PluginId, CommandId and+-- arguments in the form of a JSON object.+runPluginCommand :: Map.Map PluginId [PluginCommand]+ -> LSP.LspFuncs Config+ -> IdeState+ -> PluginId+ -> CommandId+ -> J.Value+ -> IO (Either ResponseError J.Value,+ Maybe (ServerMethod, ApplyWorkspaceEditParams))+runPluginCommand m lf ide p@(PluginId p') com@(CommandId com') arg =+ case Map.lookup p m of+ Nothing -> return+ (Left $ ResponseError InvalidRequest ("Plugin " <> p' <> " doesn't exist") Nothing, Nothing)+ Just xs -> case List.find ((com ==) . commandId) xs of+ Nothing -> return (Left $+ ResponseError InvalidRequest ("Command " <> com' <> " isn't defined for plugin " <> p'+ <> ". Legal commands are: " <> T.pack(show $ map commandId xs)) Nothing, Nothing)+ Just (PluginCommand _ _ f) -> case J.fromJSON arg of+ J.Error err -> return (Left $+ ResponseError InvalidParams ("error while parsing args for " <> com' <> " in plugin " <> p'+ <> ": " <> T.pack err+ <> "\narg = " <> T.pack (show arg)) Nothing, Nothing)+ J.Success a -> f lf ide a++-- lsp-request: error while parsing args for typesignature.add in plugin ghcide:+-- When parsing the record ExecuteCommandParams of type+-- Language.Haskell.LSP.Types.DataTypesJSON.ExecuteCommandParams the key command+-- was not present.++-- -----------------------------------------------------------++mkLspCommand :: PluginId -> CommandId -> T.Text -> Maybe [J.Value] -> IO Command+mkLspCommand plid cn title args' = do+ pid <- getPid+ let cmdId = mkLspCmdId pid plid cn+ let args = List <$> args'+ return $ Command title cmdId args++mkLspCmdId :: T.Text -> PluginId -> CommandId -> T.Text+mkLspCmdId pid (PluginId plid) (CommandId cid)+ = pid <> ":" <> plid <> ":" <> cid++allLspCmdIds :: T.Text -> [(PluginId, [PluginCommand])] -> [T.Text]+allLspCmdIds pid commands = concat $ map go commands+ where+ go (plid, cmds) = map (mkLspCmdId pid plid . commandId) cmds++-- ---------------------------------------------------------------------++hoverPlugins :: [(PluginId, HoverProvider)] -> Plugin Config+hoverPlugins hs = Plugin hoverRules (hoverHandlers hs)++hoverRules :: Rules ()+hoverRules = mempty++hoverHandlers :: [(PluginId, HoverProvider)] -> PartialHandlers Config+hoverHandlers hps = PartialHandlers $ \WithMessage{..} x ->+ return x{LSP.hoverHandler = withResponse RspHover (makeHover hps)}++makeHover :: [(PluginId, HoverProvider)]+ -> LSP.LspFuncs Config -> IdeState+ -> TextDocumentPositionParams+ -> IO (Either ResponseError (Maybe Hover))+makeHover hps _lf ideState params+ = do+ mhs <- mapM (\(_,p) -> p ideState params) hps+ -- TODO: We should support ServerCapabilities and declare that+ -- we don't support hover requests during initialization if we+ -- don't have any hover providers+ -- TODO: maybe only have provider give MarkedString and+ -- work out range here?+ let hs = catMaybes (rights mhs)+ r = listToMaybe $ mapMaybe (^. range) hs+ h = case mconcat ((map (^. contents) hs) :: [HoverContents]) of+ HoverContentsMS (List []) -> Nothing+ hh -> Just $ Hover hh r+ return $ Right h++-- ---------------------------------------------------------------------+-- ---------------------------------------------------------------------++symbolsPlugins :: [(PluginId, SymbolsProvider)] -> Plugin Config+symbolsPlugins hs = Plugin symbolsRules (symbolsHandlers hs)++symbolsRules :: Rules ()+symbolsRules = mempty++symbolsHandlers :: [(PluginId, SymbolsProvider)] -> PartialHandlers Config+symbolsHandlers hps = PartialHandlers $ \WithMessage{..} x ->+ return x {LSP.documentSymbolHandler = withResponse RspDocumentSymbols (makeSymbols hps)}++makeSymbols :: [(PluginId, SymbolsProvider)]+ -> LSP.LspFuncs Config+ -> IdeState+ -> DocumentSymbolParams+ -> IO (Either ResponseError DSResult)+makeSymbols sps lf ideState params+ = do+ let uri' = params ^. textDocument . uri+ (C.ClientCapabilities _ tdc _ _) = LSP.clientCapabilities lf+ supportsHierarchy = fromMaybe False $ tdc >>= C._documentSymbol+ >>= C._hierarchicalDocumentSymbolSupport+ convertSymbols :: [DocumentSymbol] -> DSResult+ convertSymbols symbs+ | supportsHierarchy = DSDocumentSymbols $ List symbs+ | otherwise = DSSymbolInformation (List $ concatMap (go Nothing) symbs)+ where+ go :: Maybe T.Text -> DocumentSymbol -> [SymbolInformation]+ go parent ds =+ let children' :: [SymbolInformation]+ children' = concatMap (go (Just name')) (fromMaybe mempty (ds ^. children))+ loc = Location uri' (ds ^. range)+ name' = ds ^. name+ si = SymbolInformation name' (ds ^. kind) (ds ^. deprecated) loc parent+ in [si] <> children'++ mhs <- mapM (\(_,p) -> p lf ideState params) sps+ case rights mhs of+ [] -> return $ Left $ responseError $ T.pack $ show $ lefts mhs+ hs -> return $ Right $ convertSymbols $ concat hs+++-- ---------------------------------------------------------------------+-- ---------------------------------------------------------------------++renamePlugins :: [(PluginId, RenameProvider)] -> Plugin Config+renamePlugins providers = Plugin rules handlers+ where+ rules = mempty+ handlers = PartialHandlers $ \WithMessage{..} x -> return x+ { LSP.renameHandler = withResponse RspRename (renameWith providers)}++renameWith ::+ [(PluginId, RenameProvider)] ->+ LSP.LspFuncs Config ->+ IdeState ->+ RenameParams ->+ IO (Either ResponseError WorkspaceEdit)+renameWith providers lspFuncs state params = do+ results <- mapM (\(_,p) -> p lspFuncs state params) providers+ case partitionEithers results of+ (errors, []) -> return $ Left $ responseError $ T.pack $ show $ errors+ (_, edits) -> return $ Right $ mconcat edits++-- ---------------------------------------------------------------------+-- ---------------------------------------------------------------------++formatterPlugins :: [(PluginId, FormattingProvider IO)] -> Plugin Config+formatterPlugins providers+ = Plugin formatterRules+ (formatterHandlers (Map.fromList (("none",noneProvider):providers)))++formatterRules :: Rules ()+formatterRules = mempty++formatterHandlers :: Map.Map PluginId (FormattingProvider IO) -> PartialHandlers Config+formatterHandlers providers = PartialHandlers $ \WithMessage{..} x -> return x+ { LSP.documentFormattingHandler+ = withResponse RspDocumentFormatting (formatting providers)+ , LSP.documentRangeFormattingHandler+ = withResponse RspDocumentRangeFormatting (rangeFormatting providers)+ }++-- ---------------------------------------------------------------------+-- ---------------------------------------------------------------------++completionsPlugins :: [(PluginId, CompletionProvider)] -> Plugin Config+completionsPlugins cs = Plugin completionsRules (completionsHandlers cs)++completionsRules :: Rules ()+completionsRules = mempty++completionsHandlers :: [(PluginId, CompletionProvider)] -> PartialHandlers Config+completionsHandlers cps = PartialHandlers $ \WithMessage{..} x ->+ return x {LSP.completionHandler = withResponse RspCompletion (makeCompletions cps)}++makeCompletions :: [(PluginId, CompletionProvider)]+ -> LSP.LspFuncs Config+ -> IdeState+ -> CompletionParams+ -> IO (Either ResponseError CompletionResponseResult)+makeCompletions sps lf ideState params@(CompletionParams (TextDocumentIdentifier doc) pos _context _mt)+ = do+ mprefix <- getPrefixAtPos lf doc pos+ _snippets <- WithSnippets <$> completionSnippetsOn <$> (getClientConfig lf)++ let+ combine :: [CompletionResponseResult] -> CompletionResponseResult+ combine cs = go (Completions $ List []) cs+ where+ go acc [] = acc+ go (Completions (List ls)) (Completions (List ls2):rest)+ = go (Completions (List (ls <> ls2))) rest+ go (Completions (List ls)) (CompletionList (CompletionListType complete (List ls2)):rest)+ = go (CompletionList $ CompletionListType complete (List (ls <> ls2))) rest+ go (CompletionList (CompletionListType complete (List ls))) (CompletionList (CompletionListType complete2 (List ls2)):rest)+ = go (CompletionList $ CompletionListType (complete || complete2) (List (ls <> ls2))) rest+ go (CompletionList (CompletionListType complete (List ls))) (Completions (List ls2):rest)+ = go (CompletionList $ CompletionListType complete (List (ls <> ls2))) rest++ case mprefix of+ Nothing -> return $ Right $ Completions $ List []+ Just _prefix -> do+ mhs <- mapM (\(_,p) -> p lf ideState params) sps+ case rights mhs of+ [] -> return $ Left $ responseError $ T.pack $ show $ lefts mhs+ hs -> return $ Right $ combine hs++{-+ ReqCompletion req -> do+ liftIO $ U.logs $ "reactor:got CompletionRequest:" ++ show req+ let (_, doc, pos) = reqParams req++ mprefix <- getPrefixAtPos doc pos++ let callback compls = do+ let rspMsg = Core.makeResponseMessage req+ $ J.Completions $ J.List compls+ reactorSend $ RspCompletion rspMsg+ case mprefix of+ Nothing -> callback []+ Just prefix -> do+ snippets <- Completions.WithSnippets <$> configVal completionSnippetsOn+ let hreq = IReq tn "completion" (req ^. J.id) callback+ $ lift $ Completions.getCompletions doc prefix snippets+ makeRequest hreq+-}++getPrefixAtPos :: LSP.LspFuncs Config -> Uri -> Position -> IO (Maybe VFS.PosPrefixInfo)+getPrefixAtPos lf uri pos = do+ mvf <- (LSP.getVirtualFileFunc lf) (J.toNormalizedUri uri)+ case mvf of+ Just vf -> VFS.getCompletionPrefix pos vf+ Nothing -> return Nothing++-- ---------------------------------------------------------------------+-- | Returns the current client configuration. It is not wise to permanently+-- cache the returned value of this function, as clients can at runitime change+-- their configuration.+--+-- If no custom configuration has been set by the client, this function returns+-- our own defaults.+getClientConfig :: LSP.LspFuncs Config -> IO Config+getClientConfig lf = fromMaybe Data.Default.def <$> LSP.config lf++-- | Returns the client configurarion stored in the IdeState.+-- You can use this function to access it from shake Rules+getClientConfigAction :: Action Config+getClientConfigAction = do+ mbVal <- unhashed <$> useNoFile_ GetClientSettings+ logm $ "getClientConfigAction:clientSettings:" ++ show mbVal+ case J.fromJSON <$> mbVal of+ Just (J.Success c) -> return c+ _ -> return Data.Default.def+-- ---------------------------------------------------------------------
src/Ide/Plugin/Config.hs view
@@ -1,107 +1,107 @@-{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeFamilies #-} -module Ide.Plugin.Config - ( - getInitialConfig - , getConfigFromNotification - , Config(..) - ) where - -import Control.Applicative -import qualified Data.Aeson as A -import Data.Aeson hiding ( Error ) -import Data.Default -import qualified Data.Text as T -import Language.Haskell.LSP.Types - --- --------------------------------------------------------------------- - --- | Given a DidChangeConfigurationNotification message, this function returns the parsed --- Config object if possible. -getConfigFromNotification :: DidChangeConfigurationNotification -> Either T.Text Config -getConfigFromNotification (NotificationMessage _ _ (DidChangeConfigurationParams p)) = - case fromJSON p of - A.Success c -> Right c - A.Error err -> Left $ T.pack err - --- | Given an InitializeRequest message, this function returns the parsed --- Config object if possible. Otherwise, it returns the default configuration -getInitialConfig :: InitializeRequest -> Either T.Text Config -getInitialConfig (RequestMessage _ _ _ InitializeParams{_initializationOptions = Nothing }) = Right def -getInitialConfig (RequestMessage _ _ _ InitializeParams{_initializationOptions = Just opts}) = - case fromJSON opts of - A.Success c -> Right c - A.Error err -> Left $ T.pack err - --- --------------------------------------------------------------------- - --- | We (initially anyway) mirror the hie configuration, so that existing --- clients can simply switch executable and not have any nasty surprises. There --- will be surprises relating to config options being ignored, initially though. -data Config = - Config - { hlintOn :: Bool - , diagnosticsOnChange :: Bool - , maxNumberOfProblems :: Int - , diagnosticsDebounceDuration :: Int - , liquidOn :: Bool - , completionSnippetsOn :: Bool - , formatOnImportOn :: Bool - , formattingProvider :: T.Text - } deriving (Show,Eq) - -instance Default Config where - def = Config - { hlintOn = True - , diagnosticsOnChange = True - , maxNumberOfProblems = 100 - , diagnosticsDebounceDuration = 350000 - , liquidOn = False - , completionSnippetsOn = True - , formatOnImportOn = True - -- , formattingProvider = "brittany" - , formattingProvider = "ormolu" - -- , formattingProvider = "floskell" - -- , formattingProvider = "stylish-haskell" - } - --- TODO: Add API for plugins to expose their own LSP config options -instance A.FromJSON Config where - parseJSON = A.withObject "Config" $ \v -> do - -- Officially, we use "haskell" as the section name but for - -- backwards compatibility we also accept "languageServerHaskell" - s <- v .: "haskell" <|> v .: "languageServerHaskell" - flip (A.withObject "Config.settings") s $ \o -> Config - <$> o .:? "hlintOn" .!= hlintOn def - <*> o .:? "diagnosticsOnChange" .!= diagnosticsOnChange def - <*> o .:? "maxNumberOfProblems" .!= maxNumberOfProblems def - <*> o .:? "diagnosticsDebounceDuration" .!= diagnosticsDebounceDuration def - <*> o .:? "liquidOn" .!= liquidOn def - <*> o .:? "completionSnippetsOn" .!= completionSnippetsOn def - <*> o .:? "formatOnImportOn" .!= formatOnImportOn def - <*> o .:? "formattingProvider" .!= formattingProvider def - --- 2017-10-09 23:22:00.710515298 [ThreadId 11] - ---> {"jsonrpc":"2.0","method":"workspace/didChangeConfiguration","params":{"settings":{"haskell":{"maxNumberOfProblems":100,"hlintOn":true}}}} --- 2017-10-09 23:22:00.710667381 [ThreadId 15] - reactor:got didChangeConfiguration notification: --- NotificationMessage --- {_jsonrpc = "2.0" --- , _method = WorkspaceDidChangeConfiguration --- , _params = DidChangeConfigurationParams --- {_settings = Object (fromList [("haskell",Object (fromList [("hlintOn",Bool True) --- ,("maxNumberOfProblems",Number 100.0)]))])}} - -instance A.ToJSON Config where - toJSON (Config h diag m d l c f fp) = object [ "haskell" .= r ] - where - r = object [ "hlintOn" .= h - , "diagnosticsOnChange" .= diag - , "maxNumberOfProblems" .= m - , "diagnosticsDebounceDuration" .= d - , "liquidOn" .= l - , "completionSnippetsOn" .= c - , "formatOnImportOn" .= f - , "formattingProvider" .= fp - ] +{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeFamilies #-}+module Ide.Plugin.Config+ (+ getInitialConfig+ , getConfigFromNotification+ , Config(..)+ ) where++import Control.Applicative+import qualified Data.Aeson as A+import Data.Aeson hiding ( Error )+import Data.Default+import qualified Data.Text as T+import Language.Haskell.LSP.Types++-- ---------------------------------------------------------------------++-- | Given a DidChangeConfigurationNotification message, this function returns the parsed+-- Config object if possible.+getConfigFromNotification :: DidChangeConfigurationNotification -> Either T.Text Config+getConfigFromNotification (NotificationMessage _ _ (DidChangeConfigurationParams p)) =+ case fromJSON p of+ A.Success c -> Right c+ A.Error err -> Left $ T.pack err++-- | Given an InitializeRequest message, this function returns the parsed+-- Config object if possible. Otherwise, it returns the default configuration+getInitialConfig :: InitializeRequest -> Either T.Text Config+getInitialConfig (RequestMessage _ _ _ InitializeParams{_initializationOptions = Nothing }) = Right def+getInitialConfig (RequestMessage _ _ _ InitializeParams{_initializationOptions = Just opts}) =+ case fromJSON opts of+ A.Success c -> Right c+ A.Error err -> Left $ T.pack err++-- ---------------------------------------------------------------------++-- | We (initially anyway) mirror the hie configuration, so that existing+-- clients can simply switch executable and not have any nasty surprises. There+-- will be surprises relating to config options being ignored, initially though.+data Config =+ Config+ { hlintOn :: Bool+ , diagnosticsOnChange :: Bool+ , maxNumberOfProblems :: Int+ , diagnosticsDebounceDuration :: Int+ , liquidOn :: Bool+ , completionSnippetsOn :: Bool+ , formatOnImportOn :: Bool+ , formattingProvider :: T.Text+ } deriving (Show,Eq)++instance Default Config where+ def = Config+ { hlintOn = True+ , diagnosticsOnChange = True+ , maxNumberOfProblems = 100+ , diagnosticsDebounceDuration = 350000+ , liquidOn = False+ , completionSnippetsOn = True+ , formatOnImportOn = True+ -- , formattingProvider = "brittany"+ , formattingProvider = "ormolu"+ -- , formattingProvider = "floskell"+ -- , formattingProvider = "stylish-haskell"+ }++-- TODO: Add API for plugins to expose their own LSP config options+instance A.FromJSON Config where+ parseJSON = A.withObject "Config" $ \v -> do+ -- Officially, we use "haskell" as the section name but for+ -- backwards compatibility we also accept "languageServerHaskell"+ s <- v .: "haskell" <|> v .: "languageServerHaskell"+ flip (A.withObject "Config.settings") s $ \o -> Config+ <$> o .:? "hlintOn" .!= hlintOn def+ <*> o .:? "diagnosticsOnChange" .!= diagnosticsOnChange def+ <*> o .:? "maxNumberOfProblems" .!= maxNumberOfProblems def+ <*> o .:? "diagnosticsDebounceDuration" .!= diagnosticsDebounceDuration def+ <*> o .:? "liquidOn" .!= liquidOn def+ <*> o .:? "completionSnippetsOn" .!= completionSnippetsOn def+ <*> o .:? "formatOnImportOn" .!= formatOnImportOn def+ <*> o .:? "formattingProvider" .!= formattingProvider def++-- 2017-10-09 23:22:00.710515298 [ThreadId 11] - ---> {"jsonrpc":"2.0","method":"workspace/didChangeConfiguration","params":{"settings":{"haskell":{"maxNumberOfProblems":100,"hlintOn":true}}}}+-- 2017-10-09 23:22:00.710667381 [ThreadId 15] - reactor:got didChangeConfiguration notification:+-- NotificationMessage+-- {_jsonrpc = "2.0"+-- , _method = WorkspaceDidChangeConfiguration+-- , _params = DidChangeConfigurationParams+-- {_settings = Object (fromList [("haskell",Object (fromList [("hlintOn",Bool True)+-- ,("maxNumberOfProblems",Number 100.0)]))])}}++instance A.ToJSON Config where+ toJSON (Config h diag m d l c f fp) = object [ "haskell" .= r ]+ where+ r = object [ "hlintOn" .= h+ , "diagnosticsOnChange" .= diag+ , "maxNumberOfProblems" .= m+ , "diagnosticsDebounceDuration" .= d+ , "liquidOn" .= l+ , "completionSnippetsOn" .= c+ , "formatOnImportOn" .= f+ , "formattingProvider" .= fp+ ]
src/Ide/Plugin/Formatter.hs view
@@ -1,98 +1,110 @@-{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE ViewPatterns #-} - -module Ide.Plugin.Formatter - ( - formatting - , rangeFormatting - , noneProvider - , responseError - , extractRange - , fullRange - ) -where - -import qualified Data.Map as Map -import qualified Data.Text as T -import Development.IDE -import Ide.Types -import Ide.Plugin.Config -import qualified Language.Haskell.LSP.Core as LSP -import Language.Haskell.LSP.Types -import Text.Regex.TDFA.Text() - --- --------------------------------------------------------------------- - -formatting :: Map.Map PluginId (FormattingProvider IO) - -> LSP.LspFuncs Config -> IdeState -> DocumentFormattingParams - -> IO (Either ResponseError (List TextEdit)) -formatting providers lf ideState - (DocumentFormattingParams (TextDocumentIdentifier uri) params _mprogress) - = doFormatting lf providers ideState FormatText uri params - --- --------------------------------------------------------------------- - -rangeFormatting :: Map.Map PluginId (FormattingProvider IO) - -> LSP.LspFuncs Config -> IdeState -> DocumentRangeFormattingParams - -> IO (Either ResponseError (List TextEdit)) -rangeFormatting providers lf ideState - (DocumentRangeFormattingParams (TextDocumentIdentifier uri) range params _mprogress) - = doFormatting lf providers ideState (FormatRange range) uri params - --- --------------------------------------------------------------------- - -doFormatting :: LSP.LspFuncs Config -> Map.Map PluginId (FormattingProvider IO) - -> IdeState -> FormattingType -> Uri -> FormattingOptions - -> IO (Either ResponseError (List TextEdit)) -doFormatting lf providers ideState ft uri params = do - mc <- LSP.config lf - let mf = maybe "none" formattingProvider mc - case Map.lookup (PluginId mf) providers of - Just provider -> - case uriToFilePath uri of - Just (toNormalizedFilePath -> fp) -> do - (_, mb_contents) <- runAction "Formatter" ideState $ getFileContents fp - case mb_contents of - Just contents -> do - logDebug (ideLogger ideState) $ T.pack $ - "Formatter.doFormatting: contents=" ++ show contents -- AZ - provider lf ideState ft contents fp params - Nothing -> return $ Left $ responseError $ T.pack $ "Formatter plugin: could not get file contents for " ++ show uri - Nothing -> return $ Left $ responseError $ T.pack $ "Formatter plugin: uriToFilePath failed for: " ++ show uri - Nothing -> return $ Left $ responseError $ T.pack $ "Formatter plugin: no formatter found for:[" ++ T.unpack mf ++ "]" - --- --------------------------------------------------------------------- - -noneProvider :: FormattingProvider IO -noneProvider _ _ _ _ _ _ = return $ Right (List []) - --- --------------------------------------------------------------------- - -responseError :: T.Text -> ResponseError -responseError txt = ResponseError InvalidParams txt Nothing - --- --------------------------------------------------------------------- - -extractRange :: Range -> T.Text -> T.Text -extractRange (Range (Position sl _) (Position el _)) s = newS - where focusLines = take (el-sl+1) $ drop sl $ T.lines s - newS = T.unlines focusLines - --- | Gets the range that covers the entire text -fullRange :: T.Text -> Range -fullRange s = Range startPos endPos - where startPos = Position 0 0 - endPos = Position lastLine 0 - {- - In order to replace everything including newline characters, - the end range should extend below the last line. From the specification: - "If you want to specify a range that contains a line including - the line ending character(s) then use an end position denoting - the start of the next line" - -} - lastLine = length $ T.lines s - --- --------------------------------------------------------------------- +{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE ViewPatterns #-}++module Ide.Plugin.Formatter+ (+ formatting+ , rangeFormatting+ , noneProvider+ , responseError+ , extractRange+ , fullRange+ )+where++import qualified Data.Map as Map+import qualified Data.Text as T+import Development.IDE+import Ide.Types+import Ide.Plugin.Config+import qualified Language.Haskell.LSP.Core as LSP+import Language.Haskell.LSP.Types+import Text.Regex.TDFA.Text()++-- ---------------------------------------------------------------------++formatting :: Map.Map PluginId (FormattingProvider IO)+ -> LSP.LspFuncs Config -> IdeState -> DocumentFormattingParams+ -> IO (Either ResponseError (List TextEdit))+formatting providers lf ideState+ (DocumentFormattingParams (TextDocumentIdentifier uri) params _mprogress)+ = doFormatting lf providers ideState FormatText uri params++-- ---------------------------------------------------------------------++rangeFormatting :: Map.Map PluginId (FormattingProvider IO)+ -> LSP.LspFuncs Config -> IdeState -> DocumentRangeFormattingParams+ -> IO (Either ResponseError (List TextEdit))+rangeFormatting providers lf ideState+ (DocumentRangeFormattingParams (TextDocumentIdentifier uri) range params _mprogress)+ = doFormatting lf providers ideState (FormatRange range) uri params++-- ---------------------------------------------------------------------++doFormatting :: LSP.LspFuncs Config -> Map.Map PluginId (FormattingProvider IO)+ -> IdeState -> FormattingType -> Uri -> FormattingOptions+ -> IO (Either ResponseError (List TextEdit))+doFormatting lf providers ideState ft uri params = do+ mc <- LSP.config lf+ let mf = maybe "none" formattingProvider mc+ case Map.lookup (PluginId mf) providers of+ Just provider ->+ case uriToFilePath uri of+ Just (toNormalizedFilePath -> fp) -> do+ (_, mb_contents) <- runAction "Formatter" ideState $ getFileContents fp+ case mb_contents of+ Just contents -> do+ logDebug (ideLogger ideState) $ T.pack $+ "Formatter.doFormatting: contents=" ++ show contents -- AZ+ provider lf ideState ft contents fp params+ Nothing -> return $ Left $ responseError $ T.pack $ "Formatter plugin: could not get file contents for " ++ show uri+ Nothing -> return $ Left $ responseError $ T.pack $ "Formatter plugin: uriToFilePath failed for: " ++ show uri+ Nothing -> return $ Left $ responseError $ mconcat+ [ "Formatter plugin: no formatter found for:["+ , mf+ , "]"+ , if mf == "brittany"+ then T.unlines+ [ "\nThe haskell-language-server must be compiled with the agpl flag to provide Brittany."+ , "Stack users add 'agpl: true' in the flags section of the 'stack.yaml' file."+ , "The 'haskell-language-server.cabal' file already has this flag enabled by default."+ , "For more information see: https://github.com/haskell/haskell-language-server/issues/269"+ ]+ else ""+ ]++-- ---------------------------------------------------------------------++noneProvider :: FormattingProvider IO+noneProvider _ _ _ _ _ _ = return $ Right (List [])++-- ---------------------------------------------------------------------++responseError :: T.Text -> ResponseError+responseError txt = ResponseError InvalidParams txt Nothing++-- ---------------------------------------------------------------------++extractRange :: Range -> T.Text -> T.Text+extractRange (Range (Position sl _) (Position el _)) s = newS+ where focusLines = take (el-sl+1) $ drop sl $ T.lines s+ newS = T.unlines focusLines++-- | Gets the range that covers the entire text+fullRange :: T.Text -> Range+fullRange s = Range startPos endPos+ where startPos = Position 0 0+ endPos = Position lastLine 0+ {-+ In order to replace everything including newline characters,+ the end range should extend below the last line. From the specification:+ "If you want to specify a range that contains a line including+ the line ending character(s) then use an end position denoting+ the start of the next line"+ -}+ lastLine = length $ T.lines s++-- ---------------------------------------------------------------------
src/Ide/Plugin/GhcIde.hs view
@@ -1,65 +1,65 @@-{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE OverloadedStrings #-} -module Ide.Plugin.GhcIde - ( - descriptor - ) where - -import Data.Aeson -import Development.IDE -import Development.IDE.Plugin.Completions -import Development.IDE.Plugin.CodeAction -import Development.IDE.LSP.HoverDefinition -import Development.IDE.LSP.Outline -import Ide.Plugin -import Ide.Types -import Language.Haskell.LSP.Types -import Text.Regex.TDFA.Text() - --- --------------------------------------------------------------------- - -descriptor :: PluginId -> PluginDescriptor -descriptor plId = (defaultPluginDescriptor plId) - { pluginCommands = [PluginCommand (CommandId "typesignature.add") "adds a signature" commandAddSignature] - , pluginCodeActionProvider = Just codeAction' - , pluginCodeLensProvider = Just codeLens' - , pluginHoverProvider = Just hover' - , pluginSymbolsProvider = Just symbolsProvider - , pluginCompletionProvider = Just getCompletionsLSP - } - --- --------------------------------------------------------------------- - -hover' :: HoverProvider -hover' ideState params = do - logInfo (ideLogger ideState) "GhcIde.hover entered (ideLogger)" -- AZ - hover ideState params - --- --------------------------------------------------------------------- - -commandAddSignature :: CommandFunction WorkspaceEdit -commandAddSignature lf ide params - = commandHandler lf ide (ExecuteCommandParams "typesignature.add" (Just (List [toJSON params])) Nothing) - --- --------------------------------------------------------------------- - -codeAction' :: CodeActionProvider -codeAction' lf ide _ doc range context = fmap List <$> codeAction lf ide doc range context - --- --------------------------------------------------------------------- - -codeLens' :: CodeLensProvider -codeLens' lf ide _ params = codeLens lf ide params - --- --------------------------------------------------------------------- - -symbolsProvider :: SymbolsProvider -symbolsProvider ls ide params = do - ds <- moduleOutline ls ide params - case ds of - Right (DSDocumentSymbols (List ls)) -> return $ Right ls - Right (DSSymbolInformation (List _si)) -> - return $ Left $ responseError "GhcIde.symbolsProvider: DSSymbolInformation deprecated" - Left err -> return $ Left err - --- --------------------------------------------------------------------- +{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE OverloadedStrings #-}+module Ide.Plugin.GhcIde+ (+ descriptor+ ) where++import Data.Aeson+import Development.IDE+import Development.IDE.Plugin.Completions+import Development.IDE.Plugin.CodeAction+import Development.IDE.LSP.HoverDefinition+import Development.IDE.LSP.Outline+import Ide.Plugin+import Ide.Types+import Language.Haskell.LSP.Types+import Text.Regex.TDFA.Text()++-- ---------------------------------------------------------------------++descriptor :: PluginId -> PluginDescriptor+descriptor plId = (defaultPluginDescriptor plId)+ { pluginCommands = [PluginCommand (CommandId "typesignature.add") "adds a signature" commandAddSignature]+ , pluginCodeActionProvider = Just codeAction'+ , pluginCodeLensProvider = Just codeLens'+ , pluginHoverProvider = Just hover'+ , pluginSymbolsProvider = Just symbolsProvider+ , pluginCompletionProvider = Just getCompletionsLSP+ }++-- ---------------------------------------------------------------------++hover' :: HoverProvider+hover' ideState params = do+ logInfo (ideLogger ideState) "GhcIde.hover entered (ideLogger)" -- AZ+ hover ideState params++-- ---------------------------------------------------------------------++commandAddSignature :: CommandFunction WorkspaceEdit+commandAddSignature lf ide params+ = commandHandler lf ide (ExecuteCommandParams "typesignature.add" (Just (List [toJSON params])) Nothing)++-- ---------------------------------------------------------------------++codeAction' :: CodeActionProvider+codeAction' lf ide _ doc range context = fmap List <$> codeAction lf ide doc range context++-- ---------------------------------------------------------------------++codeLens' :: CodeLensProvider+codeLens' lf ide _ params = codeLens lf ide params++-- ---------------------------------------------------------------------++symbolsProvider :: SymbolsProvider+symbolsProvider ls ide params = do+ ds <- moduleOutline ls ide params+ case ds of+ Right (DSDocumentSymbols (List ls)) -> return $ Right ls+ Right (DSSymbolInformation (List _si)) ->+ return $ Left $ responseError "GhcIde.symbolsProvider: DSSymbolInformation deprecated"+ Left err -> return $ Left err++-- ---------------------------------------------------------------------
src/Ide/PluginUtils.hs view
@@ -1,110 +1,110 @@-{-# LANGUAGE OverloadedStrings #-} -module Ide.PluginUtils where - -import qualified Data.Text as T -import Data.Maybe -import Data.Algorithm.DiffOutput -import Data.Algorithm.Diff -import qualified Data.HashMap.Strict as H -import Language.Haskell.LSP.Types.Capabilities -import qualified Language.Haskell.LSP.Types as J -import Language.Haskell.LSP.Types - --- --------------------------------------------------------------------- - --- | Extend to the line below and above to replace newline character. -normalize :: Range -> Range -normalize (Range (Position sl _) (Position el _)) = - Range (Position sl 0) (Position (el + 1) 0) - --- --------------------------------------------------------------------- - -data WithDeletions = IncludeDeletions | SkipDeletions - deriving Eq - --- | Generate a 'WorkspaceEdit' value from a pair of source Text -diffText :: ClientCapabilities -> (Uri,T.Text) -> T.Text -> WithDeletions -> WorkspaceEdit -diffText clientCaps old new withDeletions = - let - supports = clientSupportsDocumentChanges clientCaps - in diffText' supports old new withDeletions - -makeDiffTextEdit :: T.Text -> T.Text -> List TextEdit -makeDiffTextEdit f1 f2 = diffTextEdit f1 f2 IncludeDeletions - -makeDiffTextEditAdditive :: T.Text -> T.Text -> List TextEdit -makeDiffTextEditAdditive f1 f2 = diffTextEdit f1 f2 SkipDeletions - -diffTextEdit :: T.Text -> T.Text -> WithDeletions -> List TextEdit -diffTextEdit fText f2Text withDeletions = J.List r - where - r = map diffOperationToTextEdit diffOps - d = getGroupedDiff (lines $ T.unpack fText) (lines $ T.unpack f2Text) - - diffOps = filter (\x -> (withDeletions == IncludeDeletions) || not (isDeletion x)) - (diffToLineRanges d) - - isDeletion (Deletion _ _) = True - isDeletion _ = False - - - diffOperationToTextEdit :: DiffOperation LineRange -> J.TextEdit - diffOperationToTextEdit (Change fm to) = J.TextEdit range nt - where - range = calcRange fm - nt = T.pack $ init $ unlines $ lrContents to - - {- - In order to replace everything including newline characters, - the end range should extend below the last line. From the specification: - "If you want to specify a range that contains a line including - the line ending character(s) then use an end position denoting - the start of the next line" - -} - diffOperationToTextEdit (Deletion (LineRange (sl, el) _) _) = J.TextEdit range "" - where - range = J.Range (J.Position (sl - 1) 0) - (J.Position el 0) - - diffOperationToTextEdit (Addition fm l) = J.TextEdit range nt - -- fm has a range wrt to the changed file, which starts in the current file at l + 1 - -- So the range has to be shifted to start at l + 1 - where - range = J.Range (J.Position l 0) - (J.Position l 0) - nt = T.pack $ unlines $ lrContents fm - - - calcRange fm = J.Range s e - where - sl = fst $ lrNumbers fm - sc = 0 - s = J.Position (sl - 1) sc -- Note: zero-based lines - el = snd $ lrNumbers fm - ec = length $ last $ lrContents fm - e = J.Position (el - 1) ec -- Note: zero-based lines - - --- | A pure version of 'diffText' for testing -diffText' :: Bool -> (Uri,T.Text) -> T.Text -> WithDeletions -> WorkspaceEdit -diffText' supports (f,fText) f2Text withDeletions = - if supports - then WorkspaceEdit Nothing (Just docChanges) - else WorkspaceEdit (Just h) Nothing - where - diff = diffTextEdit fText f2Text withDeletions - h = H.singleton f diff - docChanges = J.List [docEdit] - docEdit = J.TextDocumentEdit (J.VersionedTextDocumentIdentifier f (Just 0)) diff - --- --------------------------------------------------------------------- - -clientSupportsDocumentChanges :: ClientCapabilities -> Bool -clientSupportsDocumentChanges caps = - let ClientCapabilities mwCaps _ _ _ = caps - supports = do - wCaps <- mwCaps - WorkspaceEditClientCapabilities mDc <- _workspaceEdit wCaps - mDc - in - fromMaybe False supports +{-# LANGUAGE OverloadedStrings #-}+module Ide.PluginUtils where++import qualified Data.Text as T+import Data.Maybe+import Data.Algorithm.DiffOutput+import Data.Algorithm.Diff+import qualified Data.HashMap.Strict as H+import Language.Haskell.LSP.Types.Capabilities+import qualified Language.Haskell.LSP.Types as J+import Language.Haskell.LSP.Types++-- ---------------------------------------------------------------------++-- | Extend to the line below and above to replace newline character.+normalize :: Range -> Range+normalize (Range (Position sl _) (Position el _)) =+ Range (Position sl 0) (Position (el + 1) 0)++-- ---------------------------------------------------------------------++data WithDeletions = IncludeDeletions | SkipDeletions+ deriving Eq++-- | Generate a 'WorkspaceEdit' value from a pair of source Text+diffText :: ClientCapabilities -> (Uri,T.Text) -> T.Text -> WithDeletions -> WorkspaceEdit+diffText clientCaps old new withDeletions =+ let+ supports = clientSupportsDocumentChanges clientCaps+ in diffText' supports old new withDeletions++makeDiffTextEdit :: T.Text -> T.Text -> List TextEdit+makeDiffTextEdit f1 f2 = diffTextEdit f1 f2 IncludeDeletions++makeDiffTextEditAdditive :: T.Text -> T.Text -> List TextEdit+makeDiffTextEditAdditive f1 f2 = diffTextEdit f1 f2 SkipDeletions++diffTextEdit :: T.Text -> T.Text -> WithDeletions -> List TextEdit+diffTextEdit fText f2Text withDeletions = J.List r+ where+ r = map diffOperationToTextEdit diffOps+ d = getGroupedDiff (lines $ T.unpack fText) (lines $ T.unpack f2Text)++ diffOps = filter (\x -> (withDeletions == IncludeDeletions) || not (isDeletion x))+ (diffToLineRanges d)++ isDeletion (Deletion _ _) = True+ isDeletion _ = False+++ diffOperationToTextEdit :: DiffOperation LineRange -> J.TextEdit+ diffOperationToTextEdit (Change fm to) = J.TextEdit range nt+ where+ range = calcRange fm+ nt = T.pack $ init $ unlines $ lrContents to++ {-+ In order to replace everything including newline characters,+ the end range should extend below the last line. From the specification:+ "If you want to specify a range that contains a line including+ the line ending character(s) then use an end position denoting+ the start of the next line"+ -}+ diffOperationToTextEdit (Deletion (LineRange (sl, el) _) _) = J.TextEdit range ""+ where+ range = J.Range (J.Position (sl - 1) 0)+ (J.Position el 0)++ diffOperationToTextEdit (Addition fm l) = J.TextEdit range nt+ -- fm has a range wrt to the changed file, which starts in the current file at l + 1+ -- So the range has to be shifted to start at l + 1+ where+ range = J.Range (J.Position l 0)+ (J.Position l 0)+ nt = T.pack $ unlines $ lrContents fm+++ calcRange fm = J.Range s e+ where+ sl = fst $ lrNumbers fm+ sc = 0+ s = J.Position (sl - 1) sc -- Note: zero-based lines+ el = snd $ lrNumbers fm+ ec = length $ last $ lrContents fm+ e = J.Position (el - 1) ec -- Note: zero-based lines+++-- | A pure version of 'diffText' for testing+diffText' :: Bool -> (Uri,T.Text) -> T.Text -> WithDeletions -> WorkspaceEdit+diffText' supports (f,fText) f2Text withDeletions =+ if supports+ then WorkspaceEdit Nothing (Just docChanges)+ else WorkspaceEdit (Just h) Nothing+ where+ diff = diffTextEdit fText f2Text withDeletions+ h = H.singleton f diff+ docChanges = J.List [docEdit]+ docEdit = J.TextDocumentEdit (J.VersionedTextDocumentIdentifier f (Just 0)) diff++-- ---------------------------------------------------------------------++clientSupportsDocumentChanges :: ClientCapabilities -> Bool+clientSupportsDocumentChanges caps =+ let ClientCapabilities mwCaps _ _ _ = caps+ supports = do+ wCaps <- mwCaps+ WorkspaceEditClientCapabilities mDc <- _workspaceEdit wCaps+ mDc+ in+ fromMaybe False supports
src/Ide/Types.hs view
@@ -1,204 +1,204 @@-{-# LANGUAGE GADTs #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} - -module Ide.Types - ( - IdePlugins(..) - , PluginDescriptor(..) - , defaultPluginDescriptor - , PluginCommand(..) - , PluginId(..) - , CommandId(..) - , DiagnosticProvider(..) - , DiagnosticProviderFunc(..) - , SymbolsProvider - , FormattingType(..) - , FormattingProvider - , HoverProvider - , CodeActionProvider - , CodeLensProvider - , CommandFunction - , ExecuteCommandProvider - , CompletionProvider - , RenameProvider - , WithSnippets(..) - ) where - -import Data.Aeson hiding (defaultOptions) -import qualified Data.Map as Map -import qualified Data.Set as S -import Data.String -import qualified Data.Text as T -import Development.IDE -import Ide.Plugin.Config -import qualified Language.Haskell.LSP.Core as LSP -import Language.Haskell.LSP.Types -import Text.Regex.TDFA.Text() - --- --------------------------------------------------------------------- - -newtype IdePlugins = IdePlugins - { ipMap :: Map.Map PluginId PluginDescriptor - } - --- --------------------------------------------------------------------- - -data PluginDescriptor = - PluginDescriptor { pluginId :: !PluginId - , pluginRules :: !(Rules ()) - , pluginCommands :: ![PluginCommand] - , pluginCodeActionProvider :: !(Maybe CodeActionProvider) - , pluginCodeLensProvider :: !(Maybe CodeLensProvider) - , pluginDiagnosticProvider :: !(Maybe DiagnosticProvider) - -- ^ TODO: diagnostics are generally provided via rules, - -- this is probably redundant. - , pluginHoverProvider :: !(Maybe HoverProvider) - , pluginSymbolsProvider :: !(Maybe SymbolsProvider) - , pluginFormattingProvider :: !(Maybe (FormattingProvider IO)) - , pluginCompletionProvider :: !(Maybe CompletionProvider) - , pluginRenameProvider :: !(Maybe RenameProvider) - } - -defaultPluginDescriptor :: PluginId -> PluginDescriptor -defaultPluginDescriptor plId = - PluginDescriptor - plId - mempty - mempty - Nothing - Nothing - Nothing - Nothing - Nothing - Nothing - Nothing - Nothing - --- instance Show PluginCommand where --- show (PluginCommand i _ _) = "PluginCommand { name = " ++ show i ++ " }" - --- newtype CommandId = CommandId T.Text --- deriving (Show, Read, Eq, Ord) --- instance IsString CommandId where --- fromString = CommandId . T.pack - --- data PluginCommand = forall a b. (FromJSON a, ToJSON b, Typeable b) => --- PluginCommand { commandId :: CommandId --- , commandDesc :: T.Text --- , commandFunc :: a -> IO (Either ResponseError b) --- } - -newtype CommandId = CommandId T.Text - deriving (Show, Read, Eq, Ord) -instance IsString CommandId where - fromString = CommandId . T.pack - -data PluginCommand = forall a. (FromJSON a) => - PluginCommand { commandId :: CommandId - , commandDesc :: T.Text - , commandFunc :: CommandFunction a - } - --- --------------------------------------------------------------------- - -type CommandFunction a = LSP.LspFuncs Config - -> IdeState - -> a - -> IO (Either ResponseError Value, Maybe (ServerMethod, ApplyWorkspaceEditParams)) - -type CodeActionProvider = LSP.LspFuncs Config - -> IdeState - -> PluginId - -> TextDocumentIdentifier - -> Range - -> CodeActionContext - -> IO (Either ResponseError (List CAResult)) - -type CompletionProvider = LSP.LspFuncs Config - -> IdeState - -> CompletionParams - -> IO (Either ResponseError CompletionResponseResult) - - - -type CodeLensProvider = LSP.LspFuncs Config - -> IdeState - -> PluginId - -> CodeLensParams - -> IO (Either ResponseError (List CodeLens)) - -type RenameProvider = LSP.LspFuncs Config - -> IdeState - -> RenameParams - -> IO (Either ResponseError WorkspaceEdit) - -type DiagnosticProviderFuncSync - = DiagnosticTrigger -> Uri - -> IO (Either ResponseError (Map.Map Uri (S.Set Diagnostic))) - -type DiagnosticProviderFuncAsync - = DiagnosticTrigger -> Uri - -> (Map.Map Uri (S.Set Diagnostic) -> IO ()) - -> IO (Either ResponseError ()) - -data DiagnosticProviderFunc - = DiagnosticProviderSync DiagnosticProviderFuncSync - | DiagnosticProviderAsync DiagnosticProviderFuncAsync - - -data DiagnosticProvider = DiagnosticProvider - { dpTrigger :: S.Set DiagnosticTrigger -- AZ:should this be a NonEmptyList? - , dpFunc :: DiagnosticProviderFunc - } - -data DiagnosticTrigger = DiagnosticOnOpen - | DiagnosticOnChange - | DiagnosticOnSave - deriving (Show,Ord,Eq) - --- type HoverProvider = Uri -> Position -> IO (Either ResponseError [Hover]) -type HoverProvider = IdeState -> TextDocumentPositionParams -> IO (Either ResponseError (Maybe Hover)) - -type SymbolsProvider = LSP.LspFuncs Config - -> IdeState - -> DocumentSymbolParams - -> IO (Either ResponseError [DocumentSymbol]) - -type ExecuteCommandProvider = IdeState - -> ExecuteCommandParams - -> IO (Either ResponseError Value, Maybe (ServerMethod, ApplyWorkspaceEditParams)) - -newtype WithSnippets = WithSnippets Bool - --- --------------------------------------------------------------------- - -newtype PluginId = PluginId T.Text - deriving (Show, Read, Eq, Ord) -instance IsString PluginId where - fromString = PluginId . T.pack - --- --------------------------------------------------------------------- - - --- | Format the given Text as a whole or only a @Range@ of it. --- Range must be relative to the text to format. --- To format the whole document, read the Text from the file and use 'FormatText' --- as the FormattingType. -data FormattingType = FormatText - | FormatRange Range - - --- | To format a whole document, the 'FormatText' @FormattingType@ can be used. --- It is required to pass in the whole Document Text for that to happen, an empty text --- and file uri, does not suffice. -type FormattingProvider m - = LSP.LspFuncs Config - -> IdeState - -> FormattingType -- ^ How much to format - -> T.Text -- ^ Text to format - -> NormalizedFilePath -- ^ location of the file being formatted - -> FormattingOptions -- ^ Options for the formatter - -> m (Either ResponseError (List TextEdit)) -- ^ Result of the formatting - --- --------------------------------------------------------------------- +{-# LANGUAGE GADTs #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Ide.Types+ (+ IdePlugins(..)+ , PluginDescriptor(..)+ , defaultPluginDescriptor+ , PluginCommand(..)+ , PluginId(..)+ , CommandId(..)+ , DiagnosticProvider(..)+ , DiagnosticProviderFunc(..)+ , SymbolsProvider+ , FormattingType(..)+ , FormattingProvider+ , HoverProvider+ , CodeActionProvider+ , CodeLensProvider+ , CommandFunction+ , ExecuteCommandProvider+ , CompletionProvider+ , RenameProvider+ , WithSnippets(..)+ ) where++import Data.Aeson hiding (defaultOptions)+import qualified Data.Map as Map+import qualified Data.Set as S+import Data.String+import qualified Data.Text as T+import Development.IDE+import Ide.Plugin.Config+import qualified Language.Haskell.LSP.Core as LSP+import Language.Haskell.LSP.Types+import Text.Regex.TDFA.Text()++-- ---------------------------------------------------------------------++newtype IdePlugins = IdePlugins+ { ipMap :: Map.Map PluginId PluginDescriptor+ }++-- ---------------------------------------------------------------------++data PluginDescriptor =+ PluginDescriptor { pluginId :: !PluginId+ , pluginRules :: !(Rules ())+ , pluginCommands :: ![PluginCommand]+ , pluginCodeActionProvider :: !(Maybe CodeActionProvider)+ , pluginCodeLensProvider :: !(Maybe CodeLensProvider)+ , pluginDiagnosticProvider :: !(Maybe DiagnosticProvider)+ -- ^ TODO: diagnostics are generally provided via rules,+ -- this is probably redundant.+ , pluginHoverProvider :: !(Maybe HoverProvider)+ , pluginSymbolsProvider :: !(Maybe SymbolsProvider)+ , pluginFormattingProvider :: !(Maybe (FormattingProvider IO))+ , pluginCompletionProvider :: !(Maybe CompletionProvider)+ , pluginRenameProvider :: !(Maybe RenameProvider)+ }++defaultPluginDescriptor :: PluginId -> PluginDescriptor+defaultPluginDescriptor plId =+ PluginDescriptor+ plId+ mempty+ mempty+ Nothing+ Nothing+ Nothing+ Nothing+ Nothing+ Nothing+ Nothing+ Nothing++-- instance Show PluginCommand where+-- show (PluginCommand i _ _) = "PluginCommand { name = " ++ show i ++ " }"++-- newtype CommandId = CommandId T.Text+-- deriving (Show, Read, Eq, Ord)+-- instance IsString CommandId where+-- fromString = CommandId . T.pack++-- data PluginCommand = forall a b. (FromJSON a, ToJSON b, Typeable b) =>+-- PluginCommand { commandId :: CommandId+-- , commandDesc :: T.Text+-- , commandFunc :: a -> IO (Either ResponseError b)+-- }++newtype CommandId = CommandId T.Text+ deriving (Show, Read, Eq, Ord)+instance IsString CommandId where+ fromString = CommandId . T.pack++data PluginCommand = forall a. (FromJSON a) =>+ PluginCommand { commandId :: CommandId+ , commandDesc :: T.Text+ , commandFunc :: CommandFunction a+ }++-- ---------------------------------------------------------------------++type CommandFunction a = LSP.LspFuncs Config+ -> IdeState+ -> a+ -> IO (Either ResponseError Value, Maybe (ServerMethod, ApplyWorkspaceEditParams))++type CodeActionProvider = LSP.LspFuncs Config+ -> IdeState+ -> PluginId+ -> TextDocumentIdentifier+ -> Range+ -> CodeActionContext+ -> IO (Either ResponseError (List CAResult))++type CompletionProvider = LSP.LspFuncs Config+ -> IdeState+ -> CompletionParams+ -> IO (Either ResponseError CompletionResponseResult)++++type CodeLensProvider = LSP.LspFuncs Config+ -> IdeState+ -> PluginId+ -> CodeLensParams+ -> IO (Either ResponseError (List CodeLens))++type RenameProvider = LSP.LspFuncs Config+ -> IdeState+ -> RenameParams+ -> IO (Either ResponseError WorkspaceEdit)++type DiagnosticProviderFuncSync+ = DiagnosticTrigger -> Uri+ -> IO (Either ResponseError (Map.Map Uri (S.Set Diagnostic)))++type DiagnosticProviderFuncAsync+ = DiagnosticTrigger -> Uri+ -> (Map.Map Uri (S.Set Diagnostic) -> IO ())+ -> IO (Either ResponseError ())++data DiagnosticProviderFunc+ = DiagnosticProviderSync DiagnosticProviderFuncSync+ | DiagnosticProviderAsync DiagnosticProviderFuncAsync+++data DiagnosticProvider = DiagnosticProvider+ { dpTrigger :: S.Set DiagnosticTrigger -- AZ:should this be a NonEmptyList?+ , dpFunc :: DiagnosticProviderFunc+ }++data DiagnosticTrigger = DiagnosticOnOpen+ | DiagnosticOnChange+ | DiagnosticOnSave+ deriving (Show,Ord,Eq)++-- type HoverProvider = Uri -> Position -> IO (Either ResponseError [Hover])+type HoverProvider = IdeState -> TextDocumentPositionParams -> IO (Either ResponseError (Maybe Hover))++type SymbolsProvider = LSP.LspFuncs Config+ -> IdeState+ -> DocumentSymbolParams+ -> IO (Either ResponseError [DocumentSymbol])++type ExecuteCommandProvider = IdeState+ -> ExecuteCommandParams+ -> IO (Either ResponseError Value, Maybe (ServerMethod, ApplyWorkspaceEditParams))++newtype WithSnippets = WithSnippets Bool++-- ---------------------------------------------------------------------++newtype PluginId = PluginId T.Text+ deriving (Show, Read, Eq, Ord)+instance IsString PluginId where+ fromString = PluginId . T.pack++-- ---------------------------------------------------------------------+++-- | Format the given Text as a whole or only a @Range@ of it.+-- Range must be relative to the text to format.+-- To format the whole document, read the Text from the file and use 'FormatText'+-- as the FormattingType.+data FormattingType = FormatText+ | FormatRange Range+++-- | To format a whole document, the 'FormatText' @FormattingType@ can be used.+-- It is required to pass in the whole Document Text for that to happen, an empty text+-- and file uri, does not suffice.+type FormattingProvider m+ = LSP.LspFuncs Config+ -> IdeState+ -> FormattingType -- ^ How much to format+ -> T.Text -- ^ Text to format+ -> NormalizedFilePath -- ^ location of the file being formatted+ -> FormattingOptions -- ^ Options for the formatter+ -> m (Either ResponseError (List TextEdit)) -- ^ Result of the formatting++-- ---------------------------------------------------------------------