hls-plugin-api 0.7.1.0 → 1.0.0.0
raw patch · 6 files changed
+1070/−1077 lines, 6 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
- Ide.PluginUtils: getClientConfig :: MonadLsp Config m => m Config
+ Ide.PluginUtils: getClientConfig :: MonadLsp Config m => m (Maybe Config)
- Ide.PluginUtils: getPluginConfig :: MonadLsp Config m => PluginId -> m PluginConfig
+ Ide.PluginUtils: getPluginConfig :: MonadLsp Config m => PluginId -> m (Maybe PluginConfig)
Files
- LICENSE +201/−201
- hls-plugin-api.cabal +67/−67
- src/Ide/Logger.hs +29/−29
- src/Ide/Plugin/Config.hs +182/−181
- src/Ide/PluginUtils.hs +213/−220
- src/Ide/Types.hs +378/−379
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,67 +1,67 @@-cabal-version: 2.2-name: hls-plugin-api-version: 0.7.1.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: The Haskell IDE Team-maintainer: alan.zimm@gmail.com-copyright: The Haskell IDE Team-category: Development-build-type: Simple--flag pedantic- description: Enable -Werror- default: False- manual: True--source-repository head- type: git- location: https://github.com/haskell/haskell-language-server--library- exposed-modules:- Ide.Logger- Ide.Plugin.Config- Ide.PluginUtils- Ide.Types-- hs-source-dirs: src- build-depends:- , aeson- , base >=4.12 && <5- , containers- , data-default- , Diff- , lsp ^>=1.1.0- , hashable- , hslogger- , lens- , process- , regex-tdfa >=1.3.1.0- , shake >=0.17.5- , text- , unordered-containers- , dependent-map- , dependent-sum- , dlist- , opentelemetry-- if os(windows)- build-depends:- Win32- else- build-depends:- unix-- ghc-options: -Wall -Wredundant-constraints -Wno-name-shadowing -Wno-unticked-promoted-constructors-- if flag(pedantic)- ghc-options: -Werror-- default-language: Haskell2010- default-extensions: DataKinds, KindSignatures, TypeOperators+cabal-version: 2.2 +name: hls-plugin-api +version: 1.0.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: The Haskell IDE Team +maintainer: alan.zimm@gmail.com +copyright: The Haskell IDE Team +category: Development +build-type: Simple + +flag pedantic + description: Enable -Werror + default: False + manual: True + +source-repository head + type: git + location: https://github.com/haskell/haskell-language-server + +library + exposed-modules: + Ide.Logger + Ide.Plugin.Config + Ide.PluginUtils + Ide.Types + + hs-source-dirs: src + build-depends: + , aeson + , base >=4.12 && <5 + , containers + , data-default + , Diff + , lsp ^>=1.1.0 + , hashable + , hslogger + , lens + , process + , regex-tdfa >=1.3.1.0 + , shake >=0.17.5 + , text + , unordered-containers + , dependent-map + , dependent-sum + , dlist + , opentelemetry + + if os(windows) + build-depends: + Win32 + else + build-depends: + unix + + ghc-options: -Wall -Wredundant-constraints -Wno-name-shadowing -Wno-unticked-promoted-constructors + + if flag(pedantic) + ghc-options: -Werror + + default-language: Haskell2010 + default-extensions: DataKinds, KindSignatures, TypeOperators
src/Ide/Logger.hs view
@@ -1,29 +1,29 @@-{- | Provides an implementation of the ghcide @Logger@ which uses- @System.Log.Logger@ under the hood.--}-module Ide.Logger- (- logm- , debugm- , warningm- , errorm- ) where--import Control.Monad.IO.Class-import System.Log.Logger---- -----------------------------------------------------------------------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 + ( + logm + , debugm + , warningm + , errorm + ) where + +import Control.Monad.IO.Class +import System.Log.Logger + +-- --------------------------------------------------------------------- + +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/Config.hs view
@@ -1,181 +1,182 @@-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE DerivingStrategies #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TypeFamilies #-}-module Ide.Plugin.Config- ( getConfigFromNotification- , Config(..)- , parseConfig- , PluginConfig(..)- , CheckParents(..)- ) where--import Control.Applicative-import qualified Data.Aeson as A-import qualified Data.Aeson.Types as A-import Data.Aeson hiding ( Error )-import Data.Default-import qualified Data.Text as T-import qualified Data.Map as Map-import GHC.Generics (Generic)---- ------------------------------------------------------------------------- | Given a DidChangeConfigurationNotification message, this function returns the parsed--- Config object if possible.-getConfigFromNotification :: Config -> A.Value -> Either T.Text Config-getConfigFromNotification defaultValue p =- case A.parse (parseConfig defaultValue) p of- A.Success c -> Right c- A.Error err -> Left $ T.pack err---- ----------------------------------------------------------------------data CheckParents- -- Note that ordering of constructors is meaningful and must be monotonically- -- increasing in the scenarios where parents are checked- = NeverCheck- | CheckOnClose- | CheckOnSaveAndClose- | AlwaysCheck- deriving stock (Eq, Ord, Show, Generic)- deriving anyclass (FromJSON, ToJSON)---- | 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- { checkParents :: CheckParents- , checkProject :: !Bool- , hlintOn :: !Bool- , diagnosticsOnChange :: !Bool- , maxNumberOfProblems :: !Int- , diagnosticsDebounceDuration :: !Int- , liquidOn :: !Bool- , completionSnippetsOn :: !Bool- , formatOnImportOn :: !Bool- , formattingProvider :: !T.Text- , maxCompletions :: !Int- , plugins :: !(Map.Map T.Text PluginConfig)- } deriving (Show,Eq)--instance Default Config where- def = Config- { checkParents = CheckOnSaveAndClose- , checkProject = True- , hlintOn = True- , diagnosticsOnChange = True- , maxNumberOfProblems = 100- , diagnosticsDebounceDuration = 350000- , liquidOn = False- , completionSnippetsOn = True- , formatOnImportOn = True- -- , formattingProvider = "brittany"- , formattingProvider = "ormolu"- -- , formattingProvider = "floskell"- -- , formattingProvider = "stylish-haskell"- , maxCompletions = 40- , plugins = Map.empty- }---- TODO: Add API for plugins to expose their own LSP config options-parseConfig :: Config -> Value -> A.Parser Config-parseConfig defValue = A.withObject "Config" $ \v -> do- -- Officially, we use "haskell" as the section name but for- -- backwards compatibility we also accept "languageServerHaskell"- c <- v .: "haskell" <|> v .:? "languageServerHaskell"- case c of- Nothing -> return defValue- Just s -> flip (A.withObject "Config.settings") s $ \o -> Config- <$> (o .:? "checkParents" <|> v .:? "checkParents") .!= checkParents defValue- <*> (o .:? "checkProject" <|> v .:? "checkProject") .!= checkProject defValue- <*> o .:? "hlintOn" .!= hlintOn defValue- <*> o .:? "diagnosticsOnChange" .!= diagnosticsOnChange defValue- <*> o .:? "maxNumberOfProblems" .!= maxNumberOfProblems defValue- <*> o .:? "diagnosticsDebounceDuration" .!= diagnosticsDebounceDuration defValue- <*> o .:? "liquidOn" .!= liquidOn defValue- <*> o .:? "completionSnippetsOn" .!= completionSnippetsOn defValue- <*> o .:? "formatOnImportOn" .!= formatOnImportOn defValue- <*> o .:? "formattingProvider" .!= formattingProvider defValue- <*> o .:? "maxCompletions" .!= maxCompletions defValue- <*> o .:? "plugin" .!= plugins defValue--instance A.ToJSON Config where- toJSON Config{..} =- object [ "haskell" .= r ]- where- r = object [ "checkParents" .= checkParents- , "checkProject" .= checkProject- , "hlintOn" .= hlintOn- , "diagnosticsOnChange" .= diagnosticsOnChange- , "maxNumberOfProblems" .= maxNumberOfProblems- , "diagnosticsDebounceDuration" .= diagnosticsDebounceDuration- , "liquidOn" .= liquidOn- , "completionSnippetsOn" .= completionSnippetsOn- , "formatOnImportOn" .= formatOnImportOn- , "formattingProvider" .= formattingProvider- , "plugin" .= plugins- ]---- ------------------------------------------------------------------------- | A PluginConfig is a generic configuration for a given HLS plugin. It--- provides a "big switch" to turn it on or off as a whole, as well as small--- switches per feature, and a slot for custom config.--- This provides a regular naming scheme for all plugin config.-data PluginConfig =- PluginConfig- { plcGlobalOn :: !Bool- , plcCodeActionsOn :: !Bool- , plcCodeLensOn :: !Bool- , plcDiagnosticsOn :: !Bool- , plcHoverOn :: !Bool- , plcSymbolsOn :: !Bool- , plcCompletionOn :: !Bool- , plcRenameOn :: !Bool- , plcConfig :: !A.Object- } deriving (Show,Eq)--instance Default PluginConfig where- def = PluginConfig- { plcGlobalOn = True- , plcCodeActionsOn = True- , plcCodeLensOn = True- , plcDiagnosticsOn = True- , plcHoverOn = True- , plcSymbolsOn = True- , plcCompletionOn = True- , plcRenameOn = True- , plcConfig = mempty- }--instance A.ToJSON PluginConfig where- toJSON (PluginConfig g ca cl d h s c rn cfg) = r- where- r = object [ "globalOn" .= g- , "codeActionsOn" .= ca- , "codeLensOn" .= cl- , "diagnosticsOn" .= d- , "hoverOn" .= h- , "symbolsOn" .= s- , "completionOn" .= c- , "renameOn" .= rn- , "config" .= cfg- ]--instance A.FromJSON PluginConfig where- parseJSON = A.withObject "PluginConfig" $ \o -> PluginConfig- <$> o .:? "globalOn" .!= plcGlobalOn def- <*> o .:? "codeActionsOn" .!= plcCodeActionsOn def- <*> o .:? "codeLensOn" .!= plcCodeLensOn def- <*> o .:? "diagnosticsOn" .!= plcDiagnosticsOn def -- AZ- <*> o .:? "hoverOn" .!= plcHoverOn def- <*> o .:? "symbolsOn" .!= plcSymbolsOn def- <*> o .:? "completionOn" .!= plcCompletionOn def- <*> o .:? "renameOn" .!= plcRenameOn def- <*> o .:? "config" .!= plcConfig def---- ---------------------------------------------------------------------+{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} +module Ide.Plugin.Config + ( getConfigFromNotification + , Config(..) + , parseConfig + , PluginConfig(..) + , CheckParents(..) + ) where + +import Control.Applicative +import qualified Data.Aeson as A +import qualified Data.Aeson.Types as A +import Data.Aeson hiding ( Error ) +import Data.Default +import qualified Data.Text as T +import qualified Data.Map as Map +import GHC.Generics (Generic) + +-- --------------------------------------------------------------------- + +-- | Given a DidChangeConfigurationNotification message, this function returns the parsed +-- Config object if possible. +getConfigFromNotification :: Config -> A.Value -> Either T.Text Config +getConfigFromNotification defaultValue p = + case A.parse (parseConfig defaultValue) p of + A.Success c -> Right c + A.Error err -> Left $ T.pack err + +-- --------------------------------------------------------------------- +data CheckParents + -- Note that ordering of constructors is meaningful and must be monotonically + -- increasing in the scenarios where parents are checked + = NeverCheck + | CheckOnClose + | CheckOnSaveAndClose + | AlwaysCheck + deriving stock (Eq, Ord, Show, Generic) + deriving anyclass (FromJSON, ToJSON) + +-- | 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 + { checkParents :: CheckParents + , checkProject :: !Bool + , hlintOn :: !Bool + , diagnosticsOnChange :: !Bool + , maxNumberOfProblems :: !Int + , diagnosticsDebounceDuration :: !Int + , liquidOn :: !Bool + , completionSnippetsOn :: !Bool + , formatOnImportOn :: !Bool + , formattingProvider :: !T.Text + , maxCompletions :: !Int + , plugins :: !(Map.Map T.Text PluginConfig) + } deriving (Show,Eq) + +instance Default Config where + def = Config + { checkParents = CheckOnSaveAndClose + , checkProject = True + , hlintOn = True + , diagnosticsOnChange = True + , maxNumberOfProblems = 100 + , diagnosticsDebounceDuration = 350000 + , liquidOn = False + , completionSnippetsOn = True + , formatOnImportOn = True + -- , formattingProvider = "brittany" + , formattingProvider = "ormolu" + -- , formattingProvider = "floskell" + -- , formattingProvider = "stylish-haskell" + , maxCompletions = 40 + , plugins = Map.empty + } + +-- TODO: Add API for plugins to expose their own LSP config options +parseConfig :: Config -> Value -> A.Parser Config +parseConfig defValue = A.withObject "Config" $ \v -> do + -- Officially, we use "haskell" as the section name but for + -- backwards compatibility we also accept "languageServerHaskell" + c <- v .: "haskell" <|> v .:? "languageServerHaskell" + case c of + Nothing -> return defValue + Just s -> flip (A.withObject "Config.settings") s $ \o -> Config + <$> (o .:? "checkParents" <|> v .:? "checkParents") .!= checkParents defValue + <*> (o .:? "checkProject" <|> v .:? "checkProject") .!= checkProject defValue + <*> o .:? "hlintOn" .!= hlintOn defValue + <*> o .:? "diagnosticsOnChange" .!= diagnosticsOnChange defValue + <*> o .:? "maxNumberOfProblems" .!= maxNumberOfProblems defValue + <*> o .:? "diagnosticsDebounceDuration" .!= diagnosticsDebounceDuration defValue + <*> o .:? "liquidOn" .!= liquidOn defValue + <*> o .:? "completionSnippetsOn" .!= completionSnippetsOn defValue + <*> o .:? "formatOnImportOn" .!= formatOnImportOn defValue + <*> o .:? "formattingProvider" .!= formattingProvider defValue + <*> o .:? "maxCompletions" .!= maxCompletions defValue + <*> o .:? "plugin" .!= plugins defValue + +instance A.ToJSON Config where + toJSON Config{..} = + object [ "haskell" .= r ] + where + r = object [ "checkParents" .= checkParents + , "checkProject" .= checkProject + , "hlintOn" .= hlintOn + , "diagnosticsOnChange" .= diagnosticsOnChange + , "maxNumberOfProblems" .= maxNumberOfProblems + , "diagnosticsDebounceDuration" .= diagnosticsDebounceDuration + , "liquidOn" .= liquidOn + , "completionSnippetsOn" .= completionSnippetsOn + , "formatOnImportOn" .= formatOnImportOn + , "formattingProvider" .= formattingProvider + , "maxCompletions" .= maxCompletions + , "plugin" .= plugins + ] + +-- --------------------------------------------------------------------- + +-- | A PluginConfig is a generic configuration for a given HLS plugin. It +-- provides a "big switch" to turn it on or off as a whole, as well as small +-- switches per feature, and a slot for custom config. +-- This provides a regular naming scheme for all plugin config. +data PluginConfig = + PluginConfig + { plcGlobalOn :: !Bool + , plcCodeActionsOn :: !Bool + , plcCodeLensOn :: !Bool + , plcDiagnosticsOn :: !Bool + , plcHoverOn :: !Bool + , plcSymbolsOn :: !Bool + , plcCompletionOn :: !Bool + , plcRenameOn :: !Bool + , plcConfig :: !A.Object + } deriving (Show,Eq) + +instance Default PluginConfig where + def = PluginConfig + { plcGlobalOn = True + , plcCodeActionsOn = True + , plcCodeLensOn = True + , plcDiagnosticsOn = True + , plcHoverOn = True + , plcSymbolsOn = True + , plcCompletionOn = True + , plcRenameOn = True + , plcConfig = mempty + } + +instance A.ToJSON PluginConfig where + toJSON (PluginConfig g ca cl d h s c rn cfg) = r + where + r = object [ "globalOn" .= g + , "codeActionsOn" .= ca + , "codeLensOn" .= cl + , "diagnosticsOn" .= d + , "hoverOn" .= h + , "symbolsOn" .= s + , "completionOn" .= c + , "renameOn" .= rn + , "config" .= cfg + ] + +instance A.FromJSON PluginConfig where + parseJSON = A.withObject "PluginConfig" $ \o -> PluginConfig + <$> o .:? "globalOn" .!= plcGlobalOn def + <*> o .:? "codeActionsOn" .!= plcCodeActionsOn def + <*> o .:? "codeLensOn" .!= plcCodeLensOn def + <*> o .:? "diagnosticsOn" .!= plcDiagnosticsOn def -- AZ + <*> o .:? "hoverOn" .!= plcHoverOn def + <*> o .:? "symbolsOn" .!= plcSymbolsOn def + <*> o .:? "completionOn" .!= plcCompletionOn def + <*> o .:? "renameOn" .!= plcRenameOn def + <*> o .:? "config" .!= plcConfig def + +-- ---------------------------------------------------------------------
src/Ide/PluginUtils.hs view
@@ -1,220 +1,213 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE FlexibleContexts #-}-module Ide.PluginUtils- ( WithDeletions(..),- getProcessID,- normalize,- makeDiffTextEdit,- makeDiffTextEditAdditive,- diffText,- diffText',- pluginDescToIdePlugins,- responseError,- getClientConfig,- getPluginConfig,- configForPlugin,- pluginEnabled,- extractRange,- fullRange,- mkLspCommand,- mkLspCmdId,- getPid,- allLspCmdIds,allLspCmdIds',installSigUsr1Handler, subRange)-where---import Data.Algorithm.Diff-import Data.Algorithm.DiffOutput-import qualified Data.HashMap.Strict as H-import Data.Maybe-import qualified Data.Text as T-import Ide.Types-import Language.LSP.Types-import qualified Language.LSP.Types as J-import Language.LSP.Types.Capabilities--import qualified Data.Default-import qualified Data.Map.Strict as Map-import Ide.Plugin.Config-import Language.LSP.Server---- ------------------------------------------------------------------------- | 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 [InL 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---- -----------------------------------------------------------------------pluginDescToIdePlugins :: [PluginDescriptor ideState] -> IdePlugins ideState-pluginDescToIdePlugins plugins = IdePlugins $ Map.fromList $ map (\p -> (pluginId p, p)) plugins----- ------------------------------------------------------------------------ | 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 :: MonadLsp Config m => m Config-getClientConfig = fromMaybe Data.Default.def <$> getConfig---- ------------------------------------------------------------------------- | Returns the current plugin configuration. It is not wise to permanently--- cache the returned value of this function, as clients can change their--- configuration at runtime.------ If no custom configuration has been set by the client, this function returns--- our own defaults.-getPluginConfig :: MonadLsp Config m => PluginId -> m PluginConfig-getPluginConfig plugin = do- config <- getClientConfig- return $ configForPlugin config plugin---- -----------------------------------------------------------------------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--subRange :: Range -> Range -> Bool-subRange smallRange range =- positionInRange (_start smallRange) range- && positionInRange (_end smallRange) range--positionInRange :: Position -> Range -> Bool-positionInRange (Position pl po) (Range (Position sl so) (Position el eo)) =- pl > sl && pl < el- || pl == sl && pl == el && po >= so && po <= eo- || pl == sl && po >= so- || pl == el && po <= eo---- -----------------------------------------------------------------------allLspCmdIds' :: T.Text -> IdePlugins ideState -> [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---allLspCmdIds :: T.Text -> [(PluginId, [PluginCommand ideState])] -> [T.Text]-allLspCmdIds pid commands = concat $ map go commands- where- go (plid, cmds) = map (mkLspCmdId pid plid . commandId) cmds-+{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +module Ide.PluginUtils + ( WithDeletions(..), + getProcessID, + normalize, + makeDiffTextEdit, + makeDiffTextEditAdditive, + diffText, + diffText', + pluginDescToIdePlugins, + responseError, + getClientConfig, + getPluginConfig, + configForPlugin, + pluginEnabled, + extractRange, + fullRange, + mkLspCommand, + mkLspCmdId, + getPid, + allLspCmdIds,allLspCmdIds',installSigUsr1Handler, subRange) +where + + +import Data.Algorithm.Diff +import Data.Algorithm.DiffOutput +import qualified Data.HashMap.Strict as H +import qualified Data.Text as T +import Ide.Types +import Language.LSP.Types +import qualified Language.LSP.Types as J +import Language.LSP.Types.Capabilities + +import qualified Data.Map.Strict as Map +import Ide.Plugin.Config +import Language.LSP.Server + +-- --------------------------------------------------------------------- + +-- | 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 [InL 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 + Just True == supports + +-- --------------------------------------------------------------------- + +pluginDescToIdePlugins :: [PluginDescriptor ideState] -> IdePlugins ideState +pluginDescToIdePlugins plugins = IdePlugins $ Map.fromList $ map (\p -> (pluginId p, p)) plugins + + +-- --------------------------------------------------------------------- +-- | 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. +-- +getClientConfig :: MonadLsp Config m => m (Maybe Config) +getClientConfig = getConfig + +-- --------------------------------------------------------------------- + +-- | Returns the current plugin configuration. It is not wise to permanently +-- cache the returned value of this function, as clients can change their +-- configuration at runtime. +getPluginConfig :: MonadLsp Config m => PluginId -> m (Maybe PluginConfig) +getPluginConfig plugin = do + config <- getClientConfig + return $ flip configForPlugin plugin <$> config + +-- --------------------------------------------------------------------- + +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 + +subRange :: Range -> Range -> Bool +subRange smallRange range = + positionInRange (_start smallRange) range + && positionInRange (_end smallRange) range + +positionInRange :: Position -> Range -> Bool +positionInRange (Position pl po) (Range (Position sl so) (Position el eo)) = + pl > sl && pl < el + || pl == sl && pl == el && po >= so && po <= eo + || pl == sl && po >= so + || pl == el && po <= eo + +-- --------------------------------------------------------------------- + +allLspCmdIds' :: T.Text -> IdePlugins ideState -> [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 + + +allLspCmdIds :: T.Text -> [(PluginId, [PluginCommand ideState])] -> [T.Text] +allLspCmdIds pid commands = concatMap go commands + where + go (plid, cmds) = map (mkLspCmdId pid plid . commandId) cmds +
src/Ide/Types.hs view
@@ -1,379 +1,378 @@-{-# LANGUAGE GADTs #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE PolyKinds #-}-{-# LANGUAGE ViewPatterns #-}-{-# LANGUAGE DefaultSignatures #-}-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE UndecidableInstances #-}--module Ide.Types- where--#ifdef mingw32_HOST_OS-import qualified System.Win32.Process as P (getCurrentProcessId)-#else-import System.Posix.Signals-import qualified System.Posix.Process as P (getProcessID)-#endif-import Data.Aeson hiding (defaultOptions)-import GHC.Generics-import qualified Data.Map as Map-import Data.String-import qualified Data.Text as T-import Development.Shake hiding (command)-import Ide.Plugin.Config-import Language.LSP.Types-import Language.LSP.VFS-import Language.LSP.Types.Lens as J hiding (id)-import Language.LSP.Types.Capabilities-import Language.LSP.Server (LspM, getVirtualFile)-import Text.Regex.TDFA.Text()-import Data.Dependent.Map (DMap)-import qualified Data.Dependent.Map as DMap-import Data.List.NonEmpty (NonEmpty(..), toList)-import Data.GADT.Compare-import Data.Maybe-import Data.Semigroup-import Control.Lens ((^.))-import qualified Data.DList as DList-import qualified Data.Default-import System.IO.Unsafe-import Control.Monad-import OpenTelemetry.Eventlog-import Data.Text.Encoding (encodeUtf8)---- -----------------------------------------------------------------------newtype IdePlugins ideState = IdePlugins- { ipMap :: Map.Map PluginId (PluginDescriptor ideState)}---- -----------------------------------------------------------------------data PluginDescriptor ideState =- PluginDescriptor { pluginId :: !PluginId- , pluginRules :: !(Rules ())- , pluginCommands :: ![PluginCommand ideState]- , pluginHandlers :: PluginHandlers ideState- }---- | Methods that can be handled by plugins.--- 'ExtraParams' captures any extra data the IDE passes to the handlers for this method--- Only methods for which we know how to combine responses can be instances of 'PluginMethod'-class HasTracing (MessageParams m) => PluginMethod m where-- -- | Parse the configuration to check if this plugin is enabled- pluginEnabled :: SMethod m -> PluginId -> Config -> Bool-- -- | How to combine responses from different plugins- combineResponses- :: SMethod m- -> Config -- ^ IDE Configuration- -> ClientCapabilities- -> MessageParams m- -> NonEmpty (ResponseResult m) -> ResponseResult m-- default combineResponses :: Semigroup (ResponseResult m)- => SMethod m -> Config -> ClientCapabilities -> MessageParams m -> NonEmpty (ResponseResult m) -> ResponseResult m- combineResponses _method _config _caps _params = sconcat--instance PluginMethod TextDocumentCodeAction where- pluginEnabled _ = pluginEnabledConfig plcCodeActionsOn- combineResponses _method _config (ClientCapabilities _ textDocCaps _ _) (CodeActionParams _ _ _ _ context) resps =- fmap compat $ List $ filter wasRequested $ (\(List x) -> x) $ sconcat resps- where-- compat :: (Command |? CodeAction) -> (Command |? CodeAction)- compat x@(InL _) = x- compat x@(InR action)- | Just _ <- textDocCaps >>= _codeAction >>= _codeActionLiteralSupport- = x- | otherwise = InL cmd- where- cmd = mkLspCommand "hls" "fallbackCodeAction" (action ^. title) (Just cmdParams)- cmdParams = [toJSON (FallbackCodeActionParams (action ^. edit) (action ^. command))]-- wasRequested :: (Command |? CodeAction) -> Bool- wasRequested (InL _) = True- wasRequested (InR ca)- | Nothing <- _only context = True- | Just (List allowed) <- _only context- , Just caKind <- ca ^. kind = caKind `elem` allowed- | otherwise = False--instance PluginMethod TextDocumentCodeLens where- pluginEnabled _ = pluginEnabledConfig plcCodeLensOn-instance PluginMethod TextDocumentRename where- pluginEnabled _ = pluginEnabledConfig plcRenameOn-instance PluginMethod TextDocumentHover where- pluginEnabled _ = pluginEnabledConfig plcHoverOn- combineResponses _ _ _ _ (catMaybes . toList -> hs) = h- where- r = listToMaybe $ mapMaybe (^. range) hs- h = case foldMap (^. contents) hs of- HoverContentsMS (List []) -> Nothing- hh -> Just $ Hover hh r--instance PluginMethod TextDocumentDocumentSymbol where- pluginEnabled _ = pluginEnabledConfig plcSymbolsOn- combineResponses _ _ (ClientCapabilities _ tdc _ _) params xs = res- where- uri' = params ^. textDocument . uri- supportsHierarchy = Just True == (tdc >>= _documentSymbol >>= _hierarchicalDocumentSymbolSupport)- dsOrSi = fmap toEither xs- res- | supportsHierarchy = InL $ sconcat $ fmap (either id (fmap siToDs)) dsOrSi- | otherwise = InR $ sconcat $ fmap (either (List . concatMap dsToSi) id) dsOrSi- siToDs (SymbolInformation name kind dep (Location _uri range) cont)- = DocumentSymbol name cont kind dep range range Nothing- dsToSi = go Nothing- 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'--instance PluginMethod TextDocumentCompletion where- pluginEnabled _ = pluginEnabledConfig plcCompletionOn- combineResponses _ conf _ _ (toList -> xs) = snd $ consumeCompletionResponse limit $ combine xs- where- limit = maxCompletions conf- combine :: [List CompletionItem |? CompletionList] -> ((List CompletionItem) |? CompletionList)- combine cs = go True mempty cs-- go !comp acc [] =- InR (CompletionList comp (List $ DList.toList acc))- go comp acc (InL (List ls) : rest) =- go comp (acc <> DList.fromList ls) rest- go comp acc (InR (CompletionList comp' (List ls)) : rest) =- go (comp && comp') (acc <> DList.fromList ls) rest-- -- boolean disambiguators- isCompleteResponse, isIncompleteResponse :: Bool- isIncompleteResponse = True- isCompleteResponse = False-- consumeCompletionResponse limit it@(InR (CompletionList _ (List xx))) =- case splitAt limit xx of- -- consumed all the items, return the result as is- (_, []) -> (limit - length xx, it)- -- need to crop the response, set the 'isIncomplete' flag- (xx', _) -> (0, InR (CompletionList isIncompleteResponse (List xx')))- consumeCompletionResponse n (InL (List xx)) =- consumeCompletionResponse n (InR (CompletionList isCompleteResponse (List xx)))--instance PluginMethod TextDocumentFormatting where- pluginEnabled _ pid conf = (PluginId $ formattingProvider conf) == pid- combineResponses _ _ _ _ (x :| _) = x--instance PluginMethod TextDocumentRangeFormatting where- pluginEnabled _ pid conf = (PluginId $ formattingProvider conf) == pid- combineResponses _ _ _ _ (x :| _) = x---- | Methods which have a PluginMethod instance-data IdeMethod (m :: Method FromClient Request) = PluginMethod m => IdeMethod (SMethod m)-instance GEq IdeMethod where- geq (IdeMethod a) (IdeMethod b) = geq a b-instance GCompare IdeMethod where- gcompare (IdeMethod a) (IdeMethod b) = gcompare a b---- | Combine handlers for the-newtype PluginHandler a (m :: Method FromClient Request)- = PluginHandler (PluginId -> a -> MessageParams m -> LspM Config (NonEmpty (Either ResponseError (ResponseResult m))))--newtype PluginHandlers a = PluginHandlers (DMap IdeMethod (PluginHandler a))--instance Semigroup (PluginHandlers a) where- (PluginHandlers a) <> (PluginHandlers b) = PluginHandlers $ DMap.unionWithKey go a b- where- go _ (PluginHandler f) (PluginHandler g) = PluginHandler $ \pid ide params ->- (<>) <$> f pid ide params <*> g pid ide params--instance Monoid (PluginHandlers a) where- mempty = PluginHandlers mempty--type PluginMethodHandler a m = a -> PluginId -> MessageParams m -> LspM Config (Either ResponseError (ResponseResult m))---- | Make a handler for plugins with no extra data-mkPluginHandler- :: PluginMethod m- => SClientMethod m- -> PluginMethodHandler ideState m- -> PluginHandlers ideState-mkPluginHandler m f = PluginHandlers $ DMap.singleton (IdeMethod m) (PluginHandler f')- where- f' pid ide params = pure <$> f ide pid params--defaultPluginDescriptor :: PluginId -> PluginDescriptor ideState-defaultPluginDescriptor plId =- PluginDescriptor- plId- mempty- mempty- mempty--newtype CommandId = CommandId T.Text- deriving (Show, Read, Eq, Ord)-instance IsString CommandId where- fromString = CommandId . T.pack--data PluginCommand ideState = forall a. (FromJSON a) =>- PluginCommand { commandId :: CommandId- , commandDesc :: T.Text- , commandFunc :: CommandFunction ideState a- }---- -----------------------------------------------------------------------type CommandFunction ideState a- = ideState- -> a- -> LspM Config (Either ResponseError Value)--newtype WithSnippets = WithSnippets Bool---- -----------------------------------------------------------------------newtype PluginId = PluginId T.Text- deriving (Show, Read, Eq, Ord)-instance IsString PluginId where- fromString = PluginId . T.pack--configForPlugin :: Config -> PluginId -> PluginConfig-configForPlugin config (PluginId plugin)- = Map.findWithDefault Data.Default.def plugin (plugins config)---- | Checks that a given plugin is both enabled and the specific feature is--- enabled-pluginEnabledConfig :: (PluginConfig -> Bool) -> PluginId -> Config -> Bool-pluginEnabledConfig f pid config = plcGlobalOn pluginConfig && f pluginConfig- where- pluginConfig = configForPlugin config pid---- ------------------------------------------------------------------------- | 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---type FormattingMethod m =- ( J.HasOptions (MessageParams m) FormattingOptions- , J.HasTextDocument (MessageParams m) TextDocumentIdentifier- , ResponseResult m ~ List TextEdit- )--type FormattingHandler a- = a- -> FormattingType- -> T.Text- -> NormalizedFilePath- -> FormattingOptions- -> LspM Config (Either ResponseError (List TextEdit))--mkFormattingHandlers :: forall a. FormattingHandler a -> PluginHandlers a-mkFormattingHandlers f = mkPluginHandler STextDocumentFormatting (provider STextDocumentFormatting)- <> mkPluginHandler STextDocumentRangeFormatting (provider STextDocumentRangeFormatting)- where- provider :: forall m. FormattingMethod m => SMethod m -> PluginMethodHandler a m- provider m ide _pid params- | Just nfp <- uriToNormalizedFilePath $ toNormalizedUri uri = do- mf <- getVirtualFile $ toNormalizedUri uri- case mf of- Just vf -> do- let typ = case m of- STextDocumentFormatting -> FormatText- STextDocumentRangeFormatting -> FormatRange (params ^. J.range)- _ -> error "mkFormattingHandlers: impossible"- f ide typ (virtualFileText vf) nfp opts- Nothing -> pure $ Left $ responseError $ T.pack $ "Formatter plugin: could not get file contents for " ++ show uri-- | otherwise = pure $ Left $ responseError $ T.pack $ "Formatter plugin: uriToFilePath failed for: " ++ show uri- where- uri = params ^. J.textDocument . J.uri- opts = params ^. J.options---- -----------------------------------------------------------------------responseError :: T.Text -> ResponseError-responseError txt = ResponseError InvalidParams txt Nothing---- -----------------------------------------------------------------------data FallbackCodeActionParams =- FallbackCodeActionParams- { fallbackWorkspaceEdit :: Maybe WorkspaceEdit- , fallbackCommand :: Maybe Command- }- deriving (Generic, ToJSON, FromJSON)---- -----------------------------------------------------------------------otSetUri :: SpanInFlight -> Uri -> IO ()-otSetUri sp (Uri t) = setTag sp "uri" (encodeUtf8 t)--class HasTracing a where- traceWithSpan :: SpanInFlight -> a -> IO ()- traceWithSpan _ _ = pure ()--instance {-# OVERLAPPABLE #-} (HasTextDocument a doc, HasUri doc Uri) => HasTracing a where- traceWithSpan sp a = otSetUri sp (a ^. J.textDocument . J.uri)--instance HasTracing Value-instance HasTracing ExecuteCommandParams-instance HasTracing DidChangeWatchedFilesParams-instance HasTracing DidChangeWorkspaceFoldersParams-instance HasTracing DidChangeConfigurationParams-instance HasTracing InitializeParams-instance HasTracing (Maybe InitializedParams)-instance HasTracing WorkspaceSymbolParams where- traceWithSpan sp (WorkspaceSymbolParams _ _ query) = setTag sp "query" (encodeUtf8 query)---- -----------------------------------------------------------------------{-# NOINLINE pROCESS_ID #-}-pROCESS_ID :: T.Text-pROCESS_ID = unsafePerformIO getPid--mkLspCommand :: PluginId -> CommandId -> T.Text -> Maybe [Value] -> Command-mkLspCommand plid cn title args' = Command title cmdId args- where- cmdId = mkLspCmdId pROCESS_ID plid cn- args = List <$> args'--mkLspCmdId :: T.Text -> PluginId -> CommandId -> T.Text-mkLspCmdId pid (PluginId plid) (CommandId cid)- = pid <> ":" <> plid <> ":" <> cid---- | Get the operating system process id for the running server--- instance. This should be the same for the lifetime of the instance,--- and different from that of any other currently running instance.-getPid :: IO T.Text-getPid = T.pack . show <$> getProcessID--getProcessID :: IO Int-installSigUsr1Handler :: IO () -> IO ()--#ifdef mingw32_HOST_OS-getProcessID = fromIntegral <$> P.getCurrentProcessId-installSigUsr1Handler _ = return ()--#else-getProcessID = fromIntegral <$> P.getProcessID--installSigUsr1Handler h = void $ installHandler sigUSR1 (Catch h) Nothing-#endif+{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE UndecidableInstances #-} + +module Ide.Types + where + +#ifdef mingw32_HOST_OS +import qualified System.Win32.Process as P (getCurrentProcessId) +#else +import System.Posix.Signals +import qualified System.Posix.Process as P (getProcessID) +#endif +import Data.Aeson hiding (defaultOptions) +import GHC.Generics +import qualified Data.Map as Map +import Data.String +import qualified Data.Text as T +import Development.Shake hiding (command) +import Ide.Plugin.Config +import Language.LSP.Types +import Language.LSP.VFS +import Language.LSP.Types.Lens as J hiding (id) +import Language.LSP.Types.Capabilities +import Language.LSP.Server (LspM, getVirtualFile) +import Text.Regex.TDFA.Text() +import Data.Dependent.Map (DMap) +import qualified Data.Dependent.Map as DMap +import Data.List.NonEmpty (NonEmpty(..), toList) +import Data.GADT.Compare +import Data.Maybe +import Data.Semigroup +import Control.Lens ((^.)) +import qualified Data.DList as DList +import qualified Data.Default +import System.IO.Unsafe +import Control.Monad +import OpenTelemetry.Eventlog +import Data.Text.Encoding (encodeUtf8) + +-- --------------------------------------------------------------------- + +newtype IdePlugins ideState = IdePlugins + { ipMap :: Map.Map PluginId (PluginDescriptor ideState)} + +-- --------------------------------------------------------------------- + +data PluginDescriptor ideState = + PluginDescriptor { pluginId :: !PluginId + , pluginRules :: !(Rules ()) + , pluginCommands :: ![PluginCommand ideState] + , pluginHandlers :: PluginHandlers ideState + } + +-- | Methods that can be handled by plugins. +-- 'ExtraParams' captures any extra data the IDE passes to the handlers for this method +-- Only methods for which we know how to combine responses can be instances of 'PluginMethod' +class HasTracing (MessageParams m) => PluginMethod m where + + -- | Parse the configuration to check if this plugin is enabled + pluginEnabled :: SMethod m -> PluginId -> Config -> Bool + + -- | How to combine responses from different plugins + combineResponses + :: SMethod m + -> Config -- ^ IDE Configuration + -> ClientCapabilities + -> MessageParams m + -> NonEmpty (ResponseResult m) -> ResponseResult m + + default combineResponses :: Semigroup (ResponseResult m) + => SMethod m -> Config -> ClientCapabilities -> MessageParams m -> NonEmpty (ResponseResult m) -> ResponseResult m + combineResponses _method _config _caps _params = sconcat + +instance PluginMethod TextDocumentCodeAction where + pluginEnabled _ = pluginEnabledConfig plcCodeActionsOn + combineResponses _method _config (ClientCapabilities _ textDocCaps _ _) (CodeActionParams _ _ _ _ context) resps = + fmap compat $ List $ filter wasRequested $ (\(List x) -> x) $ sconcat resps + where + + compat :: (Command |? CodeAction) -> (Command |? CodeAction) + compat x@(InL _) = x + compat x@(InR action) + | Just _ <- textDocCaps >>= _codeAction >>= _codeActionLiteralSupport + = x + | otherwise = InL cmd + where + cmd = mkLspCommand "hls" "fallbackCodeAction" (action ^. title) (Just cmdParams) + cmdParams = [toJSON (FallbackCodeActionParams (action ^. edit) (action ^. command))] + + wasRequested :: (Command |? CodeAction) -> Bool + wasRequested (InL _) = True + wasRequested (InR ca) + | Nothing <- _only context = True + | Just (List allowed) <- _only context + , Just caKind <- ca ^. kind = caKind `elem` allowed + | otherwise = False + +instance PluginMethod TextDocumentCodeLens where + pluginEnabled _ = pluginEnabledConfig plcCodeLensOn +instance PluginMethod TextDocumentRename where + pluginEnabled _ = pluginEnabledConfig plcRenameOn +instance PluginMethod TextDocumentHover where + pluginEnabled _ = pluginEnabledConfig plcHoverOn + combineResponses _ _ _ _ (catMaybes . toList -> hs) = h + where + r = listToMaybe $ mapMaybe (^. range) hs + h = case foldMap (^. contents) hs of + HoverContentsMS (List []) -> Nothing + hh -> Just $ Hover hh r + +instance PluginMethod TextDocumentDocumentSymbol where + pluginEnabled _ = pluginEnabledConfig plcSymbolsOn + combineResponses _ _ (ClientCapabilities _ tdc _ _) params xs = res + where + uri' = params ^. textDocument . uri + supportsHierarchy = Just True == (tdc >>= _documentSymbol >>= _hierarchicalDocumentSymbolSupport) + dsOrSi = fmap toEither xs + res + | supportsHierarchy = InL $ sconcat $ fmap (either id (fmap siToDs)) dsOrSi + | otherwise = InR $ sconcat $ fmap (either (List . concatMap dsToSi) id) dsOrSi + siToDs (SymbolInformation name kind dep (Location _uri range) cont) + = DocumentSymbol name cont kind dep range range Nothing + dsToSi = go Nothing + 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' + +instance PluginMethod TextDocumentCompletion where + pluginEnabled _ = pluginEnabledConfig plcCompletionOn + combineResponses _ conf _ _ (toList -> xs) = snd $ consumeCompletionResponse limit $ combine xs + where + limit = maxCompletions conf + combine :: [List CompletionItem |? CompletionList] -> ((List CompletionItem) |? CompletionList) + combine cs = go True mempty cs + + go !comp acc [] = + InR (CompletionList comp (List $ DList.toList acc)) + go comp acc (InL (List ls) : rest) = + go comp (acc <> DList.fromList ls) rest + go comp acc (InR (CompletionList comp' (List ls)) : rest) = + go (comp && comp') (acc <> DList.fromList ls) rest + + -- boolean disambiguators + isCompleteResponse, isIncompleteResponse :: Bool + isIncompleteResponse = True + isCompleteResponse = False + + consumeCompletionResponse limit it@(InR (CompletionList _ (List xx))) = + case splitAt limit xx of + -- consumed all the items, return the result as is + (_, []) -> (limit - length xx, it) + -- need to crop the response, set the 'isIncomplete' flag + (xx', _) -> (0, InR (CompletionList isIncompleteResponse (List xx'))) + consumeCompletionResponse n (InL (List xx)) = + consumeCompletionResponse n (InR (CompletionList isCompleteResponse (List xx))) + +instance PluginMethod TextDocumentFormatting where + pluginEnabled _ pid conf = (PluginId $ formattingProvider conf) == pid + combineResponses _ _ _ _ (x :| _) = x + +instance PluginMethod TextDocumentRangeFormatting where + pluginEnabled _ pid conf = (PluginId $ formattingProvider conf) == pid + combineResponses _ _ _ _ (x :| _) = x + +-- | Methods which have a PluginMethod instance +data IdeMethod (m :: Method FromClient Request) = PluginMethod m => IdeMethod (SMethod m) +instance GEq IdeMethod where + geq (IdeMethod a) (IdeMethod b) = geq a b +instance GCompare IdeMethod where + gcompare (IdeMethod a) (IdeMethod b) = gcompare a b + +-- | Combine handlers for the +newtype PluginHandler a (m :: Method FromClient Request) + = PluginHandler (PluginId -> a -> MessageParams m -> LspM Config (NonEmpty (Either ResponseError (ResponseResult m)))) + +newtype PluginHandlers a = PluginHandlers (DMap IdeMethod (PluginHandler a)) + +instance Semigroup (PluginHandlers a) where + (PluginHandlers a) <> (PluginHandlers b) = PluginHandlers $ DMap.unionWithKey go a b + where + go _ (PluginHandler f) (PluginHandler g) = PluginHandler $ \pid ide params -> + (<>) <$> f pid ide params <*> g pid ide params + +instance Monoid (PluginHandlers a) where + mempty = PluginHandlers mempty + +type PluginMethodHandler a m = a -> PluginId -> MessageParams m -> LspM Config (Either ResponseError (ResponseResult m)) + +-- | Make a handler for plugins with no extra data +mkPluginHandler + :: PluginMethod m + => SClientMethod m + -> PluginMethodHandler ideState m + -> PluginHandlers ideState +mkPluginHandler m f = PluginHandlers $ DMap.singleton (IdeMethod m) (PluginHandler f') + where + f' pid ide params = pure <$> f ide pid params + +defaultPluginDescriptor :: PluginId -> PluginDescriptor ideState +defaultPluginDescriptor plId = + PluginDescriptor + plId + mempty + mempty + mempty + +newtype CommandId = CommandId T.Text + deriving (Show, Read, Eq, Ord) +instance IsString CommandId where + fromString = CommandId . T.pack + +data PluginCommand ideState = forall a. (FromJSON a) => + PluginCommand { commandId :: CommandId + , commandDesc :: T.Text + , commandFunc :: CommandFunction ideState a + } + +-- --------------------------------------------------------------------- + +type CommandFunction ideState a + = ideState + -> a + -> LspM Config (Either ResponseError Value) + +newtype WithSnippets = WithSnippets Bool + +-- --------------------------------------------------------------------- + +newtype PluginId = PluginId T.Text + deriving (Show, Read, Eq, Ord) +instance IsString PluginId where + fromString = PluginId . T.pack + +configForPlugin :: Config -> PluginId -> PluginConfig +configForPlugin config (PluginId plugin) + = Map.findWithDefault Data.Default.def plugin (plugins config) + +-- | Checks that a given plugin is both enabled and the specific feature is +-- enabled +pluginEnabledConfig :: (PluginConfig -> Bool) -> PluginId -> Config -> Bool +pluginEnabledConfig f pid config = plcGlobalOn pluginConfig && f pluginConfig + where + pluginConfig = configForPlugin config pid + +-- --------------------------------------------------------------------- + +-- | 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 + + +type FormattingMethod m = + ( J.HasOptions (MessageParams m) FormattingOptions + , J.HasTextDocument (MessageParams m) TextDocumentIdentifier + , ResponseResult m ~ List TextEdit + ) + +type FormattingHandler a + = a + -> FormattingType + -> T.Text + -> NormalizedFilePath + -> FormattingOptions + -> LspM Config (Either ResponseError (List TextEdit)) + +mkFormattingHandlers :: forall a. FormattingHandler a -> PluginHandlers a +mkFormattingHandlers f = mkPluginHandler STextDocumentFormatting (provider STextDocumentFormatting) + <> mkPluginHandler STextDocumentRangeFormatting (provider STextDocumentRangeFormatting) + where + provider :: forall m. FormattingMethod m => SMethod m -> PluginMethodHandler a m + provider m ide _pid params + | Just nfp <- uriToNormalizedFilePath $ toNormalizedUri uri = do + mf <- getVirtualFile $ toNormalizedUri uri + case mf of + Just vf -> do + let typ = case m of + STextDocumentFormatting -> FormatText + STextDocumentRangeFormatting -> FormatRange (params ^. J.range) + _ -> error "mkFormattingHandlers: impossible" + f ide typ (virtualFileText vf) nfp opts + Nothing -> pure $ Left $ responseError $ T.pack $ "Formatter plugin: could not get file contents for " ++ show uri + + | otherwise = pure $ Left $ responseError $ T.pack $ "Formatter plugin: uriToFilePath failed for: " ++ show uri + where + uri = params ^. J.textDocument . J.uri + opts = params ^. J.options + +-- --------------------------------------------------------------------- + +responseError :: T.Text -> ResponseError +responseError txt = ResponseError InvalidParams txt Nothing + +-- --------------------------------------------------------------------- + +data FallbackCodeActionParams = + FallbackCodeActionParams + { fallbackWorkspaceEdit :: Maybe WorkspaceEdit + , fallbackCommand :: Maybe Command + } + deriving (Generic, ToJSON, FromJSON) + +-- --------------------------------------------------------------------- + +otSetUri :: SpanInFlight -> Uri -> IO () +otSetUri sp (Uri t) = setTag sp "uri" (encodeUtf8 t) + +class HasTracing a where + traceWithSpan :: SpanInFlight -> a -> IO () + traceWithSpan _ _ = pure () + +instance {-# OVERLAPPABLE #-} (HasTextDocument a doc, HasUri doc Uri) => HasTracing a where + traceWithSpan sp a = otSetUri sp (a ^. J.textDocument . J.uri) + +instance HasTracing Value +instance HasTracing ExecuteCommandParams +instance HasTracing DidChangeWatchedFilesParams +instance HasTracing DidChangeWorkspaceFoldersParams +instance HasTracing DidChangeConfigurationParams +instance HasTracing InitializeParams +instance HasTracing (Maybe InitializedParams) +instance HasTracing WorkspaceSymbolParams where + traceWithSpan sp (WorkspaceSymbolParams _ _ query) = setTag sp "query" (encodeUtf8 query) + +-- --------------------------------------------------------------------- + +{-# NOINLINE pROCESS_ID #-} +pROCESS_ID :: T.Text +pROCESS_ID = unsafePerformIO getPid + +mkLspCommand :: PluginId -> CommandId -> T.Text -> Maybe [Value] -> Command +mkLspCommand plid cn title args' = Command title cmdId args + where + cmdId = mkLspCmdId pROCESS_ID plid cn + args = List <$> args' + +mkLspCmdId :: T.Text -> PluginId -> CommandId -> T.Text +mkLspCmdId pid (PluginId plid) (CommandId cid) + = pid <> ":" <> plid <> ":" <> cid + +-- | Get the operating system process id for the running server +-- instance. This should be the same for the lifetime of the instance, +-- and different from that of any other currently running instance. +getPid :: IO T.Text +getPid = T.pack . show <$> getProcessID + +getProcessID :: IO Int +installSigUsr1Handler :: IO () -> IO () + +#ifdef mingw32_HOST_OS +getProcessID = fromIntegral <$> P.getCurrentProcessId +installSigUsr1Handler _ = return () + +#else +getProcessID = fromIntegral <$> P.getProcessID + +installSigUsr1Handler h = void $ installHandler sigUSR1 (Catch h) Nothing +#endif